Perl-Version-1.013/000755 000765 000024 00000000000 12276760004 014305 5ustar00brianstaff000000 000000 Perl-Version-1.013/Changes000644 000765 000024 00000005774 12276757515 015632 0ustar00brianstaff000000 000000 Revision history for Perl-Version 0.0.1 2007-02-03 Initial release. 0.0.2 2007-02-07 Minor documentation tidying. 0.0.3 2007-02-23 Added machine readable licence. 0.0.4 2007-02-24 Doesn't check for vstrings on Perl < 5.8.1 now. 0.0.5 2007-02-24 Added perl-reversion example / utility 0.0.6 2007-02-27 Fixed skip condition so vstring tests are properly skipped. 0.0.7 2007-02-28 Alpha used to default to three digits, changed to two. 0.0.8 2007-03-29 Documentation fixes Added -dryrun option to perl-reversion [27649]. Thanks to DAXIM for the patch. 1.000 2007-09-03 Removed warning about long version numbers not having a mulitple of three digits. Perl 5.00504 doesn't have a multiple of three digits and it shouldn't be discriminated against. 1.001 2007-09-07 Added META.yml to perl-reversion's list of target files. 1.002 2007-09-07 Improved META.yml handling. So now it, er, works. 1.003 2007-11-08 Removed version.pm dependency. 1.004 2007-11-08 Removed '> 999' warning. 1.005 2008-04-03 Fixes for perl-reversion: * Allow any of the version formats as options for displaying or setting/bumping the version. * Display current version in the format found rather than as though -normal had been used. * Allow more specific -bump- options. * Using -current=1.2 no longer matches 1.2.3 in some cases 1.006 2008-04-07 Major fix for perl-reversion: * -bump now properly maintains the number of version components; previously, it was treating every version as though it had at least 3 components, so e.g. 1.1 was being wrongly bumped to 1.1.1 Other fixes for perl-reversion: * -bump -stringify will now properly keep the original version format (it was acting as though -normal had been specified) * noted that -stringify is the effective default for -bump/-set, so those options more accurately report the new version 1.007 2008-04-07 Fix for perl-reversion: * try to only find top-level keys in META.yml; this means we will stop catching the version from meta-spec and (hopefully) only catch the dist's version. 1.008 2009-03-07 Skip perl-reversion tests on Windows. They need fork. Allow negative indexes on component, increment. See #42181. perl-reversion now checks in bin, script subdirectories. See #28119. 1.009 2009-03-08 Make perl-reversion better at inferring version from structured files and not getting confused by unstructured files (like README). See #43946. 1.010 2010-09-19 Install perl-reversion by default. 1.011 2011-02-21 Remove Build.PL which didn't install perl-reversion. 1.013 2014-02-12 Remove File::Slurp, which has a critical security issue (RT 92974) Perl-Version-1.013/examples/000755 000765 000024 00000000000 12276760003 016122 5ustar00brianstaff000000 000000 Perl-Version-1.013/lib/000755 000765 000024 00000000000 12276760003 015052 5ustar00brianstaff000000 000000 Perl-Version-1.013/Makefile.PL000644 000765 000024 00000001656 12276757650 016304 0ustar00brianstaff000000 000000 use strict; use warnings; use ExtUtils::MakeMaker; eval 'use ExtUtils::MakeMaker::Coverage'; my %ARGS = ( license( 'perl' ), NAME => 'Perl::Version', AUTHOR => 'Andy Armstrong ', VERSION_FROM => 'lib/Perl/Version.pm', ABSTRACT_FROM => 'lib/Perl/Version.pm', PL_FILES => {}, PREREQ_PM => { 'Carp' => 0, 'Test::More' => 0, 'Scalar::Util' => 0, 'Getopt::Long' => '2.34', 'Pod::Usage' => '1.3', 'File::Slurp::Tiny' => 0, 'Data::Dumper' => 0, }, EXE_FILES => ['examples/perl-reversion'], dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', }, clean => { FILES => 'Perl-Version-*' }, ); WriteMakefile( %ARGS ); sub license { my $lic = shift; local $^W = 0; # Silence warning about non-numeric version return unless $ExtUtils::MakeMaker::VERSION >= '6.31'; return ( LICENSE => $lic ); } Perl-Version-1.013/MANIFEST000644 000765 000024 00000000606 12276760004 015440 0ustar00brianstaff000000 000000 Changes examples/perl-reversion lib/Perl/Version.pm Makefile.PL MANIFEST Notes.txt README t/00.load.t t/05.misc.t t/10.regression.t t/20.compare.t t/30.vstring.t t/40.perl-reversion.t t/manifest.t t/pod-coverage.t t/pod.t META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) Perl-Version-1.013/META.json000664 000765 000024 00000002106 12276760004 015727 0ustar00brianstaff000000 000000 { "abstract" : "Parse and manipulate Perl version strings", "author" : [ "Andy Armstrong " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 6.66, CPAN::Meta::Converter version 2.132830", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Perl-Version", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "Carp" : "0", "Data::Dumper" : "0", "File::Slurp::Tiny" : "0", "Getopt::Long" : "2.34", "Pod::Usage" : "1.3", "Scalar::Util" : "0", "Test::More" : "0" } } }, "release_status" : "stable", "version" : "1.013" } Perl-Version-1.013/META.yml000664 000765 000024 00000001142 12276760003 015555 0ustar00brianstaff000000 000000 --- abstract: 'Parse and manipulate Perl version strings' author: - 'Andy Armstrong ' build_requires: ExtUtils::MakeMaker: 0 configure_requires: ExtUtils::MakeMaker: 0 dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 6.66, CPAN::Meta::Converter version 2.132830' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Perl-Version no_index: directory: - t - inc requires: Carp: 0 Data::Dumper: 0 File::Slurp::Tiny: 0 Getopt::Long: 2.34 Pod::Usage: 1.3 Scalar::Util: 0 Test::More: 0 version: 1.013 Perl-Version-1.013/Notes.txt000644 000765 000024 00000000417 12266310710 016132 0ustar00brianstaff000000 000000 Bugs in version.pm 1._1 produces garbage xdg: AndyA, as-tuple (or whatever you want to call it) should put the output in $version->normal() form xdg: AndyA, more specifically -- when bumping, it should convert the current version to normal() form and then bump it. Perl-Version-1.013/README000644 000765 000024 00000000533 12266310710 015160 0ustar00brianstaff000000 000000 Perl-Version version 1.012 INSTALLATION To install this module, run the following commands: perl Makefile.PL make make test make install DEPENDENCIES None. COPYRIGHT AND LICENCE Copyright (C) 2007, Andy Armstrong This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Perl-Version-1.013/t/000755 000765 000024 00000000000 12276760003 014547 5ustar00brianstaff000000 000000 Perl-Version-1.013/t/00.load.t000644 000765 000024 00000000175 12266310710 016067 0ustar00brianstaff000000 000000 use Test::More tests => 1; BEGIN { use_ok( 'Perl::Version' ); } diag( "Testing Perl::Version $Perl::Version::VERSION" ); Perl-Version-1.013/t/05.misc.t000644 000765 000024 00000003556 12266310710 016116 0ustar00brianstaff000000 000000 #!/usr/bin/perl use strict; use warnings; use Perl::Version; use Test::More tests => 44; package dummy; sub new { return bless {}, shift } package main; my $v1 = Perl::Version->new(); isa_ok $v1, 'Perl::Version'; my $warned; local $SIG{__WARN__} = sub { $warned = shift }; my %expect = ( stringify => 'v0.0.0', numify => '0.000', components => '1', alpha => 0, normal => 'v0.0.0', revision => 0, version => undef, subversion => undef, is_alpha => '', ); while ( my ( $meth, $expect ) = each %expect ) { $warned = undef; my $result = eval { $v1->$meth }; unless ( ok !$@, "$meth: no error" ) { diag( "Error was $@" ); } unless ( ok !$warned, "$meth: no warning" ) { diag( "Warning was $@" ); } is $result, $expect, "$meth: result OK"; } my $v2 = Perl::Version->new( '5.8.8' ); is "$v2", '5.8.8', 'stringify overload OK'; my $v3 = $v2->new(); is "$v3", 'v0.0.0', 'new as method yields empty object'; my $v4 = $v3->new( $v2 ); is "$v4", '5.8.8', 'copy OK'; ok $v2 < 'v5.8.9', 'compare with string'; ok $v2 == 'v5.8.8', 'compare with string'; ok $v2 > 'v5.8.7', 'compare with string'; ok 'v5.8.9' > $v2, 'compare with string'; ok 'v5.8.8' == $v2, 'compare with string'; ok 'v5.8.7' < $v2, 'compare with string'; my $ar = [ 1, 2, 3 ]; $v3->components( $ar ); is "$v3", 'v1.2.3', 'set components from array'; $ar->[1]++; is "$v3", 'v1.2.3', 'array copied rather than referenced'; eval { Perl::Version::new() }; like $@, qr/called.+method/, 'calling new as a function fails'; my $dummy = dummy->new; eval { my $x = $v1 <=> $dummy }; like $@, qr/compare with/, 'compare to random object fails'; eval { my $x = $v1 <=> [] }; like $@, qr/compare with/, 'compare to hash ref fails'; eval { $v4->component }; like $@, qr/component number/, 'need component number'; eval { $v2->increment( 3 ) }; like $@, qr/out of range/, 'out of range'; Perl-Version-1.013/t/10.regression.t000644 000765 000024 00000064132 12266310710 017334 0ustar00brianstaff000000 000000 #!/usr/bin/perl use strict; use warnings; use Perl::Version; use Data::Dumper; my @tests; BEGIN { @tests = ( # Tests that peform no modification - just check that the components # have the correct values { name => 'Single component', new_arg => '1', components => 1, component_0 => 1, component_1 => undef, alpha => 0, normal => 'v1.0.0', numify => '1.000', }, { name => 'Two components', new_arg => '1.2', components => 2, component_0 => 1, component_1 => 2, component_2 => undef, alpha => 0, normal => 'v1.2.0', numify => '1.002', }, { name => 'Three components', new_arg => '1.2.3', components => 3, component_0 => 1, component_1 => 2, component_2 => 3, component_3 => undef, alpha => 0, normal => 'v1.2.3', numify => '1.002003', }, { name => 'Three components, named components', new_arg => '1.2.3', components => 3, component_revision => 1, component_version => 2, component_subversion => 3, component_3 => undef, alpha => 0, normal => 'v1.2.3', numify => '1.002003', }, { name => 'Four components', new_arg => '1.2.3.4', components => 4, component_0 => 1, component_1 => 2, component_2 => 3, component_3 => 4, component_4 => undef, alpha => 0, normal => 'v1.2.3.4', numify => '1.002003004', }, { name => 'Perl style, three components', new_arg => '1.002030', components => 3, component_0 => 1, component_1 => 2, component_2 => 30, component_3 => undef, alpha => 0, normal => 'v1.2.30', numify => '1.002030', }, { name => 'Single component, v prefix', new_arg => 'v1', components => 1, component_0 => 1, component_1 => undef, alpha => 0, normal => 'v1.0.0', numify => '1.000', }, { name => 'Two components, v prefix', new_arg => 'v1.2', components => 2, component_0 => 1, component_1 => 2, component_2 => undef, alpha => 0, normal => 'v1.2.0', numify => '1.002', }, { name => 'Three components, v prefix', new_arg => 'v1.2.3', components => 3, component_0 => 1, component_1 => 2, component_2 => 3, component_3 => undef, alpha => 0, normal => 'v1.2.3', numify => '1.002003', }, { name => 'Four components, v prefix', new_arg => 'v1.2.3.4', components => 4, component_0 => 1, component_1 => 2, component_2 => 3, component_3 => 4, component_4 => undef, alpha => 0, normal => 'v1.2.3.4', numify => '1.002003004', }, { name => 'Two components, alpha', new_arg => '1.2_1', components => 2, component_0 => 1, component_1 => 2, component_2 => undef, alpha => 1, normal => 'v1.2.0_01', numify => '1.002_01', }, { name => 'Three components, alpha', new_arg => '1.2.3_1', components => 3, component_0 => 1, component_1 => 2, component_2 => 3, component_3 => undef, alpha => 1, normal => 'v1.2.3_01', numify => '1.002003_01', }, { name => 'Four components, alpha', new_arg => '1.2.3.4_1', components => 4, component_0 => 1, component_1 => 2, component_2 => 3, component_3 => 4, component_4 => undef, alpha => 1, normal => 'v1.2.3.4_01', numify => '1.002003004_01', }, { name => 'Two components, v prefix, alpha', new_arg => 'v1.2_1', components => 2, component_0 => 1, component_1 => 2, component_2 => undef, alpha => 1, normal => 'v1.2.0_01', numify => '1.002_01', }, { name => 'Three components, v prefix, alpha', new_arg => 'v1.2.3_1', components => 3, component_0 => 1, component_1 => 2, component_2 => 3, component_3 => undef, alpha => 1, normal => 'v1.2.3_01', numify => '1.002003_01', }, { name => 'Four components, v prefix, alpha', new_arg => 'v1.2.3.4_1', components => 4, component_0 => 1, component_1 => 2, component_2 => 3, component_3 => 4, component_4 => undef, alpha => 1, normal => 'v1.2.3.4_01', numify => '1.002003004_01', }, # Tests that modify various values { name => 'Single component, modify it', new_arg => '1', action => sub { $_->component( 0, 2 ); }, components => 1, component_0 => 2, component_1 => undef, alpha => 0, stringify => '2', normal => 'v2.0.0', numify => '2.000', }, { name => 'Single component, add component', new_arg => '1', action => sub { $_->component( 1, 2 ); }, components => 2, component_0 => 1, component_1 => 2, component_2 => undef, alpha => 0, stringify => '1.2', normal => 'v1.2.0', numify => '1.002', }, { name => 'Single component, add gap, component', new_arg => '1', action => sub { $_->component( 2, 2 ); }, components => 3, component_0 => 1, component_1 => 0, component_2 => 2, component_3 => undef, alpha => 0, stringify => '1.0.2', normal => 'v1.0.2', numify => '1.000002', }, { name => 'Single component, attempt to set components to 0', new_arg => '1', action => sub { $_->components( 0 ); }, act_err => { error => qr/set the number of components to 0/ }, components => 1, component_0 => 1, component_1 => undef, alpha => 0, stringify => '1', normal => 'v1.0.0', numify => '1.000', }, { name => 'Single component, attempt to set components to 1', new_arg => '1', action => sub { $_->components( 1 ); }, components => 1, component_0 => 1, component_1 => undef, alpha => 0, stringify => '1', normal => 'v1.0.0', numify => '1.000', }, { name => 'Two components, set components to 1', new_arg => '1.2', action => sub { $_->components( 1 ); }, components => 1, component_0 => 1, component_1 => undef, alpha => 0, stringify => '1', normal => 'v1.0.0', numify => '1.000', }, { name => 'Two components, set components to 3', new_arg => '1.2', action => sub { $_->components( 3 ); }, components => 3, component_0 => 1, component_1 => 2, component_2 => 0, component_3 => undef, alpha => 0, stringify => '1.2.0', normal => 'v1.2.0', numify => '1.002000', }, { name => 'Three components, set alpha', new_arg => '1.2.3', action => sub { $_->alpha( 4 ); }, components => 3, component_0 => 1, component_1 => 2, component_2 => 3, component_3 => undef, alpha => 4, stringify => '1.2.3_04', normal => 'v1.2.3_04', numify => '1.002003_04', }, { name => 'Three components, clear alpha', new_arg => '1.2.3_4', action => sub { $_->alpha( 0 ); }, components => 3, component_0 => 1, component_1 => 2, component_2 => 3, component_3 => undef, alpha => 0, stringify => '1.2.3', normal => 'v1.2.3', numify => '1.002003', }, { name => 'Three components, inc revision', new_arg => '1.2.3', action => sub { $_->increment( 0 ); }, components => 3, component_0 => 2, component_1 => 0, component_2 => 0, component_3 => undef, alpha => 0, stringify => '2.0.0', normal => 'v2.0.0', numify => '2.000000', }, { name => 'Three components, inc version', new_arg => '1.2.3', action => sub { $_->increment( 1 ); }, components => 3, component_0 => 1, component_1 => 3, component_2 => 0, component_3 => undef, alpha => 0, stringify => '1.3.0', normal => 'v1.3.0', numify => '1.003000', }, { name => 'Three components, inc subversion', new_arg => '1.2.3', action => sub { $_->increment( 2 ); }, components => 3, component_0 => 1, component_1 => 2, component_2 => 4, component_3 => undef, alpha => 0, stringify => '1.2.4', normal => 'v1.2.4', numify => '1.002004', }, { name => 'Three components, no alpha, inc alpha', new_arg => '1.2.3', action => sub { $_->increment( 'alpha' ); }, components => 3, component_0 => 1, component_1 => 2, component_2 => 3, component_3 => undef, alpha => 1, stringify => '1.2.3_01', normal => 'v1.2.3_01', numify => '1.002003_01', }, { name => 'Three components, no alpha, inc alpha (caps)', new_arg => '1.2.3', action => sub { $_->increment( 'AlphA' ); }, components => 3, component_0 => 1, component_1 => 2, component_2 => 3, component_3 => undef, component_alpha => 1, stringify => '1.2.3_01', normal => 'v1.2.3_01', numify => '1.002003_01', }, { name => 'Three components, alpha, inc alpha', new_arg => '1.2.3_4', action => sub { $_->increment( 'alpha' ); }, components => 3, component_0 => 1, component_1 => 2, component_2 => 3, component_3 => undef, alpha => 5, stringify => '1.2.3_5', normal => 'v1.2.3_05', numify => '1.002003_05', }, { name => 'Two components, inc revision', new_arg => '1.2', action => sub { $_->increment( 0 ); }, components => 2, component_0 => 2, component_1 => 0, component_2 => undef, alpha => 0, stringify => '2.0', normal => 'v2.0.0', numify => '2.000', }, { name => 'Two components, inc version', new_arg => '1.2', action => sub { $_->increment( 1 ); }, components => 2, component_0 => 1, component_1 => 3, component_2 => undef, alpha => 0, stringify => '1.3', normal => 'v1.3.0', numify => '1.003', }, { name => 'Two components, inc alpha', new_arg => '1.2', action => sub { $_->increment( 'alpha' ); }, components => 2, component_0 => 1, component_1 => 2, component_2 => undef, alpha => 1, stringify => '1.2_01', normal => 'v1.2.0_01', numify => '1.002_01', }, { name => 'Three components, inc revision by name', new_arg => '1.2.3', action => sub { $_->increment( 'revision' ); }, components => 3, component_0 => 2, component_1 => 0, component_2 => 0, component_3 => undef, alpha => 0, stringify => '2.0.0', normal => 'v2.0.0', numify => '2.000000', }, { name => 'Three components, inc revision by name (caps)', new_arg => '1.2.3', action => sub { $_->increment( 'Revision' ); }, components => 3, component_0 => 2, component_1 => 0, component_2 => 0, component_3 => undef, alpha => 0, stringify => '2.0.0', normal => 'v2.0.0', numify => '2.000000', }, { name => 'Three components, inc version by name', new_arg => '1.2.3', action => sub { $_->increment( 'version' ); }, components => 3, component_0 => 1, component_1 => 3, component_2 => 0, component_3 => undef, alpha => 0, stringify => '1.3.0', normal => 'v1.3.0', numify => '1.003000', }, { name => 'Three components, inc subversion by name', new_arg => '1.2.3', action => sub { $_->increment( 'subversion' ); }, components => 3, component_0 => 1, component_1 => 2, component_2 => 4, component_3 => undef, alpha => 0, stringify => '1.2.4', normal => 'v1.2.4', numify => '1.002004', }, { name => 'Three components, inc subversion by name (caps)', new_arg => '1.2.3', action => sub { $_->increment( 'SuBversion' ); }, components => 3, component_0 => 1, component_1 => 2, component_2 => 4, component_3 => undef, alpha => 0, stringify => '1.2.4', normal => 'v1.2.4', numify => '1.002004', }, { name => 'Three components, inc illegal name', new_arg => '1.2.3', action => sub { $_->increment( 'major' ); }, act_err => { error => qr/Unknown component name: major/ }, components => 3, component_0 => 1, component_1 => 2, component_2 => 3, component_3 => undef, alpha => 0, stringify => '1.2.3', normal => 'v1.2.3', numify => '1.002003', }, { name => 'Three components, negative index (-1)', new_arg => '1.2.3', action => sub { $_->increment( -1 ); }, components => 3, component_0 => 1, component_1 => 2, component_2 => 4, component_3 => undef, component_alpha => 0, stringify => '1.2.4', normal => 'v1.2.4', numify => '1.002004', }, { name => 'Three components, negative index (-2)', new_arg => '1.2.3', action => sub { $_->increment( -2 ); }, components => 3, component_0 => 1, component_1 => 3, component_2 => 0, component_3 => undef, component_alpha => 0, stringify => '1.3.0', normal => 'v1.3.0', numify => '1.003000', }, { name => 'Three components, negative index (-3)', new_arg => '1.2.3', action => sub { $_->increment( -3 ); }, components => 3, component_0 => 2, component_1 => 0, component_2 => 0, component_3 => undef, component_alpha => 0, stringify => '2.0.0', normal => 'v2.0.0', numify => '2.000000', }, { name => 'Three components, negative index (-1)', new_arg => '1.2.3', action => sub { $_->component( -1, 5 ); }, components => 3, component_0 => 1, component_1 => 2, component_2 => 5, component_3 => undef, component_alpha => 0, stringify => '1.2.5', normal => 'v1.2.5', numify => '1.002005', }, { name => 'Three components, set illegal name', new_arg => '1.2.3', action => sub { $_->component( 'major', 99 ); }, act_err => { error => qr/Unknown component name: major/ }, components => 3, component_0 => 1, component_1 => 2, component_2 => 3, component_3 => undef, alpha => 0, stringify => '1.2.3', normal => 'v1.2.3', numify => '1.002003', }, { name => 'Three components, named accessors', new_arg => '1.2.3', components => 3, revision => 1, version => 2, subversion => 3, component_3 => undef, alpha => 0, stringify => '1.2.3', normal => 'v1.2.3', numify => '1.002003', }, { name => 'Three components, set revision by name', new_arg => '1.2.3', action => sub { $_->revision( 2 ); }, components => 3, revision => 2, version => 2, subversion => 3, component_3 => undef, alpha => 0, stringify => '2.2.3', normal => 'v2.2.3', numify => '2.002003', }, { name => 'Three components, set version by name', new_arg => '1.2.3', action => sub { $_->version( 3 ); }, components => 3, revision => 1, version => 3, subversion => 3, component_3 => undef, alpha => 0, stringify => '1.3.3', normal => 'v1.3.3', numify => '1.003003', }, { name => 'Three components, set subversion by name', new_arg => '1.2.3', action => sub { $_->subversion( 4 ); }, components => 3, revision => 1, version => 2, subversion => 4, component_3 => undef, alpha => 0, stringify => '1.2.4', normal => 'v1.2.4', numify => '1.002004', }, { name => 'Three components, inc_revision', new_arg => '1.2.3', action => sub { $_->inc_revision; }, components => 3, component_0 => 2, component_1 => 0, component_2 => 0, component_3 => undef, alpha => 0, stringify => '2.0.0', normal => 'v2.0.0', numify => '2.000000', }, { name => 'Three components, inc_version', new_arg => '1.2.3', action => sub { $_->inc_version; }, components => 3, component_0 => 1, component_1 => 3, component_2 => 0, component_3 => undef, alpha => 0, stringify => '1.3.0', normal => 'v1.3.0', numify => '1.003000', }, { name => 'Numeric, inc_version', new_arg => '0.09', action => sub { $_->inc_version; }, components => 2, component_0 => 0, component_1 => 10, component_2 => undef, component_3 => undef, alpha => 0, stringify => '0.10', normal => 'v0.10.0', numify => '0.010', }, { name => 'Numeric, inc_version (2)', new_arg => '0.19', action => sub { $_->inc_version; }, components => 2, component_0 => 0, component_1 => 20, component_2 => undef, component_3 => undef, alpha => 0, stringify => '0.20', normal => 'v0.20.0', numify => '0.020', }, { name => 'Three components, inc_subversion', new_arg => '1.2.3', action => sub { $_->inc_subversion; }, components => 3, component_0 => 1, component_1 => 2, component_2 => 4, component_3 => undef, alpha => 0, stringify => '1.2.4', normal => 'v1.2.4', numify => '1.002004', }, # Various tests that the format preservation works as expected { name => 'Three components, two digits, long alpha', new_arg => 'v1.02.34_00056', action => sub { $_->inc_revision; }, stringify => 'v2.00.00', normal => 'v2.0.0', numify => '2.000000', }, { name => 'Three components, eight digits, long alpha', new_arg => 'v1.00000002.00000034_00056', action => sub { $_->inc_revision; }, stringify => 'v2.00000000.00000000', normal => 'v2.0.0', numify => '2.000000', }, { name => 'Four components, two digits', new_arg => 'v1.23.45.00', action => sub { $_->inc_revision; }, stringify => 'v2.00.00.00', normal => 'v2.0.0.0', numify => '2.000000000', }, { name => 'Three components, last padded to three digits, long alpha', new_arg => 'v1.2.034', action => sub { $_->inc_revision; }, stringify => 'v2.0.000', normal => 'v2.0.0', numify => '2.000000', }, # Setting value { name => 'Three components, last padded to three digits, long alpha, set', new_arg => 'v1.2.034', action => sub { $_->set( '2.0.0' ); }, stringify => 'v2.0.000', normal => 'v2.0.0', numify => '2.000000', }, { name => 'Three components, last padded to three digits, long alpha, set to another version', new_arg => 'v1.2.034', action => sub { $_->set( Perl::Version->new( '2.3.4' ) ); }, stringify => 'v2.3.004', normal => 'v2.3.4', numify => '2.003004', }, # Misc formatting { name => 'CVS revision', new_arg => 'Revision: 1.2.3', normal => 'v1.2.3', }, { name => 'CVS revision, mixed case', new_arg => 'revisioN: 1.2.3', normal => 'v1.2.3', }, { name => 'Leading spaces', new_arg => ' v1.2.3', numify => '1.002003', }, { name => 'Trailing spaces', new_arg => 'v1.2.3 ', numify => '1.002003', }, { name => 'Leading and trailing spaces', new_arg => ' v1.2.3 ', numify => '1.002003', }, { name => 'CVS revision, increment', new_arg => 'Revision: 1.2.3', action => sub { $_->inc_version; }, stringify => 'Revision: 1.3.0', }, { name => 'Leading spaces, increment', new_arg => ' v1.2.3', action => sub { $_->inc_version; }, stringify => ' v1.3.0', }, { name => 'Trailing spaces, increment', new_arg => 'v1.2.3 ', action => sub { $_->inc_version; }, stringify => 'v1.3.0 ', }, { name => 'Leading and trailing spaces, increment', new_arg => ' v1.2.3 ', action => sub { $_->inc_version; }, stringify => ' v1.3.0 ', }, # Some errors { name => 'Trailing decimal', new_arg => '1.1.', new_err => { error => qr/Illegal version string/i }, }, # Versions used in documentation { name => 'Round trip 1.3.0 OK', new_arg => '1.3.0' }, { name => 'Round trip v1.03.00 OK', new_arg => 'v1.03.00' }, { name => 'Round trip 1.10.03 OK', new_arg => '1.10.03' }, { name => 'Round trip 2.00.00 OK', new_arg => '2.00.00' }, { name => 'Round trip 1.2 OK', new_arg => '1.2' }, { name => 'Round trip v1.2.3.4.5.6 OK', new_arg => 'v1.2.3.4.5.6' }, { name => 'Round trip v1.2 OK', new_arg => 'v1.2' }, { name => 'Round trip Revision: 3.0 OK', new_arg => 'Revision: 3.0' }, { name => 'Round trip 1.001001 OK', new_arg => '1.001001' }, { name => 'Round trip 1.001_001 OK', new_arg => '1.001_001' }, { name => 'Round trip 3.0.4_001 OK', new_arg => '3.0.4_001' }, # Tests added in response to specific bugs { name => 'Looks like a number with alpha', new_arg => '1.001_001', }, { name => 'Zero alpha', new_arg => '9.8.7_000', }, ); } use Test::More tests => @tests * 7; for my $test ( @tests ) { my $name = delete $test->{name}; my $version = delete $test->{new_arg}; my $new_err = delete $test->{new_err}; my $act_err = delete $test->{act_err}; my $safe = sub { my ( $err, $arg, $code ) = @_; my $warned; # Promote warnings to errors local $SIG{__WARN__} = sub { $warned = $_[0] }; my $result = eval { $code->( @$arg ) }; for my $diag ( [ 'error', $@ ], [ 'warning', $warned ] ) { my ( $key, $val ) = @$diag; like $val || '', $err->{$key} || qr{^$}, "$name: warning OK"; } return $result; }; my $obj = $safe->( $new_err, [$version], sub { return Perl::Version->new( @_ ); }, ); if ( $new_err->{error} ) { ok !$obj, "$name: object creation failed as expected"; pass "$name: no object created" for 1 .. 4; } else { isa_ok $obj, 'Perl::Version'; is $obj->stringify, $version, "$name: stringify round trips correctly"; if ( my $action = delete $test->{action} ) { $safe->( $act_err, [$obj], sub { local $_ = shift; $action->(); } ); } else { pass "$name: no action defined" for 1 .. 2; } verify( $name, $obj, $test ); } } sub verify { my ( $test, $obj, $ref ) = @_; my $got = {}; my @components = sort keys %$ref; for my $component ( @components ) { my ( $method, @args ) = split( /_/, $component ); $got->{$component} = $obj->$method( @args ); } my $test_name = "$test: " . join( ', ', @components ) . ' match'; $test_name .= 'es' if @components = 1; unless ( is_deeply $got, $ref, $test_name ) { local $Data::Dumper::Sortkeys = 1; local $Data::Dumper::Quotekeys = 0; warn Data::Dumper->Dump( [$got], ['$got'] ); warn Data::Dumper->Dump( [$ref], ['$ref'] ); warn Data::Dumper->Dump( [$obj], ['$obj'] ); } } Perl-Version-1.013/t/20.compare.t000644 000765 000024 00000011246 12266310710 016601 0ustar00brianstaff000000 000000 #!/usr/bin/perl use strict; use warnings; use Data::Dumper; use Perl::Version; use Test::More tests => 409; my ( $SORTED, $EQUAL ); BEGIN { $SORTED = [ '0', '0.000', '0.000001', '0.0.4', '0.000004', 'v0.0.4', '0.0.8', '0.000008', 'v0.0.8', '0.01', '0.1', '0.58', '0.700', '1', '1', '1.0', '1.0.0', '1.0.0.0', '1.000', '1.000000', '1.000000000', 'v1', 'v1.0.0', '1.0004', '1.1', '1.001_002', '1.001002', '1.1.999', '1.02', '1.2', '1.2', '1.2.0', 'v1.2', 'v1.2.0', '1.2_1', 'v1.2_1', '1.2_3', '1.002001', '1.002003', '1.2.3', '1.2.3', '1.2.3.0', '1.2.3_0', 'v1.2.3', 'v1.2.3', '1.2.3_01', '1.2.3_1', '1.2.3_1', 'v1.2.3_1', '1.2.3_002', '1.2.3_4', '1.2.3_4', 'v1.2.3_4', 'v1.2.3_4', '1.2.3.1', '1.2.3.4', '1.2.3.4', 'v1.2.3.4', '1.2.3.4_1', 'v1.2.3.4_1', '1.2.3.4.5.6.7.8.0.1', '1.2.3.4.5.6.7.8.9', '1.2.04', '1.2.4', '1.2.005', '1.002030', 'v1.2.034', 'v1.00000002.00000034_00056', 'v1.02.34_00056', '1.003', 'v001.3', '1.7', '1.23', 'v1.23', 'v1.23.0', '1.23_01', '1.23_0100', 'v1.23.45.00', '1.24', '1.230', '1.700', '2', '2', '3', '3', '4', '4', '5', '5.005', '5.005_02', 'v5.005_02', '5.005_03', '5.005_030', '5.005030', '5.5.30', '5.006_002', '5.006.001', '5.006001', 'v5.6.1', 'v5.6.1', '5.6.2', '5.008', '5.8.0', '5.008_001', '5.8.1', '06', '6', '7', '8', '23', '44', '99', '99', '99.0', '99.000', 'v99.0.0', 'v99.0.0', '100', '2002.009030001', '2002.09.30.1', '2002.9.30.1', '19017', '19517', '885915' ]; $EQUAL = [ [ '0', '0.000' ], [ '0.0.4', '0.000004', 'v0.0.4' ], [ '0.0.8', '0.000008', 'v0.0.8' ], [ '0.01', '0.1' ], [ '1', '1', '1.0', '1.0.0', '1.0.0.0', '1.000', '1.000000', '1.000000000', 'v1', 'v1.0.0' ], [ '1.02', '1.2', '1.2', '1.2.0', 'v1.2', 'v1.2.0' ], [ '1.2_1', 'v1.2_1' ], [ '1.002003', '1.2.3', '1.2.3', '1.2.3.0', '1.2.3_0', 'v1.2.3', 'v1.2.3' ], [ '1.2.3_01', '1.2.3_1', '1.2.3_1', 'v1.2.3_1' ], [ '1.2.3_4', '1.2.3_4', 'v1.2.3_4', 'v1.2.3_4' ], [ '1.2.3.4', '1.2.3.4', 'v1.2.3.4' ], [ '1.2.3.4_1', 'v1.2.3.4_1' ], [ '1.2.04', '1.2.4' ], [ 'v1.00000002.00000034_00056', 'v1.02.34_00056' ], [ '1.003', 'v001.3' ], [ '1.23', 'v1.23', 'v1.23.0' ], [ '2', '2' ], [ '3', '3' ], [ '4', '4' ], [ '5.005_02', 'v5.005_02' ], [ '5.005030', '5.5.30' ], [ '5.006.001', '5.006001', 'v5.6.1', 'v5.6.1' ], [ '5.008', '5.8.0' ], [ '06', '6' ], [ '99', '99', '99.0', '99.000', 'v99.0.0', 'v99.0.0' ], [ '2002.009030001', '2002.09.30.1', '2002.9.30.1' ] ]; } { # Ordering local $SIG{__WARN__} = sub { }; my @obj = map { { ver => $_, obj => Perl::Version->new( $_ ) } } @$SORTED; for my $i ( 0 .. $#obj - 1 ) { my ( $v1, $v2 ) = @obj[ $i .. $i + 1 ]; my $test = $v1->{ver} . ' <= ' . $v2->{ver}; unless ( ok $v1->{obj} <= $v2->{obj}, $test ) { diag( $v1->{ver} ); diag( Data::Dumper->Dump( [ $v1->{obj} ], ['$v1'] ) ); diag( $v2->{ver} ); diag( Data::Dumper->Dump( [ $v2->{obj} ], ['$v2'] ) ); } } } { # Equality local $SIG{__WARN__} = sub { }; for my $equals ( @$EQUAL ) { my @obj = map { { ver => $_, obj => Perl::Version->new( $_ ) } } @$equals; for my $i ( 0 .. $#obj - 1 ) { for my $j ( 0 .. $#obj ) { my ( $v1, $v2 ) = ( $obj[$i], $obj[$j] ); my $test = $v1->{ver} . ' == ' . $v2->{ver}; unless ( ok $v1->{obj} == $v2->{obj}, $test ) { diag( $v1->{ver} ); diag( Data::Dumper->Dump( [ $v1->{obj} ], ['$v1'] ) ); diag( $v2->{ver} ); diag( Data::Dumper->Dump( [ $v2->{obj} ], ['$v2'] ) ); } } } } } Perl-Version-1.013/t/30.vstring.t000644 000765 000024 00000001430 12266310710 016642 0ustar00brianstaff000000 000000 #!/usr/bin/perl use strict; use warnings; use Perl::Version; use Test::More tests => 6; SKIP: { skip 'cannot test bare v-strings with Perl < 5.8.1', 6 if $] < 5.008_001; my $ver = eval { Perl::Version->new( v1.2.3 ) }; unless ( ok !$@, 'vstring parses without error' ) { diag( "Error: $@\n" ); } is $ver, 'v1.2.3', 'vstring parses correctly'; $ver = eval { Perl::Version->new( 1.2.3 ) }; unless ( ok !$@, 'naked vstring parses without error' ) { diag( "Error: $@\n" ); } is $ver, 'v1.2.3', 'naked vstring parses correctly'; $ver = eval { Perl::Version->new( 49.50.51 ) }; unless ( ok !$@, 'naked vstring, ascii digits parses without error' ) { diag( "Error: $@\n" ); } is $ver, 'v49.50.51', 'naked vstring, ascii digits parses correctly'; } Perl-Version-1.013/t/40.perl-reversion.t000755 000765 000024 00000007710 12276756005 020151 0ustar00brianstaff000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More; use File::Temp; use File::Path qw(mkpath); use File::Spec; use FileHandle; use File::Slurp::Tiny qw(read_file); use Data::Dumper; if ( $^O =~ /MSWin32/ ) { plan skip_all => 'cannot run on Windows'; } # -Mblib makes a lot of noise my $libs = join " ", map { '-I' . File::Spec->catfile( 'blib', $_ ) } qw(lib arch); my $RUN = "$^X $libs examples/perl-reversion"; if ( system( "$RUN -quiet" ) ) { plan skip_all => 'cannot run perl-reversion, skipping its tests'; } plan tests => 44; my $dir = File::Temp::tempdir( CLEANUP => 1 ); sub find { my $rv = _run( @_ ); if ( $rv->{output} =~ /version is (\S+)$/ ) { return { found => $1 }; } else { return {}; } } sub _run { my $cmd = "$RUN @_"; #diag $cmd; my $output; my $pid = open my $fh, '-|'; die "Could not open pipe: $!" unless defined $pid; if ( $pid ) { $output = join '', <$fh>; } else { close *STDERR; exec $cmd; } #diag $output; return { output => $output }; } sub with_file { my ( $name, $content, $code ) = @_; my $fh = FileHandle->new( "> $dir/$name" ) or die "Can't open $dir/$name: $!"; binmode $fh; print $fh $content; close $fh; $code->(); unlink "$dir/$name" or die "Can't unlink $dir/$name: $!"; } sub count_newlines { my @newlines= ("\x{0d}\x{0a}","\x{0d}","\x{0a}"); my %result; for my $name (@_) { my $content= read_file($name, binmode => ':raw' ); $result{ $name }= +{ map { my $key= unpack 'H*', $_; my $count =()= $content=~ /$_/g; $key=>$count } @newlines }; }; %result }; sub ok_newlines { my( $name, %expected ) = @_; my %got= count_newlines( keys %expected ); is_deeply \%got, \%expected, "$name - All newlines remain intact" or diag Dumper [ \%expected, \%got ]; }; sub runtests { my ( $name, $version ) = @_; # Check that we keep line endings consistent: my @files= (grep { -f } glob( "$dir/*" ), glob( "$dir/*/*" ) ); my %newlines= count_newlines( @files ); is_deeply( find( $dir ), { found => '1.2.3' }, "found in $name" ); is_deeply( find( $dir, "-current=1.2" ), {}, "partial does not match" ); _run( $dir, '-set', '1.2' ); ok_newlines( "$name -set", %newlines ); _run( $dir, '-bump' ); ok_newlines( "$name -bump", %newlines ); is_deeply( find( $dir ), { found => '1.3', }, "-bump did not extend version" ); my $rv = _run( $dir, '-bump-subversion', '2>&1' ); ok_newlines( "$name -bump-subversion", %newlines ); like( $rv->{output}, qr/version 1\.3 does not have 'subversion' component/, "-bump- with missing component has useful error", ); } FileHandle->new( "> $dir/Makefile.PL" ); mkpath( "$dir/lib" ); with_file( "META.yml", <<'END', --- bar: 2 version: 1.2.3 meta-spec: url: whatever version: 1.3 END sub { runtests( META => '1.2.3' ) }, ); # weirdly indented but still valid with_file( "META.yml", <<'END', --- bar: 2 version: 1.2.3 meta-spec: url: whatever version: 1.3 END sub { runtests( META => '1.2.3' ) }, ); with_file( "lib/Foo_pod.pm", <<'END', =head1 VERSION Version 1.2.3 =cut END sub { runtests( pod => "1.2.3" ) }, ); with_file( "Foo.pm", <<'END', package Foo; our $VERSION = '1.2.3'; 1; END sub { runtests( pm => "1.2.3" ) }, ); with_file( "Foo.pm", <<'END', package Foo; our $VERSION = version->declare('v1.2.3'); 1; END sub { is_deeply( find( $dir ), { found => 'v1.2.3' }, "found in pm" ); _run( $dir, '-set', '1.2' ); _run( $dir, '-bump' ); is_deeply( find( $dir ), { found => 'v1.3' }, "bump subversion with v prefix" ); }, ); with_file( README => <<'END', This README describes version 1.2.3 of Flurble. END sub { runtests( plain => "1.2.3" ) }, ); with_file( README => "This README describes\x{0d}\x{0a}version 1.2.3 of\x{0d}\x{0a}Flurble.\x{0a}", sub { runtests( newlines => "1.2.3" ) }, ); Perl-Version-1.013/t/manifest.t000644 000765 000024 00000000603 12266310710 016534 0ustar00brianstaff000000 000000 #!perl use strict; use warnings; use Test::More; eval { require ExtUtils::Manifest }; plan skip_all => 'No ExtUtils::Manifest' if $@; plan skip_all => 'No MANIFEST.SKIP' unless -f 'MANIFEST.SKIP'; plan tests => 2; my ( $missing, $extra ) = ExtUtils::Manifest::fullcheck(); is_deeply $missing, [], 'missing files'; is_deeply $extra, [], 'extra files'; # vim:ts=2:sw=2:et:ft=perl Perl-Version-1.013/t/pod-coverage.t000644 000765 000024 00000000406 12266310710 017302 0ustar00brianstaff000000 000000 #!perl -T use Test::More; eval "use Test::Pod::Coverage 1.04"; plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage" if $@; all_pod_coverage_ok( { private => [ qr{^BUILD|DEMOLISH|AUTOMETHOD|START$}, qr{^_}, qr{^\(} ] } ); Perl-Version-1.013/t/pod.t000644 000765 000024 00000000214 12266310710 015506 0ustar00brianstaff000000 000000 #!perl -T use Test::More; eval "use Test::Pod 1.14"; plan skip_all => "Test::Pod 1.14 required for testing POD" if $@; all_pod_files_ok(); Perl-Version-1.013/lib/Perl/000755 000765 000024 00000000000 12276760003 015754 5ustar00brianstaff000000 000000 Perl-Version-1.013/lib/Perl/Version.pm000644 000765 000024 00000062107 12276757355 017765 0ustar00brianstaff000000 000000 package Perl::Version; use warnings; use strict; use Carp; use Scalar::Util qw( blessed ); our $VERSION = '1.013'; use overload ( '""' => \&stringify, '<=>' => \&vcmp, 'cmp' => \&vcmp, ); use constant REGEX => qr/ ( (?i: Revision: \s+ ) | v | ) ( \d+ (?: [.] \d+)* ) ( (?: _ \d+ )? ) /x; use constant MATCH => qr/ ^ ( \s* ) @{[ REGEX ]} ( \s* ) $ /x; my %NORMAL_FORMAT = ( prefix => 'v', printf => ['%d'], extend => '.%d', alpha => '_%02d', suffix => '', fields => 3, ); my %NUMERIC_FORMAT = ( prefix => '', printf => [ '%d', '.%03d' ], extend => '%03d', alpha => '_%02d', suffix => '', fields => 2, ); my %COMPONENT_NAME; BEGIN { %COMPONENT_NAME = ( revision => 0, version => 1, subversion => 2 ); # Make accessors my @fields = ( keys %COMPONENT_NAME, qw( alpha ) ); no strict 'refs'; for my $field ( @fields ) { *$field = sub { my $self = shift; return $self->component( $field, @_ ); }; my $inc_func = "inc_$field"; *$inc_func = sub { my $self = shift; return $self->increment( $field ); }; } } sub new { my $class = shift; my $self = bless {}, ref $class || $class || croak "new must be called as a class or object method"; $self->{version} = [0]; $self->_parse( @_ ) if @_; return $self; } sub _resolve_component_name { my $self = shift; my $name = shift; if ( $name =~ /^-?\d+$/ ) { # Allow negative subscripts $name += $self->components if $name < 0; return $name; } croak "Unknown component name: $name" unless exists $COMPONENT_NAME{ lc( $name ) }; return $COMPONENT_NAME{ lc( $name ) }; } sub _guess_num_format { my $self = shift; my $num = shift; if ( $num =~ m{ ^ 0 \d }x ) { return '%0' . length( $num ) . 'd'; } return '%d'; } sub _parse { my $self = shift; # Check for vstring before anything else happens if ( $] >= 5.008_001 && Scalar::Util::isvstring $_[0] ) { $self->{format} = {%NORMAL_FORMAT}; my @parts = map { ord } split //, shift; $self->{version} = \@parts; return; } my $version = join( ' ', map { "$_" } @_ ); croak "Illegal version string: $version" unless $version =~ MATCH; my $format = { fields => 1 }; my ( $pad, $pfx, $ver, $alp, $sfx ) = ( $1, $2, $3, $4, $5 ); # Decode version into format $format->{prefix} = $pad . $pfx; $format->{suffix} = $sfx; my @parts = split( /[.]/, $ver ); my @ver = ( shift( @parts ) + 0 ); my @fmt = ( $self->_guess_num_format( $ver[0] ) ); if ( @parts == 1 && length( $parts[0] ) >= 3 ) { my $threes = pop @parts; my @cluster = ( $threes =~ /(\d{1,3})/g ); # warn "# $threes <", join( '>, <', @cluster ), ">\n"; push @fmt, map { $self->_guess_num_format( $_ ) } @cluster; $fmt[1] = '.' . $fmt[1]; $format->{extend} = '%03d'; push @parts, map { 0 + $_ } @cluster; } else { # Parts with leading zeros my @lz = grep { m{ ^ 0 \d }x } @parts; # Work out how many different lengths we have my %le = map { length( $_ ) => 1 } @parts; if ( @lz && keys %le == 1 ) { push @fmt, ( '.' . $self->_guess_num_format( shift @lz ) ) x @parts; } else { push @fmt, map { '.' . $self->_guess_num_format( $_ ) } @parts; } $format->{extend} = ( @parts ? '' : '.' ) . $fmt[-1]; } $format->{printf} = \@fmt; if ( length( $alp ) ) { die "Badly formatted alpha got through" unless $alp =~ m{ _ (\d+) }x; my $alpha = $1; $self->{alpha} = $alpha + 0; $format->{alpha} = '_' . $self->_guess_num_format( $alpha ); } else { $format->{alpha} = $NORMAL_FORMAT{alpha}; } $self->{format} = $format; push @ver, map { $_ + 0 } @parts; $self->{version} = \@ver; return; } sub _format { my $self = shift; my $format = shift; my @result = (); my @parts = @{ $self->{version} }; my @fmt = @{ $format->{printf} }; push @parts, 0 while @parts < $format->{fields}; # Adjust the format to be the same length as the number of fields pop @fmt while @fmt > @parts; push @fmt, $format->{extend} while @parts > @fmt; my $version = ( $format->{prefix} ) . sprintf( join( '', @fmt ), @parts ) . ( $format->{suffix} ); $version .= sprintf( $format->{alpha}, $self->{alpha} ) if defined $self->{alpha}; push @result, $version; return join( ' ', @result ); } sub stringify { my $self = shift; return $self->_format( $self->{format} || \%NORMAL_FORMAT ); } sub normal { return shift->_format( \%NORMAL_FORMAT ); } sub numify { return shift->_format( \%NUMERIC_FORMAT ); } sub is_alpha { my $self = shift; return exists $self->{alpha}; } sub vcmp { my ( $self, $other, $rev ) = @_; # Promote to object $other = __PACKAGE__->new( $other ) unless ref $other; croak "Can't compare with $other" unless blessed $other && $other->isa( __PACKAGE__ ); return $other->vcmp( $self, 0 ) if $rev; my @this = @{ $self->{version} }; my @that = @{ $other->{version} }; push @this, 0 while @this < @that; push @that, 0 while @that < @this; while ( @this ) { if ( my $cmp = ( shift( @this ) <=> shift( @that ) ) ) { return $cmp; } } return ( $self->{alpha} || 0 ) <=> ( $other->{alpha} || 0 ); } sub components { my $self = shift; if ( @_ ) { my $fields = shift; if ( ref $fields eq 'ARRAY' ) { $self->{version} = [@$fields]; } else { croak "Can't set the number of components to 0" unless $fields; # Adjust the number of fields pop @{ $self->{version} }, while @{ $self->{version} } > $fields; push @{ $self->{version} }, 0, while @{ $self->{version} } < $fields; } } else { return @{ $self->{version} }; } } sub component { my $self = shift; my $field = shift; defined $field or croak "You must specify a component number"; if ( lc( $field ) eq 'alpha' ) { if ( @_ ) { my $alpha = shift; if ( $alpha ) { $self->{alpha} = $alpha; } else { delete $self->{alpha}; } } else { return $self->{alpha} || 0; } } else { $field = $self->_resolve_component_name( $field ); my $fields = $self->components; if ( @_ ) { if ( $field >= $fields ) { # Extend array if necessary $self->components( $field + 1 ); } $self->{version}->[$field] = shift; } else { return unless $field >= 0 && $field < $fields; return $self->{version}->[$field]; } } } sub increment { my $self = shift; my $field = shift; my $fields = $self->components; if ( lc( $field ) eq 'alpha' ) { $self->alpha( $self->alpha + 1 ); } else { $field = $self->_resolve_component_name( $field ); croak "Component $field is out of range 0..", $fields - 1 if $field < 0 || $field >= $fields; # Increment the field $self->component( $field, $self->component( $field ) + 1 ); # Zero out any following fields while ( ++$field < $fields ) { $self->component( $field, 0 ); } $self->alpha( 0 ); } } sub set { my $self = shift; my $other = shift; $other = __PACKAGE__->new( $other ) unless ref $other; my @comp = $other->components; $self->components( \@comp ); $self->alpha( $other->alpha ); } 1; __END__ =head1 NAME Perl::Version - Parse and manipulate Perl version strings =head1 VERSION This document describes Perl::Version version 1.013 =head1 SYNOPSIS use Perl::Version; # Init from string my $version = Perl::Version->new( '1.2.3' ); # Stringification preserves original format print "$version\n"; # prints '1.2.3' # Normalised print $version->normal, "\n"; # prints 'v1.2.3' # Numified print $version->numify, "\n"; # prints '1.002003' # Explicitly stringified print $version->stringify, "\n"; # prints '1.2.3' # Increment the subversion (the third component) $version->inc_subversion; # Stringification returns the updated version formatted # as the original was print "$version\n"; # prints '1.2.4' # Normalised print $version->normal, "\n"; # prints 'v1.2.4' # Numified print $version->numify, "\n"; # prints '1.002004' # Refer to subversion component by position ( zero based ) $version->increment( 2 ); print "$version\n"; # prints '1.2.5' # Increment the version (second component) which sets all # components to the right of it to zero. $version->inc_version; print "$version\n"; # prints '1.3.0' # Increment the revision (main version number) $version->inc_revision; print "$version\n"; # prints '2.0.0' # Increment the alpha number $version->inc_alpha; print "$version\n"; # prints '2.0.0_001' =head1 DESCRIPTION Perl::Version provides a simple interface for parsing, manipulating and formatting Perl version strings. Unlike version.pm (which concentrates on parsing and comparing version strings) Perl::Version is designed for cases where you'd like to parse a version, modify it and get back the modified version formatted like the original. For example: my $version = Perl::Version->new( '1.2.3' ); $version->inc_version; print "$version\n"; prints 1.3.0 whereas my $version = Perl::Version->new( 'v1.02.03' ); $version->inc_version; print "$version\n"; prints v1.03.00 Both are representations of the same version and they'd compare equal but their formatting is different. Perl::Version tries hard to guess and recreate the format of the original version and in most cases it succeeds. In rare cases the formatting is ambiguous. Consider 1.10.03 Do you suppose that second component '10' is zero padded like the third component? Perl::Version will assume that it is: my $version = Perl::Version->new( '1.10.03' ); $version->inc_revision; print "$version\n"; will print 2.00.00 If all of the components after the first are the same length (two characters in this case) and any of them begins with a zero Perl::Version will assume that they're all zero padded to the same length. The first component and any alpha suffix are handled separately. In each case if either of them starts with a zero they will be zero padded to the same length when stringifying the version. =head2 Version Formats Perl::Version supports a few different version string formats. =over =item Z<> 1, 1.2 Versions that look like a number. If you pass a numeric value its string equivalent will be parsed: my $version = Perl::Version->new( 1.2 ); print "$version\n"; prints 1.2 In fact there is no special treatment for versions that resemble decimal numbers. This is worthy of comment only because it differs from version.pm which treats actual numbers used as versions as a special case and performs various transformations on the stored version. =item Z<> 1.2.3, 1.2.3.4 Simple versions with three or more components. =item Z<> v1.2.3 Versions with a leading 'v'. =item Z<> 5.008006 Fielded numeric versions. You'll likely have seen this in relation to versions of Perl itself. If a version string has a single decimal point and the part after the point is three more more digits long, components are extracted from each group of three digits in the fractional part. For example my $version = Perl::Version->new( 1.002003004005006 ); print $version->normal; prints v1.2.3.4.5.6 =item vstring Perls later than 5.8.1 support vstring format. A vstring looks like a number with more than one decimal point and (optionally) a leading 'v'. The 'v' is mandatory for vstrings containing fewer than two decimal points. Perl::Version will successfully parse vstrings my $version = Perl::Version->new( v1.2 ); print "$version\n"; prints v1.2 Note that stringifying a Perl::Version constructed from a vstring will result in a regular string. Because it has no way of knowing whether the vstring constant had a 'v' prefix it always generates one when stringifying back to a version string. =item CVS version A common idiom for users of CVS is to use keyword replacement to generate a version automatically like this: $VERSION = version->new( qw$Revision: 2.7 $ ); Perl::Version does the right thing with such versions so that my $version = Perl::Version->new( qw$Revision: 2.7 $ ); $version->inc_revision; print "$version\n"; prints Revision: 3.0 =back =head3 Real Numbers Real numbers are stringified before parsing. This has two implications: trailing zeros after the decimal point will be lost and any underscore characters in the number are discarded. Perl allows underscores anywhere in numeric constants as an aid to formatting. These are discarded when Perl converts the number into its internal format. This means that # Numeric version print Perl::Version->new( 1.001_001 )->stringify; prints 1.001001 but # String version print Perl::Version->new( '1.001_001' )->stringify; prints 1.001_001 as expected. In general you should probably avoid versions expressed either as decimal numbers or vstrings. The safest option is to pass a regular string to Perl::Version->new(). =head3 Alpha Versions By convention if a version string has suffix that consists of an underscore followed by one or more digits it represents an alpha or developer release. CPAN treats modules with such version strings specially to reflect their alpha status. This alpha notation is one reason why using decimal numbers as versions is a bad idea. Underscore is a valid character in numeric constants which is discarded by Perl when a program's source is parsed so any intended alpha suffix will become part of the version number. To be considered alpha a version must have a non-zero alpha component like this 3.0.4_001 Generally the alpha component will be formatted with leading zeros but this is not a requirement. =head2 Component Naming A version number consists of a series of components. By Perl convention the first three components are named 'revision', 'version' and 'subversion': $ perl -V Summary of my perl5 (revision 5 version 8 subversion 6) configuration: (etc) Perl::Version follows that convention. Any component may be accessed by passing a number from 0 to N-1 to the L or L but for convenience the first three components are aliased as L, L and L. $version->increment( 0 ); is the same as $version->inc_revision; and my $subv = $version->subversion; is the same as my $subv = $version->component( 2 ); The alpha component is named 'alpha'. =head2 Comparison with version.pm If you're familiar with version.pm you'll notice that there's a certain amount of overlap between what it does and this module. I originally created this module as a mutable subclass of version.pm but the requirement to be able to reformat a modified version to match the formatting of the original didn't sit well with version.pm's internals. As a result this module is not dependent or based on version.pm. =head1 INTERFACE =over =item C<< new >> Create a new Perl::Version by parsing a version string. As discussed above a number of different version formats are supported. Along with the value of the version formatting information is captured so that the version can be modified and the updated value retrieved in the same format as the original. my @version = ( '1.3.0', 'v1.03.00', '1.10.03', '2.00.00', '1.2', 'v1.2.3.4.5.6', 'v1.2', 'Revision: 3.0', '1.001001', '1.001_001', '3.0.4_001', ); for my $v ( @version ) { my $version = Perl::Version->new( $v ); $version->inc_version; print "$version\n"; } prints 1.4.0 v1.04.00 1.11.00 2.01.00 1.3 v1.3.0.0.0.0 v1.3 Revision: 3.1 1.002000 1.002 3.1.0 In each case the incremented version is formatted in the same way as the original. If no arguments are passed an empty version intialised to 'v0' will be constructed. In order to support CVS version syntax my $version = Perl::Version->new( qw$Revision: 2.7 $ ); C may be passed an array in which case it concatenates all of its arguments with spaces before parsing the result. If the string can't be parsed as a version C will croak with a suitable error. See L for more information. =back =head2 Accessors =over =item C<< component >> Set or get one of the components of a version. # Set the subversion $version->component( 2, 17 ); # Get the revision my $rev = $version->component( 0 ); Instead of a component number you may pass a name: 'revision', 'version', 'subversion' or 'alpha': my $rev = $version->component( 'revision' ); =item C<< components >> Get or set all of the components of a version. # Set the number of components $version->components( 4 ); # Get the number of components my $parts = $version->components; # Get the individual components as an array my @parts = $version->components; # Set the components from an array $version->components( [ 5, 9, 2 ] ); Hmm. That's a lot of interface for one subroutine. Sorry about that. =item C<< revision >> Alias for C<< component( 0 ) >>. Gets or sets the revision component. =item C<< version >> Alias for C<< component( 1 ) >>. Gets or sets the version component. =item C<< subversion >> Alias for C<< component( 2 ) >>. Gets or sets the subversion component. =item C<< alpha >> Get or set the alpha component of a version. Returns 0 for versions with no alpha. # Set alpha $version->alpha( 12 ); # Get alpha my $alp = $version->alpha; =item C<< is_alpha >> Return true if a version has a non-zero alpha component. =item C<< set >> Set the version to match another version preserving the formatting of this version. $version->set( $other_version ); You may also set the version from a literal string: $version->set( '1.2.3' ); The version will be updated to the value of the version string but will retain its current formatting. =back =head2 Incrementing =over =item C<< increment >> Increment a component of a version. my $version = Perl::Version->new( '3.1.4' ); $version->increment( 1 ); print "$version\n"; prints 3.2.0 Components to the right of the incremented component will be set to zero as will any alpha component. As an alternative to passing a component number one of the predefined component names 'revision', 'version', 'subversion' or 'alpha' may be passed. =item C<< inc_alpha >> Increment a version's alpha component. =item C<< inc_revision >> Increment a version's revision component. =item C<< inc_subversion >> Increment a version's subversion component. =item C<< inc_version >> Increment a version's version component. =back =head2 Formatting =over =item C<< normal >> Return a normalised representation of a version. my $version = Perl::Version->new( '5.008007_01' ); print $version->normal, "\n"; prints v5.8.7_001 =item C<< numify >> Return a numeric representation of a version. The numeric form is most frequently used for versions of Perl itself. my $version = Perl::Version->new( '5.8.7_1' ); print $version->normal, "\n"; prints 5.008007_001 =item C<< stringify >> Return the version formatted as closely as possible to the version from which it was initialised. my $version = Perl::Version->new( '5.008007_01' ); $version->inc_alpha; print $version->stringify, "\n"; prints 5.008007_02 and my $version = Perl::Version->new( '5.8.7_1' ); $version->inc_alpha; print $version->stringify, "\n"; prints 5.8.7_2 =back =head2 Comparison =over =item C<< vcmp >> Perform 'spaceship' comparison between two version and return -1, 0 or 1 depending on their ordering. Comparisons are semantically correct so that my $v1 = Perl::Version->new( '1.002001' ); my $v2 = Perl::Version->new( '1.1.3' ); print ($v1->vcmp( $v2 ) > 0 ? 'yes' : 'no'), "\n"; prints yes =back =head2 Overloaded Operators =over =item C<< <=> >> and C<< cmp >> The C<< <=> >> and C<< cmp >> operators are overloaded (by the L method) so that comparisons between versions work as expected. This means that the other numeric and string comparison operators also work as expected. my $v1 = Perl::Version->new( '1.002001' ); my $v2 = Perl::Version->new( '1.1.3' ); print "OK!\n" if $v1 > $v2; prints OK! =item C<< "" >> (stringification) Perl::Version objects are converted to strings by calling the L method. This usually results in formatting close to that of the original version string. =back =head2 Constants =over =item C<< REGEX >> An unanchored regular expression that matches any of the version formats supported by Perl::Version. Three captures get the prefix part, the main body of the version and any alpha suffix respectively. my $version = 'v1.2.3.4_5'; my ($prefix, $main, $suffix) = ($version =~ Perl::Version::REGEX); print "$prefix\n$main\n$suffix\n"; prints v 1.2.3.4 _5 =item C<< MATCH >> An anchored regular expression that matches a correctly formatted version string. Five captures get any leading whitespace, the prefix part, the main body of the version, any alpha suffix and any trailing spaces respectively. my $version = ' v1.2.3.4_5 '; my ($before, $prefix, $main, $suffix, $after) = ($version =~ Perl::Version::MATCH); print "|$before|$prefix|$main|$suffix|$after|\n"; prints | |v|1.2.3.4|_5| | =back =head1 DIAGNOSTICS =head2 Error messages =over =item C<< Illegal version string: %s >> The version string supplied to C can't be parsed as a valid version. Valid versions match this regex: qr/ ( (?i: Revision: \s+ ) | v | ) ( \d+ (?: [.] \d+)* ) ( (?: _ \d+ )? ) /x; =item C<< new must be called as a class or object method >> C can't be called as a normal subroutine. Use $version_object->new( '1.2.3' ); or Perl::Version->new( '1.2.3' ); instead of Perl::Version::new( '1.2.3' ); =item C<< Unknown component name: %s >> You've attempted to access a component by name using a name that isn't recognised. Valid component names are 'revision', 'version', 'subversion' and 'alpha'. Case is not significant. =item C<< Can't compare with %s >> You've tried to compare a Perl::Version with something other than a version string, a number or another Perl::Version. =item C<< Can't set the number of components to 0 >> Versions must have at least one component. =item C<< You must specify a component number >> You've called L or L without specifying the number (or name) of the component to access. =item C<< Component %s is out of range 0..%s >> You've attempted to increment a component of a version but you've specified a component that doesn't exist within the version: # Fails my $version = Perl::Version->new( '1.4' ); $version->increment( 2 ); Slightly confusingly you'll see this message even if you specified the component number implicitly by using one of the named convenience accessors. =back =head1 CONFIGURATION AND ENVIRONMENT Perl::Version requires no configuration files or environment variables. =head1 DEPENDENCIES No non-core modules. =head1 INCOMPATIBILITIES None reported. =head1 BUGS AND LIMITATIONS No bugs have been reported. Please report any bugs or feature requests to C, or through the web interface at L. =head1 AUTHOR Andy Armstrong C<< >> Hans Dieter Pearcey C<< >> =head1 LICENCE AND COPYRIGHT Copyright (c) 2007, Andy Armstrong C<< >>. All rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L. =head1 DISCLAIMER OF WARRANTY BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR, OR CORRECTION. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. Perl-Version-1.013/examples/perl-reversion000755 000765 000024 00000041666 12276756643 021060 0ustar00brianstaff000000 000000 #!/usr/bin/perl # vim: ts=4 sts=4 sw=4: # # perl-reversion # # Update embedded version strings in Perl source use strict; use warnings; use Perl::Version; use Carp qw(croak); use Getopt::Long; use Pod::Usage; use File::Spec; use File::Slurp::Tiny qw(read_lines); use File::Basename; # Files that suggest that we have a project directory. The scores next # to each are summed for each candidate directory. The first directory # with a score >= 1.0 is assumed to be the project home. my %PROJECT_SIGNATURE = ( 'Makefile.PL' => 0.4, 'Build.PL' => 0.4, 'dist.ini' => 0.4, 'MANIFEST' => 0.4, 't/' => 0.4, 'lib/' => 0.4, 'Changes' => 0.4, 'xt/' => 0.4, ); my $MODULE_RE = qr{ [.] pm $ }x; my $SCRIPT_RE = qr/ \p{IsWord}+ /x; # filenames # Places to look for files / directories when processing a project my %CONSIDER = ( 'lib/' => { like => $MODULE_RE }, 'bin/' => { like => $SCRIPT_RE }, 'script/' => { like => $SCRIPT_RE }, 'README' => {}, 'META.yml' => {}, ); # Maximum number of levels above current directory to search for # project home. my $MAX_UP = 5; # Directories to skip during expansion my $SKIP = qr{^ [.]svn | CVS | [.]DS_Store | [.]git $}x; # Subroutines to identify file types my @MAGIC = ( { name => 'perl', test => sub { my ( $name, $info ) = @_; return 1 if $name =~ m{ [.] (?i: pl | pm | t ) $ }x; my $lines = $info->{lines}; return 1 if @$lines && $lines->[0] =~ m{ ^ \#\! .* perl }ix; return; }, }, { name => 'meta', test => sub { my ( $name, $info ) = @_; return basename( $name ) eq 'META.yml'; }, }, { name => 'plain', test => sub { my ( $name, $info ) = @_; return -T $name; }, } ); my $man = 0; my $help = 0; my $quiet = 0; my $bump = undef; my $current = undef; my $set = undef; my $dryrun = undef; my $force_to = undef; my %BUMP = ( bump => 'auto', # original -bump behavior 'bump-revision' => 0, 'bump-version' => 1, 'bump-subversion' => 2, 'bump-alpha' => 3, ); GetOptions( 'help|?' => \$help, 'man' => \$man, 'current=s' => \$current, 'set=s' => \$set, ( map { my $opt = $_; $_ => sub { if ( defined $bump ) { die "Please specify only one -bump option\n"; } $bump = $BUMP{$opt}; } } keys %BUMP ), ( map { my $opt = $_; $_ => sub { if ( defined $force_to ) { die "Please specify only one of -normal, -numify, or -stringify\n"; } $force_to = $opt; } } qw(normal numify stringify) ), 'dryrun' => \$dryrun, 'quiet' => \$quiet, ) or pod2usage( 2 ); pod2usage( 1 ) if $help; pod2usage( -exitstatus => 0, -verbose => 2 ) if $man; die "Please specify either -set or -bump, not both\n" if $set && $bump; my @files = @ARGV ? expand_dirs( @ARGV ) : find_proj_files(); die "Can't find any files to process. Try naming some\n", "directories and/or files on the command line.\n" unless @files; if ( my @missing = grep { !-e $_ } @files ) { die "Can't find ", conjunction_list( 'or', @missing ), "\n"; } my %documents = map { $_ => {} } @files; load_all( \%documents ); if ( my @bad_type = grep { !defined $documents{$_}{type} } keys %documents ) { die "Can't process ", conjunction_list( 'or', @bad_type ), "\n", "I can only process text files\n"; } my $versions = find_versions( \%documents, $current ); my @got = sort keys %$versions; if ( @got == 0 ) { die "Can't find ", defined $current ? "version string $current\n" : "any version strings\n"; } elsif ( @got > 1 ) { die "Found versions ", conjunction_list( 'and', map { "$versions->{$_}[0]{ver}" } @got ), ". Please use\n", "the --current option to specify the current version\n"; } my $new_ver; if ( $set ) { $new_ver = Perl::Version->new( $set ); } elsif ( defined $bump ) { $new_ver = $versions->{ $got[0] }[0]{ver}; if ( $bump eq 'auto' ) { if ( $new_ver->is_alpha ) { $new_ver->inc_alpha; } else { my $pos = $new_ver->components - 1; $new_ver->increment( $pos ); } } else { my $pos = $new_ver->components - 1; if ( $bump > $pos ) { my %NAME = ( 0 => 'revision', 1 => 'version', 2 => 'subversion', 3 => 'alpha', ); my $name = $NAME{$bump}; die "Cannot -bump-$name -- version $new_ver does not have " . "'$name' component.\n" . "Use -set if you intended to add it.\n"; } $new_ver->increment( $bump ); } } else { my $current_ver = $versions->{ $got[0] }[0]{ver}; $current_ver = $current_ver->$force_to if $force_to; note( "Current project version is $current_ver\n" ); } if ( defined $new_ver ) { set_versions( \%documents, $versions, $new_ver, $force_to ); save_all( \%documents ); } sub version_re_perl { my $ver_re = shift; return qr{ ^ ( .*? [\$\*] (?: \w+ (?: :: | ' ) )* VERSION \s* = \D*? ) $ver_re ( .* \s*) \z }x; } sub version_re_pod { my $ver_re = shift; return qr{ ^ ( .*? (?i: version ) .*? ) $ver_re ( .* \s*) \z }x; } sub version_re_plain { my $ver_re = shift; return qr{ ^ ( .*? ) $ver_re ( .* \s* ) \z }x; } sub version_re_meta { my ( $indent, $ver_re ) = @_; return qr{ ^ ( $indent version: \s* ) $ver_re ( \s* ) }x; } sub set_versions { my $docs = shift; my $versions = shift; my $new_version = shift or die "Internal: no version specified"; my $force_to = shift; if ( $force_to ) { $new_version = Perl::Version->new( $new_version->$force_to ); } note( "Setting version to $new_version\n" ); # Edit the documents for my $edits ( values %$versions ) { for my $edit ( @$edits ) { my $info = $edit->{info}; if ( $force_to ) { $edit->{ver} = $new_version; } else { $edit->{ver}->set( $new_version ); } $info->{lines}[ $edit->{line} ] = $edit->{pre} . $edit->{ver} . $edit->{post}; $info->{dirty}++; } } } sub find_version_for_doc { my ( $ver_found, $version, $name, $info, $machine ) = @_; note( "Scanning $name" ); my $state = $machine->{init}; my $lines = $info->{lines}; LINE: for my $ln ( 0 .. @$lines - 1 ) { my $line = $lines->[$ln]; # Bail out when we're in a state with no possible actions. last LINE unless @$state; STATE: { for my $trans ( @$state ) { if ( my @match = $line =~ $trans->{re} ) { if ( $trans->{mark} ) { my $ver = Perl::Version->new( $2 . $3 . $4 ); next if defined $version and "$version" ne "$ver"; push @{ $ver_found->{ $ver->normal } }, { file => $name, info => $info, line => $ln, pre => $1, ver => $ver, post => $5 }; note( " $ver" ); } if ( my $code = $trans->{exec} ) { $code->( $machine, \@match, $line ); } if ( my $goto = $trans->{goto} ) { $state = $machine->{$goto}; redo STATE; } } } } } note( "\n" ); } sub find_versions { my $docs = shift; my $version = shift; my $ver_re = Perl::Version::REGEX; # Filetypes that don't have much to say about what the version # might be. my %uncertain = map { $_ => 1 } qw( plain ); my %machines = ( # State machine for Perl source perl => { init => [ { re => qr{ ^ = (?! cut ) }x, goto => 'pod', }, { re => version_re_perl( $ver_re ), mark => 1, }, ], # pod within perl pod => [ { re => qr{ ^ =head\d\s+VERSION\b }x, goto => 'version', }, { re => qr{ ^ =cut }x, goto => 'init', }, ], # version section within pod version => [ { re => qr{ ^ = (?! head\d\s+VERSION\b ) }x, goto => 'pod', }, { re => version_re_pod( $ver_re ), mark => 1, }, ], }, # State machine for plain text. Matches once then loops plain => { init => [ { re => version_re_plain( $ver_re ), mark => 1, goto => 'done', } ], done => [], }, # State machine for META.yml. meta => { init => [ { re => qr{^ (\s*) (?! ---) }x, goto => 'version', exec => sub { my ( $machine, $matches, $line ) = @_; $machine->{version} = [ { re => version_re_meta( '\s{' . length( $matches->[0] ) . '}', $ver_re ), mark => 1, }, ]; }, }, ], }, ); my $ver_found = {}; my $scan_like = sub { my ( $version, $filter ) = @_; while ( my ( $name, $info ) = each %$docs ) { next unless $filter->( $info->{type} ); my $machine = $machines{ $info->{type} } or die "Internal: can't find state machine for type ", $info->{type}; find_version_for_doc( $ver_found, $version, $name, $info, $machine ); } }; $scan_like->( $version, sub { !$uncertain{ $_[0] } } ); # Can we guess what the version is now? unless ( defined $version ) { my @found = keys %$ver_found; $version = $ver_found->{ $found[0] }[0]{ver} if @found == 1; } $scan_like->( $version, sub { $uncertain{ $_[0] } } ); return $ver_found; } sub guess_type { my ( $name, $info ) = @_; for my $try ( @MAGIC ) { return $try->{name} if $try->{test}->( $name, $info ); } return; } sub load_all { my $docs = shift; for my $doc ( keys %$docs ) { #note( "Loading $doc\n" ); $docs->{$doc} = { lines => read_lines( $doc, binmode => ':raw', array_ref => 1 ), dirty => 0, }; $docs->{$doc}{type} = guess_type( $doc, $docs->{$doc} ); #note( "Type is ", $docs->{$doc}{type}, "\n" ); } } sub save_all { my $docs = shift; for my $doc ( grep { $docs->{$_}{dirty} } keys %$docs ) { if ( $dryrun ) { note( "Would save $doc\n" ); } else { note( "Saving $doc\n" ); open my $fh, '>:raw', $doc or croak "Could not open file $doc: $!\n"; $fh->autoflush(1); print $fh @{ $docs->{$doc}{lines} }; close $fh; } } } sub note { print join( '', @_ ) unless $quiet; } sub find_proj_files { if ( my $dir = find_project( File::Spec->curdir ) ) { my @files = (); while ( my ( $obj, $spec ) = each %CONSIDER ) { if ( my $got = exists_in( $dir, $obj ) ) { push @files, expand_dirs_matching( $spec->{like} || qr{}, $got ); } } unless ( @files ) { die "I looked at ", conjunction_list( 'and', sort keys %CONSIDER ), " but found no files to process\n"; } return @files; } else { die "No files / directories specified and I can't\n", "find a directory that looks like a project home.\n"; } } sub conjunction_list { my $conj = shift; my @list = @_; my $last = pop @list; return $last unless @list; return join( " $conj ", join( ', ', @list ), $last ); } sub expand_dirs { return expand_dirs_matching( qr{}, @_ ); } sub expand_dirs_matching { my $match = shift; my @work = @_; my @out = (); while ( my $obj = shift @work ) { if ( -d $obj ) { opendir my $dh, $obj or die "Can't read directory $obj ($!)\n"; push @work, map { File::Spec->catdir( $obj, $_ ) } grep { $_ !~ $SKIP } grep { $_ !~ /^[.][.]?$/ } readdir $dh; closedir $dh; } elsif ( $obj =~ $match ) { push @out, $obj; } } return @out; } sub exists_in { my ( $base, $name ) = @_; my $try; if ( $name =~ m{^(.+)/$} ) { $try = File::Spec->catdir( $base, $1 ); return unless -d $try; } else { $try = File::Spec->catfile( $base, $name ); return unless -f $try; } return File::Spec->canonpath( $try ); } sub find_dir_like { my $start = shift; my $max_up = shift; my $signature = shift; for ( 1 .. $max_up ) { my $score = 0; while ( my ( $file, $weight ) = each %$signature ) { $score += $weight if exists_in( $start, $file ); } return File::Spec->canonpath( $start ) if $score >= 1.0; $start = File::Spec->catdir( $start, File::Spec->updir ); } return; } # Find the project directory sub find_project { return find_dir_like( shift, $MAX_UP, \%PROJECT_SIGNATURE ); } __END__ =head1 NAME perl-reversion - Manipulate project version numbers =head1 SYNOPSIS perl-reversion [options] [file ...] Options: -help see this summary -man view man page for perl-reversion -bump make the smallest possible increment -bump-revision increment the specified version component -bump-version -bump-subversion -bump-alpha -set set the project version number -current specify the current version -normal print current version in a specific format OR -numify force versions to be a specific format, -stringify with -set or -bump -dryrun just go through the motions, but don't actually save files =head1 DESCRIPTION A typical distribution of a Perl module has embedded version numbers is a number of places. Typically the version will be mentioned in the README file and in each module's source. For a module the version may appear twice: once in the code and once in the pod. This script makes it possible to update all of these version numbers with a simple command. To update the version numbers of specific files name them on the command line. Any directories will be recursively expanded. If used with no filename arguments perl-reversion will attempt to update README and any files below lib/ in the current project. =head1 OPTIONS =over =item C<< -bump >> Attempt to make the smallest possible increment to the version. The least significant part of the version string is incremented. 1 => 2 1.1 => 1.2 1.1.1 => 1.1.2 1.1.1_1 => 1.1.1_2 =item C<< -bump-revision >> =item C<< -bump-version >> =item C<< -bump-subversion >> =item C<< -bump-alpha >> Increment the specified version component. Like the C methods of L, incrementing a component sets all components to the right of it to zero. =item C<< -set >> Set the version to the specified value. Unless the C<-normal> option is also specified the format of each individual version string will be preserved. =item C<< -current >> Specify the current version. Only matching version strings will be updated. =item C<< -normal >> =item C<< -numify >> =item C<< -stringify >> Use a specific formatting, as in L. Alone, these options control how the current (found) version is displayed. With C<-bump> or C<-set>, also update version strings to have the given formatting, regardless of the version format passed to C<-set> or the current version (for C<-bump>). If none of these options are specified, perl-reversion will preserve the formatting of each individual version string (the same as C<-stringify>). =item C<< -dryrun >> If set, perl-reversion will not save files. Use this to see what gets changed before it actually happens. =back =head1 AUTHOR Andy Armstrong C<< >> =head1 LICENCE AND COPYRIGHT Copyright (c) 2007, Andy Armstrong C<< >>. All rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L. =head1 DISCLAIMER OF WARRANTY BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR, OR CORRECTION. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.