├── t ├── data │ ├── c │ │ ├── bin │ │ │ └── tmp.txt │ │ ├── lib │ │ │ └── tmp.txt │ │ ├── include │ │ │ └── tmp.txt │ │ └── i686-w64-mingw32 │ │ │ ├── lib │ │ │ └── tmp.txt │ │ │ └── include │ │ │ └── tmp.txt │ ├── cpan │ │ └── tmp.txt │ ├── perl │ │ ├── site │ │ │ ├── bin │ │ │ │ └── tmp.txt │ │ │ └── lib │ │ │ │ └── tmp.txt │ │ ├── vendor │ │ │ ├── bin │ │ │ │ └── tmp.txt │ │ │ └── lib │ │ │ │ └── tmp.txt │ │ ├── bin │ │ │ └── perl.exe │ │ └── lib │ │ │ └── strict.pm │ └── portable.perl ├── minicpan │ └── mirror.yml ├── 01_compile.t ├── 04_cpan.t ├── 05_minicpan.t ├── 03_config.t └── 02_simple.t ├── .gitignore ├── lib ├── CPAN │ └── Mini │ │ └── Portable.pm ├── Portable │ ├── minicpan.pm │ ├── CPAN.pm │ ├── Config.pm │ ├── HomeDir.pm │ ├── FileSpec.pm │ └── LoadYaml.pm └── Portable.pm ├── MANIFEST.SKIP ├── Makefile.PL ├── README.md └── Changes /t/data/c/bin/tmp.txt: -------------------------------------------------------------------------------- 1 | Placeholder -------------------------------------------------------------------------------- /t/data/c/lib/tmp.txt: -------------------------------------------------------------------------------- 1 | Placeholder -------------------------------------------------------------------------------- /t/data/cpan/tmp.txt: -------------------------------------------------------------------------------- 1 | Placeholder -------------------------------------------------------------------------------- /t/data/c/include/tmp.txt: -------------------------------------------------------------------------------- 1 | Placeholder -------------------------------------------------------------------------------- /t/data/perl/site/bin/tmp.txt: -------------------------------------------------------------------------------- 1 | Placeholder -------------------------------------------------------------------------------- /t/data/perl/site/lib/tmp.txt: -------------------------------------------------------------------------------- 1 | Placeholder -------------------------------------------------------------------------------- /t/data/perl/vendor/bin/tmp.txt: -------------------------------------------------------------------------------- 1 | Placeholder -------------------------------------------------------------------------------- /t/data/perl/vendor/lib/tmp.txt: -------------------------------------------------------------------------------- 1 | Placeholder -------------------------------------------------------------------------------- /t/data/c/i686-w64-mingw32/lib/tmp.txt: -------------------------------------------------------------------------------- 1 | Placeholder -------------------------------------------------------------------------------- /t/data/c/i686-w64-mingw32/include/tmp.txt: -------------------------------------------------------------------------------- 1 | Placeholder -------------------------------------------------------------------------------- /t/minicpan/mirror.yml: -------------------------------------------------------------------------------- 1 | --- 2 | - This is not a real mirror.yml file 3 | -------------------------------------------------------------------------------- /t/data/perl/bin/perl.exe: -------------------------------------------------------------------------------- 1 | This is a placeholder for the Perl executable 2 | -------------------------------------------------------------------------------- /t/data/perl/lib/strict.pm: -------------------------------------------------------------------------------- 1 | This is a placeholder for the Perl executable 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.o 2 | *.obj 3 | *.pdb 4 | *.old 5 | *.tmp 6 | *.bak 7 | *.zip 8 | *.gz 9 | tmp* 10 | xxx* 11 | blib* 12 | pm_to_blib* 13 | META.yml 14 | MYMETA.yml 15 | META.json 16 | MYMETA.json 17 | Makefile 18 | Makefile.old 19 | MANIFEST.bak 20 | MANIFEST 21 | Portable-* 22 | -------------------------------------------------------------------------------- /lib/CPAN/Mini/Portable.pm: -------------------------------------------------------------------------------- 1 | package CPAN::Mini::Portable; 2 | 3 | use 5.008; 4 | use strict; 5 | use warnings; 6 | use Portable (); 7 | use CPAN::Mini 0.575 (); 8 | 9 | our $VERSION = '1.23'; 10 | our @ISA = 'CPAN::Mini'; 11 | 12 | sub new { 13 | # Use the portable values as defaults, 14 | # completely ignoring any passed params 15 | my $minicpan = Portable->default->minicpan; 16 | 17 | # Hand off to the parent class 18 | return $_[0]->SUPER::new( %$minicpan ); 19 | } 20 | 21 | 1; 22 | -------------------------------------------------------------------------------- /MANIFEST.SKIP: -------------------------------------------------------------------------------- 1 | # Avoid version control files. 2 | \B\.svn\b 3 | \B\.git\b 4 | \B\.gitignore\b 5 | 6 | # Avoid CI files 7 | ^.travis* 8 | ^.appveyor* 9 | 10 | # Avoid Makemaker generated and utility files. 11 | \bblib/ 12 | \bMakeMaker-\d 13 | \bpm_to_blib\.ts$ 14 | \bpm_to_blib$ 15 | \bblibdirs\.ts$ # 6.18 through 6.25 generated this 16 | \bMakefile$ 17 | \bMANIFEST\.bak$ 18 | \bMANIFEST\.SKIP$ 19 | \bMETA_new\.json$ 20 | \bMETA_new\.yml$ 21 | \bMYMETA\.yml$ 22 | \bMYMETA\.json$ 23 | 24 | # Avoid temp and backup files. 25 | \.old$ 26 | \.tmp$ 27 | \.bak$ 28 | 29 | # Avoid our own built files. 30 | \APortable- 31 | -------------------------------------------------------------------------------- /t/01_compile.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use 5.008; 4 | use strict; 5 | use warnings 'all'; 6 | BEGIN { 7 | $| = 1; 8 | } 9 | 10 | use Test::More 0.42 tests => 9; 11 | use Test::NoWarnings 0.084; 12 | use Test::Exception 0.27; 13 | 14 | is( $Portable::ENABLED, undef, '$Portable::ENABLED is undef' ); 15 | 16 | require_ok( 'Portable' ); 17 | require_ok( 'Portable::Config' ); 18 | require_ok( 'Portable::CPAN' ); 19 | require_ok( 'Portable::HomeDir' ); 20 | require_ok( 'Portable::minicpan' ); 21 | require_ok( 'CPAN::Mini::Portable' ); 22 | 23 | is( $Portable::ENABLED, undef, '$Portable::ENABLED is still undef' ); 24 | -------------------------------------------------------------------------------- /t/04_cpan.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use 5.008; 4 | use strict; 5 | use warnings 'all'; 6 | BEGIN { 7 | $| = 1; 8 | } 9 | 10 | use Test::More tests => 2; 11 | use Test::NoWarnings; 12 | use File::Spec::Functions ':ALL'; 13 | use Class::Inspector (); 14 | 15 | # Override the perl path for testing purposes 16 | $Portable::FAKE_PERL = 17 | $Portable::FAKE_PERL = rel2abs( 18 | catfile( qw{ 19 | t data perl bin perl.exe 20 | } ) 21 | ); 22 | 23 | SKIP: { 24 | unless ( Class::Inspector->installed('CPAN::Config') ) { 25 | skip( "CPAN::Config not found", 1 ); 26 | } 27 | eval { 28 | require Portable; 29 | Portable->import('CPAN'); 30 | }; 31 | ok( ! $@, '->import(CPAN) ok' ); 32 | } 33 | -------------------------------------------------------------------------------- /t/05_minicpan.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use 5.008; 4 | use strict; 5 | use warnings 'all'; 6 | BEGIN { 7 | $| = 1; 8 | } 9 | 10 | # This test requires the internet 11 | use LWP::Online ':skip_all'; 12 | 13 | use Test::More tests => 4; 14 | use Test::NoWarnings; 15 | use File::Spec::Functions ':ALL'; 16 | 17 | # Override the perl path for testing purposes 18 | $Portable::FAKE_PERL = 19 | $Portable::FAKE_PERL = rel2abs( 20 | catfile( qw{ 21 | t data perl bin perl.exe 22 | } ) 23 | ); 24 | 25 | # Create a default object 26 | use_ok( 'CPAN::Mini::Portable' ); 27 | my $object = CPAN::Mini::Portable->new( 28 | 'local' => 1, 29 | 'remote' => 1, 30 | ); 31 | isa_ok( $object, 'CPAN::Mini::Portable' ); 32 | is( 33 | $object->{remote}, 34 | 'http://cpan.strawberryperl.com/', 35 | '->remote ok', 36 | ); 37 | 38 | 1; 39 | -------------------------------------------------------------------------------- /t/03_config.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use 5.008; 4 | use strict; 5 | use warnings 'all'; 6 | BEGIN { 7 | $| = 1; 8 | } 9 | 10 | use Test::More tests => 5; 11 | use Test::NoWarnings; 12 | use Test::Exception; 13 | use File::Spec (); 14 | 15 | # Override the perl path for testing purposes 16 | $Portable::FAKE_PERL = 17 | $Portable::FAKE_PERL = File::Spec->rel2abs( 18 | File::Spec->catfile( qw{ 19 | t data perl bin perl.exe 20 | } ) 21 | ); 22 | 23 | eval { 24 | require Portable; 25 | Portable->import('Config'); 26 | }; 27 | warn "XXXXX: $@" if $@; 28 | ok( ! $@, "->import(Config) ok" ); 29 | 30 | # CPAN::Config should not be loaded 31 | ok( ! $INC{'CPAN/Config.pm'}, 'CPAN::Config is not loaded' ); 32 | 33 | # We are now enabled (twice to avoid a warning) 34 | is( $Portable::ENABLED, 1, '$Portable::ENABLED is true' ); 35 | is( $Portable::ENABLED, 1, '$Portable::ENABLED is true' ); 36 | -------------------------------------------------------------------------------- /Makefile.PL: -------------------------------------------------------------------------------- 1 | use 5.008; 2 | use strict; 3 | use warnings; 4 | use ExtUtils::MakeMaker; 5 | 6 | WriteMakefile( 7 | NAME => 'Portable', 8 | VERSION_FROM => 'lib/Portable.pm', 9 | AUTHOR => 'KMX', 10 | ABSTRACT => 'Perl on a Stick', 11 | MIN_PERL_VERSION => '5.008', 12 | LICENSE => 'perl', 13 | PREREQ_PM => { 14 | 'CPAN::Mini' => '0.575', 15 | }, 16 | BUILD_REQUIRES => { 17 | 'ExtUtils::MakeMaker' => '6.59', 18 | 'Class::Inspector' => '1.22', 19 | 'LWP::Online' => '1.07', 20 | 'Test::Exception' => '0.27', 21 | 'Test::More' => '0.42', 22 | 'Test::NoWarnings' => '0.084', 23 | }, 24 | META_MERGE => { 25 | resources => { 26 | repository => 'https://github.com/StrawberryPerl/Portable', 27 | bugtracker => 'https://github.com/StrawberryPerl/Portable/issues', 28 | }, 29 | }, 30 | dist => { 31 | PREOP => 'perldoc -u lib/Portable.pm | pod2markdown > README.md', 32 | TAR => 'ptar', 33 | TARFLAGS => '-c -C -f' 34 | }, 35 | ); 36 | -------------------------------------------------------------------------------- /t/02_simple.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use 5.008; 4 | use strict; 5 | use warnings 'all'; 6 | BEGIN { 7 | $| = 1; 8 | } 9 | 10 | use Test::More tests => 59; 11 | use Test::NoWarnings; 12 | use File::Spec (); 13 | 14 | # Override the perl path for testing purposes 15 | $Portable::FAKE_PERL = 16 | $Portable::FAKE_PERL = File::Spec->rel2abs( 17 | File::Spec->catfile( qw{ 18 | t data perl bin perl.exe 19 | } ) 20 | ); 21 | 22 | require_ok( 'Portable' ); 23 | ok( $Portable::FAKE_PERL, 'FAKE_PERL remains defined' ); 24 | ok( ! $INC{'CPAN/Config.pm'}, 'CPAN::Config is not loaded' ); 25 | 26 | # Create an object 27 | my $perl = Portable->default; 28 | isa_ok( $perl, 'Portable' ); 29 | 30 | # Twice to avoid a warning 31 | is( $Portable::ENABLED, undef, '$Portable::ENABLED is true' ); 32 | is( $Portable::ENABLED, undef, '$Portable::ENABLED is true' ); 33 | 34 | # Do all the config entries exist 35 | my $config = $perl->config; 36 | foreach my $k ( sort keys %$config ) { 37 | next if $k =~ /^ld|^libpth$/; 38 | next unless defined $config->{$k}; 39 | next unless length $config->{$k}; 40 | ok( -e $config->{$k}, "$k: $config->{$k} exists" ); 41 | } 42 | 43 | like( $config->{libpth}, qr|^[^ ]*?[/\\]c[/\\]lib [^ ]*?[/\\]c[/\\][\w-]+[/\\]lib|, "$config->{libpth} check" ); 44 | 45 | ok( -e $perl->cpan->{cpan_home}, 'cpan_home exists' ); 46 | -------------------------------------------------------------------------------- /lib/Portable/minicpan.pm: -------------------------------------------------------------------------------- 1 | package Portable::minicpan; 2 | 3 | use 5.008; 4 | use strict; 5 | use warnings; 6 | use Portable::FileSpec; 7 | 8 | our $VERSION = '1.23'; 9 | 10 | ##################################################################### 11 | # Portable Driver API 12 | 13 | sub new { 14 | my $class = shift; 15 | my $parent = shift; 16 | unless ( Portable::_HASH($parent->portable_minicpan) ) { 17 | die('Missing or invalid minicpan key in portable.perl'); 18 | } 19 | 20 | # Create the object 21 | my $self = bless { }, $class; 22 | 23 | # Map paths to absolute paths 24 | my $minicpan = $parent->portable_minicpan; 25 | my $root = $parent->dist_root; 26 | foreach my $key ( qw{ local } ) { 27 | unless ( 28 | defined $minicpan->{$key} 29 | and 30 | length $minicpan->{$key} 31 | ) { 32 | $self->{$key} = $minicpan->{$key}; 33 | next; 34 | } 35 | $self->{$key} = Portable::FileSpec::catdir( 36 | $root, split /\//, $minicpan->{$key} 37 | ); 38 | } 39 | 40 | # Add the literal params 41 | $self->{remote} = $minicpan->{remote}; 42 | $self->{quiet} = $minicpan->{quiet}; 43 | $self->{force} = $minicpan->{force}; 44 | $self->{offline} = $minicpan->{offline}; 45 | $self->{also_mirror} = $minicpan->{also_mirror}; 46 | $self->{module_filters} = $minicpan->{module_filters}; 47 | $self->{path_filters} = $minicpan->{path_filters}; 48 | $self->{skip_cleanup} = $minicpan->{skip_cleanup}; 49 | $self->{skip_perl} = $minicpan->{skip_perl}; 50 | $self->{no_conn_cache} = $minicpan->{no_conn_cache}; 51 | 52 | return $self; 53 | } 54 | 55 | 1; 56 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # NAME 2 | 3 | Portable - Perl on a Stick 4 | 5 | # SYNOPSIS 6 | 7 | Launch a script portably 8 | 9 | F:\anywhere\perl.exe -MPortable script.pl 10 | 11 | Have a script specifically request to run portably 12 | 13 | #!/usr/bin/perl 14 | use Portable; 15 | 16 | # DESCRIPTION 17 | 18 | "Portable" is a term used for applications that are installed onto a 19 | portable storage device (most commonly a USB memory stick) rather than 20 | onto a single host. 21 | 22 | This technique has become very popular for Windows applications, as it 23 | allows a user to make use of their own software on typical publically 24 | accessible computers at libraries, hotels and internet cafes. 25 | 26 | Converting a Windows application into portable form has a specific set 27 | of challenges, as the application has no access to the Windows registry, 28 | no access to "My Documents" type directories, and does not exist at a 29 | reliable filesystem path (because the portable storage medium can be 30 | mounted at an arbitrary volume or filesystem location). 31 | 32 | **Portable** provides a methodology and implementation to support 33 | the creating of "Portable Perl" applications and distributions. 34 | 35 | While this will initially be focused on a Windows implementation, 36 | wherever possible the module will be built to be platform-agnostic 37 | in the hope that future versions can support other operating systems, 38 | or work across multiple operating systems. 39 | 40 | This module is not ready for public use. For now, see the code for 41 | more details on how it works... 42 | 43 | # METHODS 44 | 45 | # AUTHOR 46 | 47 | Adam Kennedy 48 | 49 | # COPYRIGHT 50 | 51 | Copyright 2008 - 2011 Adam Kennedy. 52 | 53 | This program is free software; you can redistribute 54 | it and/or modify it under the same terms as Perl itself. 55 | 56 | The full text of the license can be found in the 57 | LICENSE file included with this module. 58 | -------------------------------------------------------------------------------- /lib/Portable/CPAN.pm: -------------------------------------------------------------------------------- 1 | package Portable::CPAN; 2 | 3 | use 5.008; 4 | use strict; 5 | use warnings; 6 | use Portable::FileSpec; 7 | 8 | our $VERSION = '1.23'; 9 | 10 | # Create the enumerations 11 | our %bin = map { $_ => 1 } qw{ 12 | bzip2 curl ftp gpg gzip lynx 13 | ncftp ncftpget pager patch 14 | shell tar unzip wget 15 | }; 16 | our %post = map { $_ => 1 } qw{ 17 | make_arg make_install_arg makepl_arg 18 | mbuild_arg mbuild_install_arg mbuildpl_arg 19 | }; 20 | our %file = ( %bin, histfile => 1 ); 21 | 22 | 23 | 24 | 25 | 26 | ##################################################################### 27 | # Constructor 28 | 29 | sub new { 30 | my $class = shift; 31 | my $parent = shift; 32 | unless ( Portable::_HASH($parent->portable_cpan) ) { 33 | die('Missing or invalid cpan key in portable.perl'); 34 | } 35 | 36 | # Create the object 37 | my $self = bless { }, $class; 38 | 39 | # Map the 40 | my $cpan = $parent->portable_cpan; 41 | my $root = $parent->dist_root; 42 | foreach my $key ( sort keys %$cpan ) { 43 | unless ( 44 | defined $cpan->{$key} 45 | and 46 | length $cpan->{$key} 47 | and not 48 | $post{$key} 49 | ) { 50 | $self->{$key} = $cpan->{$key}; 51 | next; 52 | } 53 | if ($file{$key}) { 54 | $self->{$key} = Portable::FileSpec::catfile($root, split /\//, $cpan->{$key}); 55 | } 56 | else { 57 | $self->{$key} = Portable::FileSpec::catdir($root, split /\//, $cpan->{$key}); 58 | } 59 | } 60 | my $config = $parent->config; 61 | foreach my $key ( sort keys %post ) { 62 | next unless defined $self->{$key}; 63 | $self->{$key} =~ s/\$(\w+)/$config->{$1}/g; 64 | } 65 | 66 | return $self; 67 | } 68 | 69 | sub apply { 70 | my $self = shift; 71 | my $parent = shift; 72 | 73 | # Load the CPAN configuration 74 | require CPAN::Config; 75 | 76 | # Overwrite the CPAN config entries 77 | foreach my $key ( sort keys %$self ) { 78 | $CPAN::Config->{$key} = $self->{$key}; 79 | } 80 | 81 | # Confirm we got all the paths 82 | my $volume = quotemeta $parent->dist_volume; 83 | foreach my $key ( sort keys %$CPAN::Config ) { 84 | next unless defined $CPAN::Config->{$key}; 85 | next if $CPAN::Config->{$key} =~ /$volume/; 86 | next unless $CPAN::Config->{$key} =~ /\b[a-z]\:/i; 87 | next if -e $CPAN::Config->{$key}; 88 | die "Failed to localize \$CPAN::Config->{$key} ($CPAN::Config->{$key})"; 89 | } 90 | 91 | return 1; 92 | } 93 | 94 | 1; 95 | -------------------------------------------------------------------------------- /lib/Portable/Config.pm: -------------------------------------------------------------------------------- 1 | package Portable::Config; 2 | 3 | use 5.008; 4 | use strict; 5 | use warnings; 6 | use Portable::FileSpec; 7 | 8 | our $VERSION = '1.23'; 9 | 10 | ##################################################################### 11 | # Constructor 12 | 13 | sub new { 14 | my $class = shift; 15 | my $parent = shift; 16 | unless ( Portable::_HASH($parent->portable_config) ) { 17 | die('Missing or invalid config key in portable.perl'); 18 | } 19 | 20 | # Create the object 21 | my $self = bless { }, $class; 22 | my $conf = $parent->portable_config; 23 | my $root = $parent->dist_root; 24 | foreach my $key ( sort keys %$conf ) { 25 | unless ( 26 | defined $conf->{$key} 27 | and 28 | length $conf->{$key} 29 | and not 30 | $key =~ /^ld|^libpth$/ 31 | ) { 32 | $self->{$key} = $conf->{$key}; 33 | next; 34 | } 35 | #join path to directory of portable perl with value from config file 36 | if ($key eq 'perlpath') { 37 | $self->{$key} = Portable::FileSpec::catfile($root, split /\//, $conf->{$key}); 38 | } 39 | else { 40 | $self->{$key} = Portable::FileSpec::catdir($root, split /\//, $conf->{$key}); 41 | } 42 | } 43 | foreach my $key ( grep { /^ld|^libpth$/ } keys %$self ) { 44 | #special handling of linker config variables and libpth 45 | next unless defined $self->{$key}; 46 | $self->{$key} =~ s/\$(\w+)/$self->{$1}/g; 47 | } 48 | 49 | return $self; 50 | } 51 | 52 | sub apply { 53 | my $self = shift; 54 | my $parent = shift; 55 | 56 | # Force all Config entries to load, so that 57 | # all Config_heavy.pl code has run, and none 58 | # of our values will be overwritten later. 59 | require Config; 60 | my $preload = { %Config::Config }; 61 | 62 | # Shift the tie STORE method out the way 63 | SCOPE: { 64 | no warnings; 65 | *Config::_TEMP = *Config::STORE; 66 | *Config::STORE = sub { 67 | $_[0]->{$_[1]} = $_[2]; 68 | }; 69 | } 70 | 71 | # Write the values to the Config hash 72 | foreach my $key ( sort keys %$self ) { 73 | $Config::Config{$key} = $self->{$key}; 74 | } 75 | 76 | # Restore the STORE method 77 | SCOPE: { 78 | no warnings; 79 | *Config::STORE = delete $Config::{_TEMP}; 80 | } 81 | 82 | # Confirm we got all the paths 83 | my $volume = quotemeta $parent->dist_volume; 84 | foreach my $key ( sort keys %Config::Config ) { 85 | next unless defined $Config::Config{$key}; 86 | next if $Config::Config{$key} =~ /$volume/i; 87 | next unless $Config::Config{$key} =~ /\b[a-z]\:/i; 88 | die "Failed to localize \$Config::Config{$key} ($Config::Config{$key})"; 89 | } 90 | 91 | return 1; 92 | } 93 | 94 | 1; 95 | -------------------------------------------------------------------------------- /lib/Portable/HomeDir.pm: -------------------------------------------------------------------------------- 1 | package Portable::HomeDir; 2 | 3 | # In the trivial case, only my_home is implemented 4 | 5 | use 5.008; 6 | use strict; 7 | use warnings; 8 | use Portable::FileSpec; 9 | 10 | our $VERSION = '1.23'; 11 | 12 | ##################################################################### 13 | # Portable Driver API 14 | 15 | sub new { 16 | my $class = shift; 17 | my $parent = shift; 18 | unless ( Portable::_HASH($parent->portable_homedir) ) { 19 | die('Missing or invalid HomeDir key in portable.perl'); 20 | } 21 | 22 | # Create the object 23 | my $self = bless { }, $class; 24 | 25 | # Map the 26 | my $homedir = $parent->portable_homedir; 27 | my $root = $parent->dist_root; 28 | foreach my $key ( sort keys %$homedir ) { 29 | unless ( 30 | defined $homedir->{$key} 31 | and 32 | length $homedir->{$key} 33 | ) { 34 | $self->{$key} = $homedir->{$key}; 35 | next; 36 | } 37 | $self->{$key} = Portable::FileSpec::catdir( 38 | $root, split /\//, $homedir->{$key} 39 | ); 40 | } 41 | 42 | return $self; 43 | } 44 | 45 | sub apply { 46 | my $self = shift; 47 | 48 | # Shortcut if we've already applied 49 | if ( $File::HomeDir::IMPLEMENTED_BY eq __PACKAGE__ ) { 50 | return 1; 51 | } 52 | 53 | # Load File::HomeDir and the regular platform driver 54 | require File::HomeDir; 55 | 56 | # Remember the platform we're on so we can default 57 | # to it properly if there's no portable equivalent. 58 | $self->{platform} = $File::HomeDir::IMPLEMENTED_BY; 59 | 60 | # Hijack the implementation class to us 61 | $File::HomeDir::IMPLEMENTED_BY = __PACKAGE__; 62 | 63 | return 1; 64 | } 65 | 66 | sub platform { 67 | $_[0]->{platform}; 68 | } 69 | 70 | 71 | 72 | 73 | 74 | ##################################################################### 75 | # File::HomeDir::Driver API 76 | 77 | sub _SELF { 78 | ref($_[0]) ? $_[0] : Portable->default->homedir; 79 | } 80 | 81 | sub my_home { 82 | _SELF(@_)->{my_home}; 83 | } 84 | 85 | # The concept of "my_desktop" is incompatible with the idea of 86 | # a Portable Perl distribution (because Windows won't overwrite 87 | # the desktop with anything on the flash drive) 88 | # sub my_desktop 89 | 90 | sub my_documents { 91 | _SELF(@_)->{my_documents}; 92 | } 93 | 94 | sub my_music { 95 | _SELF(@_)->{my_music}; 96 | } 97 | 98 | sub my_pictures { 99 | _SELF(@_)->{my_pictures}; 100 | } 101 | 102 | sub my_videos { 103 | _SELF(@_)->{my_videos}; 104 | } 105 | 106 | sub my_data { 107 | _SELF(@_)->{my_data}; 108 | } 109 | 110 | 1; 111 | -------------------------------------------------------------------------------- /t/data/portable.perl: -------------------------------------------------------------------------------- 1 | --- 2 | Config: 3 | archlib: perl/lib 4 | archlibexp: perl/lib 5 | bin: perl/bin 6 | binexp: perl/bin 7 | incpath: c/include 8 | installarchlib: perl/lib 9 | installbin: perl/bin 10 | installbin: perl/bin 11 | installhtml1dir: '' 12 | installhtml3dir: '' 13 | installhtmldir: '' 14 | installhtmlhelpdir: '' 15 | installman1dir: '' 16 | installman3dir: '' 17 | installprefix: perl 18 | installprefixexp: perl 19 | installprivlib: perl/lib 20 | installscript: perl/bin 21 | installsitearch: perl/site/lib 22 | installsitebin: perl/site/bin 23 | installsitehtml1dir: '' 24 | installsitehtml3dir: '' 25 | installsitelib: perl/site/lib 26 | installsiteman1dir: '' 27 | installsiteman3dir: '' 28 | installsitescript: 'perl/site/bin' 29 | installstyle: perl/lib 30 | installusrbinperl: ~ 31 | installvendorarch: 'perl/vendor/lib' 32 | installvendorbin: 'perl/bin' 33 | installvendorhtml1dir: '' 34 | installvendorhtml3dir: '' 35 | installvendorlib: 'perl/vendor/lib' 36 | installvendorman1dir: '' 37 | installvendorman3dir: '' 38 | installvendorscript: 'perl/bin' 39 | ld: g++.exe 40 | _libpthfix_part1: c/lib 41 | _libpthfix_part2: c/i686-w64-mingw32/lib 42 | lddlflags: '-mdll -s -L"$archlib\CORE" -L"$_libpthfix_part1"' 43 | ldflags: '-s -L"$archlib\CORE" -L"$_libpthfix_part1"' 44 | ldflags_nolargefiles: '-s -L"$archlib\CORE" -L"$_libpthfix_part1"' 45 | libpth: $_libpthfix_part1 $_libpthfix_part2 46 | perlpath: perl/bin/perl.exe 47 | prefix: perl 48 | prefixexp: perl 49 | privlib: perl/lib 50 | privlibexp: perl/lib 51 | scriptdir: perl/bin 52 | scriptdirexp: perl/bin 53 | sitearch: perl/site/lib 54 | sitearchexp: perl/site/lib 55 | sitebin: perl/site/bin 56 | sitebinexp: perl/site/bin 57 | sitelib: perl/site/lib 58 | sitelibexp: perl/site/lib 59 | siteprefix: perl/site 60 | siteprefixexp: perl/site 61 | man1dir: '' 62 | man1direxp: '' 63 | man3dir: '' 64 | man3direxp: '' 65 | vendorarch: perl/vendor/lib 66 | vendorarchexp: perl/vendor/lib 67 | vendorbin: perl/bin 68 | vendorbinexp: perl/bin 69 | vendorhtml1dir: '' 70 | vendorhtml3dir: '' 71 | vendorlib: perl/vendor/lib 72 | vendorlibexp: perl/vendor/lib 73 | vendorman1dir: '' 74 | vendorman3dir: '' 75 | vendorprefix: perl/vendor 76 | vendorprefixexp: perl/vendor 77 | vendorscript: perl/bin 78 | sitescript: perl/site/bin 79 | sitescriptexp: perl/site/bin 80 | vendorscriptexp: perl/bin 81 | usrinc: c/include 82 | CPAN: 83 | build_dir: cpan/build 84 | cpan_home: cpan 85 | histfile: cpan/histfile 86 | keep_source_where: cpan/sources 87 | make: c/bin/dmake.exe 88 | makepl_arg: 'LIBS=-L$_libpthfix_part1 INC=-I$incpath' 89 | patch: c/bin/patch.exe 90 | prefs_dir: cpan/prefs 91 | Env: 92 | PATH: 93 | - c/bin 94 | - perl/bin 95 | LIB: 96 | - c/lib 97 | - perl/bin 98 | INCLUDE: 99 | - c/include 100 | - perl/lib/CORE 101 | FTP_PASSIVE: 1 102 | TERM: dumb 103 | minicpan: 104 | local: /minicpan 105 | remote: http://cpan.strawberryperl.com/ 106 | skip_perl: 1 107 | -------------------------------------------------------------------------------- /Changes: -------------------------------------------------------------------------------- 1 | Changes for Perl extension Portable. 2 | 3 | 1.23 2020-02-07 4 | - switch to EUMM 5 | 6 | 1.22 2014-04-09 7 | - avoiding Parse::CPAN::Meta (collisions with cpanminus) - another UGLY HACK!!! 8 | 9 | 1.21 2014-04-09 10 | - avoiding Carp (due to Carp reload failures) 11 | 12 | 1.20 2014-04-07 13 | - missing test files 14 | 15 | 1.19 2014-04-06 16 | - fixing troubles/collisions/interferences with File::Spec in 5.19.10 17 | - introducing Portable::FileSpec which is Win32 ONLY!!!! (I know it is not good) 18 | 19 | 1.18 2013-02-25 20 | - eliminating warning 21 | 22 | 1.17 2012-05-09 23 | - just versioning fix 24 | 25 | 1.16 2012-05-08 26 | - Removing dependency on List::Util (KMX) 27 | - Removing "ALPHA" from NAME (KMX) 28 | 29 | 1.15 2011-11-02 30 | - Updated to Module::Install::DSL 1.04 (ADAMK) 31 | - Fixed #68937: $Config{libpth} not correctly transformed (KMX) 32 | 33 | 1.14 2011-04-13 34 | - Updating to Module::Install::DSL 1.00 35 | - Switching to a production release 36 | 37 | 0.13 2009-06-01 38 | - Updating to Module::Install::DSL 0.91 39 | - Supports running the test suite while offline 40 | - Adding no_conn_cache support to minicpan 41 | 42 | 0.12 2009-02-09 43 | - Upgrading to Module::Install 0.79 44 | - Adding a globally-accessible $Portable::ENABLED variable that 45 | external module can use to detect if Portable mode is enabled. 46 | 47 | 0.11 2008-07-02 48 | - Debugged the minicpan backend to the point where it will 49 | actually build and install properly. 50 | 51 | 0.10 2008-07-02 52 | - Working on a proper implementation of the minicpan backend. 53 | - Added missing test_requires Test::Exception. 54 | 55 | 0.09 2008-07-02 56 | - Fixing my_documents, my_data, etc in Portable::HomeDir. 57 | - Implementing my_data also fixes Portable::CPAN. 58 | - Adding CPAN::Mini as a dependency for that backend. 59 | 60 | 0.08 2008-07-01 61 | - Adding a dependency on a new version of File::HomeDir. 62 | 63 | 0.07 2008-06-20 64 | - Bug fix to make the CPAN driver test optional. 65 | (Avoids breaking CPAN Testers) 66 | 67 | 0.06 2008-06-28 68 | - Satisfactorily completed the Config.pm hook. 69 | - Satisfactorily completed the File::HomeDir hook. 70 | - Some test tweaks to make them actually work. 71 | 72 | 0.05 2008-04-27 73 | - Don't preload the configurations. 74 | (Delay until the final ->apply is called) 75 | - Import now takes backend names as params. 76 | (Allows appending "use Portable 'Config';" to Config.pm etc) 77 | - Adding tests for the new interfaces. 78 | - Disable warnings when playing around with Config::STORE. 79 | - Completing the implementation of Portable::CPAN. 80 | - A variety of functionality bug fixes. 81 | 82 | 0.04 2008-04-23 83 | - Separating out each task into a separate class. 84 | - Making the overwriting of CPAN::Config optional, 85 | because (at least theoretically) it doesn't always exist. 86 | 87 | 0.03 2008-04-22 88 | - Moving the name from Perl::Portable to Portable. 89 | - Adding proper support for Portable'ing CPAN::Config. 90 | - Removing dependency bloat, use only 5.10.1 core modules. 91 | 92 | 0.02 2008-04-21 93 | - Completely changed the portable.perl format to be based on 94 | Config.pm instead of some arbitrary format I invented myself. 95 | 96 | 0.01 2008-04-18 97 | - Experimental first release. 98 | -------------------------------------------------------------------------------- /lib/Portable/FileSpec.pm: -------------------------------------------------------------------------------- 1 | package Portable::FileSpec; 2 | 3 | ### UGLY HACK: these functions where completely copied from File::Spec::Win32 4 | 5 | use 5.008; 6 | use strict; 7 | use warnings; 8 | 9 | our $VERSION = '1.23'; 10 | 11 | # Some regexes we use for path splitting 12 | my $DRIVE_RX = '[a-zA-Z]:'; 13 | my $UNC_RX = '(?:\\\\\\\\|//)[^\\\\/]+[\\\\/][^\\\\/]+'; 14 | my $VOL_RX = "(?:$DRIVE_RX|$UNC_RX)"; 15 | 16 | sub splitpath { 17 | my ($path, $nofile) = @_; 18 | my ($volume,$directory,$file) = ('','',''); 19 | if ( $nofile ) { 20 | $path =~ 21 | m{^ ( $VOL_RX ? ) (.*) }sox; 22 | $volume = $1; 23 | $directory = $2; 24 | } 25 | else { 26 | $path =~ 27 | m{^ ( $VOL_RX ? ) 28 | ( (?:.*[\\/](?:\.\.?\Z(?!\n))?)? ) 29 | (.*) 30 | }sox; 31 | $volume = $1; 32 | $directory = $2; 33 | $file = $3; 34 | } 35 | 36 | return ($volume,$directory,$file); 37 | } 38 | 39 | sub splitdir { 40 | my ($directories) = @_ ; 41 | # 42 | # split() likes to forget about trailing null fields, so here we 43 | # check to be sure that there will not be any before handling the 44 | # simple case. 45 | # 46 | if ( $directories !~ m|[\\/]\Z(?!\n)| ) { 47 | return split( m|[\\/]|, $directories ); 48 | } 49 | else { 50 | # 51 | # since there was a trailing separator, add a file name to the end, 52 | # then do the split, then replace it with ''. 53 | # 54 | my( @directories )= split( m|[\\/]|, "${directories}dummy" ) ; 55 | $directories[ $#directories ]= '' ; 56 | return @directories ; 57 | } 58 | } 59 | 60 | sub catpath { 61 | my ($volume,$directory,$file) = @_; 62 | 63 | # If it's UNC, make sure the glue separator is there, reusing 64 | # whatever separator is first in the $volume 65 | my $v; 66 | $volume .= $v 67 | if ( (($v) = $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s) && 68 | $directory =~ m@^[^\\/]@s 69 | ) ; 70 | 71 | $volume .= $directory ; 72 | 73 | # If the volume is not just A:, make sure the glue separator is 74 | # there, reusing whatever separator is first in the $volume if possible. 75 | if ( $volume !~ m@^[a-zA-Z]:\Z(?!\n)@s && 76 | $volume =~ m@[^\\/]\Z(?!\n)@ && 77 | $file =~ m@[^\\/]@ 78 | ) { 79 | $volume =~ m@([\\/])@ ; 80 | my $sep = $1 ? $1 : '\\' ; 81 | $volume .= $sep ; 82 | } 83 | 84 | $volume .= $file ; 85 | 86 | return $volume ; 87 | } 88 | 89 | sub catdir { 90 | # Legacy / compatibility support 91 | return "" unless @_; 92 | shift, return _canon_cat( "/", @_ ) if $_[0] eq ""; 93 | 94 | # Compatibility with File::Spec <= 3.26: 95 | # catdir('A:', 'foo') should return 'A:\foo'. 96 | return _canon_cat( ($_[0].'\\'), @_[1..$#_] ) if $_[0] =~ m{^$DRIVE_RX\z}o; 97 | 98 | return _canon_cat( @_ ); 99 | } 100 | 101 | sub catfile { 102 | # Legacy / compatibility support 103 | # 104 | shift, return _canon_cat( "/", @_ ) 105 | if $_[0] eq ""; 106 | 107 | # Compatibility with File::Spec <= 3.26: 108 | # catfile('A:', 'foo') should return 'A:\foo'. 109 | return _canon_cat( ($_[0].'\\'), @_[1..$#_] ) 110 | if $_[0] =~ m{^$DRIVE_RX\z}o; 111 | 112 | return _canon_cat( @_ ); 113 | } 114 | 115 | sub _canon_cat { 116 | my ($first, @rest) = @_; 117 | 118 | my $volume = $first =~ s{ \A ([A-Za-z]:) ([\\/]?) }{}x # drive letter 119 | ? ucfirst( $1 ).( $2 ? "\\" : "" ) 120 | : $first =~ s{ \A (?:\\\\|//) ([^\\/]+) 121 | (?: [\\/] ([^\\/]+) )? 122 | [\\/]? }{}xs # UNC volume 123 | ? "\\\\$1".( defined $2 ? "\\$2" : "" )."\\" 124 | : $first =~ s{ \A [\\/] }{}x # root dir 125 | ? "\\" 126 | : ""; 127 | my $path = join "\\", $first, @rest; 128 | 129 | $path =~ tr#\\/#\\\\#s; # xx/yy --> xx\yy & xx\\yy --> xx\yy 130 | 131 | # xx/././yy --> xx/yy 132 | $path =~ s{(?: 133 | (?:\A|\\) # at begin or after a slash 134 | \. 135 | (?:\\\.)* # and more 136 | (?:\\|\z) # at end or followed by slash 137 | )+ # performance boost -- I do not know why 138 | }{\\}gx; 139 | 140 | # XXX I do not know whether more dots are supported by the OS supporting 141 | # this ... annotation (NetWare or symbian but not MSWin32). 142 | # Then .... could easily become ../../.. etc: 143 | # Replace \.\.\. by (\.\.\.+) and substitute with 144 | # { $1 . ".." . "\\.." x (length($2)-2) }gex 145 | # ... --> ../.. 146 | $path =~ s{ (\A|\\) # at begin or after a slash 147 | \.\.\. 148 | (?=\\|\z) # at end or followed by slash 149 | }{$1..\\..}gx; 150 | # xx\yy\..\zz --> xx\zz 151 | while ( $path =~ s{(?: 152 | (?:\A|\\) # at begin or after a slash 153 | [^\\]+ # rip this 'yy' off 154 | \\\.\. 155 | (? xx NOTE: this is *not* root 162 | $path =~ s#\\\z##; # xx\ --> xx 163 | 164 | if ( $volume =~ m#\\\z# ) 165 | { # \.. --> \ 166 | $path =~ s{ \A # at begin 167 | \.\. 168 | (?:\\\.\.)* # and more 169 | (?:\\|\z) # at end or followed by slash 170 | }{}x; 171 | 172 | return $1 # \\HOST\SHARE\ --> \\HOST\SHARE 173 | if $path eq "" 174 | and $volume =~ m#\A(\\\\.*)\\\z#s; 175 | } 176 | return $path ne "" || $volume ? $volume.$path : "."; 177 | } 178 | 179 | 180 | 1; 181 | -------------------------------------------------------------------------------- /lib/Portable.pm: -------------------------------------------------------------------------------- 1 | package Portable; 2 | 3 | =pod 4 | 5 | =head1 NAME 6 | 7 | Portable - Perl on a Stick 8 | 9 | =head1 SYNOPSIS 10 | 11 | Launch a script portably 12 | 13 | F:\anywhere\perl.exe -MPortable script.pl 14 | 15 | Have a script specifically request to run portably 16 | 17 | #!/usr/bin/perl 18 | use Portable; 19 | 20 | =head1 DESCRIPTION 21 | 22 | "Portable" is a term used for applications that are installed onto a 23 | portable storage device (most commonly a USB memory stick) rather than 24 | onto a single host. 25 | 26 | This technique has become very popular for Windows applications, as it 27 | allows a user to make use of their own software on typical publically 28 | accessible computers at libraries, hotels and internet cafes. 29 | 30 | Converting a Windows application into portable form has a specific set 31 | of challenges, as the application has no access to the Windows registry, 32 | no access to "My Documents" type directories, and does not exist at a 33 | reliable filesystem path (because the portable storage medium can be 34 | mounted at an arbitrary volume or filesystem location). 35 | 36 | B provides a methodology and implementation to support 37 | the creating of "Portable Perl" applications and distributions. 38 | 39 | While this will initially be focused on a Windows implementation, 40 | wherever possible the module will be built to be platform-agnostic 41 | in the hope that future versions can support other operating systems, 42 | or work across multiple operating systems. 43 | 44 | This module is not ready for public use. For now, see the code for 45 | more details on how it works... 46 | 47 | =head1 METHODS 48 | 49 | =cut 50 | 51 | use 5.008; 52 | use strict; 53 | use warnings; 54 | use Portable::LoadYaml; 55 | use Portable::FileSpec; 56 | 57 | our $VERSION = '1.23'; 58 | 59 | # This variable is provided exclusively for the 60 | # use of test scripts. 61 | our $FAKE_PERL; 62 | 63 | # Globally-accessible flag to see if Portable is enabled. 64 | # Defaults to undef, because if Portable.pm is not loaded 65 | # AT ALL, $Portable::ENABLED returns undef anyways. 66 | our $ENABLED = undef; 67 | 68 | # Param-checking 69 | sub _STRING ($) { 70 | (defined $_[0] and ! ref $_[0] and length($_[0])) ? $_[0] : undef; 71 | } 72 | sub _HASH ($) { 73 | (ref $_[0] eq 'HASH' and scalar %{$_[0]}) ? $_[0] : undef; 74 | } 75 | sub _ARRAY ($) { 76 | (ref $_[0] eq 'ARRAY' and @{$_[0]}) ? $_[0] : undef; 77 | } 78 | 79 | # Package variables 80 | my %applied; 81 | my $cache; 82 | 83 | 84 | 85 | 86 | 87 | ##################################################################### 88 | # Pragma/Import Interface 89 | 90 | sub import { 91 | my $class = shift; 92 | $class->apply( @_ ? @_ : qw{ Config CPAN } ); 93 | } 94 | 95 | sub apply { 96 | # default %applied; 97 | my $class = shift; 98 | my $self = $class->default; 99 | my %apply = map { $_ => 1 } @_; 100 | if ( $apply{Config} and ! $applied{Config} ) { 101 | $self->config->apply($self); 102 | $applied{Config} = 1; 103 | $ENABLED = 1; 104 | } 105 | if ( $apply{CPAN} and ! $applied{CPAN} and $self->cpan ) { 106 | $self->cpan->apply($self); 107 | $applied{CPAN} = 1; 108 | $ENABLED = 1; 109 | } 110 | if ( $apply{HomeDir} and ! $applied{HomeDir} and $self->homedir ) { 111 | $self->homedir->apply($self); 112 | $applied{HomeDir} = 1; 113 | $ENABLED = 1; 114 | } 115 | 116 | # We don't need to do anything for CPAN::Mini. 117 | # It will load us instead (I think) 118 | 119 | return 1; 120 | } 121 | 122 | sub applied { 123 | $applied{$_[1]}; 124 | } 125 | 126 | 127 | 128 | 129 | 130 | ##################################################################### 131 | # Constructors 132 | 133 | sub new { 134 | my $class = shift; 135 | my $self = bless { @_ }, $class; 136 | 137 | # Param checking 138 | unless ( exists $self->{dist_volume} ) { 139 | die('Missing or invalid dist_volume param'); 140 | } 141 | unless ( _STRING($self->dist_dirs) ) { 142 | die('Missing or invalid dist_dirs param'); 143 | } 144 | unless ( _STRING($self->dist_root) ) { 145 | die('Missing or invalid dist_root param'); 146 | } 147 | unless ( _HASH($self->{portable}) ) { 148 | die('Missing or invalid portable param'); 149 | } 150 | 151 | # Compulsory support for Config.pm 152 | require Portable::Config; 153 | $self->{Config} = Portable::Config->new( $self ); 154 | 155 | # Optional support for CPAN::Config 156 | if ( $self->portable_cpan ) { 157 | require Portable::CPAN; 158 | $self->{CPAN} = Portable::CPAN->new( $self ); 159 | } 160 | 161 | # Optional support for File::HomeDir 162 | if ( $self->portable_homedir ) { 163 | require Portable::HomeDir; 164 | $self->{HomeDir} = Portable::HomeDir->new( $self ); 165 | } 166 | 167 | # Optional support for CPAN::Mini 168 | if ( $self->portable_minicpan ) { 169 | require Portable::minicpan; 170 | $self->{minicpan} = Portable::minicpan->new( $self ); 171 | } 172 | 173 | return $self; 174 | } 175 | 176 | sub default { 177 | # state $cache; 178 | return $cache if $cache; 179 | 180 | # Get the perl executable location 181 | my $perlpath = ($ENV{HARNESS_ACTIVE} and $FAKE_PERL) ? $FAKE_PERL : $^X; 182 | 183 | # The path to Perl has a localized path. 184 | # G:\\strawberry\\perl\\bin\\perl.exe 185 | # Split it up, and search upwards to try and locate the 186 | # portable.perl file in the distribution root. 187 | my ($dist_volume, $d, $f) = Portable::FileSpec::splitpath($perlpath); 188 | my @d = Portable::FileSpec::splitdir($d); 189 | pop @d if @d > 0 && $d[-1] eq ''; 190 | my @tmp = grep { 191 | -f Portable::FileSpec::catpath( $dist_volume, $_, 'portable.perl' ) 192 | } 193 | map { 194 | Portable::FileSpec::catdir(@d[0 .. $_]) 195 | } reverse ( 0 .. $#d ); 196 | my $dist_dirs = $tmp[0]; 197 | unless ( defined $dist_dirs ) { 198 | die("Failed to find the portable.perl file"); 199 | } 200 | 201 | # Derive the main paths from the plain dirs 202 | my $dist_root = Portable::FileSpec::catpath($dist_volume, $dist_dirs, '' ); 203 | my $conf = Portable::FileSpec::catpath($dist_volume, $dist_dirs, 'portable.perl' ); 204 | 205 | # Load the YAML file 206 | my $portable = Portable::LoadYaml::load_file( $conf ); 207 | unless ( _HASH($portable) ) { 208 | die("Missing or invalid portable.perl file"); 209 | } 210 | 211 | # Hand off to the main constructor, 212 | # cache the result and return it 213 | $cache = __PACKAGE__->new( 214 | dist_volume => $dist_volume, 215 | dist_dirs => $dist_dirs, 216 | dist_root => $dist_root, 217 | conf => $conf, 218 | perlpath => $perlpath, 219 | portable => $portable, 220 | ); 221 | } 222 | 223 | 224 | 225 | 226 | 227 | ##################################################################### 228 | # Configuration Accessors 229 | 230 | sub dist_volume { 231 | $_[0]->{dist_volume}; 232 | } 233 | 234 | sub dist_dirs { 235 | $_[0]->{dist_dirs}; 236 | } 237 | 238 | sub dist_root { 239 | $_[0]->{dist_root}; 240 | } 241 | 242 | sub conf { 243 | $_[0]->{conf}; 244 | } 245 | 246 | sub perlpath { 247 | $_[0]->{perlpath}; 248 | } 249 | 250 | sub portable_cpan { 251 | $_[0]->{portable}->{CPAN}; 252 | } 253 | 254 | sub portable_config { 255 | $_[0]->{portable}->{Config}; 256 | } 257 | 258 | sub portable_homedir { 259 | $_[0]->{portable}->{HomeDir}; 260 | } 261 | 262 | sub portable_minicpan { 263 | $_[0]->{portable}->{minicpan}; 264 | } 265 | 266 | sub portable_env { 267 | $_[0]->{portable}->{Env}; 268 | } 269 | 270 | sub config { 271 | $_[0]->{Config}; 272 | } 273 | 274 | sub cpan { 275 | $_[0]->{CPAN}; 276 | } 277 | 278 | sub homedir { 279 | $_[0]->{HomeDir}; 280 | } 281 | 282 | sub minicpan { 283 | $_[0]->{minicpan}; 284 | } 285 | 286 | sub env { 287 | $_[0]->{Env}; 288 | } 289 | 290 | 1; 291 | 292 | =pod 293 | 294 | =head1 AUTHOR 295 | 296 | Adam Kennedy Eadamk@cpan.orgE 297 | 298 | =head1 COPYRIGHT 299 | 300 | Copyright 2008 - 2011 Adam Kennedy. 301 | 302 | This program is free software; you can redistribute 303 | it and/or modify it under the same terms as Perl itself. 304 | 305 | The full text of the license can be found in the 306 | LICENSE file included with this module. 307 | 308 | =cut 309 | -------------------------------------------------------------------------------- /lib/Portable/LoadYaml.pm: -------------------------------------------------------------------------------- 1 | package Portable::LoadYaml; 2 | 3 | ### UGLY HACK: these functions where completely copied from Parse::CPAN::Meta 4 | 5 | use 5.008; 6 | use strict; 7 | use warnings; 8 | 9 | our $VERSION = '1.23'; 10 | 11 | sub load_file { 12 | my $file = shift; 13 | my $self = __PACKAGE__->_load_file($file); 14 | return $self->[-1]; 15 | } 16 | 17 | ##################################################################### 18 | # Constants 19 | 20 | # Printed form of the unprintable characters in the lowest range 21 | # of ASCII characters, listed by ASCII ordinal position. 22 | my @UNPRINTABLE = qw( 23 | 0 x01 x02 x03 x04 x05 x06 a 24 | b t n v f r x0E x0F 25 | x10 x11 x12 x13 x14 x15 x16 x17 26 | x18 x19 x1A e x1C x1D x1E x1F 27 | ); 28 | 29 | # Printable characters for escapes 30 | my %UNESCAPES = ( 31 | 0 => "\x00", z => "\x00", N => "\x85", 32 | a => "\x07", b => "\x08", t => "\x09", 33 | n => "\x0a", v => "\x0b", f => "\x0c", 34 | r => "\x0d", e => "\x1b", '\\' => '\\', 35 | ); 36 | 37 | # These 3 values have special meaning when unquoted and using the 38 | # default YAML schema. They need quotes if they are strings. 39 | my %QUOTE = map { $_ => 1 } qw{ 40 | null true false 41 | }; 42 | 43 | # The commented out form is simpler, but overloaded the Perl regex 44 | # engine due to recursion and backtracking problems on strings 45 | # larger than 32,000ish characters. Keep it for reference purposes. 46 | # qr/\"((?:\\.|[^\"])*)\"/ 47 | my $re_capture_double_quoted = qr/\"([^\\"]*(?:\\.[^\\"]*)*)\"/; 48 | my $re_capture_single_quoted = qr/\'([^\']*(?:\'\'[^\']*)*)\'/; 49 | # unquoted re gets trailing space that needs to be stripped 50 | my $re_capture_unquoted_key = qr/([^:]+(?::+\S[^:]*)*)(?=\s*\:(?:\s+|$))/; 51 | my $re_trailing_comment = qr/(?:\s+\#.*)?/; 52 | my $re_key_value_separator = qr/\s*:(?:\s+(?:\#.*)?|$)/; 53 | 54 | ### 55 | # Loader functions: 56 | 57 | # Create an object from a file 58 | sub _load_file { 59 | my $class = ref $_[0] ? ref shift : shift; 60 | 61 | # Check the file 62 | my $file = shift or $class->_error( 'You did not specify a file name' ); 63 | $class->_error( "File '$file' does not exist" ) 64 | unless -e $file; 65 | $class->_error( "'$file' is a directory, not a file" ) 66 | unless -f _; 67 | $class->_error( "Insufficient permissions to read '$file'" ) 68 | unless -r _; 69 | 70 | # Open unbuffered 71 | open( my $fh, "<:unix", $file ); 72 | unless ( $fh ) { 73 | $class->_error("Failed to open file '$file': $!"); 74 | } 75 | 76 | # slurp the contents 77 | my $contents = eval { 78 | use warnings FATAL => 'utf8'; 79 | local $/; 80 | <$fh> 81 | }; 82 | if ( my $err = $@ ) { 83 | $class->_error("Error reading from file '$file': $err"); 84 | } 85 | 86 | # close the file (release the lock) 87 | unless ( close $fh ) { 88 | $class->_error("Failed to close file '$file': $!"); 89 | } 90 | 91 | $class->_load_string( $contents ); 92 | } 93 | 94 | # Create an object from a string 95 | sub _load_string { 96 | my $class = ref $_[0] ? ref shift : shift; 97 | my $self = bless [], $class; 98 | my $string = $_[0]; 99 | eval { 100 | unless ( defined $string ) { 101 | die \"Did not provide a string to load"; 102 | } 103 | 104 | # Check if Perl has it marked as characters, but it's internally 105 | # inconsistent. E.g. maybe latin1 got read on a :utf8 layer 106 | if ( utf8::is_utf8($string) && ! utf8::valid($string) ) { 107 | die \<<'...'; 108 | Read an invalid UTF-8 string (maybe mixed UTF-8 and 8-bit character set). 109 | Did you decode with lax ":utf8" instead of strict ":encoding(UTF-8)"? 110 | ... 111 | } 112 | 113 | # Ensure Unicode character semantics, even for 0x80-0xff 114 | utf8::upgrade($string); 115 | 116 | # Check for and strip any leading UTF-8 BOM 117 | $string =~ s/^\x{FEFF}//; 118 | 119 | # Check for some special cases 120 | return $self unless length $string; 121 | 122 | # Split the file into lines 123 | my @lines = grep { ! /^\s*(?:\#.*)?\z/ } 124 | split /(?:\015{1,2}\012|\015|\012)/, $string; 125 | 126 | # Strip the initial YAML header 127 | @lines and $lines[0] =~ /^\%YAML[: ][\d\.]+.*\z/ and shift @lines; 128 | 129 | # A nibbling parser 130 | my $in_document = 0; 131 | while ( @lines ) { 132 | # Do we have a document header? 133 | if ( $lines[0] =~ /^---\s*(?:(.+)\s*)?\z/ ) { 134 | # Handle scalar documents 135 | shift @lines; 136 | if ( defined $1 and $1 !~ /^(?:\#.+|\%YAML[: ][\d\.]+)\z/ ) { 137 | push @$self, 138 | $self->_load_scalar( "$1", [ undef ], \@lines ); 139 | next; 140 | } 141 | $in_document = 1; 142 | } 143 | 144 | if ( ! @lines or $lines[0] =~ /^(?:---|\.\.\.)/ ) { 145 | # A naked document 146 | push @$self, undef; 147 | while ( @lines and $lines[0] !~ /^---/ ) { 148 | shift @lines; 149 | } 150 | $in_document = 0; 151 | 152 | # XXX The final '-+$' is to look for -- which ends up being an 153 | # error later. 154 | } elsif ( ! $in_document && @$self ) { 155 | # only the first document can be explicit 156 | die \"failed to classify the line '$lines[0]'"; 157 | } elsif ( $lines[0] =~ /^\s*\-(?:\s|$|-+$)/ ) { 158 | # An array at the root 159 | my $document = [ ]; 160 | push @$self, $document; 161 | $self->_load_array( $document, [ 0 ], \@lines ); 162 | 163 | } elsif ( $lines[0] =~ /^(\s*)\S/ ) { 164 | # A hash at the root 165 | my $document = { }; 166 | push @$self, $document; 167 | $self->_load_hash( $document, [ length($1) ], \@lines ); 168 | 169 | } else { 170 | # Shouldn't get here. @lines have whitespace-only lines 171 | # stripped, and previous match is a line with any 172 | # non-whitespace. So this clause should only be reachable via 173 | # a perlbug where \s is not symmetric with \S 174 | 175 | # uncoverable statement 176 | die \"failed to classify the line '$lines[0]'"; 177 | } 178 | } 179 | }; 180 | if ( ref $@ eq 'SCALAR' ) { 181 | $self->_error(${$@}); 182 | } elsif ( $@ ) { 183 | $self->_error($@); 184 | } 185 | 186 | return $self; 187 | } 188 | 189 | sub _unquote_single { 190 | my ($self, $string) = @_; 191 | return '' unless length $string; 192 | $string =~ s/\'\'/\'/g; 193 | return $string; 194 | } 195 | 196 | sub _unquote_double { 197 | my ($self, $string) = @_; 198 | return '' unless length $string; 199 | $string =~ s/\\"/"/g; 200 | $string =~ 201 | s{\\([Nnever\\fartz0b]|x([0-9a-fA-F]{2}))} 202 | {(length($1)>1)?pack("H2",$2):$UNESCAPES{$1}}gex; 203 | return $string; 204 | } 205 | 206 | # Load a YAML scalar string to the actual Perl scalar 207 | sub _load_scalar { 208 | my ($self, $string, $indent, $lines) = @_; 209 | 210 | # Trim trailing whitespace 211 | $string =~ s/\s*\z//; 212 | 213 | # Explitic null/undef 214 | return undef if $string eq '~'; 215 | 216 | # Single quote 217 | if ( $string =~ /^$re_capture_single_quoted$re_trailing_comment\z/ ) { 218 | return $self->_unquote_single($1); 219 | } 220 | 221 | # Double quote. 222 | if ( $string =~ /^$re_capture_double_quoted$re_trailing_comment\z/ ) { 223 | return $self->_unquote_double($1); 224 | } 225 | 226 | # Special cases 227 | if ( $string =~ /^[\'\"!&]/ ) { 228 | die \"does not support a feature in line '$string'"; 229 | } 230 | return {} if $string =~ /^{}(?:\s+\#.*)?\z/; 231 | return [] if $string =~ /^\[\](?:\s+\#.*)?\z/; 232 | 233 | # Regular unquoted string 234 | if ( $string !~ /^[>|]/ ) { 235 | die \"found illegal characters in plain scalar: '$string'" 236 | if $string =~ /^(?:-(?:\s|$)|[\@\%\`])/ or 237 | $string =~ /:(?:\s|$)/; 238 | $string =~ s/\s+#.*\z//; 239 | return $string; 240 | } 241 | 242 | # Error 243 | die \"failed to find multi-line scalar content" unless @$lines; 244 | 245 | # Check the indent depth 246 | $lines->[0] =~ /^(\s*)/; 247 | $indent->[-1] = length("$1"); 248 | if ( defined $indent->[-2] and $indent->[-1] <= $indent->[-2] ) { 249 | die \"found bad indenting in line '$lines->[0]'"; 250 | } 251 | 252 | # Pull the lines 253 | my @multiline = (); 254 | while ( @$lines ) { 255 | $lines->[0] =~ /^(\s*)/; 256 | last unless length($1) >= $indent->[-1]; 257 | push @multiline, substr(shift(@$lines), length($1)); 258 | } 259 | 260 | my $j = (substr($string, 0, 1) eq '>') ? ' ' : "\n"; 261 | my $t = (substr($string, 1, 1) eq '-') ? '' : "\n"; 262 | return join( $j, @multiline ) . $t; 263 | } 264 | 265 | # Load an array 266 | sub _load_array { 267 | my ($self, $array, $indent, $lines) = @_; 268 | 269 | while ( @$lines ) { 270 | # Check for a new document 271 | if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) { 272 | while ( @$lines and $lines->[0] !~ /^---/ ) { 273 | shift @$lines; 274 | } 275 | return 1; 276 | } 277 | 278 | # Check the indent level 279 | $lines->[0] =~ /^(\s*)/; 280 | if ( length($1) < $indent->[-1] ) { 281 | return 1; 282 | } elsif ( length($1) > $indent->[-1] ) { 283 | die \"found bad indenting in line '$lines->[0]'"; 284 | } 285 | 286 | if ( $lines->[0] =~ /^(\s*\-\s+)[^\'\"]\S*\s*:(?:\s+|$)/ ) { 287 | # Inline nested hash 288 | my $indent2 = length("$1"); 289 | $lines->[0] =~ s/-/ /; 290 | push @$array, { }; 291 | $self->_load_hash( $array->[-1], [ @$indent, $indent2 ], $lines ); 292 | 293 | } elsif ( $lines->[0] =~ /^\s*\-\s*\z/ ) { 294 | shift @$lines; 295 | unless ( @$lines ) { 296 | push @$array, undef; 297 | return 1; 298 | } 299 | if ( $lines->[0] =~ /^(\s*)\-/ ) { 300 | my $indent2 = length("$1"); 301 | if ( $indent->[-1] == $indent2 ) { 302 | # Null array entry 303 | push @$array, undef; 304 | } else { 305 | # Naked indenter 306 | push @$array, [ ]; 307 | $self->_load_array( 308 | $array->[-1], [ @$indent, $indent2 ], $lines 309 | ); 310 | } 311 | 312 | } elsif ( $lines->[0] =~ /^(\s*)\S/ ) { 313 | push @$array, { }; 314 | $self->_load_hash( 315 | $array->[-1], [ @$indent, length("$1") ], $lines 316 | ); 317 | 318 | } else { 319 | die \"failed to classify line '$lines->[0]'"; 320 | } 321 | 322 | } elsif ( $lines->[0] =~ /^\s*\-(\s*)(.+?)\s*\z/ ) { 323 | # Array entry with a value 324 | shift @$lines; 325 | push @$array, $self->_load_scalar( 326 | "$2", [ @$indent, undef ], $lines 327 | ); 328 | 329 | } elsif ( defined $indent->[-2] and $indent->[-1] == $indent->[-2] ) { 330 | # This is probably a structure like the following... 331 | # --- 332 | # foo: 333 | # - list 334 | # bar: value 335 | # 336 | # ... so lets return and let the hash parser handle it 337 | return 1; 338 | 339 | } else { 340 | die \"failed to classify line '$lines->[0]'"; 341 | } 342 | } 343 | 344 | return 1; 345 | } 346 | 347 | # Load a hash 348 | sub _load_hash { 349 | my ($self, $hash, $indent, $lines) = @_; 350 | 351 | while ( @$lines ) { 352 | # Check for a new document 353 | if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) { 354 | while ( @$lines and $lines->[0] !~ /^---/ ) { 355 | shift @$lines; 356 | } 357 | return 1; 358 | } 359 | 360 | # Check the indent level 361 | $lines->[0] =~ /^(\s*)/; 362 | if ( length($1) < $indent->[-1] ) { 363 | return 1; 364 | } elsif ( length($1) > $indent->[-1] ) { 365 | die \"found bad indenting in line '$lines->[0]'"; 366 | } 367 | 368 | # Find the key 369 | my $key; 370 | 371 | # Quoted keys 372 | if ( $lines->[0] =~ 373 | s/^\s*$re_capture_single_quoted$re_key_value_separator// 374 | ) { 375 | $key = $self->_unquote_single($1); 376 | } 377 | elsif ( $lines->[0] =~ 378 | s/^\s*$re_capture_double_quoted$re_key_value_separator// 379 | ) { 380 | $key = $self->_unquote_double($1); 381 | } 382 | elsif ( $lines->[0] =~ 383 | s/^\s*$re_capture_unquoted_key$re_key_value_separator// 384 | ) { 385 | $key = $1; 386 | $key =~ s/\s+$//; 387 | } 388 | elsif ( $lines->[0] =~ /^\s*\?/ ) { 389 | die \"does not support a feature in line '$lines->[0]'"; 390 | } 391 | else { 392 | die \"failed to classify line '$lines->[0]'"; 393 | } 394 | 395 | # Do we have a value? 396 | if ( length $lines->[0] ) { 397 | # Yes 398 | $hash->{$key} = $self->_load_scalar( 399 | shift(@$lines), [ @$indent, undef ], $lines 400 | ); 401 | } else { 402 | # An indent 403 | shift @$lines; 404 | unless ( @$lines ) { 405 | $hash->{$key} = undef; 406 | return 1; 407 | } 408 | if ( $lines->[0] =~ /^(\s*)-/ ) { 409 | $hash->{$key} = []; 410 | $self->_load_array( 411 | $hash->{$key}, [ @$indent, length($1) ], $lines 412 | ); 413 | } elsif ( $lines->[0] =~ /^(\s*)./ ) { 414 | my $indent2 = length("$1"); 415 | if ( $indent->[-1] >= $indent2 ) { 416 | # Null hash entry 417 | $hash->{$key} = undef; 418 | } else { 419 | $hash->{$key} = {}; 420 | $self->_load_hash( 421 | $hash->{$key}, [ @$indent, length($1) ], $lines 422 | ); 423 | } 424 | } 425 | } 426 | } 427 | 428 | return 1; 429 | } 430 | 431 | 1; --------------------------------------------------------------------------------