File Coverage

lib/Changes/Version.pm
Criterion Covered Total %
statement 405 793 51.0
branch 160 732 21.8
condition 145 397 36.5
subroutine 58 84 69.0
pod 35 35 100.0
total 803 2041 39.3


line stmt bran cond sub pod time code
1             ##----------------------------------------------------------------------------
2             ## Changes file management - ~/lib/Changes/Version.pm
3             ## Version v0.1.0
4             ## Copyright(c) 2022 DEGUEST Pte. Ltd.
5             ## Author: Jacques Deguest <jack@deguest.jp>
6             ## Created 2022/12/01
7             ## Modified 2022/12/01
8             ## All rights reserved
9             ##
10             ##
11             ## This program is free software; you can redistribute it and/or modify it
12             ## under the same terms as Perl itself.
13             ##----------------------------------------------------------------------------
14             package Changes::Version;
15             BEGIN
16             {
17 20     20   114028 use strict;
  20         62  
  20         759  
18 20     20   121 use warnings;
  20         45  
  20         608  
19 20     20   114 use warnings::register;
  20         171  
  20         2255  
20 20     20   659 use parent qw( Module::Generic );
  20         341  
  20         117  
21 20     20   11551868 use vars qw( $VERSION $VERSION_LAX_REGEX $DEFAULT_TYPE );
  20         49  
  20         1099  
22 20     20   129 use version ();
  20         41  
  20         350  
23 20     20   99 use Nice::Try;
  20         36  
  20         184  
24             # From version::regex
25             # Comments in the regular expression below are taken from version::regex
26 20     20   5700 our $VERSION_LAX_REGEX = qr/
27             (?<ver_str>
28             # Lax dotted-decimal version number. Distinguished by having either leading "v"
29             # or at least three non-alpha parts. Alpha part is only permitted if there are
30             # at least two non-alpha parts. Strangely enough, without the leading "v", Perl
31             # takes .1.2 to mean v0.1.2, so when there is no "v", the leading part is optional
32             (?<dotted>
33             (?<has_v>v)
34             (?<ver>
35             (?<major>[0-9]+)
36             (?:
37             (?<minor_patch>(?:\.[0-9]+)+)
38             (?:_(?<alpha>[0-9]+))?
39             )?
40             )
41             |
42             (?<ver>
43             (?<major>[0-9]+)?
44             (?<minor_patch>(?:\.[0-9]+){2,})
45             (?:_(?<alpha>[0-9]+))?
46             )
47             )
48             |
49             # Lax decimal version number. Just like the strict one except for allowing an
50             # alpha suffix or allowing a leading or trailing decimal-point
51             (?<decimal>
52             (?<ver>(?<release>(?<major>[0-9]+) (?: (?:\.(?<minor>[0-9]+)) | \. )?) (?:_(?<alpha>[0-9]+))?)
53             |
54             (?<ver>(?:\.(?<release>(?<major>[0-9]+))) (?:_(?<alpha>[0-9]+))?)
55             )
56             )/x;
57 20         51 our $DEFAULT_TYPE = 'dotted';
58             use overload (
59             '""' => \&as_string,
60             # '=' => \&clone,
61             '0+' => \&numify,
62             '<=>' => \&_compare,
63             'cmp' => \&_compare,
64             'bool' => \&_bool,
65 12     12   4147 '+' => sub { return( shift->_compute( @_, { op => '+' }) ); },
66 12     12   4180 '-' => sub { return( shift->_compute( @_, { op => '-' }) ); },
67 12     12   4226 '*' => sub { return( shift->_compute( @_, { op => '*' }) ); },
68 12     12   4014 '/' => sub { return( shift->_compute( @_, { op => '/' }) ); },
69 8     8   2669 '+=' => sub { return( shift->_compute( @_, { op => '+=' }) ); },
70 8     8   2675 '-=' => sub { return( shift->_compute( @_, { op => '-=' }) ); },
71 8     8   3059 '*=' => sub { return( shift->_compute( @_, { op => '*=' }) ); },
72 8     8   2725 '/=' => sub { return( shift->_compute( @_, { op => '/=' }) ); },
73 8     8   66 '++' => sub { return( shift->_compute( @_, { op => '++' }) ); },
74 8     8   68 '--' => sub { return( shift->_compute( @_, { op => '--' }) ); },
75             # We put it here so perl won't trigger the noop overload method
76 16     16   5258 '=' => sub { $_[0] },
77 20         633 'abs' => \&_noop,
78             'nomethod' => \&_noop,
79 20     20   34334342 );
  20         60  
80 20         433 our $VERSION = 'v0.1.0';
81             };
82              
83 20     20   147 use strict;
  20         45  
  20         583  
84 20     20   129 use warnings;
  20         36  
  20         13947  
85              
86             sub init
87             {
88 132     132 1 19743 my $self = shift( @_ );
89             # XXX
90             # print( STDERR ref( $self ), "::init: called with args: '", join( "', '", map( defined( $_ ) ? $_ : 'undef', @_ ) ), "'\n" );
91 132         576 $self->{alpha} = undef;
92             # Used for other version types
93 132         349 $self->{beta} = undef;
94 132         379 $self->{compat} = 0;
95             # What version fragment to increase/decrease by default, such as when we do operations like $v++ or $v--
96 132         410 $self->{default_frag} = 'minor';
97 132         346 $self->{extra} = [];
98 132         318 $self->{major} = undef;
99 132         296 $self->{minor} = undef;
100 132         408 $self->{original} = undef;
101 132         346 $self->{padded} = 1;
102 132         283 $self->{patch} = undef;
103 132         296 $self->{pretty} = 0;
104 132         347 $self->{qv} = 0;
105             # Release candidate used by non-perl open source softwares
106 132         306 $self->{rc} = undef;
107 132         352 $self->{target} = 'perl';
108 132         260 $self->{type} = undef;
109 132         836 my $keys = [qw( alpha beta compat default_frag extra major minor original patch qv rc target type _version )];
110 132         228 my $vstr;
111             # Changes::Version->new( 'v0.1.2_3' ); or
112             # Changes::Version->new( 'v0.1.2_3', alpha => 4 ); or
113             # Changes::Version->new( 'v0.1.2_3', { alpha => 4 } ); or
114             # Changes::Version->new( major => 0, minor => 1, patch => 2, alpha => 3, qv => 1 ); or
115             # Changes::Version->new({ major => 0, minor => 1, patch => 2, alpha => 3, qv => 1 }); or
116 132 100 33     2131 if( ( @_ == 1 && ref( $_[0] ) ne 'HASH' ) ||
      33        
      66        
      33        
      33        
117             ( @_ > 1 && ref( $_[0] ) ne 'HASH' && ( ( @_ % 2 ) || ref( $_[1] ) eq 'HASH' ) ) )
118             {
119 42         125 $vstr = shift( @_ );
120 42 50 33     327 return( $self->error( "version string provided is empty." ) ) if( !defined( $vstr ) || !length( "$vstr" ) );
121             # So we can get options like debug for parser
122 42         268 my $opts = $self->_get_args_as_hash( @_ );
123 42 100 66     6298 $self->debug( $opts->{debug} ) if( exists( $opts->{debug} ) && defined( $opts->{debug} ) && length( "$opts->{debug}" ) );
      66        
124             # A version string was provided, so we parse it
125 42         284 my $v = $self->parse( $vstr );
126 42 50       178 return( $self->pass_error ) if( !defined( $v ) );
127             # And we copy the collected value as default values for our new object, which can then be overriden by additional option passed here.
128 42         819 @$self{ @$keys } = @$v{ @$keys };
129             # XXX
130             # print( STDERR ref( $self ), "::init: \$v -> ", $self->dump( $v ), "\n" );
131             }
132 132         502 $self->{_init_strict_use_sub} = 1;
133             # XXX
134             # print( STDERR ref( $self ), "::init: passing \@_ to SUPER::init: '", join( "', '", @_ ), "'\n" );
135 132         849 my $rv = $self->SUPER::init( @_ );
136             # XXX
137             # print( STDERR ref( $self ), "::init: \$rv is defined ? ", ( defined( $rv ) ? 'yes' : 'no' ), "\n" );
138 132 50       429808 return( $self->pass_error ) if( !defined( $rv ) );
139 132         786 return( $self );
140             }
141              
142 439     439 1 21177 sub alpha { return( shift->reset(@_)->_set_get_number( { field => 'alpha', undef_ok => 1 }, @_ ) ); }
143              
144             sub as_string
145             {
146 309     309 1 185179 my $self = shift( @_ );
147             # XXX
148             # my $caller = [caller];
149             # print( STDERR ref( $self ), "::as_string: called from file $caller->[1] at line $caller->[2]\n" );
150             # print( STDERR ref( $self ), "::as_string: _reset exists? ", ( exists( $self->{_reset} ) ? 'yes' : 'no' ), "\n" );
151 309 50 66     2153 if( !exists( $self->{_reset} ) ||
      33        
152             !defined( $self->{_reset} ) ||
153             !CORE::length( $self->{_reset} ) )
154             {
155 192   100     2276 $self->message( 5, "Reset is disabled, checking for cache value '", ( $self->{_cache_value} // '' ), "' and raw cache '", ( $self->{raw} // '' ), "'" );
      50        
156 192 100 66     6516 if( exists( $self->{_cache_value} ) &&
    50 66        
      33        
157             defined( $self->{_cache_value} ) &&
158             length( $self->{_cache_value} ) )
159             {
160 68         628 return( $self->{_cache_value} );
161             }
162             elsif( defined( $self->{original} ) && length( "$self->{original}" ) )
163             {
164 124         1564 $self->message( 5, "Re-using the original cache '", $self->{original}->scalar, "' (", overload::StrVal( $self->{original} ), ")." );
165 124         4181 return( $self->{original}->scalar );
166             }
167             }
168 117         416 my $type = $self->type;
169 117         25943 my $str;
170 117 100 100     928 if( ( defined( $type ) && $type eq 'dotted' ) ||
      66        
      100        
171             ( !defined( $type ) && $DEFAULT_TYPE eq 'dotted' ) )
172             {
173 59         257 $str = $self->normal( raw => 1 );
174             }
175             else
176             {
177 58         1013 $str = $self->numify( raw => 1 );
178 58 100 66     243 if( !$self->padded && index( $str, '_' ) == -1 )
179             {
180 2         346 return( $str * 1 );
181             }
182            
183 56 100 100     9008 if( $self->pretty && index( $str, '_' ) == -1 && !( length( [split( /\./, $str )]->[1] ) % 3 ) )
      66        
184             {
185             # $str = join( '_', grep{ $_ ne ''} split( /(...)/, $str ) );
186             # Credit: <https://stackoverflow.com/questions/33442240/perl-printf-to-use-commas-as-thousands-separator>
187 3         484 while( $str =~ s/(\d+)(\d{3})/$1\_$2/ ){};
188             }
189             }
190 115         7773 $self->{_cache_value} = $str;
191 115         341 CORE::delete( $self->{_reset} );
192 115         773 return( $str );
193             }
194              
195             {
196 20     20   194 no warnings 'once';
  20         52  
  20         29225  
197             *stringify = \&as_string;
198             }
199              
200 0     0 1 0 sub beta { return( shift->reset(@_)->_set_get_number( { field => 'beta', undef_ok => 1 }, @_ ) ); }
201              
202             # NOTE: clone() is inherited
203              
204 1     1 1 5 sub compat { return( shift->_set_get_boolean( 'compat', @_ ) ); }
205              
206 0     0 1 0 sub dec { return( shift->_inc_dec( 'dec', @_ ) ); }
207              
208 0     0 1 0 sub dec_alpha { return( shift->_inc_dec( 'dec' => 'alpha', @_ ) ); }
209              
210             # For non-perl open source softwares
211 0     0 1 0 sub dec_beta { return( shift->_inc_dec( 'dec' => 'beta', @_ ) ); }
212              
213 0     0 1 0 sub dec_major { return( shift->_inc_dec( 'dec' => 'major', @_ ) ); }
214              
215 0     0 1 0 sub dec_minor { return( shift->_inc_dec( 'dec' => 'minor', @_ ) ); }
216              
217 0     0 1 0 sub dec_patch { return( shift->_inc_dec( 'dec' => 'patch', @_ ) ); }
218              
219 288     288 1 383977 sub default_frag { return( shift->_set_get_scalar_as_object( 'default_frag', @_ ) ); }
220              
221 273     273 1 329661 sub extra { return( shift->_set_get_array_as_object( 'extra', @_ ) ); }
222              
223 4     4 1 17 sub inc { return( shift->_inc_dec( 'inc', @_ ) ); }
224              
225 0     0 1 0 sub inc_alpha { return( shift->_inc_dec( 'inc' => 'alpha', @_ ) ); }
226              
227 0     0 1 0 sub inc_beta { return( shift->_inc_dec( 'inc' => 'beta', @_ ) ); }
228              
229 0     0 1 0 sub inc_major { return( shift->_inc_dec( 'inc' => 'major', @_ ) ); }
230              
231 0     0 1 0 sub inc_minor { return( shift->_inc_dec( 'inc' => 'minor', @_ ) ); }
232              
233 0     0 1 0 sub inc_patch { return( shift->_inc_dec( 'inc' => 'patch', @_ ) ); }
234              
235 0 0   0 1 0 sub is_alpha { return( shift->alpha->length > 0 ? 1 : 0 ); }
236              
237 0 0   0 1 0 sub is_qv { return( shift->qv ? 1 : 0 ); }
238              
239 346     346 1 246052 sub major { return( shift->reset(@_)->_set_get_number( { field => 'major', undef_ok => 1 }, @_ ) ); }
240              
241 367     367 1 3791330 sub minor { return( shift->reset(@_)->_set_get_number( { field => 'minor', undef_ok => 1 }, @_ ) ); }
242              
243             sub normal
244             {
245 60     60 1 119 my $self = shift( @_ );
246 60         257 my $opts = $self->_get_args_as_hash( @_ );
247 60   100     7786 $opts->{raw} //= 0;
248 60         130 my $v;
249 60 50 33     171 try
  60         101  
  60         116  
  60         213  
  0         0  
  60         83  
  60         165  
  60         152  
250 60     60   106 {
251 60         1798 my $clone = $self->clone;
252 60 100       78327 if( !$self->qv )
253             {
254 1         158 $clone->qv(1);
255             }
256 60 100       9895 if( $opts->{raw} )
257             {
258 59         208 $v = $clone->_stringify;
259 59         808 $self->message( 4, "Wants raw. String is already formatted with qv, returning '$v'" );
260             # We already did it with stringify, so we return what we got
261 59         1591 return( $v );
262             }
263             else
264             {
265 1         7 $self->message( 4, "Does not want raw. String is already formatted with qv, returning a clone of self" );
266 1         25 $clone->type( 'dotted' );
267 1         221 return( $clone );
268             }
269             }
270 60 0 0     283 catch( $e )
  0 0 33     0  
  0 0       0  
  60 0       120  
  60 0       83  
  60 0       94  
  60 0       103  
  60 0       264  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 50       0  
  0 50       0  
  0 50       0  
  0 50       0  
  0 50       0  
  0 0       0  
  0 50       0  
  0         0  
  0         0  
  0         0  
  60         207  
  0         0  
  60         115  
  0         0  
  0         0  
  60         22866  
  60         297  
  60         150  
  60         196  
  0         0  
  0         0  
  0         0  
  0         0  
271 0     0   0 {
272 0         0 return( $self->error( "Error normalising version $v: $e" ) );
273 20 0 0 20   197 }
  20 0 0     51  
  20 0 33     23632  
  0 0 66     0  
  0 0 66     0  
  0 0 33     0  
  0 0 33     0  
  0 0 0     0  
  0 0 0     0  
  0 0 0     0  
  0 0 0     0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 50       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  60 0       154  
  0 0       0  
  60 50       471  
  60 50       311  
  60 50       185  
  0 50       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  60         760  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
274             }
275              
276             sub numify
277             {
278 59     59 1 123 my $self = shift( @_ );
279 59         266 my $opts = $self->_get_args_as_hash( @_ );
280 59   100     7635 $opts->{raw} //= 0;
281 59         99 my $v;
282 59 50 33     187 try
  59         101  
  59         99  
  59         215  
  0         0  
  59         85  
  59         166  
  59         124  
283 59     59   77 {
284 59 100       136 if( $opts->{raw} )
285             {
286             # If alpha is set, such as when we convert a dotted decimal into a decimal, we need to remove it and add it back later, because version mess it up
287             # For example: version->parse( '1.0_3' )->normal yields v1.30.0 instead of v1.0.0_3 whereas version->parse( '1.0' )->normal yields correctly v1.0.0
288 58         1706 my $clone = $self->clone;
289 58         74157 my $alpha = $clone->alpha;
290 58         10809 $clone->alpha( undef );
291 58         11284 $v = $clone->_stringify;
292 58   100     921 $self->message( 4, "Alpha value is '", ( $alpha // '' ), "'. Stringified version string, before calling version, is: $v" );
293 58         2365 my $str = version->parse( $v )->numify;
294 58 100 66     364 $str .= "_${alpha}" if( defined( $alpha ) && length( "$alpha" ) );
295 58 100 66     663 $self->message( 4, "Numified version string is '$str', appending alpha ? ", ( ( defined( $alpha ) && length( "$alpha" ) ) ? "'_${alpha}'" : 'no' ) );
296 58         1545 return( $str );
297             }
298             else
299             {
300 1         4 $self->message( 4, "Returning cloned object for numified version." );
301 1         48 my $new = $self->clone;
302             # This will also remove qv boolean
303 1         1216 $new->type( 'decimal' );
304 1         222 return( $new );
305             }
306             }
307 59 0 0     361 catch( $e )
  0 0 33     0  
  0 0       0  
  59 0       114  
  59 0       87  
  59 0       96  
  59 0       105  
  59 0       214  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 50       0  
  0 50       0  
  0 50       0  
  0 50       0  
  0 50       0  
  0 0       0  
  0 50       0  
  0         0  
  0         0  
  0         0  
  59         197  
  0         0  
  59         92  
  0         0  
  0         0  
  59         22369  
  59         306  
  59         133  
  59         185  
  0         0  
  0         0  
  0         0  
  0         0  
308 0     0   0 {
309 0         0 return( $self->error( "Error numifying version $v: $e" ) );
310 20 0 0 20   181 }
  20 0 0     49  
  20 0 33     36636  
  0 0 66     0  
  0 0 66     0  
  0 0 33     0  
  0 0 33     0  
  0 0 0     0  
  0 0 0     0  
  0 0 0     0  
  0 0 0     0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 50       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  59 0       166  
  0 0       0  
  59 50       514  
  59 50       359  
  59 50       193  
  0 50       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  59         928  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
311             }
312              
313 89     89 1 435345 sub original { return( shift->_set_get_scalar_as_object( 'original', @_ ) ); }
314              
315 61     61 1 184 sub padded { return( shift->reset(@_)->_set_get_boolean( 'padded', @_ ) ); }
316              
317             sub parse
318             {
319 89     89 1 48312 my $self = shift( @_ );
320 89         260 my $str = shift( @_ );
321 89 50 33     754 return( $self->error( "No version string was provided." ) ) if( !defined( $str ) || !length( "$str" ) );
322 89 50       3403 if( $str =~ /^$VERSION_LAX_REGEX$/ )
323             {
324 89         2862 my $re = { %+ };
325 89     0   1507 $self->message( 4, "Found version with regexp data -> ", sub{ $self->dump( $re ) } );
  0         0  
326 89         5140 my $def = { original => $str };
327 89 100 66     1103 if( defined( $re->{dotted} ) && length( $re->{dotted} ) )
    50 33        
328             {
329 10         33 $def->{type} = 'dotted';
330             }
331             elsif( defined( $re->{decimal} ) && length( $re->{decimal} ) )
332             {
333 79         342 $def->{type} = 'decimal';
334             }
335             else
336             {
337 0         0 return( $self->error( "No version types found. This should not happen." ) );
338             }
339 89         171 my $v;
340 89 100 66     515 $def->{qv} = 1 if( defined( $re->{has_v} ) && length( $re->{has_v} ) );
341 89         297 $def->{major} = $re->{major};
342 89 100 66     774 $def->{alpha} = $re->{alpha} if( defined( $re->{alpha} ) && length( $re->{alpha} ) );
343 89 100       516 if( $def->{type} eq 'dotted' )
    50          
344             {
345 10 50       41 if( defined( $re->{minor_patch} ) )
346             {
347 10         57 my @frags = split( /\./, $re->{minor_patch} );
348 10         25 shift( @frags );
349 10         25 $def->{minor} = shift( @frags );
350 10         29 $def->{patch} = shift( @frags );
351 10         30 $def->{extra} = \@frags;
352             }
353 10         148 $v = version->parse( $re->{dotted} );
354             }
355             elsif( $def->{type} eq 'decimal' )
356             {
357             # $def->{minor} = $re->{minor} if( defined( $re->{minor} ) );
358             # $re->{release} is the decimal version without the alpha information if it is smaller than 3
359             # This issue stems from decimal number having an underscore can either mean they have a version like
360             # 5.006_002 which would be equivalent v5.6.2 and in this case, "_002" is not an alpha information; and
361             # 1.002_03 where 03 is the alpha version and should be converted to 1.2_03, but instead becomes v1.2.30
362             # If compatibility with 'compat' is enabled, then we use the classic albeit erroneous way of converting the decimal version
363 79 100 66     444 if( defined( $def->{alpha} ) &&
      66        
364             length( $def->{alpha} ) < 3 &&
365             !$self->compat )
366             {
367 1         169 $self->message( 5, "Decimal version has alpha value. Getting version object from '$re->{release}'" );
368 1         29 $v = version->parse( "$re->{release}" );
369             }
370             else
371             {
372 78         512 $self->message( 5, "Getting version object from '$str'" );
373 78         2789 $v = version->parse( "$str" );
374             }
375 79         774 my $vstr = $v->normal;
376 79         776 $self->message( 5, "Sub parsing normalised version '$v'" );
377 79 50       4061 if( $vstr =~ /^$VERSION_LAX_REGEX$/ )
378             {
379 79         1927 my $re2 = { %+ };
380 79     0   910 $self->message( 5, "Subparsing yielded -> ", sub{ $self->dump( $re2 ) } );
  0         0  
381 79 50 33     2739 if( defined( $re2->{dotted} ) && length( $re2->{dotted} ) )
382             {
383 79 50       336 if( defined( $re2->{minor_patch} ) )
384             {
385 79         231 $def->{major} = $re2->{major};
386 79         421 my @frags = split( /\./, $re2->{minor_patch} );
387 79         173 shift( @frags );
388 79         234 $def->{minor} = shift( @frags );
389 79         233 $def->{patch} = shift( @frags );
390 79         423 $def->{extra} = \@frags;
391             }
392             }
393             }
394             }
395 89     0   705 $self->message( 5, "Version components are -> ", sub{ $self->dump( $def ) } );
  0         0  
396 89         2689 my $new = $self->new( %$def );
397 89 50       1004 $new->{_version} = $v if( defined( $v ) );
398 89 50       406 return( $self->pass_error ) if( !defined( $new ) );
399 89         285 CORE::delete( $new->{_reset} );
400 89         1427 return( $new );
401             }
402             else
403             {
404 0         0 return( $self->error( "Invalid version '$str'" ) );
405             }
406             }
407              
408 390     390 1 359260 sub patch { return( shift->reset(@_)->_set_get_number( { field => 'patch', undef_ok => 1 }, @_ ) ); }
409              
410 57     57 1 177 sub pretty { return( shift->reset(@_)->_set_get_boolean( 'pretty', @_ ) ); }
411              
412 448     448 1 20880 sub qv { return( shift->reset(@_)->_set_get_boolean( 'qv', @_ ) ); }
413              
414 0     0 1 0 sub rc { return( shift->_set_get_scalar_as_object( 'rc', @_ ) ); }
415              
416             sub reset
417             {
418 2509     2509 1 3835 my $self = shift( @_ );
419 2509 100 33     16302 if( (
      100        
420             !exists( $self->{_reset} ) ||
421             !defined( $self->{_reset} ) ||
422             !CORE::length( $self->{_reset} )
423             ) && scalar( @_ ) )
424             {
425             # XXX
426             # my $trace = $self->_get_stack_trace;
427             # print( STDERR ref( $self ), "::reset called with trace $trace\n" );
428 163         521 $self->{_reset} = scalar( @_ );
429 163 100       671 if( defined( $self->{major} ) )
430             {
431 73         286 my $str = $self->_stringify;
432 73 50 33     741 try
  73         226  
  73         162  
  73         645  
  0         0  
  73         132  
  73         198  
  73         153  
433 73     73   128 {
434 73         743 my $v = version->parse( "$str" );
435 73         369 $self->{_version} = $v;
436             }
437 73 0 50     431 catch( $e )
  73 0 33     250  
  73 0       227  
  73 0       134  
  73 0       146  
  73 0       154  
  73 0       145  
  73 0       319  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 50       0  
  0 50       0  
  0 50       0  
  0 50       0  
  0 50       0  
  0 0       0  
  0 50       0  
  0         0  
  0         0  
  0         0  
  73         350  
  0         0  
  73         162  
  0         0  
  0         0  
  73         220  
  73         291  
  73         167  
  73         185  
  0         0  
  0         0  
  0         0  
  0         0  
438 0     0   0 {
439 0 0       0 warn( "Warning only: error trying to get a version object from version string '$str': $e\n" ) if( $self->_warnings_is_enabled );
440 20 0 0 20   183 }
  20 0 0     44  
  20 0 33     65666  
  0 0 33     0  
  0 0 33     0  
  0 0 0     0  
  0 0 0     0  
  0 0 0     0  
  0 0 0     0  
  0 0 0     0  
  0 0 0     0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 50       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  73 0       184  
  0 0       0  
  73 0       1413  
  0 0       0  
  0 0       0  
  0 50       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 50       0  
  0 50       0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  73         249  
  0         0  
  0         0  
  0         0  
  0         0  
  73         234  
441             }
442             }
443 2509         13322 return( $self );
444             }
445              
446 0     0 1 0 sub target { return( shift->_set_get_scalar_as_object( 'target', @_ ) ); }
447              
448             sub type { return( shift->reset(@_)->_set_get_scalar_as_object({
449             field => 'type',
450             callbacks =>
451             {
452             add => sub
453             {
454 92     92   11337 my $self = shift( @_ );
455 92 100       501 if( $self->{type} eq 'decimal' )
    50          
456             {
457 82         1236 $self->{qv} = 0;
458             }
459             elsif( $self->{type} eq 'dotted' )
460             {
461             # By default
462 10         233 $self->{qv} = 1;
463             }
464             }
465             }
466 401     401 1 686488 }, @_ ) ); }
467              
468             sub _bool
469             {
470 0     0   0 my $self = shift( @_ );
471             # return( $self->_compare( $self->_version, version->new("0"), 1 ) );
472 0         0 return( $self->_compare( $self, "0", 1 ) );
473             }
474              
475             sub _cascade
476             {
477 84     84   183 my $self = shift( @_ );
478 84         175 my $frag = shift( @_ );
479             # We die, because this is an internal method and those cases should not happen unless this were a design bug
480 84 50 33     457 if( !defined( $frag ) || !length( $frag ) )
    50          
481             {
482 0         0 die( "No fragment was provided to cascade" );
483             }
484             elsif( $frag !~ /^(major|minor|patch|alpha|\d+)$/ )
485             {
486 0         0 die( "Unsupported version fragment '$frag'. Only use 'major', 'minor', 'patch' or 'alpha' or a number starting from 1 (1 = major, 2 = minor, etc)." );
487             }
488 84         1522 my $extra = $self->extra;
489 84 50       12454 my $frag_is_int = ( $frag =~ /^\d+$/ ? 1 : 0 );
490 84 100 33     1182 if( $frag eq 'major' || ( $frag_is_int && $frag == 1 ) )
    100 66        
    100 33        
    50 66        
    0 33        
      66        
491             {
492 21         329 $self->alpha( undef );
493 21         6795 $self->patch(0);
494 21         198175 $self->minor(0);
495             }
496             elsif( $frag eq 'minor' || ( $frag_is_int && $frag == 2 ) )
497             {
498 21         536 $self->alpha( undef );
499 21         6623 $self->patch(0);
500             }
501             elsif( $frag eq 'patch' || ( $frag_is_int && $frag == 3 ) )
502             {
503 21         710 $self->alpha( undef );
504 21   50     6887 $self->message( 4, "After setting undef, value for alpha is '", ( $self->{alpha} // '' ), "'" );
505             }
506             elsif( $frag eq 'alpha' )
507             {
508             # Nothing to do
509             }
510             elsif( $frag_is_int )
511             {
512 0         0 my $offset = ( $frag - 4 );
513 0         0 my $len = $extra->length;
514             # Before the fragment offset, we set the value to 0 if it is undefined or empty, and
515             # after the fragment offset everything else is reset to 0
516 0 0       0 for( my $i = 0; $i < ( $offset < $len ? $len : $offset ); $i++ )
517             {
518 0 0 0     0 if( (
      0        
      0        
519             $i < $offset &&
520             ( !defined( $extra->[$i] ) || !length( $extra->[$i] ) )
521             ) || $i > $offset )
522             {
523 0         0 $extra->[$i] = 0;
524             }
525             }
526 0         0 $self->alpha( undef );
527             }
528             }
529              
530             sub _compare
531             {
532 40     40   17597 my( $left, $right, $swap ) = @_;
533 40 50       267 $left->message( 4, "Arguments received: '", overload::StrVal( $left ), "' '", ( defined( $right ) ? $right : 'undef' ), "', '", ( defined( $swap ) ? $swap : 'undef' ), "'" );
    50          
534 40         1486 my $class = ref( $left );
535 40 50       282 unless( $left->_is_a( $right => $class ) )
536             {
537 40         964 $right = $class->new( $right, debug => $left->debug );
538             }
539              
540 40 50       358 if( $swap )
541             {
542 0         0 ( $left, $right ) = ( $right, $left );
543             }
544            
545 40 50       207 unless( _verify( $left ) )
546             {
547 0 0       0 die( "Invalid version ", ( $swap ? 'format' : 'object ' . overload::StrVal( $left ) ), "." );
548             }
549 40 50       145 unless( _verify( $right ) )
550             {
551 0 0       0 die( "Invalid version ", ( $swap ? 'format' : 'object' . overload::StrVal( $right ) ), "." );
552             }
553 40         213 my $lv = $left->_version;
554 40         119 my $rv = $right->_version;
555             # TODO: better compare version. perl's version fails at comparing version that have alpha.
556             # For example, the documentation states:
557             # Note that "alpha" version objects (where the version string contains a trailing underscore segment) compare as less than the equivalent version without an underscore:
558             # $bool = version->parse("1.23_45") < version->parse("1.2345"); # TRUE
559             # However, this is not true. The above doc example will yield FALSE, not TRUE, and even the following too:
560             # perl -Mversion -lE 'my $v = version->parse("v1.2.3"); my $v2 = version->parse("v1.2.3_4"); say $v > $v2'
561             # See RT#145290: <https://rt.cpan.org/Ticket/Display.html?id=145290>
562             # return( $left->{_version} == $right->{_version} );
563 40         742 $left->message( 5, "Comparing '$lv' to '$rv' -> '", ( $lv == $rv ), "'" );
564             # return( $lv == $rv );
565 40         1076 return( $lv <=> $rv );
566             }
567              
568             sub _compute
569             {
570 96     96   236 my $self = shift( @_ );
571 96         189 my $opts = pop( @_ );
572 96         298 my( $other, $swap, $nomethod, $bitwise ) = @_;
573             # XXX
574             # print( STDERR ref( $self ), "::compute: Called with \$other = '", ( $other // '' ), "', swap = '", ( $swap // '' ), "' and extra '", ( $nomethod // '' ), "' and \$bitwise is '", ( $bitwise // '' ), "'\n" );
575 96   50     284 my $frag = $self->default_frag // 'minor';
576 96   50     19285 $self->message( 5, "Called with \$frag = '$frag' (default fragment is '", ( $self->default_frag // 'undef' ), "'), \$other = '", ( $other // '' ), "', swap = '", ( $swap // '' ), "' and extra '", ( $nomethod // '' ), "' and \$bitwise is '", ( $bitwise // '' ), "'" );
      100        
      100        
      50        
      50        
577 96 50       18924 $frag = 'minor' if( $frag !~ /^(major|minor|patch|alpha|\d+)$/ );
578 96 50 33     2466 if( !defined( $opts ) ||
      33        
      33        
      33        
579             ref( $opts ) ne 'HASH' ||
580             !exists( $opts->{op} ) ||
581             !defined( $opts->{op} ) ||
582             !length( $opts->{op} ) )
583             {
584 0         0 die( "No argument 'op' provided" );
585             }
586 96         271 my $op = $opts->{op};
587 96         2358 my $clone = $self->clone;
588 96         124519 my $extra = $self->extra;
589 96 50       16296 my $frag_is_int = ( $frag =~ /^\d+$/ ? 1 : 0 );
590 96         1148 my $map =
591             {
592             1 => 'major',
593             2 => 'minor',
594             3 => 'patch',
595             };
596 96         178 my $coderef;
597 96 50 33     691 if( ( $frag_is_int && exists( $map->{ $frag } ) ) || !$frag_is_int )
      33        
598             {
599             $coderef = $self->can( $map->{ $frag } // $frag ) ||
600 96   50     261 die( "Cannot find code reference for method ", ( $frag_is_int ? $map->{ $frag } : $frag ) );
601             }
602 96 50       1991 my $val = defined( $coderef ) ? $coderef->( $self ) : $extra->[ $frag - 4 ];
603 96 50       16420 $self->message( 4, "Operation is '$op' for fragment '$frag' and $frag value '", ( defined( $val ) ? $val : 'undef' ), "' (", overload::StrVal( $val ), "), other is '", ( defined( $other ) ? $other : 'undef' ), " (", overload::StrVal( $other ), ") and swap is ", ( $swap ? 'true' : 'not true' ) );
    100          
    100          
604 96         4166 my $err;
605 96 50       572 if( !defined( $val ) )
    50          
606             {
607 0         0 $val = $self->new_number(0);
608             }
609             elsif( !$self->_is_a( $val => 'Module::Generic::Number' ) )
610             {
611 0         0 $val = $self->new_number( "$val" );
612 0 0       0 if( !defined( $val ) )
613             {
614 0         0 $err = $self->error->message;
615             }
616             }
617 96         4138 my $n = $val->scalar;
618 96         784 my $eval;
619 96 100 100     596 if( $opts->{op} eq '++' || $opts->{op} eq '--' )
620             {
621 16         52 $eval = "\$n${op}";
622             }
623             else
624             {
625 80 50       395 $eval = $swap ? ( defined( $other ) ? $other : 'undef' ) . "${op} \$n" : "\$n ${op} " . ( defined( $other ) ? $other : 'undef' );
    50          
    100          
626             }
627 96         429 $self->message( 5, "Evaluating '$eval'" );
628 96         8689 my $rv = eval( $eval );
629 96 50       571 $err = $@ if( $@ );
630 96         731 $self->message( 5, "\$rv = '$rv' and \$@ = '$@'" );
631 96 50       2216 if( defined( $err ) )
632             {
633 0 0       0 warn( $err, "\n" ) if( $self->_warnings_is_enabled );
634             # Return unchanged
635             # return( $swap ? $other : $self );
636 0         0 return;
637             }
638            
639 96 100       350 if( $swap )
640             {
641 16 50       142 return( ref( $rv ) ? $rv->scalar : $rv );
642             }
643             else
644             {
645 80         128 my $new = $clone;
646 80         129 my $new_val;
647 80 100 100     390 if( $op eq '++' || $op eq '--' )
648             {
649 16         30 $new = $self;
650 16         35 $new_val = $n;
651             }
652             else
653             {
654 64         151 $new_val = int( $rv );
655             }
656            
657 80 50       170 if( defined( $coderef ) )
658             {
659 80         369 $self->message( 5, "Updating $frag level to $new_val" );
660 80         1741 $coderef->( $new, $new_val );
661             }
662             else
663             {
664 0         0 $self->message( 5, "Setting fragment offset $frag to $new_val" );
665 0         0 $extra->[( $frag - 4 )] = $new_val;
666             }
667 80         767593 $self->message( 5, "$frag is set to '", $coderef->( $new ), "'" );
668 80         14299 $new->_cascade( $frag );
669 80         379230 return( $new );
670             }
671             }
672              
673             sub _inc_dec
674             {
675 4     4   8 my $self = shift( @_ );
676 4   50     15 my $op = shift( @_ ) || return( $self->error( "No op was provided." ) );
677 4 50       27 return( $self->error( "Op can only be 'inc' or 'dec'" ) ) if( $op !~ /^(inc|dec)$/ );
678 4         10 my $frag = shift( @_ );
679 4         7 my $unit = shift( @_ );
680 4 50 33     47 if( !defined( $frag ) || !length( "$frag" ) )
    50          
681             {
682 0 0       0 return( $self->error( "No version fragment was specified to ", ( $op eq 'inc' ? 'increase' : 'decrease' ), " the version number." ) );
683             }
684             elsif( $frag !~ /^(major|minor|patch|alpha|\d+)$/ )
685             {
686 0 0       0 return( $self->error( "Unsupported version fragment '$frag' to ", ( $op eq 'inc' ? 'increase' : 'decrease' ), ". Only use 'major', 'minor', 'patch' or 'alpha' or a number starting from 1 (1 = major, 2 = minor, etc)." ) );
687             }
688 4 50 33     13 if( defined( $unit ) && $unit !~ /^\d+$/ )
689             {
690 0 0       0 return( $self->error( "Unit to ", ( $op eq 'inc' ? 'increase' : 'decrease' ), " fragment $frag value must be an integer." ) );
691             }
692 4         13 my $extra = $self->extra;
693 4 50       647 my $frag_is_int = ( $frag =~ /^\d+$/ ? 1 : 0 );
694 4         17 my $map =
695             {
696             1 => 'major',
697             2 => 'minor',
698             3 => 'patch',
699             };
700 4         5 my $coderef;
701 4 50 33     26 if( ( $frag_is_int && exists( $map->{ $frag } ) ) || !$frag_is_int )
      33        
702             {
703             $coderef = $self->can( $map->{ $frag } // $frag ) ||
704 4   50     35 die( "Cannot find code reference for method ", ( $frag_is_int ? $map->{ $frag } : $frag ) );
705             }
706 4 50       17 my $n = defined( $coderef ) ? $coderef->( $self ) : $extra->[ $frag - 4 ];
707             # The offset specified is out of bound
708 4 50 33     689 if( $frag_is_int && ( $frag - 4 ) > $extra->size )
    50 33        
709             {
710 0 0       0 $n = (
    0          
711             $op eq 'inc'
712             ? ( defined( $unit ) ? $unit : 1 )
713             : 0
714             );
715             }
716             elsif( defined( $unit ) && $unit == 1 )
717             {
718 0 0       0 $op eq 'inc' ? ( $n += $unit ) : ( $n -= $unit );
719             }
720             else
721             {
722 4 50       24 $op eq 'inc' ? $n++ : $n--;
723             }
724            
725 4 50       29 if( defined( $coderef ) )
726             {
727 4         15 $self->message( 5, "Updating $frag level to $n" );
728 4         101 $coderef->( $self, $n );
729             }
730             else
731             {
732 0         0 $extra->[( $frag - 4 )] = $n;
733             }
734 4         37160 $self->_cascade( $frag );
735 4         18627 return( $self );
736             }
737              
738             sub _noop
739             {
740 0     0   0 my( $self, $other, $swap, $nomethod, $bitwise ) = @_;
741 0 0       0 warn( "This operation $nomethod is not supported by Changes::Version\n" ) if( $self->_warnings_is_enabled );
742             }
743              
744             sub _stringify
745             {
746 190     190   402 my $self = shift( @_ );
747 190         564 my $comp = $self->new_array;
748 190         2821 my $def = {};
749 190         430 for( qw( major minor patch alpha ) )
750             {
751 760         87963 $def->{ $_ } = $self->$_;
752             }
753 190         31085 my $type = $self->type;
754 190 50 33     40794 $def->{major} = 0 if( !defined( $def->{major} ) || !length( $def->{major} ) );
755 190 100 50     1628 if( $self->qv || ( ( $type // '' ) eq 'dotted' ) )
    50 66        
      50        
756             {
757 94 50 33     14371 $def->{minor} = 0 if( !defined( $def->{minor} ) || !length( "$def->{minor}" ) );
758 94 50 33     878 $def->{patch} = 0 if( !defined( $def->{patch} ) || !length( "$def->{patch}" ) );
759             }
760             elsif( ( $type // '' ) eq 'decimal' )
761             {
762             # We need to avoid the scenario where we would have a major and alpha, but not minor.
763             # For example: 3_6 would trigger version error "Invalid version format (alpha without decimal)"
764 96 0 33     17216 $def->{minor} = 0 if( ( !defined( $def->{minor} ) || !length( "$def->{minor}" ) ) && defined( $def->{alpha} ) && length( "$def->{alpha}" ) );
      33        
      33        
765             }
766             # $self->message( 4, "version fragments are -> ", sub{ $self->dump( $def ) } );
767 190         1426 my $ok = 0;
768 190         382 for( qw( patch minor major ) )
769             {
770 570 50 66     3044 next if( !length( $def->{ $_ } ) && !$ok );
771             # We stop skipping version fragments as soon as one is defined
772 567         2347 $ok++;
773 567         1695 $comp->unshift( $def->{ $_ } );
774             }
775 190 100   567   1389 my $v = ( $self->qv ? 'v' : '' ) . $comp->map(sub{ 0 + $_ })->join( '.' )->scalar;
  567         446908  
776 190 100 66     226871 $v .= '_' . $def->{alpha} if( defined( $def->{alpha} ) && length( $def->{alpha} ) );
777 190         66550 return( $v );
778             }
779              
780             sub _verify
781             {
782 80     80   166 my $self = shift( @_ );
783 80 50       215 if( defined( $self ) )
784             {
785 80 50       340 $self->message( 5, "Is \$self a Changes::Version object? -> ", ( Module::Generic->_is_a( $self => 'Changes::Version' ) ? 'yes' : 'no' ), " and _version exists ? ", ( exists( $self->{_version} ) ? 'yes' : 'no' ), " and is _version (", overload::StrVal( $self->{_version} ), ") a version object ? ", ( Module::Generic->_is_a( $self->{_version} => 'version' ) ? 'yes' : 'no' ) );
    50          
    50          
786             }
787 80 50 33     7081 if( defined( $self ) &&
      33        
      33        
788             Module::Generic->_is_a( $self => 'Changes::Version' ) &&
789 80         2621 eval{ exists( $self->{_version} ) } &&
790             Module::Generic->_is_a( $self->{_version} => 'version' ) )
791             {
792 80         2256 return(1);
793             }
794             else
795             {
796 0         0 return(0);
797             }
798             }
799              
800             sub _version
801             {
802 80     80   157 my $self = shift( @_ );
803 80 50 33     584 if( @_ )
    50          
804             {
805 0         0 my $v = shift( @_ );
806 0 0       0 return( $self->error( "Value provided is not a version object." ) ) if( !$self->_is_a( $v => 'version' ) );
807             }
808             elsif( !exists( $self->{_version} ) || !defined( $self->{_version} ) )
809             {
810 0         0 my $str = $self->_stringify;
811 0 0 0     0 try
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
812 0     0   0 {
813 0         0 $self->{_version} = version->parse( "$str" );
814             }
815 0 0 0     0 catch( $e )
  0 0 0     0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
816 0     0   0 {
817 0 0       0 warn( "Warning only: error trying to get a version object from version string '$str': $e\n" ) if( $self->_warnings_is_enabled );
818 20 0 0 20   188 }
  20 0 0     50  
  20 0 0     3781  
  0 0 0     0  
  0 0 0     0  
  0 0 0     0  
  0 0 0     0  
  0 0 0     0  
  0 0 0     0  
  0 0 0     0  
  0 0 0     0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
819             }
820 80         194 return( $self->{_version} );
821             }
822              
823             1;
824             # NOTE: POD
825             __END__
826              
827             =encoding utf-8
828              
829             =head1 NAME
830              
831             Changes::Version - Version string object class
832              
833             =head1 SYNOPSIS
834              
835             use Changes::Version;
836             my $v = Changes::Version->new(
837             major => 1,
838             minor => 2,
839             patch => 3,
840             alpha => 4,
841             qv => 1,
842             debug => 2,
843             );
844             # or
845             my $v = Changes::Version->new( 'v0.1.2_3' );
846             # or
847             my $v = Changes::Version->new( 'v0.1.2_3', alpha => 4 );
848             # or
849             my $v = Changes::Version->new( 'v0.1.2_3', { alpha => 4 } );
850             # or
851             my $v = Changes::Version->new( major => 0, minor => 1, patch => 2, alpha => 3, qv => 1 );
852             # or
853             my $v = Changes::Version->new({ major => 0, minor => 1, patch => 2, alpha => 3, qv => 1 });
854             die( Changes::Version->error ) if( !defined( $v ) );
855             my $v = Changes::Version->parse( 'v1.2.3_4' );
856             die( Changes::Version->error ) if( !defined( $v ) );
857             my $type = $v->type;
858             $v->type( 'decimal' );
859             $v->padded(0);
860             $v->pretty(1);
861             $v->type( 'dotted' );
862             $v++;
863             # Updating 'minor'
864             say "$v"; # v1.3.0
865             $v += 2;
866             $v->default_frag( 'major' );
867             $v++;
868             say "$v"; # v2.0.0
869             $v->inc_patch;
870             say $v->is_alpha; # false
871             say $v->numify; # returns new Changes::Version object
872             say $v->normal; # returns new Changes::Version object
873             say $v->as_string; # same as say "$v";
874              
875             =head1 VERSION
876              
877             v0.1.0
878              
879             =head1 DESCRIPTION
880              
881             This class represents a software version based on perl's definition and providing for perl recommended C<dotted decimal> and also C<decimal> types. In the future, this will be expanded to other non-perl version formats.
882              
883             It allows for parsing and manipulation of version objects.
884              
885             =head1 CONSTRUCTOR
886              
887             =head2 new
888              
889             Provided with an optional version string and an optional hash or hash reference of options and this will instantiate a new L<Changes::Version> object.
890              
891             If an error occurs, it will return an L<error|Module::Generic/error>, so alway check for the definedness of the returned value.
892              
893             my $v = Changes::Version->new(
894             major => 1,
895             minor => 2,
896             patch => 3,
897             alpha => 4,
898             );
899             die( Changes::Version->error ) if( !defined( $v ) );
900              
901             Note that if you do:
902              
903             my $v = Changes::Version->new( ... ) || die( Changes::Version->error );
904              
905             would be dangerous, because you would be assessing the return version object in a boolean context that could return false if the version was C<0>.
906              
907             It supports the following options that can also be accessed or changed with their corresponding method.
908              
909             =over 4
910              
911             =item * C<alpha>
912              
913             Specifies the alpha fragment integer of the version. See L</alpha> for more information.
914              
915             my $v = Changes::Version->new(
916             major => 1,
917             minor => 2,
918             patch => 3,
919             alpha => 4,
920             );
921             my $alpha = $v->alpha; # 4
922             $v->alpha(7);
923             say "$v"; # v1.2.3_7
924              
925             =item * C<beta>
926              
927             Specifies the beta fragment integer of the version. See L</beta> for more information.
928              
929             Currently unused and reserved for future release.
930              
931             =item * C<compat>
932              
933             Boolean. When enabled, this will ensure the version formatting is strictly compliant with the L<version> module. Default to false.
934              
935             =item * C<default_frag>
936              
937             Specifies the fragment name or integer value used by overloaded operations.
938              
939             my $v = Changes::Version->new( 'v1.2.3_4' );
940             my $default = $v->default_frag; # By default 'minor'
941             $v->default_frag( 'major' );
942             $v++; # Version is now v2.2.3_4
943              
944             =item * C<extra>
945              
946             Specifies the array reference of version fragments beyond C<patch>
947              
948             my $v = Changes::Version->new(
949             major => 1,
950             minor => 2,
951             patch => 3,
952             alpha => 12,
953             extra => [qw( 4 5 6 7 )],
954             );
955             say "$v"; # v1.2.3.4.5.6.7_12
956             my $a = $v->extra; # contains 4, 5, 6, 7
957              
958             =item * C<major>
959              
960             Specifies the C<major> fragment of the version string.
961              
962             my $v = Changes::Version->new(
963             major => 1,
964             minor => 2,
965             patch => 3,
966             alpha => 4,
967             );
968             my $major = $v->major; # 1
969             say "$v"; # v1.2.3_4
970             $v->major(3);
971             say "$v"; # v3.0.0
972              
973             =item * C<minor>
974              
975             Specifies the C<minor> fragment of the version string.
976              
977             my $v = Changes::Version->new(
978             major => 1,
979             minor => 2,
980             patch => 3,
981             alpha => 4,
982             );
983             my $minor = $v->minor; # 2
984             say "$v"; # v1.2.3_4
985             $v->minor(3);
986             say "$v"; # v1.3.0
987              
988             =item * C<original>
989              
990             Specifies an original version string. This is normally set by L</parse> and used by L</as_string> to bypass any formatting when nothing has been changed.
991              
992             =item * C<padded>
993              
994             Specifies whether version string of type decimal should be zero padded or not. Default to true.
995              
996             my $v = Change::Version->new(
997             major => 1,
998             minor => 20,
999             patch => 300,
1000             type => 'decimal',
1001             );
1002             say "$v"; # 1.020300
1003             $v->padded(0);
1004             say "$v"; # 1.0203
1005              
1006             =item * C<patch>
1007              
1008             Specifies the C<patch> fragment of the version string.
1009              
1010             my $v = Changes::Version->new(
1011             major => 1,
1012             minor => 2,
1013             patch => 3,
1014             alpha => 4,
1015             );
1016             my $patch = $v->patch; # 3
1017             say "$v"; # v1.2.3_4
1018             $v->patch(7);
1019             say "$v"; # v1.3.7
1020              
1021             =item * C<pretty>
1022              
1023             Specifies whether version string of type C<decimal> should be formatted with an underscore (C<_>) separating thousands in the fraction part.
1024              
1025             my $v = Change::Version->new(
1026             major => 1,
1027             minor => 20,
1028             patch => 300,
1029             type => 'decimal',
1030             pretty => 1,
1031             );
1032             say "$v"; # 1.020_300
1033             $v->pretty(0);
1034             say "$v"; # 1.020300
1035              
1036             =item * C<qv>
1037              
1038             Specifies whether version string of type C<dotted> should be formatted with the prefix C<v>. Defaults to true.
1039              
1040             my $v = Changes::Version->new(
1041             major => 1,
1042             minor => 2,
1043             patch => 3,
1044             alpha => 4,
1045             );
1046             say "$v"; # v1.2.3_4
1047             $v->qv(0);
1048             say "$v"; # 1.2.3_4
1049              
1050             =item * C<rc>
1051              
1052             Specifies the release candidate value. This is currently unused and reserved for future release.
1053              
1054             =item * C<target>
1055              
1056             Specifies the target formatting for the version string. By default this is C<perl> and is the only supported value for now. In future release, other format types will be supported, such as C<opensource>.
1057              
1058             =item * C<type>
1059              
1060             Specifies the version type. Possible values are C<dotted> for dotted decimal versions such as C<v1.2.3> or C<decimal> for decimal versions such as C<1.002003>
1061              
1062             =back
1063              
1064             =head2 parse
1065              
1066             Provided with a version string, and this will parse it and return a new L<Changes::Version> object.
1067              
1068             Currently, only 2 version types are supported: C<dotted decimal> and C<decimal>
1069              
1070             v1.2
1071             1.2345.6
1072             v1.23_4
1073             1.2345
1074             1.2345_01
1075              
1076             are all legitimate version strings.
1077              
1078             If an error occurred, this will return an L<error|Module::Generic/error>.
1079              
1080             =head1 METHODS
1081              
1082             =head2 alpha
1083              
1084             Sets or gets the C<alpha> fragment integer of the version.
1085              
1086             Setting this to C<undef> effectively removes it.
1087              
1088             Returns a L<number object|Module::Generic::Number>
1089              
1090             =head2 as_string
1091              
1092             Returns a version string properly formatted according to the C<type> set with L</type> and other parameters sets such as L</qv>, L</padded> and L</pretty>
1093              
1094             Resulting value is cached, which means the second time this is called, the cached value will be returned for speed.
1095              
1096             Any change to the version object parameters, and this will force the re-formatting of the version string.
1097              
1098             For example:
1099              
1100             my $v = Changes::Version->new( 'v1.2.3_4' );
1101             # This is a version of type 'dotted' for dotted decimal
1102             say "$v"; # v1.2.3_4
1103             # Changing the patch level
1104             $v->inc( 'patch' );
1105             # Now forced to re-format
1106             say "$v"; # v1.2.4
1107             # No change, using the cache
1108             say "$v"; # v1.2.4
1109              
1110             =head2 beta
1111              
1112             The beta fragment integer of the version. This is currently unused and reserved for future release of this class.
1113              
1114             =head2 compat
1115              
1116             Boolean. When enabled, this will ensure the version formatting is strictly compliant with the L<version> module. Default to false.
1117              
1118             =head2 dec
1119              
1120             Provided with a version fragment, and an optiona integer, and this will decrease the version fragment value by as much. If no integer is provided, the default decrement is 1.
1121              
1122             my $v = Changes::Version->new(
1123             major => 1,
1124             minor => 2,
1125             patch => 3,
1126             alpha => 4,
1127             );
1128             say "$v"; # v1.2.3_4;
1129             $v->dec( 'alpha' );
1130             say "$v"; # v1.2.3_3;
1131             $v->dec( 'patch', 2 );
1132             say "$v"; # v1.2.1
1133              
1134             my $v = Changes::Version->new( 'v1.2.3.4.5.6.7_8' );
1135             # Decrease the 5th fragment
1136             $v->dec(5);
1137             say "$v"; # v1.2.3.4.4.0.0
1138              
1139             Any change to a fragment value will reset the lower fragment values to zero. Thus:
1140              
1141             =over 4
1142              
1143             =item * changing the C<major> value will reset C<minor> and C<patch> to 0 and C<alpha> to C<undef>
1144              
1145             =item * changing the C<minor> value will reset C<patch> to 0 and C<alpha> to C<undef>
1146              
1147             =item * changing the C<patch> value will reset C<alpha> to C<undef>
1148              
1149             =item * changing the nth fragment value will reset all fragment value after that to 0
1150              
1151             =back
1152              
1153             If you pass a fragment that is an integer and it is outside the maximum number of fragments, it will automatically expand the number of version fragments and initialise the intermediary fragments to 0. A fragment as an integer starts at 1.
1154              
1155             Using the example above:
1156              
1157             $v->dec(10);
1158             say "$v"; # v1.2.3.4.5.6.7.0.0.0
1159              
1160             The 10th element is set to 0 because it does not exist, so it cannot be decreased.
1161              
1162             =head2 dec_alpha
1163              
1164             This is a shortcut for calling L</dec> on fragment C<alpha>
1165              
1166             =head2 dec_beta
1167              
1168             This is a shortcut for calling L</dec> on fragment C<beta>
1169              
1170             =head2 dec_major
1171              
1172             This is a shortcut for calling L</dec> on fragment C<major>
1173              
1174             =head2 dec_minor
1175              
1176             This is a shortcut for calling L</dec> on fragment C<minor>
1177              
1178             =head2 dec_patch
1179              
1180             This is a shortcut for calling L</dec> on fragment C<patch>
1181              
1182             =head2 default_frag
1183              
1184             my $v = Changes::Version->new( 'v1.2.3_4' );
1185             my $default = $v->default_frag; # By default 'minor'
1186             $v->default_frag( 'major' );
1187             $v++; # Version is now v2.2.3_4
1188              
1189             String. Sets or gets the name or the integer value for the version fragment. Supported value can be C<major>, C<minor>. C<patch>, C<alpha>, or an integer.
1190              
1191             Returns a L<scalar object|Module::Generic::Scalar>
1192              
1193             =head2 extra
1194              
1195             Sets or gets an array reference of version fragments starting from C<1> for C<major>, C<2> for C<minor>, C<3> for C<patch>, etc. For example:
1196              
1197             my $v = Changes::Version->new( 'v1.2.3.4.5.6.7_8' );
1198             my $a = $v->extra; # contains 4, 5, 6, 7
1199              
1200             Note that C<alpha> is not accessible via digits, but only using L</alpha>
1201              
1202             You should not be accessing this directly.
1203              
1204             Returns an L<array object|Module::Generic::Array>
1205              
1206             =head2 inc
1207              
1208             Same as L</dec>, but increasing instead of decreasing.
1209              
1210             =head2 inc_alpha
1211              
1212             This is a shortcut for calling L</inc> on fragment C<alpha>
1213              
1214             =head2 inc_beta
1215              
1216             This is a shortcut for calling L</inc> on fragment C<beta>
1217              
1218             =head2 inc_major
1219              
1220             This is a shortcut for calling L</inc> on fragment C<major>
1221              
1222             =head2 inc_minor
1223              
1224             This is a shortcut for calling L</inc> on fragment C<minor>
1225              
1226             =head2 inc_patch
1227              
1228             This is a shortcut for calling L</inc> on fragment C<patch>
1229              
1230             =head2 is_alpha
1231              
1232             Returns true if L</alpha> has a value set.
1233              
1234             =head2 is_qv
1235              
1236             Returns true if L</qv> is set to true, false otherwise.
1237              
1238             =head2 major
1239              
1240             Sets or gets the C<major> fragment of the version string.
1241              
1242             my $v = Changes::Version->new( 'v1.2.3_4' );
1243             my $major = $v->major; # 1
1244             $v->major(3);
1245             say "$v"; # v3.2.3_4
1246              
1247             Setting this to C<undef> effectively removes it.
1248              
1249             Returns a L<number object|Module::Generic::Number>
1250              
1251             =head2 minor
1252              
1253             Sets or gets the C<minor> fragment of the version string.
1254              
1255             my $v = Changes::Version->new( 'v1.2.3_4' );
1256             my $minor = $v->minor; # 2
1257             $v->minor(3);
1258             say "$v"; # v1.3.3_4
1259              
1260             Setting this to C<undef> effectively removes it.
1261              
1262             Returns a L<number object|Module::Generic::Number>
1263              
1264             =head2 normal
1265              
1266             Returns a new L<Changes::Version> object as a normalised version, which is a dotted decimal format with the C<v> prefix.
1267              
1268             If an error occurred, an L<error|Module::Generic/error> is returned.
1269              
1270             =head2 numify
1271              
1272             Returns a new L<Changes::Version> object as a number, which represent a decimal-type version
1273              
1274             Contrary to L<version> if there is an C<alpha> value set, it will add it to the numified version.
1275              
1276             my $v = Changes::Version->new(
1277             major => 1,
1278             minor => 2,
1279             patch => 3,
1280             alpha => 4,
1281             );
1282             say $v->numify; # 1.002003_4
1283              
1284             L<version> would yields a different, albeit wrong result:
1285              
1286             perl -Mversion -lE 'say version->parse("v1.2.3_4")->numify'
1287              
1288             would wrongly return C<1.002034> and not C<1.002003_4>
1289              
1290             perl -Mversion -lE 'say version->parse("1.002034")->normal'
1291              
1292             then yields C<v1.2.34>
1293              
1294             If an error occurred, an L<error|Module::Generic/error> is returned.
1295              
1296             =head2 original
1297              
1298             Sets or gets the original string. This is set by L</parse>
1299              
1300             Returns a L<scalar object|Module::Generic::Scalar>
1301              
1302             =head2 padded
1303              
1304             Boolean. Sets or ges whether the resulting version string of type C<decimal> should be '0' padded or not. Default to pad with zeroes decimal numbers.
1305              
1306             For example:
1307              
1308             my $v = Changes::Version->new(
1309             major => 1,
1310             minor => 2,
1311             patch => 30,
1312             type => 'decimal',
1313             padded => 1,
1314             );
1315             say "$v"; # 1.002030
1316             $v->padded(0);
1317             say "$v"; # 1.00203
1318              
1319             Returns a L<boolean object|Module::Generic::Boolean>
1320              
1321             =head2 patch
1322              
1323             Sets or gets the C<patch> fragment of the version string.
1324              
1325             my $v = Changes::Version->new( 'v1.2.3_4' );
1326             my $patch = $v->patch; # 3
1327             $v->patch(5);
1328             say "$v"; # v1.3.5_4
1329              
1330             Returns a L<number object|Module::Generic::Number>
1331              
1332             =head2 pretty
1333              
1334             Boolean. When enabled, this will render version number for decimal type a bit cleaner by separating blocks of 3 digits by an underscore (C<_>). This does not work on dotted decimal version numbers such as C<v1.2.3> or on version that have an C<alpha> set up.
1335              
1336             my $v = Changes::Version->new(
1337             major => 1,
1338             minor => 2,
1339             patch => 30,
1340             type => 'decimal',
1341             );
1342              
1343             Returns a L<boolean object|Module::Generic::Boolean>
1344              
1345             =head2 qv
1346              
1347             Boolean. When enabled, this will prepend the dotted decimal version strings with C<v>. This is true by default.
1348              
1349             my $v = Changes::Version->new(
1350             major => 1,
1351             minor => 2,
1352             patch => 3,
1353             alpha => 4,
1354             );
1355             say "$v"; # v1.2.3_4
1356             $v->qv(0);
1357             say "$v"; # 1.2.3_4
1358              
1359             Returns a L<boolean object|Module::Generic::Boolean>
1360              
1361             =head2 rc
1362              
1363             Sets or gets the release candidate value. This is currently unused and reserved for future releases.
1364              
1365             Returns a L<scalar object|Module::Generic::Scalar>
1366              
1367             =for Pod::Coverage reset
1368              
1369             =head2 stringify
1370              
1371             This is an alias for L</as_string>
1372              
1373             =head2 target
1374              
1375             Sets or gets the target format. By default this is C<perl>. This means that L</as_string> will format the version string for C<perl>. n future release of this class, other format wil be supported, such as C<opensource>
1376              
1377             Returns a L<scalar object|Module::Generic::Scalar>
1378              
1379             =head2 type
1380              
1381             Sets or gets the version type. Currently, supported values are C<dotted> for dotted decimal versions such as C<v1.2.3>, and C<decimal> for decimal versions such as C<1.002003>.
1382              
1383             Returns a L<scalar object|Module::Generic::Scalar>
1384              
1385             =head1 OVERLOADED OPERATIONS
1386              
1387             The following operations are overloaded, and internally relies on L<version> to return the value. See also L<overload> for more information.
1388              
1389             Note that calling the version object with any operations other than those listed below will trigger a warning, if warnings are enabled with L<warnings> and C<undef> is return in scalar context or an empty list in list context.
1390              
1391             =over 4
1392              
1393             =item * C<stringification>
1394              
1395             Returns value from L</as_string>
1396              
1397             =item * C<0+>
1398              
1399             Returns value from L</numify>
1400              
1401             =item * C<< <=> >>
1402              
1403             Compares two versions. If the other version being compared is not a L<Changes::Version>, it is made one before comparison actually occurs.
1404              
1405             Note that, C<version> core module L<states in its documentation|version/"How to compare version objects"> that: "alpha" version objects (where the version string contains a trailing underscore segment) compare as less than the equivalent version without an underscore."
1406              
1407             $bool = version->parse("1.23_45") < version->parse("1.2345"); # TRUE
1408              
1409             However, as of perl v5.10, this is not true. The above will actually return false, not true. And so will the following:
1410              
1411             perl -Mversion -lE 'say version->parse("v1.002003") > version->parse("v1.002003_4");'
1412              
1413             This is on my bucket list of things to improve.
1414              
1415             =item * C<cmp>
1416              
1417             Same as above.
1418              
1419             =item * C<bool>
1420              
1421             =item * C<+>, C<->, C<*>, C</>
1422              
1423             When performing those operations, it will use the value of the fragment of the version set with L</default_frag>, which, by default, is C<minor>.
1424              
1425             It returns a new L<Changes::Version> object reflecting the new version value. However, if the operation is swapped, with the version object on the right-hand side instead of the left-hand side, this will return a regular number.
1426              
1427             my $vers = Changes::Version->new( 'v1.2.3_4' );
1428             my $new_version_object = $vers + 2; # Now v1.4.3_4 (minor has been bumped up by 2)
1429             $vers->default_frag( 'major' );
1430             my $new_version_object = $vers + 2; # Now v3.2.3_4 (this time, 'major' was increased)
1431              
1432             But, when swapped:
1433              
1434             my $vers = Changes::Version->new( 'v1.2.3_4' );
1435             my $n = 3 + $vers; # yields 5 (using the 'minor' fragment by default)
1436             $vers->default_frag( 'major' );
1437             my $n = 3 + $vers; # yields 4 (this time, using the 'major' fragment)
1438              
1439             =item * C<+=>, C<-=>, C<*=>, C</=>
1440              
1441             In this operations, it modifies the current object with the operand provided and returns the current object, instead of creating a new one.
1442              
1443             my $vers = Changes::Version->new( 'v1.2.3_4' );
1444             # By default, using the 'minor' fragment
1445             $vers += 1; # version is now v2.2.3_4
1446             $vers->default_frag( 'alpha' );
1447             $vers /= 2; # version is now v1.2.3_2
1448              
1449             =item * C<++>, C<-->
1450              
1451             When using those operations, it updates the current object directly and returns it. For example:
1452              
1453             my $vers = Changes::Version->new( 'v1.2.3_4' );
1454             # By default, using the 'minor' fragment
1455             $vers++; # version is now v1.3.3_4
1456              
1457             =back
1458              
1459             =head1 AUTHOR
1460              
1461             Jacques Deguest E<lt>F<jack@deguest.jp>E<gt>
1462              
1463             =head1 SEE ALSO
1464              
1465             L<Changes>, L<Changes::Release>, L<Changes::Group>, L<Changes::Change> and L<Changes::NewLine>
1466              
1467             L<version>, L<Perl::Version>
1468              
1469             L<CPAN::Meta::Spec/"Version Formats">
1470              
1471             L<http://www.modernperlbooks.com/mt/2009/07/version-confusion.html>
1472              
1473             L<https://xdg.me/version-numbers-should-be-boring/>
1474              
1475             L<https://en.wikipedia.org/wiki/Software_versioning>
1476              
1477             =head1 COPYRIGHT & LICENSE
1478              
1479             Copyright(c) 2022 DEGUEST Pte. Ltd.
1480              
1481             All rights reserved
1482              
1483             This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
1484              
1485             =cut