#!/usr/bin/perl use strict; use Config; BEGIN { my @oldinc = @INC; @INC = ( $Config{sitelibexp}."/".$Config{archname}, $Config{sitelibexp}, @Config{qw<vendorlibexp vendorarchexp archlibexp privlibexp>} ); require Cwd; @INC = @oldinc; } # This chunk of stuff was generated by App::FatPacker. To find the original # file's code, look for the end of this BEGIN block or the string 'FATPACK' BEGIN { my %fatpacked; $fatpacked{"App/Perlbrew/HTTP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_PERLBREW_HTTP'; package App::Perlbrew::HTTP; use strict; use warnings; use 5.008; use Exporter 'import'; our @EXPORT_OK = qw(http_user_agent_program http_user_agent_command http_get http_download); our $HTTP_VERBOSE = 0; our $HTTP_USER_AGENT_PROGRAM; my %commands = ( curl => { test => '--version >/dev/null 2>&1', get => '--silent --location --fail -o - {url}', download => '--silent --location --fail -o {output} {url}', order => 1, # Exit code is 22 on 404s etc die_on_error => sub { die 'Page not retrieved; HTTP error code 400 or above.' if ($_[ 0 ] >> 8 == 22); }, }, wget => { test => '--version >/dev/null 2>&1', get => '--quiet -O - {url}', download => '--quiet -O {output} {url}', order => 2, # Exit code is not 0 on error die_on_error => sub { die 'Page not retrieved: fetch failed.' if ($_[ 0 ]); }, }, fetch => { test => '--version >/dev/null 2>&1', get => '-o - {url}', download => '-o {output} {url}', order => 3, # Exit code is 8 on 404s etc die_on_error => sub { die 'Server issued an error response.' if ($_[ 0 ] >> 8 == 8); }, } ); sub http_user_agent_program { $HTTP_USER_AGENT_PROGRAM ||= do { my $program; for my $p (sort {$commands{$a}{order}<=>$commands{$b}{order}} keys %commands) { my $code = system("$p $commands{$p}->{test}") >> 8; if ($code != 127) { $program = $p; last; } } unless ($program) { die "[ERROR] Cannot find a proper http user agent program. Please install curl or wget.\n"; } $program; }; die "[ERROR] Unrecognized http user agent program: $HTTP_USER_AGENT_PROGRAM. It can only be one of: ".join(",", keys %commands)."\n" unless $commands{$HTTP_USER_AGENT_PROGRAM}; return $HTTP_USER_AGENT_PROGRAM; } sub http_user_agent_command { my ($purpose, $params) = @_; my $ua = http_user_agent_program; my $cmd = $commands{ $ua }->{ $purpose }; for (keys %$params) { $cmd =~ s!{$_}!\Q$params->{$_}\E!g; } if ($HTTP_VERBOSE) { unless ($ua eq "fetch") { $cmd =~ s/(silent|quiet)/verbose/; } } $cmd = $ua . " " . $cmd; return ($ua, $cmd) if wantarray; return $cmd; } sub http_download { my ($url, $path) = @_; if (-e $path) { die "ERROR: The download target < $path > already exists.\n"; } my $partial = 0; local $SIG{TERM} = local $SIG{INT} = sub { $partial++ }; my $download_command = http_user_agent_command(download => { url => $url, output => $path }); my $status = system($download_command); if ($partial) { $path->unlink; return "ERROR: Interrupted."; } unless ($status == 0) { $path->unlink; if ($? == -1) { return "ERROR: Failed to execute the command\n\n\t$download_command\n\nReason:\n\n\t$!"; } elsif ($? & 127) { return "ERROR: The command died with signal " . ($? & 127) . "\n\n\t$download_command\n\n"; } else { return "ERROR: The command finished with error\n\n\t$download_command\n\nExit code:\n\n\t" . ($? >> 8); } } return 0; } sub http_get { my ($url, $header, $cb) = @_; if (ref($header) eq 'CODE') { $cb = $header; $header = undef; } my ($program, $command) = http_user_agent_command(get => { url => $url }); open my $fh, '-|', $command or die "open() pipe for '$command': $!"; local $/; my $body = <$fh>; close $fh; # check if the download has failed and die automatically $commands{ $program }{ die_on_error }->($?); return $cb ? $cb->($body) : $body; } 1; APP_PERLBREW_HTTP $fatpacked{"App/Perlbrew/Path.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_PERLBREW_PATH'; use strict; use warnings; package App::Perlbrew::Path; use File::Basename (); use File::Glob (); use File::Path (); use overload ( '""' => \& stringify, fallback => 1, ); sub _joinpath { for my $entry (@_) { no warnings 'uninitialized'; die 'Received an undefined entry as a parameter (all parameters are: '. join(', ', @_). ')' unless (defined($entry)); } return join "/", @_; } sub _child { my ($self, $package, @path) = @_; $package->new($self->{path}, @path); } sub _children { my ($self, $package) = @_; map { $package->new($_) } File::Glob::bsd_glob($self->child("*")); } sub new { my ($class, @path) = @_; bless { path => _joinpath (@path) }, $class; } sub exists { my ($self) = @_; -e $self->stringify; } sub basename { my ($self, $suffix) = @_; return scalar File::Basename::fileparse($self, ($suffix) x!! defined $suffix); } sub child { my ($self, @path) = @_; return $self->_child(__PACKAGE__, @path); } sub children { my ($self) = @_; return $self->_children(__PACKAGE__); } sub dirname { my ($self) = @_; return App::Perlbrew::Path->new( File::Basename::dirname($self) ); } sub mkpath { my ($self) = @_; File::Path::mkpath( [$self->stringify], 0, 0777 ); return $self; } sub readlink { my ($self) = @_; my $link = CORE::readlink( $self->stringify ); $link = __PACKAGE__->new($link) if defined $link; return $link; } sub rmpath { my ($self) = @_; File::Path::rmtree( [$self->stringify], 0, 0 ); return $self; } sub stringify { my ($self) = @_; return $self->{path}; } sub stringify_with_tilde { my ($self) = @_; my $path = $self->stringify; my $home = $ENV{HOME}; $path =~ s!\Q$home/\E!~/! if $home; return $path; } sub symlink { my ($self, $destination, $force) = @_; $destination = App::Perlbrew::Path->new($destination) unless ref $destination; CORE::unlink($destination) if $force && (-e $destination || -l $destination); $destination if CORE::symlink($self, $destination); } sub unlink { my ($self) = @_; CORE::unlink($self); } 1; APP_PERLBREW_PATH $fatpacked{"App/Perlbrew/Path/Installation.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_PERLBREW_PATH_INSTALLATION'; use strict; use warnings; package App::Perlbrew::Path::Installation; require App::Perlbrew::Path; our @ISA = qw( App::Perlbrew::Path ); sub name { $_[0]->basename; } sub bin { shift->child(bin => @_); } sub man { shift->child(man => @_); } sub perl { shift->bin('perl'); } sub version_file { shift->child('.version'); } 1; APP_PERLBREW_PATH_INSTALLATION $fatpacked{"App/Perlbrew/Path/Installations.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_PERLBREW_PATH_INSTALLATIONS'; use strict; use warnings; package App::Perlbrew::Path::Installations; require App::Perlbrew::Path; require App::Perlbrew::Path::Installation; our @ISA = qw( App::Perlbrew::Path ); sub child { my ($self, @params) = @_; my $return = $self; $return = $return->_child('App::Perlbrew::Path::Installation' => shift @params) if @params; $return = $return->child(@params) if @params; $return; } sub children { shift->_children('App::Perlbrew::Path::Installation' => @_); } sub list { shift->children; } 1; APP_PERLBREW_PATH_INSTALLATIONS $fatpacked{"App/Perlbrew/Path/Root.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_PERLBREW_PATH_ROOT'; use strict; use warnings; package App::Perlbrew::Path::Root; use App::Perlbrew::Path (); use App::Perlbrew::Path::Installations (); our @ISA = qw( App::Perlbrew::Path ); sub bin { shift->child(bin => @_); } sub build { shift->child(build => @_); } sub dists { shift->child(dists => @_); } sub etc { shift->child(etc => @_); } sub perls { my ($self, @params) = @_; my $return = $self->_child('App::Perlbrew::Path::Installations', 'perls'); $return = $return->child(@params) if @params; return $return; } 1; APP_PERLBREW_PATH_ROOT $fatpacked{"App/Perlbrew/Sys.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_PERLBREW_SYS'; package App::Perlbrew::Sys; use strict; use warnings; use Config; sub osname { $Config{osname} } sub archname { $Config{archname} } sub os { $Config{osname} } sub arch { (split(/-/, $Config{myarchname}, 2))[0] } 1; APP_PERLBREW_SYS $fatpacked{"App/Perlbrew/Util.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_PERLBREW_UTIL'; package App::Perlbrew::Util; use strict; use warnings; use 5.008; use Exporter 'import'; our @EXPORT = qw( uniq min editdist files_are_the_same perl_version_to_integer ); our @EXPORT_OK = qw( find_similar_tokens looks_like_url_of_skaji_relocatable_perl looks_like_sys_would_be_compatible_with_skaji_relocatable_perl make_skaji_relocatable_perl_url ); sub uniq { my %seen; grep { !$seen{$_}++ } @_; } sub min(@) { my $m = $_[0]; for(@_) { $m = $_ if $_ < $m; } return $m; } # straight copy of Wikipedia's "Levenshtein Distance" sub editdist { my @a = split //, shift; my @b = split //, shift; # There is an extra row and column in the matrix. This is the # distance from the empty string to a substring of the target. my @d; $d[$_][0] = $_ for (0 .. @a); $d[0][$_] = $_ for (0 .. @b); for my $i (1 .. @a) { for my $j (1 .. @b) { $d[$i][$j] = ($a[$i-1] eq $b[$j-1] ? $d[$i-1][$j-1] : 1 + min($d[$i-1][$j], $d[$i][$j-1], $d[$i-1][$j-1])); } } return $d[@a][@b]; } sub files_are_the_same { ## Check dev and inode num. Not useful on Win32. ## The for loop should always return false on Win32, as a result. my @files = @_; my @stats = map {[ stat($_) ]} @files; my $stats0 = join " ", @{$stats[0]}[0,1]; for (@stats) { return 0 if ((! defined($_->[1])) || $_->[1] == 0); unless ($stats0 eq join(" ", $_->[0], $_->[1])) { return 0; } } return 1 } sub perl_version_to_integer { my $version = shift; my @v; if ($version eq 'blead') { @v = (999,999,999); } else { @v = split(/[\.\-_]/, $version); } return undef if @v < 2; if ($v[1] <= 5) { $v[2] ||= 0; $v[3] = 0; } else { $v[3] ||= $v[1] >= 6 ? 9 : 0; $v[3] =~ s/[^0-9]//g; } return $v[1]*1000000 + $v[2]*1000 + $v[3]; } sub find_similar_tokens { my ($token, $tokens) = @_; my $SIMILAR_DISTANCE = 6; my @similar_tokens = sort { $a->[1] <=> $b->[1] } map { my $d = editdist( $_, $token ); ( ( $d < $SIMILAR_DISTANCE ) ? [$_, $d] : () ) } @$tokens; if (@similar_tokens) { my $best_score = $similar_tokens[0][1]; @similar_tokens = map { $_->[0] } grep { $_->[1] == $best_score } @similar_tokens; } return \@similar_tokens; } sub looks_like_url_of_skaji_relocatable_perl { my ($str) = @_; # https://github.com/skaji/relocatable-perl/releases/download/5.40.0.0/perl-linux-amd64.tar.gz my $prefix = "https://github.com/skaji/relocatable-perl/releases/download"; my $version_re = qr/(5\.[0-9][0-9]\.[0-9][0-9]?.[0-9])/; my $name_re = qr/perl-(linux|darwin)-(amd64|arm64)\.tar\.gz/; return undef unless $str =~ m{ \Q$prefix\E / $version_re / $name_re }x; return { url => $str, version => $1, os => $2, arch => $3, original_filename => "perl-$2-$3.tar.gz", }; } sub _arch_compat { my ($arch) = @_; my $compat = { x86_64 => "amd64", i386 => "amd64", }; return $compat->{$arch} || $arch; } sub looks_like_sys_would_be_compatible_with_skaji_relocatable_perl { my ($detail, $sys) = @_; return ( ($detail->{os} eq $sys->os) && (_arch_compat($detail->{arch}) eq _arch_compat($sys->arch)) ); } sub make_skaji_relocatable_perl_url { my ($str, $sys) = @_; if ($str =~ m/\Askaji-relocatable-perl-(5\.[0-9][0-9]\.[0-9][0-9]?.[0-9])\z/) { my $version = $1; my $os = $sys->os; my $arch = $sys->arch; $arch = "amd64" if $arch eq 'x86_64' || $arch eq 'i386'; return "https://github.com/skaji/relocatable-perl/releases/download/$version/perl-$os-$arch.tar.gz"; } return undef; } 1; APP_PERLBREW_UTIL $fatpacked{"App/perlbrew.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_PERLBREW'; package App::perlbrew; use strict; use warnings; use 5.008; our $VERSION = "1.01"; use Config qw( %Config ); BEGIN { # Special treat for Cwd to prevent it to be loaded from somewhere binary-incompatible with system perl. my @oldinc = @INC; @INC = ( $Config{sitelibexp} . "/" . $Config{archname}, $Config{sitelibexp}, @Config{qw<vendorlibexp vendorarchexp archlibexp privlibexp>}, ); require Cwd; @INC = @oldinc; } use Getopt::Long (); use CPAN::Perl::Releases (); use JSON::PP qw( decode_json ); use File::Copy qw( copy move ); use Capture::Tiny (); use App::Perlbrew::Util qw( files_are_the_same uniq find_similar_tokens looks_like_url_of_skaji_relocatable_perl looks_like_sys_would_be_compatible_with_skaji_relocatable_perl make_skaji_relocatable_perl_url ); use App::Perlbrew::Path (); use App::Perlbrew::Path::Root (); use App::Perlbrew::HTTP qw( http_download http_get ); use App::Perlbrew::Sys; ### global variables # set $ENV{SHELL} to executable path of parent process (= shell) if it's missing # (e.g. if this script was executed by a daemon started with "service xxx start") # ref: https://github.com/gugod/App-perlbrew/pull/404 $ENV{SHELL} ||= App::Perlbrew::Path->new( "/proc", getppid, "exe" )->readlink if -d "/proc"; local $SIG{__DIE__} = sub { my $message = shift; warn $message; exit(1); }; our $CONFIG; our $PERLBREW_ROOT; our $PERLBREW_HOME; my @flavors = ( { d_option => 'usethreads', implies => 'multi', common => 1, opt => 'thread|threads' }, # threads is for backward compatibility { d_option => 'usemultiplicity', opt => 'multi' }, { d_option => 'uselongdouble', common => 1, opt => 'ld' }, { d_option => 'use64bitint', common => 1, opt => '64int' }, { d_option => 'use64bitall', implies => '64int', opt => '64all' }, { d_option => 'DEBUGGING', opt => 'debug' }, { d_option => 'cc=clang', opt => 'clang' }, ); my %flavor; my $flavor_ix = 0; for (@flavors) { my ($name) = $_->{opt} =~ /([^|]+)/; $_->{name} = $name; $_->{ix} = ++$flavor_ix; $flavor{$name} = $_; } for (@flavors) { if ( my $implies = $_->{implies} ) { $flavor{$implies}{implied_by} = $_->{name}; } } ### methods sub new { my ( $class, @argv ) = @_; my %opt = ( original_argv => \@argv, args => [], yes => 0, force => 0, quiet => 0, D => [], U => [], A => [], sitecustomize => '', destdir => '', noman => '', variation => '', both => [], append => '', reverse => 0, verbose => 0, ); $opt{$_} = '' for keys %flavor; if (@argv) { # build a local @ARGV to allow us to use an older # Getopt::Long API in case we are building on an older system local (@ARGV) = @argv; Getopt::Long::Configure( 'pass_through', 'no_ignore_case', 'bundling', 'permute', # default behaviour except 'exec' ); $class->parse_cmdline( \%opt ); $opt{args} = \@ARGV; # fix up the effect of 'bundling' foreach my $flags ( @opt{qw(D U A)} ) { foreach my $value ( @{$flags} ) { $value =~ s/^=//; } } } my $self = bless \%opt, $class; # Treat --root option same way as env variable PERLBREW_ROOT (with higher priority) if ( $opt{root} ) { $ENV{PERLBREW_ROOT} = $self->root( $opt{root} ); } if ( $opt{builddir} ) { $self->{builddir} = App::Perlbrew::Path->new( $opt{builddir} ); } # Ensure propagation of $PERLBREW_HOME and $PERLBREW_ROOT $self->root; $self->home; if ( $self->{verbose} ) { $App::Perlbrew::HTTP::HTTP_VERBOSE = 1; } return $self; } sub parse_cmdline { my ( $self, $params, @ext ) = @_; my @f = map { $flavor{$_}{opt} || $_ } keys %flavor; return Getopt::Long::GetOptions( $params, 'yes', 'force|f', 'reverse', 'notest|n', 'quiet|q', 'verbose|v', 'input|i=s', 'output|o=s', 'as=s', 'append=s', 'help|h', 'version', 'root=s', 'switch', 'all', 'shell=s', 'no-patchperl', 'no-decoration', "builddir=s", # options passed directly to Configure 'D=s@', 'U=s@', 'A=s@', 'j=i', # options that affect Configure and customize post-build 'sitecustomize=s', 'destdir=s', 'noman', # flavors support 'both|b=s@', 'all-variations', 'common-variations', @f, @ext ); } sub sys { App::Perlbrew::Sys:: } sub root { my ( $self, $new_root ) = @_; $new_root ||= $PERLBREW_ROOT || $ENV{PERLBREW_ROOT} || App::Perlbrew::Path->new( $ENV{HOME}, "perl5", "perlbrew" )->stringify unless $self->{root}; $self->{root} = $PERLBREW_ROOT = $new_root if defined $new_root; $self->{root} = App::Perlbrew::Path::Root->new( $self->{root} ) unless ref $self->{root}; $self->{root} = App::Perlbrew::Path::Root->new( $self->{root}->stringify ) unless $self->{root}->isa('App::Perlbrew::Path::Root'); return $self->{root}; } sub home { my ( $self, $new_home ) = @_; $new_home ||= $PERLBREW_HOME || $ENV{PERLBREW_HOME} || App::Perlbrew::Path->new( $ENV{HOME}, ".perlbrew" )->stringify unless $self->{home}; $self->{home} = $PERLBREW_HOME = $new_home if defined $new_home; $self->{home} = App::Perlbrew::Path->new( $self->{home} ) unless ref $self->{home}; return $self->{home}; } sub builddir { my ($self) = @_; return $self->{builddir} || $self->root->build; } sub current_perl { my ( $self, $v ) = @_; $self->{current_perl} = $v if $v; return $self->{current_perl} || $self->env('PERLBREW_PERL') || ''; } sub current_lib { my ( $self, $v ) = @_; $self->{current_lib} = $v if $v; return $self->{current_lib} || $self->env('PERLBREW_LIB') || ''; } sub current_shell_is_bashish { my ($self) = @_; return ( $self->current_shell eq 'bash' ) || ( $self->current_shell eq 'zsh' ); } sub current_shell { my ( $self, $x ) = @_; $self->{current_shell} = $x if $x; return $self->{current_shell} ||= do { my $shell_name = App::Perlbrew::Path->new( $self->{shell} || $self->env('SHELL') )->basename; $shell_name =~ s/\d+$//; $shell_name; }; } sub current_env { my ($self) = @_; my $l = $self->current_lib; $l = "@" . $l if $l; return $self->current_perl . $l; } sub installed_perl_executable { my ( $self, $name ) = @_; die unless $name; my $executable = $self->root->perls($name)->perl; return $executable if -e $executable; return ""; } sub configure_args { my ( $self, $name ) = @_; my $perl_cmd = $self->installed_perl_executable($name); my $code = 'while(($_,$v)=each(%Config)){print"$_ $v" if /config_arg/}'; my @output = split "\n" => $self->do_capture( $perl_cmd, '-MConfig', '-wle', $code ); my %arg; for (@output) { my ( $k, $v ) = split " ", $_, 2; $arg{$k} = $v; } if (wantarray) { return map { $arg{"config_arg$_"} } ( 1 .. $arg{config_argc} ); } return $arg{config_args}; } sub cpan_mirror { my ( $self, $v ) = @_; $self->{cpan_mirror} = $v if $v; unless ( $self->{cpan_mirror} ) { $self->{cpan_mirror} = $self->env("PERLBREW_CPAN_MIRROR") || "https://cpan.metacpan.org"; $self->{cpan_mirror} =~ s{/+$}{}; } return $self->{cpan_mirror}; } sub env { my ( $self, $name ) = @_; return $ENV{$name} if $name; return \%ENV; } sub is_shell_csh { my ($self) = @_; return 1 if $self->env('SHELL') =~ /(t?csh)/; return 0; } # Entry point method: handles all the arguments # and dispatches to an appropriate internal # method to execute the corresponding command. sub run { my ($self) = @_; $self->run_command( $self->args ); } sub args { my ($self) = @_; # keep 'force' and 'yes' coherent across commands $self->{force} = $self->{yes} = 1 if ( $self->{force} || $self->{yes} ); return @{ $self->{args} }; } sub commands { my ($self) = @_; my $package = ref $self ? ref $self : $self; my @commands; my $symtable = do { no strict 'refs'; \%{ $package . '::' }; }; foreach my $sym ( keys %$symtable ) { if ( $sym =~ /^run_command_/ ) { my $glob = $symtable->{$sym}; if ( ref($glob) eq 'CODE' || defined *$glob{CODE} ) { # with perl >= 5.27 stash entry can points to a CV directly $sym =~ s/^run_command_//; $sym =~ s/_/-/g; push @commands, $sym; } } } return @commands; } sub find_similar_commands { my ( $self, $command ) = @_; $command =~ s/_/-/g; return @{ find_similar_tokens($command, [ sort $self->commands ]) }; } # This method is called in the 'run' loop # and executes every specific action depending # on the type of command. # # The first argument to this method is a self reference, # while the first "real" argument is the command to execute. # Other parameters after the command to execute are # considered as arguments for the command itself. # # In general the command is executed via a method named after the # command itself and with the 'run_command' prefix. For instance # the command 'exec' is handled by a method # `run_command_exec` # # If no candidates can be found, an execption is thrown # and a similar command is shown to the user. sub run_command { my ( $self, $x, @args ) = @_; my $command = $x; if ( $self->{version} ) { $x = 'version'; } elsif ( !$x ) { $x = 'help'; @args = ( 0, 0 ); } elsif ( $x eq 'help' ) { @args = ( 0, 2 ) unless @args; } my $s = $self->can("run_command_$x"); unless ($s) { $x =~ y/-/_/; $s = $self->can("run_command_$x"); } unless ($s) { my @commands = $self->find_similar_commands($x); if ( @commands > 1 ) { @commands = map { ' ' . $_ } @commands; die "Unknown command: `$command`. Did you mean one of the following?\n" . join( "\n", @commands ) . "\n"; } elsif ( @commands == 1 ) { die "Unknown command: `$command`. Did you mean `$commands[0]`?\n"; } else { die "Unknown command: `$command`. Typo?\n"; } } $self->$s(@args); } sub run_command_version { my ($self) = @_; my $package = ref $self; my $version = $self->VERSION; print "$0 - $package/$version\n"; } # Provides help information about a command. # The idea is similar to the 'run_command' and 'run_command_$x' chain: # this method dispatches to a 'run_command_help_$x' method # if found in the class, otherwise it tries to extract the help # documentation via the POD of the class itself using the # section 'COMMAND: $x' with uppercase $x. sub run_command_help { my ( $self, $status, $verbose, $return_text ) = @_; require Pod::Usage; if ( $status && !defined($verbose) ) { if ( $self->can("run_command_help_${status}") ) { $self->can("run_command_help_${status}")->($self); } else { my $out = ""; open my $fh, ">", \$out; Pod::Usage::pod2usage( -exitval => "NOEXIT", -verbose => 99, -sections => "COMMAND: " . uc($status), -output => $fh, -noperldoc => 1 ); $out =~ s/\A[^\n]+\n//s; $out =~ s/^ //gm; if ( $out =~ /\A\s*\Z/ ) { $out = "Cannot find documentation for '$status'\n\n"; } return "\n$out" if ($return_text); print "\n$out"; close $fh; } } else { Pod::Usage::pod2usage( -noperldoc => 1, -verbose => $verbose || 0, -exitval => ( defined $status ? $status : 1 ) ); } } # introspection for compgen my %comp_installed = ( use => 1, switch => 1, ); sub run_command_compgen { my ( $self, $cur, @args ) = @_; $cur = 0 unless defined($cur); # do `tail -f bashcomp.log` for debugging if ( $self->env('PERLBREW_DEBUG_COMPLETION') ) { open my $log, '>>', 'bashcomp.log'; print $log "[$$] $cur of [@args]\n"; } my $subcommand = $args[1]; my $subcommand_completed = ( $cur >= 2 ); if ( !$subcommand_completed ) { $self->_compgen( $subcommand, $self->commands ); } else { # complete args of a subcommand if ( $comp_installed{$subcommand} ) { if ( $cur <= 2 ) { my $part; if ( defined( $part = $args[2] ) ) { $part = qr/ \Q$part\E /xms; } $self->_compgen( $part, map { $_->{name} } $self->installed_perls() ); } } elsif ( $subcommand eq 'help' ) { if ( $cur <= 2 ) { $self->_compgen( $args[2], $self->commands() ); } } else { # TODO } } } sub _firstrcfile { my ( $self, @files ) = @_; foreach my $path (@files) { return $path if -f App::Perlbrew::Path->new( $self->env('HOME'), $path ); } return; } sub _compgen { my ( $self, $part, @reply ) = @_; if ( defined $part ) { $part = qr/\A \Q$part\E /xms if ref($part) ne ref(qr//); @reply = grep { /$part/ } @reply; } foreach my $word (@reply) { print $word, "\n"; } } # Internal utility function. # Given a specific perl version, e.g., perl-5.27.4 # returns a string with a formatted version number such # as 05027004. Such string can be used as a number # in order to make either a string comparison # or a numeric comparison. # # In the case of cperl the major number is added by 6 # so that it would match the project claim of being # Perl 5+6 = 11. The final result is then # multiplied by a negative factor (-1) in order # to make cperl being "less" in the ordered list # than a normal Perl installation. # # The returned string is made by four pieces of two digits each: # MMmmppbb # where: # MM is the major Perl version (e.g., 5 -> 05) # mm is the minor Perl version (e.g. 27 -> 27) # pp is the patch level (e.g., 4 -> 04) # bb is the blead flag: it is 00 for a "normal" release, or 01 for a blead one sub comparable_perl_version { my ( $self, $perl_version ) = @_; my ( $is_cperl, $is_blead ) = ( 0, 0 ); my ( $major, $minor, $patch ) = ( 0, 0, 0 ); if ( $perl_version =~ /^(?:(c?perl)-?)?(\d)\.(\d+).(\d+).*/ ) { $is_cperl = $1 && ( $1 eq 'cperl' ); $major = $2 + ( $is_cperl ? 6 : 0 ); # major version $minor = $3; # minor version $patch = $4; # patch level } elsif ( $perl_version =~ /^(?:(c?perl)-?)?-?(blead)$/ ) { # in the case of a blead release use a fake high number # to assume it is the "latest" release number available $is_cperl = $1 && ( $1 eq 'cperl' ); $is_blead = $2 && ( $2 eq 'blead' ); ( $major, $minor, $patch ) = ( 5, 99, 99 ); } return ( $is_cperl ? -1 : 1 ) * sprintf( '%02d%02d%02d%02d', $major + ( $is_cperl ? 6 : 0 ), # major version $minor, # minor version $patch, # patch level $is_blead ); # blead } # Internal method. # Performs a comparable sort of the perl versions specified as # list. sub sort_perl_versions { my ( $self, @perls ) = @_; return map { $_->[0] } sort { ( $self->{reverse} ? $a->[1] <=> $b->[1] : $b->[1] <=> $a->[1] ) } map { [$_, $self->comparable_perl_version($_)] } @perls; } sub run_command_available { my ($self) = @_; my @installed = $self->installed_perls(@_); my $is_verbose = $self->{verbose}; my @sections = ( ['perl', 'available_perl_distributions'] ); for (@sections) { my ( $header, $method ) = @$_; print "# $header\n"; my $perls = $self->$method; # sort the keys of Perl installation (Randal to the rescue!) my @sorted_perls = $self->sort_perl_versions( keys %$perls ); for my $available (@sorted_perls) { my $url = $perls->{$available}; my $ctime; for my $installed (@installed) { my $name = $installed->{name}; my $cur = $installed->{is_current}; if ( $available eq $installed->{name} ) { $ctime = $installed->{ctime}; last; } } printf "%1s %12s %s %s\n", $ctime ? 'i' : '', $available, ( $is_verbose ? $ctime ? "INSTALLED on $ctime via" : 'available from ' : '' ), ( $is_verbose ? "<$url>" : '' ); } print "\n\n"; } return; } sub available_perls { my ($self) = @_; my %dists = ( %{ $self->available_perl_distributions } ); return $self->sort_perl_versions( keys %dists ); } # -> Map[ NameVersion => URL ] sub available_perl_distributions { my ($self) = @_; my $perls = {}; my @perllist; # we got impatient waiting for cpan.org to get updated to show 5.28... # So, we also fetch from metacpan for anything that looks perlish, # and we do our own processing to filter out the development # releases and minor versions when needed (using # filter_perl_available) my $json = http_get('https://fastapi.metacpan.org/v1/release/versions/perl') or die "\nERROR: Unable to retrieve list of perls from Metacpan.\n\n"; my $decoded = decode_json($json); for my $release ( @{ $decoded->{releases} } ) { next if !$release->{authorized}; push @perllist, [$release->{name}, $release->{download_url}]; } foreach my $perl ( $self->filter_perl_available( \@perllist ) ) { $perls->{ $perl->[0] } = $perl->[1]; } return $perls; } # $perllist is an arrayref of arrayrefs. The inner arrayrefs are of the # format: [ <perl_name>, <perl_url> ] # perl_name = something like perl-5.28.0 # perl_url = URL the Perl is available from. # # If $self->{all} is true, this just returns a list of the contents of # the list referenced by $perllist # # Otherwise, this looks for even middle numbers in the version and no # suffix (like -RC1) following the URL, and returns the list of # arrayrefs that so match # # If any "newest" Perl has a sub filter_perl_available { my ( $self, $perllist ) = @_; if ( $self->{all} ) { return @$perllist; } my %max_release; foreach my $perl (@$perllist) { my $ver = $perl->[0]; if ( $ver !~ m/^perl-5\.[0-9]*[02468]\.[0-9]+$/ ) { next; } # most likely TRIAL or RC, or a DEV release my ( $release_line, $minor ) = $ver =~ m/^perl-5\.([0-9]+)\.([0-9]+)/; if ( exists $max_release{$release_line} ) { if ( $max_release{$release_line}->[0] > $minor ) { next; } # We have a newer release } $max_release{$release_line} = [$minor, $perl]; } return map { $_->[1] } values %max_release; } sub perl_release { my ( $self, $version ) = @_; my $mirror = $self->cpan_mirror(); # try CPAN::Perl::Releases my $tarballs = CPAN::Perl::Releases::perl_tarballs($version); my $x = ( values %$tarballs )[0]; if ($x) { my $dist_tarball = ( split( "/", $x ) )[-1]; my $dist_tarball_url = "$mirror/authors/id/$x"; return ( $dist_tarball, $dist_tarball_url ); } # try src/5.0 symlinks, either perl-5.X or perl5.X; favor .tar.bz2 over .tar.gz my $index = http_get("https://cpan.metacpan.org/src/5.0/"); if ($index) { for my $prefix ( "perl-", "perl" ) { for my $suffix ( ".tar.bz2", ".tar.gz" ) { my $dist_tarball = "$prefix$version$suffix"; my $dist_tarball_url = "$mirror/src/5.0/$dist_tarball"; return ( $dist_tarball, $dist_tarball_url ) if ( $index =~ /href\s*=\s*"\Q$dist_tarball\E"/ms ); } } } my $json = http_get("https://fastapi.metacpan.org/v1/release/_search?size=1&q=name:perl-${version}"); my $result; unless ( $json and $result = decode_json($json)->{hits}{hits}[0] ) { die "ERROR: Failed to locate perl-${version} tarball."; } my ( $dist_path, $dist_tarball ) = $result->{_source}{download_url} =~ m[(/authors/id/.+/(perl-${version}.tar.(gz|bz2|xz)))$]; die "ERROR: Cannot find the tarball for perl-$version\n" if !$dist_path and !$dist_tarball; my $dist_tarball_url = "https://cpan.metacpan.org${dist_path}"; return ( $dist_tarball, $dist_tarball_url ); } sub release_detail_perl_local { my ( $self, $dist, $rd ) = @_; $rd ||= {}; my $error = 1; my $mirror = $self->cpan_mirror(); my $tarballs = CPAN::Perl::Releases::perl_tarballs( $rd->{version} ); if ( keys %$tarballs ) { for ( "tar.bz2", "tar.gz" ) { if ( my $x = $tarballs->{$_} ) { $rd->{tarball_name} = ( split( "/", $x ) )[-1]; $rd->{tarball_url} = "$mirror/authors/id/$x"; $error = 0; last; } } } return ( $error, $rd ); } sub release_detail_perl_remote { my ( $self, $dist, $rd ) = @_; $rd ||= {}; my $error = 1; my $mirror = $self->cpan_mirror(); my $version = $rd->{version}; # try src/5.0 symlinks, either perl-5.X or perl5.X; favor .tar.bz2 over .tar.gz my $index = http_get("https://cpan.metacpan.org/src/5.0/"); if ($index) { for my $prefix ( "perl-", "perl" ) { for my $suffix ( ".tar.bz2", ".tar.gz" ) { my $dist_tarball = "$prefix$version$suffix"; my $dist_tarball_url = "$mirror/src/5.0/$dist_tarball"; if ( $index =~ /href\s*=\s*"\Q$dist_tarball\E"/ms ) { $rd->{tarball_url} = $dist_tarball_url; $rd->{tarball_name} = $dist_tarball; $error = 0; return ( $error, $rd ); } } } } my $json = http_get("https://fastapi.metacpan.org/v1/release/_search?size=1&q=name:perl-${version}"); my $result; unless ( $json and $result = decode_json($json)->{hits}{hits}[0] ) { die "ERROR: Failed to locate perl-${version} tarball."; } my ( $dist_path, $dist_tarball ) = $result->{_source}{download_url} =~ m[(/authors/id/.+/(perl-${version}.tar.(gz|bz2|xz)))$]; die "ERROR: Cannot find the tarball for perl-$version\n" if !$dist_path and !$dist_tarball; my $dist_tarball_url = "https://cpan.metacpan.org${dist_path}"; $rd->{tarball_name} = $dist_tarball; $rd->{tarball_url} = $dist_tarball_url; $error = 0; return ( $error, $rd ); } sub release_detail { my ( $self, $dist ) = @_; my ( $dist_type, $dist_version ); ( $dist_type, $dist_version ) = $dist =~ /^ (?: (perl) -? )? ( [\d._]+ (?:-RC\d+)? |git|stable|blead)$/x; $dist_type = "perl" if $dist_version && !$dist_type; my $rd = { type => $dist_type, version => $dist_version, tarball_url => undef, tarball_name => undef, }; # dynamic methods: release_detail_perl_local, release_detail_perl_remote my $m_local = "release_detail_${dist_type}_local"; my $m_remote = "release_detail_${dist_type}_remote"; unless ($self->can($m_local) && $self->can($m_remote)) { die "ERROR: Unknown dist type: $dist_type\n"; } my ($error) = $self->$m_local( $dist, $rd ); ($error) = $self->$m_remote( $dist, $rd ) if $error; if ($error) { die "ERROR: Fail to get the tarball URL for dist: $dist\n"; } return $rd; } sub run_command_init { my $self = shift; my @args = @_; if ( @args && $args[0] eq '-' ) { if ( $self->current_shell_is_bashish ) { $self->run_command_init_in_bash; } exit 0; } $_->mkpath for ( grep { !-d $_ } map { $self->root->$_ } qw(perls dists build etc bin) ); my ( $f, $fh ) = @_; my $etc_dir = $self->root->etc; for ( ["bashrc", "BASHRC_CONTENT"], ["cshrc", "CSHRC_CONTENT"], ["csh_reinit", "CSH_REINIT_CONTENT"], ["csh_wrapper", "CSH_WRAPPER_CONTENT"], ["csh_set_path", "CSH_SET_PATH_CONTENT"], ["perlbrew-completion.bash", "BASH_COMPLETION_CONTENT"], ["perlbrew.fish", "PERLBREW_FISH_CONTENT"], ) { my ( $file_name, $method ) = @$_; my $path = $etc_dir->child($file_name); if ( !-f $path ) { open( $fh, ">", $path ) or die "Fail to create $path. Please check the permission of $etc_dir and try `perlbrew init` again."; print $fh $self->$method; close $fh; } else { if ( -w $path && open( $fh, ">", $path ) ) { print $fh $self->$method; close $fh; } else { print "NOTICE: $path already exists and not updated.\n" unless $self->{quiet}; } } } my $root_dir = $self->root->stringify_with_tilde; # Skip this if we are running in a shell that already 'source's perlbrew. # This is true during a self-install/self-init. # Ref. https://github.com/gugod/App-perlbrew/issues/525 if ( $ENV{PERLBREW_SHELLRC_VERSION} ) { print("\nperlbrew root ($root_dir) is initialized.\n"); } else { my $shell = $self->current_shell; my ( $code, $yourshrc ); if ( $shell =~ m/(t?csh)/ ) { $code = "source $root_dir/etc/cshrc"; $yourshrc = $1 . "rc"; } elsif ( $shell =~ m/zsh\d?$/ ) { $code = "source $root_dir/etc/bashrc"; $yourshrc = $self->_firstrcfile( qw( .zshenv .bash_profile .bash_login .profile ) ) || ".zshenv"; } elsif ( $shell =~ m/fish/ ) { $code = ". $root_dir/etc/perlbrew.fish"; $yourshrc = '.config/fish/config.fish'; } else { $code = "source $root_dir/etc/bashrc"; $yourshrc = $self->_firstrcfile( qw( .bash_profile .bash_login .profile ) ) || ".bash_profile"; } if ( $self->home ne App::Perlbrew::Path->new( $self->env('HOME'), ".perlbrew" ) ) { my $pb_home_dir = $self->home->stringify_with_tilde; if ( $shell =~ m/fish/ ) { $code = "set -x PERLBREW_HOME $pb_home_dir\n $code"; } else { $code = "export PERLBREW_HOME=$pb_home_dir\n $code"; } } print <<INSTRUCTION; perlbrew root ($root_dir) is initialized. Append the following piece of code to the end of your ~/${yourshrc} and start a new shell, perlbrew should be up and fully functional from there: $code Simply run `perlbrew` for usage details. Happy brewing! INSTRUCTION } } sub run_command_init_in_bash { print BASHRC_CONTENT(); } sub run_command_self_install { my $self = shift; my $executable = $0; my $target = $self->root->bin("perlbrew"); if ( files_are_the_same( $executable, $target ) ) { print "You are already running the installed perlbrew:\n\n $executable\n"; exit; } $self->root->bin->mkpath; open my $fh, "<", $executable; my $head; read( $fh, $head, 3, 0 ); if ( $head eq "#!/" ) { seek( $fh, 0, 0 ); my @lines = <$fh>; close $fh; $lines[0] = $self->system_perl_shebang . "\n"; open $fh, ">", $target; print $fh $_ for @lines; close $fh; } else { close($fh); copy( $executable, $target ); } chmod( 0755, $target ); my $path = $target->stringify_with_tilde; print "perlbrew is installed: $path\n" unless $self->{quiet}; $self->run_command_init(); return; } sub do_install_git { my ( $self, $dist ) = @_; my $dist_name; my $dist_git_describe; my $dist_version; opendir my $cwd_orig, "."; chdir $dist; if ( `git describe` =~ /v((5\.\d+\.\d+(?:-RC\d)?)(-\d+-\w+)?)$/ ) { $dist_name = 'perl'; $dist_git_describe = "v$1"; $dist_version = $2; } chdir $cwd_orig; require File::Spec; my $dist_extracted_dir = File::Spec->rel2abs($dist); $self->do_install_this( App::Perlbrew::Path->new($dist_extracted_dir), $dist_version, "$dist_name-$dist_version" ); return; } sub do_install_url { my ( $self, $dist ) = @_; my $dist_name = 'perl'; # need the period to account for the file extension my ($dist_version) = $dist =~ m/-([\d.]+(?:-RC\d+)?|git)\./; my ($dist_tarball) = $dist =~ m{/([^/]*)$}; if ( !$dist_version && $dist =~ /blead\.tar.gz$/ ) { $dist_version = "blead"; } my $dist_tarball_path = $self->root->dists($dist_tarball); my $dist_tarball_url = $dist; $dist = "$dist_name-$dist_version"; # we install it as this name later if ( $dist_tarball_url =~ m/^file/ ) { print "Installing $dist from local archive $dist_tarball_url\n"; $dist_tarball_url =~ s/^file:\/+/\//; $dist_tarball_path = $dist_tarball_url; } else { print "Fetching $dist as $dist_tarball_path\n"; my $error = http_download( $dist_tarball_url, $dist_tarball_path ); die "ERROR: Failed to download $dist_tarball_url\n$error\n" if $error; } my $dist_extracted_path = $self->do_extract_tarball($dist_tarball_path); $self->do_install_this( $dist_extracted_path, $dist_version, $dist ); return; } sub do_extract_tarball { my ( $self, $dist_tarball ) = @_; # Assuming the dir extracted from the tarball is named after the tarball. my $dist_tarball_basename = $dist_tarball->basename(qr/\.tar\.(?:gz|bz2|xz)$/); my $workdir; if ( $self->{as} ) { # TODO: Should we instead use the installation_name (see run_command_install()): # $destdir = $self->{as} . $self->{variation} . $self->{append}; $workdir = $self->builddir->child( $self->{as} ); } else { # Note that this is incorrect for blead. $workdir = $self->builddir->child($dist_tarball_basename); } $workdir->rmpath; $workdir->mkpath; my $extracted_dir; # Was broken on Solaris, where GNU tar is probably # installed as 'gtar' - RT #61042 my $tarx = ( $^O =~ /solaris|aix/ ? 'gtar ' : 'tar ' ) . ( $dist_tarball =~ m/xz$/ ? 'xJf' : $dist_tarball =~ m/bz2$/ ? 'xjf' : 'xzf' ); my $extract_command = "cd $workdir; $tarx $dist_tarball"; die "Failed to extract $dist_tarball" if system($extract_command); my @things = $workdir->children; if ( @things == 1 ) { $extracted_dir = App::Perlbrew::Path->new( $things[0] ); } unless ( defined($extracted_dir) && -d $extracted_dir ) { die "Failed to find the extracted directory under $workdir"; } return $extracted_dir; } sub do_install_blead { my ($self) = @_; # We always blindly overwrite anything that's already there, # because blead is a moving target. my $dist_tarball_path = $self->root->dists("blead.tar.gz"); unlink($dist_tarball_path) if -f $dist_tarball_path; $self->do_install_url("https://github.com/Perl/perl5/archive/blead.tar.gz"); } sub resolve_stable_version { my ($self) = @_; my ( $latest_ver, $latest_minor ); for my $cand ( $self->available_perls ) { my ( $ver, $minor ) = $cand =~ m/^perl-(5\.(6|8|[0-9]+[02468])\.[0-9]+)$/ or next; ( $latest_ver, $latest_minor ) = ( $ver, $minor ) if !defined $latest_minor || $latest_minor < $minor; } die "Can't determine latest stable Perl release\n" if !defined $latest_ver; return $latest_ver; } sub do_install_release { my ( $self, $dist, $dist_version ) = @_; my $rd = $self->release_detail($dist); my $dist_type = $rd->{type}; die "\"$dist\" does not look like a perl distribution name. " unless $dist_type && $dist_version =~ /^\d\./; my $dist_tarball = $rd->{tarball_name}; my $dist_tarball_url = $rd->{tarball_url}; my $dist_tarball_path = $self->root->dists($dist_tarball); if ( -f $dist_tarball_path ) { print "Using the previously fetched ${dist_tarball}\n" if $self->{verbose}; } else { print "Fetching perl $dist_version as $dist_tarball_path\n" unless $self->{quiet}; $self->run_command_download($dist); } my $dist_extracted_path = $self->do_extract_tarball($dist_tarball_path); $self->do_install_this( $dist_extracted_path, $dist_version, $dist ); return; } sub run_command_install { my ( $self, $dist, $opts ) = @_; unless ( $self->root->exists ) { die( "ERROR: perlbrew root " . $self->root . " does not exist. Run `perlbrew init` to prepare it first.\n" ); } unless ($dist) { $self->run_command_help("install"); exit(-1); } if ( my $url = make_skaji_relocatable_perl_url($dist, $self->sys) ) { return $self->run_command_install($url); } if ( my $detail = looks_like_url_of_skaji_relocatable_perl($dist) ) { if (looks_like_sys_would_be_compatible_with_skaji_relocatable_perl($detail, $self->sys)) { return $self->do_install_skaji_relocatable_perl($detail); } else { die "ERROR: The given url points to a tarball for different os/arch.\n"; } } $self->{dist_name} = $dist; # for help msg generation, set to non # normalized name my ( $dist_type, $dist_version ); if ( ( $dist_type, $dist_version ) = $dist =~ /^(?:(c?perl)-?)?([\d._]+(?:-RC\d+)?|git|stable|blead)$/ ) { $dist_version = $self->resolve_stable_version if $dist_version eq 'stable'; $dist_type ||= "perl"; $dist = "${dist_type}-${dist_version}"; # normalize dist name my $installation_name = ( $self->{as} || $dist ) . $self->{variation} . $self->{append}; if ( not $self->{force} and $self->is_installed($installation_name) ) { die "\nABORT: $installation_name is already installed.\n\n"; } if ( $dist_type eq 'perl' && $dist_version eq 'blead' ) { $self->do_install_blead(); } else { $self->do_install_release( $dist, $dist_version ); } } # else it is some kind of special install: elsif ( -d "$dist/.git" ) { $self->do_install_git($dist); } elsif ( -f $dist ) { $self->do_install_archive( App::Perlbrew::Path->new($dist) ); } elsif ( $dist =~ m/^(?:https?|ftp|file)/ ) { # more protocols needed? $self->do_install_url($dist); } else { die "Unknown installation target \"$dist\", abort.\nPlease see `perlbrew help` " . "for the instruction on using the install command.\n\n"; } if ( $self->{switch} ) { if ( defined( my $installation_name = $self->{installation_name} ) ) { $self->switch_to($installation_name); } else { warn "can't switch, unable to infer final destination name.\n\n"; } } return; } sub check_and_calculate_variations { my $self = shift; my @both = @{ $self->{both} }; if ( $self->{'all-variations'} ) { @both = keys %flavor; } elsif ( $self->{'common-variations'} ) { push @both, grep $flavor{$_}{common}, keys %flavor; } # check the validity of the varitions given via 'both' for my $both (@both) { $flavor{$both} or die "$both is not a supported flavor.\n\n"; $self->{$both} and die "options --both $both and --$both can not be used together"; if ( my $implied_by = $flavor{$both}{implied_by} ) { $self->{$implied_by} and die "options --both $both and --$implied_by can not be used together"; } } # flavors selected always my $start = ''; $start .= "-$_" for grep $self->{$_}, keys %flavor; # make variations my @var = $start; for my $both (@both) { my $append = join( '-', $both, grep defined, $flavor{$both}{implies} ); push @var, map "$_-$append", @var; } # normalize the variation names @var = map { join '-', '', sort { $flavor{$a}{ix} <=> $flavor{$b}{ix} } grep length, split /-+/, $_ } @var; s/(\b\w+\b)(?:-\1)+/$1/g for @var; # remove duplicate flavors # After inspecting perl Configure script this seems to be the most # reliable heuristic to determine if perl would have 64bit IVs by # default or not: if ( $Config::Config{longsize} >= 8 ) { # We are in a 64bit platform. 64int and 64all are always set but # we don't want them to appear on the final perl name s/-64\w+//g for @var; } # remove duplicated variations my %var = map { $_ => 1 } @var; sort keys %var; } sub run_command_install_multiple { my ( $self, @dists ) = @_; unless (@dists) { $self->run_command_help("install-multiple"); exit(-1); } die "--switch can not be used with command install-multiple.\n\n" if $self->{switch}; die "--as can not be used when more than one distribution is given.\n\n" if $self->{as} and @dists > 1; my @variations = $self->check_and_calculate_variations; print join( "\n", "Compiling the following distributions:", map( " $_$self->{append}", @dists ), " with the following variations:", map( ( /-(.*)/ ? " $1" : " default" ), @variations ), "", "" ); my @ok; for my $dist (@dists) { for my $variation (@variations) { local $@; eval { $self->{$_} = '' for keys %flavor; $self->{$_} = 1 for split /-/, $variation; $self->{variation} = $variation; $self->{installation_name} = undef; $self->run_command_install($dist); push @ok, $self->{installation_name}; }; if ($@) { $@ =~ s/\n+$/\n/; print "Installation of $dist$variation failed: $@"; } } } print join( "\n", "", "The following perls have been installed:", map ( " $_", grep defined, @ok ), "", "" ); return; } sub run_command_download { my ( $self, $dist ) = @_; $dist = $self->resolve_stable_version if $dist && $dist eq 'stable'; my $rd = $self->release_detail($dist); my $dist_tarball = $rd->{tarball_name}; my $dist_tarball_url = $rd->{tarball_url}; my $dist_tarball_path = $self->root->dists($dist_tarball); if ( -f $dist_tarball_path && !$self->{force} ) { print "$dist_tarball already exists\n"; } else { print "Download $dist_tarball_url to $dist_tarball_path\n" unless $self->{quiet}; my $error = http_download( $dist_tarball_url, $dist_tarball_path ); if ($error) { die "ERROR: Failed to download $dist_tarball_url\n$error\n"; } } } sub purify { my ( $self, $envname ) = @_; my @paths = grep { index( $_, $self->home ) < 0 && index( $_, $self->root ) < 0 } split /:/, $self->env($envname); return wantarray ? @paths : join( ":", @paths ); } sub system_perl_executable { my ($self) = @_; my $system_perl_executable = do { local $ENV{PATH} = $self->pristine_path; `perl -MConfig -e 'print \$Config{perlpath}'`; }; return $system_perl_executable; } sub system_perl_shebang { my ($self) = @_; return $Config{sharpbang} . $self->system_perl_executable; } sub pristine_path { my ($self) = @_; return $self->purify("PATH"); } sub pristine_manpath { my ($self) = @_; return $self->purify("MANPATH"); } sub run_command_display_system_perl_executable { print $_[0]->system_perl_executable . "\n"; } sub run_command_display_system_perl_shebang { print $_[0]->system_perl_shebang . "\n"; } sub run_command_display_pristine_path { print $_[0]->pristine_path . "\n"; } sub run_command_display_pristine_manpath { print $_[0]->pristine_manpath . "\n"; } sub do_install_archive { require File::Basename; my $self = shift; my $dist_tarball_path = shift; my $dist_version; my $installation_name; if ( $dist_tarball_path->basename =~ m{(c?perl)-?(5.+)\.tar\.(gz|bz2|xz)\Z} ) { my $perl_variant = $1; $dist_version = $2; $installation_name = "${perl_variant}-${dist_version}"; } unless ( $dist_version && $installation_name ) { die "Unable to determine perl version from archive filename.\n\nThe archive name should look like perl-5.x.y.tar.gz or perl-5.x.y.tar.bz2 or perl-5.x.y.tar.xz\n"; } my $dist_extracted_path = $self->do_extract_tarball($dist_tarball_path); $self->do_install_this( $dist_extracted_path, $dist_version, $installation_name ); } sub do_install_this { my ( $self, $dist_extracted_dir, $dist_version, $installation_name ) = @_; my $variation = $self->{variation}; my $append = $self->{append}; my $looks_like_we_are_installing_cperl = $dist_extracted_dir =~ /\/ cperl- /x; $self->{dist_extracted_dir} = $dist_extracted_dir; $self->{log_file} = $self->root->child("build.${installation_name}${variation}${append}.log"); my @d_options = @{ $self->{D} }; my @u_options = @{ $self->{U} }; my @a_options = @{ $self->{A} }; my $sitecustomize = $self->{sitecustomize}; my $destdir = $self->{destdir}; $installation_name = $self->{as} if $self->{as}; $installation_name .= "$variation$append"; $self->{installation_name} = $installation_name; if ($sitecustomize) { die "Could not read sitecustomize file '$sitecustomize'\n" unless -r $sitecustomize; push @d_options, "usesitecustomize"; } if ( $self->{noman} ) { push @d_options, qw/man1dir=none man3dir=none/; } for my $flavor ( keys %flavor ) { $self->{$flavor} and push @d_options, $flavor{$flavor}{d_option}; } my $perlpath = $self->root->perls($installation_name); unshift @d_options, qq(prefix=$perlpath); push @d_options, "usedevel" if $dist_version =~ /5\.\d[13579]|git|blead/; push @d_options, "usecperl" if $looks_like_we_are_installing_cperl; my $version = $self->comparable_perl_version($dist_version); if ( defined $version and $version < $self->comparable_perl_version('5.6.0') ) { # ancient perls do not support -A for Configure @a_options = (); } else { unless ( grep { /eval:scriptdir=/ } @a_options ) { push @a_options, "'eval:scriptdir=${perlpath}/bin'"; } } print "Installing $dist_extracted_dir into " . $self->root->perls($installation_name)->stringify_with_tilde . "\n\n"; print <<INSTALL if !$self->{verbose}; This could take a while. You can run the following command on another shell to track the status: tail -f ${\ $self->{log_file}->stringify_with_tilde } INSTALL my @preconfigure_commands = ( "cd $dist_extracted_dir", "rm -f config.sh Policy.sh", ); unless ( $self->{"no-patchperl"} || $looks_like_we_are_installing_cperl ) { my $patchperl = $self->root->bin("patchperl"); unless ( -x $patchperl && -f _ ) { $patchperl = "patchperl"; } push @preconfigure_commands, 'chmod -R +w .', $patchperl; } my $configure_flags = $self->env("PERLBREW_CONFIGURE_FLAGS") || '-de'; my @configure_commands = ( "sh Configure $configure_flags " . join( ' ', ( map { qq{'-D$_'} } @d_options ), ( map { qq{'-U$_'} } @u_options ), ( map { qq{'-A$_'} } @a_options ), ), ( defined $version and $version < $self->comparable_perl_version('5.8.9') ) ? ("$^X -i -nle 'print unless /command-line/' makefile x2p/makefile") : () ); my $make = $ENV{MAKE} || ( $^O eq "solaris" ? 'gmake' : 'make' ); my @build_commands = ( $make . ' ' . ( $self->{j} ? "-j$self->{j}" : "" ) ); # Test via "make test_harness" if available so we'll get # automatic parallel testing via $HARNESS_OPTIONS. The # "test_harness" target was added in 5.7.3, which was the last # development release before 5.8.0. my $use_harness = ( $dist_version =~ /^5\.(\d+)\.(\d+)/ && ( $1 >= 8 || $1 == 7 && $2 == 3 ) ) || $dist_version eq "blead"; my $test_target = $use_harness ? "test_harness" : "test"; local $ENV{TEST_JOBS} = $self->{j} if $test_target eq "test_harness" && ( $self->{j} || 1 ) > 1; my @install_commands = ( "${make} install" . ( $destdir ? " DESTDIR=$destdir" : q|| ) ); unshift @install_commands, "${make} $test_target" unless $self->{notest}; # Whats happening here? we optionally join with && based on $self->{force}, but then subsequently join with && anyway? @install_commands = join " && ", @install_commands unless ( $self->{force} ); my $cmd = join " && ", ( @preconfigure_commands, @configure_commands, @build_commands, @install_commands ); $self->{log_file}->unlink; if ( $self->{verbose} ) { $cmd = "($cmd) 2>&1 | tee $self->{log_file}"; print "$cmd\n" if $self->{verbose}; } else { $cmd = "($cmd) >> '$self->{log_file}' 2>&1 "; } delete $ENV{$_} for qw(PERL5LIB PERL5OPT AWKPATH NO_COLOR); if ( $self->do_system($cmd) ) { my $newperl = $self->root->perls($installation_name)->perl; unless ( -e $newperl ) { $self->run_command_symlink_executables($installation_name); } eval { $self->append_log('##### Brew Finished #####') }; if ($sitecustomize) { my $capture = $self->do_capture("$newperl -V:sitelib"); my ($sitelib) = $capture =~ m/sitelib='([^']*)';/; $sitelib = $destdir . $sitelib if $destdir; $sitelib = App::Perlbrew::Path->new($sitelib); $sitelib->mkpath; my $target = $sitelib->child("sitecustomize.pl"); open my $dst, ">", $target or die "Could not open '$target' for writing: $!\n"; open my $src, "<", $sitecustomize or die "Could not open '$sitecustomize' for reading: $!\n"; print {$dst} do { local $/; <$src> }; } my $version_file = $self->root->perls($installation_name)->version_file; if ( -e $version_file ) { $version_file->unlink() or die "Could not unlink $version_file file: $!\n"; } print "$installation_name is successfully installed.\n"; } else { eval { $self->append_log('##### Brew Failed #####') }; die $self->INSTALLATION_FAILURE_MESSAGE; } return; } sub do_install_skaji_relocatable_perl { my ($self, $detail) = @_; my $installation_name = $self->{as} || ("skaji-relocatable-perl-" . $detail->{version}); my $installation_path = $self->root->perls->child($installation_name); die "ERROR: Installation target \"${installation_name}\" already exists\n" if $installation_path->exists; my $path = $self->root->dists ->child("skaji-relocatable-perl") ->child($detail->{version}) ->mkpath() ->child($detail->{original_filename}); if (-f $path) { print "Re-using the downloaded $path\n"; } else { my $url = $detail->{url}; print "Downloading $url as $path\n"; my $error = http_download( $detail->{url}, $path ); if ($error) { die "Failed to download from $url\nError: $error"; } } my $extracted_path = $self->do_extract_skaji_relocatable_perl_tarball($detail, $path); move $extracted_path, $installation_path; print "$installation_name is installed at $installation_path.\n"; print "$installation_name is successfully installed.\n"; } sub do_extract_skaji_relocatable_perl_tarball { my ($self, $detail, $tarball_path) = @_; my $workdir = $self->builddir ->child("skaji-relocatable-perl") ->child($detail->{version}); $workdir->rmpath() if $workdir->exists(); $workdir->mkpath(); my $tarx = "tar xzf"; my $extract_command = "cd $workdir; $tarx $tarball_path"; system($extract_command) == 0 or die "Failed to extract $tarball_path"; my ($extracted_path) = $workdir->children; return $extracted_path; } sub do_install_program_from_url { my ( $self, $url, $program_name, $body_filter ) = @_; my $out = $self->root->bin($program_name); if ( -f $out && !$self->{force} && !$self->{yes} ) { require ExtUtils::MakeMaker; my $ans = ExtUtils::MakeMaker::prompt( "\n$out already exists, are you sure to override ? [y/N]", "N" ); if ( $ans !~ /^Y/i ) { print "\n$program_name installation skipped.\n\n" unless $self->{quiet}; return; } } my $body = http_get($url) or die "\nERROR: Failed to retrieve $program_name executable.\n\n"; unless ( $body =~ m{\A#!/}s ) { my $x = App::Perlbrew::Path->new( $self->env('TMPDIR') || "/tmp", "${program_name}.downloaded.$$" ); my $message = "\nERROR: The downloaded $program_name program seem to be invalid. Please check if the following URL can be reached correctly\n\n\t$url\n\n...and try again latter."; unless ( -f $x ) { open my $OUT, ">", $x; print $OUT $body; close($OUT); $message .= "\n\nThe previously downloaded file is saved at $x for manual inspection.\n\n"; } die $message; } if ( $body_filter && ref($body_filter) eq "CODE" ) { $body = $body_filter->($body); } $self->root->bin->mkpath; open my $OUT, '>', $out or die "cannot open file($out): $!"; print $OUT $body; close $OUT; chmod 0755, $out; print "\n$program_name is installed to\n\n $out\n\n" unless $self->{quiet}; } sub do_exit_with_error_code { my ( $self, $code ) = @_; exit($code); } sub do_system_with_exit_code { my ( $self, @cmd ) = @_; return system(@cmd); } sub do_system { my ( $self, @cmd ) = @_; return !$self->do_system_with_exit_code(@cmd); } sub do_capture { my ( $self, @cmd ) = @_; return Capture::Tiny::capture( sub { $self->do_system(@cmd); } ); } sub do_capture_current_perl { my ( $self, @cmd ) = @_; return $self->do_capture( $self->installed_perl_executable( $self->current_perl ), @cmd, ); } sub format_perl_version { my $self = shift; my $version = shift; return sprintf "%d.%d.%d", substr( $version, 0, 1 ), substr( $version, 2, 3 ), substr( $version, 5 ) || 0; } sub installed_perls { my $self = shift; my @result; my $root = $self->root; for my $installation ( $root->perls->list ) { my $name = $installation->name; my $executable = $installation->perl; next unless -f $executable; my $version_file = $installation->version_file; my $ctime = localtime( ( stat $executable )[10] ); # localtime in scalar context! my $orig_version; if ( -e $version_file ) { open my $fh, '<', $version_file; local $/; $orig_version = <$fh>; chomp $orig_version; } else { $orig_version = `$executable -e 'print \$]'`; if ( defined $orig_version and length $orig_version ) { if ( open my $fh, '>', $version_file ) { print {$fh} $orig_version; } } } push @result, { name => $name, orig_version => $orig_version, version => $self->format_perl_version($orig_version), is_current => ( $self->current_perl eq $name ) && !( $self->current_lib ), libs => [$self->local_libs($name)], executable => $executable, dir => $installation, comparable_version => $self->comparable_perl_version($orig_version), ctime => $ctime, }; } return sort { ( $self->{reverse} ? ( $a->{comparable_version} <=> $b->{comparable_version} or $b->{name} cmp $a->{name} ) : ( $b->{comparable_version} <=> $a->{comparable_version} or $a->{name} cmp $b->{name} ) ) } @result; } sub compose_locallib { my ( $self, $perl_name, $lib_name ) = @_; return join '@', $perl_name, $lib_name; } sub decompose_locallib { my ( $self, $name ) = @_; return split '@', $name; } sub enforce_localib { my ( $self, $name ) = @_; $name =~ s/^/@/ unless $name =~ m/@/; return $name; } sub local_libs { my ( $self, $perl_name ) = @_; my $current = $self->current_env; my @libs = map { my $name = $_->basename; my ( $p, $l ) = $self->decompose_locallib($name); +{ name => $name, is_current => $name eq $current, perl_name => $p, lib_name => $l, dir => $_, } } $self->home->child("libs")->children; if ($perl_name) { @libs = grep { $perl_name eq $_->{perl_name} } @libs; } return @libs; } sub is_installed { my ( $self, $name ) = @_; return grep { $name eq $_->{name} } $self->installed_perls; } sub assert_known_installation { my ( $self, $name ) = @_; return 1 if $self->is_installed($name); die "ERROR: The installation \"$name\" is unknown\n\n"; } # Return a hash of PERLBREW_* variables sub perlbrew_env { my ( $self, $name ) = @_; my ( $perl_name, $lib_name ); if ($name) { ( $perl_name, $lib_name ) = $self->resolve_installation_name($name); unless ($perl_name) { die "\nERROR: The installation \"$name\" is unknown.\n\n"; } unless ( !$lib_name || grep { $_->{lib_name} eq $lib_name } $self->local_libs($perl_name) ) { die "\nERROR: The lib name \"$lib_name\" is unknown.\n\n"; } } my %env = ( PERLBREW_VERSION => $VERSION, PERLBREW_PATH => $self->root->bin, PERLBREW_MANPATH => "", PERLBREW_ROOT => $self->root ); require local::lib; my $pb_home = $self->home; my $current_local_lib_root = $self->env("PERL_LOCAL_LIB_ROOT") || ""; my $current_local_lib_context = local::lib->new; my @perlbrew_local_lib_root = uniq( grep { /\Q${pb_home}\E/ } split( /:/, $current_local_lib_root ) ); if ( $current_local_lib_root =~ /^\Q${pb_home}\E/ ) { $current_local_lib_context = $current_local_lib_context->activate($_) for @perlbrew_local_lib_root; } if ($perl_name) { my $installation = $self->root->perls($perl_name); if ( -d $installation->child("bin") ) { $env{PERLBREW_PERL} = $perl_name; $env{PERLBREW_PATH} .= ":" . $installation->child("bin"); $env{PERLBREW_MANPATH} = $installation->child("man"); } if ($lib_name) { $current_local_lib_context = $current_local_lib_context->deactivate($_) for @perlbrew_local_lib_root; my $base = $self->home->child( "libs", "${perl_name}\@${lib_name}" ); if ( -d $base ) { $current_local_lib_context = $current_local_lib_context->activate($base); if ( $self->env('PERLBREW_LIB_PREFIX') ) { unshift @{ $current_local_lib_context->libs }, $self->env('PERLBREW_LIB_PREFIX'); } $env{PERLBREW_PATH} = $base->child("bin") . ":" . $env{PERLBREW_PATH}; $env{PERLBREW_MANPATH} = $base->child("man") . ":" . $env{PERLBREW_MANPATH}; $env{PERLBREW_LIB} = $lib_name; } } else { $current_local_lib_context = $current_local_lib_context->deactivate($_) for @perlbrew_local_lib_root; $env{PERLBREW_LIB} = undef; } my %ll_env = $current_local_lib_context->build_environment_vars; delete $ll_env{PATH}; for my $key ( keys %ll_env ) { $env{$key} = $ll_env{$key}; } } else { $current_local_lib_context = $current_local_lib_context->deactivate($_) for @perlbrew_local_lib_root; my %ll_env = $current_local_lib_context->build_environment_vars; delete $ll_env{PATH}; for my $key ( keys %ll_env ) { $env{$key} = $ll_env{$key}; } $env{PERLBREW_LIB} = undef; $env{PERLBREW_PERL} = undef; } return %env; } sub run_command_list { my $self = shift; my $is_verbose = $self->{verbose}; if ( $self->{'no-decoration'} ) { for my $i ( $self->installed_perls ) { print $i->{name} . "\n"; for my $lib ( @{ $i->{libs} } ) { print $lib->{name} . "\n"; } } } else { for my $i ( $self->installed_perls ) { printf "%-2s%-20s %-20s %s\n", $i->{is_current} ? '*' : '', $i->{name}, ( $is_verbose ? ( index( $i->{name}, $i->{version} ) < 0 ) ? "($i->{version})" : '' : '' ), ( $is_verbose ? "(installed on $i->{ctime})" : '' ); for my $lib ( @{ $i->{libs} } ) { print $lib->{is_current} ? "* " : " ", $lib->{name}, "\n"; } } } return 0; } sub launch_sub_shell { my ( $self, $name ) = @_; my $shell = $self->env('SHELL'); my $shell_opt = ""; if ( $shell =~ /\/zsh\d?$/ ) { $shell_opt = "-d -f"; if ( $^O eq 'darwin' ) { my $root_dir = $self->root; print <<"WARNINGONMAC"; -------------------------------------------------------------------------------- WARNING: zsh perlbrew sub-shell is not working on Mac OSX Lion. It is known that on MacOS Lion, zsh always resets the value of PATH on launching a sub-shell. Effectively nullify the changes required by perlbrew sub-shell. You may `echo \$PATH` to examine it and if you see perlbrew related paths are in the end, instead of in the beginning, you are unfortunate. You are advised to include the following line to your ~/.zshenv as a better way to work with perlbrew: source $root_dir/etc/bashrc -------------------------------------------------------------------------------- WARNINGONMAC } } my %env = ( $self->perlbrew_env($name), PERLBREW_SKIP_INIT => 1 ); unless ( $ENV{PERLBREW_VERSION} ) { my $root = $self->root; # The user does not source bashrc/csh in their shell initialization. $env{PATH} = $env{PERLBREW_PATH} . ":" . join ":", grep { !/$root\/bin/ } split ":", $ENV{PATH}; $env{MANPATH} = $env{PERLBREW_MANPATH} . ":" . join ":", grep { !/$root\/man/ } ( defined( $ENV{MANPATH} ) ? split( ":", $ENV{MANPATH} ) : () ); } my $command = "env "; while ( my ( $k, $v ) = each(%env) ) { no warnings "uninitialized"; $command .= "$k=\"$v\" "; } $command .= " $shell $shell_opt"; my $pretty_name = defined($name) ? $name : "the default perl"; print "\nA sub-shell is launched with $pretty_name as the activated perl. Run 'exit' to finish it.\n\n"; exec($command); } sub run_command_use { my $self = shift; my $perl = shift; if ( !$perl ) { my $current = $self->current_env; if ($current) { print "Currently using $current\n"; } else { print "No version in use; defaulting to system\n"; } return; } $self->launch_sub_shell($perl); } sub run_command_switch { my ( $self, $dist, $alias ) = @_; unless ($dist) { my $current = $self->current_env; printf "Currently switched %s\n", ( $current ? "to $current" : 'off' ); return; } $self->switch_to( $dist, $alias ); } sub switch_to { my ( $self, $dist, $alias ) = @_; die "Cannot use for alias something that starts with 'perl-'\n" if $alias && $alias =~ /^perl-/; die "${dist} is not installed\n" unless -d $self->root->perls($dist); if ( $self->env("PERLBREW_SHELLRC_VERSION") && $self->current_shell_is_bashish ) { local $ENV{PERLBREW_PERL} = $dist; my $HOME = $self->env('HOME'); my $pb_home = $self->home; $pb_home->mkpath; system( "$0 env $dist > " . $pb_home->child("init") ); print "Switched to $dist.\n\n"; } else { $self->launch_sub_shell($dist); } } sub run_command_off { my $self = shift; $self->launch_sub_shell; } sub run_command_switch_off { my $self = shift; my $pb_home = $self->home; $pb_home->mkpath; system( "env PERLBREW_PERL= $0 env > " . $pb_home->child("init") ); print "\nperlbrew is switched off. Please exit this shell and start a new one to make it effective.\n"; print "To immediately make it effective, run this line in this terminal:\n\n exec @{[ $self->env('SHELL') ]}\n\n"; } sub shell_env { my ( $self, $env ) = @_; my %env = %$env; my @statements; for my $k ( sort keys %env ) { my $v = $env{$k}; if ( defined($v) && $v ne '' ) { $v =~ s/(\\")/\\$1/g; push @statements, ["set", $k, $v]; } else { push @statements, ["unset", $k]; } } my $statements = ""; if ( $self->env('SHELL') =~ /(ba|k|z|\/)sh\d?$/ ) { for (@statements) { my ( $o, $k, $v ) = @$_; if ( $o eq 'unset' ) { $statements .= "unset $k\n"; } else { $v =~ s/(\\")/\\$1/g; $statements .= "export $k=\"$v\"\n"; } } } else { for (@statements) { my ( $o, $k, $v ) = @$_; if ( $o eq 'unset' ) { $statements .= "unsetenv $k\n"; } else { $statements .= "setenv $k \"$v\"\n"; } } } return $statements; } sub run_command_env { my ( $self, $name ) = @_; print $self->shell_env({ $self->perlbrew_env($name) }); } sub run_command_symlink_executables { my ( $self, @perls ) = @_; my $root = $self->root; unless (@perls) { @perls = map { $_->name } grep { -d $_ && !-l $_ } $root->perls->list; } for my $perl (@perls) { for my $executable ( $root->perls($perl)->bin->children ) { my ( $name, $version ) = $executable =~ m/bin\/(.+?)(5\.\d.*)?$/; next unless $version; $executable->symlink( $root->perls($perl)->bin($name) ); $executable->symlink( $root->perls($perl)->perl ) if $name eq "cperl"; } } } sub run_command_install_patchperl { my ($self) = @_; $self->do_install_program_from_url( 'https://raw.githubusercontent.com/gugod/patchperl-packing/master/patchperl', 'patchperl', sub { my ($body) = @_; $body =~ s/\A#!.+?\n/ $self->system_perl_shebang . "\n" /se; return $body; } ); } sub run_command_install_cpanm { my ($self) = @_; $self->do_install_program_from_url( 'https://raw.githubusercontent.com/miyagawa/cpanminus/master/cpanm' => 'cpanm' ); } sub run_command_install_cpm { my ($self) = @_; $self->do_install_program_from_url( 'https://raw.githubusercontent.com/skaji/cpm/main/cpm' => 'cpm' ); } sub run_command_self_upgrade { my ($self) = @_; require FindBin; unless ( -w $FindBin::Bin ) { die "Your perlbrew installation appears to be system-wide. Please upgrade through your package manager.\n"; } my $TMPDIR = $ENV{TMPDIR} || "/tmp"; my $TMP_PERLBREW = App::Perlbrew::Path->new( $TMPDIR, "perlbrew" ); http_download( 'https://raw.githubusercontent.com/gugod/App-perlbrew/master/perlbrew', $TMP_PERLBREW ); chmod 0755, $TMP_PERLBREW; my $new_version = qx($TMP_PERLBREW version); chomp $new_version; if ( $new_version =~ /App::perlbrew\/(\d+\.\d+)$/ ) { $new_version = $1; } else { $TMP_PERLBREW->unlink; die "Unable to detect version of new perlbrew!\n"; } if ( $new_version <= $VERSION ) { print "Your perlbrew is up-to-date (version $VERSION).\n" unless $self->{quiet}; $TMP_PERLBREW->unlink; return; } print "Upgrading from $VERSION to $new_version\n" unless $self->{quiet}; system $TMP_PERLBREW, "self-install"; $TMP_PERLBREW->unlink; } sub run_command_uninstall { my ( $self, $target ) = @_; unless ($target) { $self->run_command_help("uninstall"); exit(-1); } my @installed = $self->installed_perls(@_); my ($to_delete) = grep { $_->{name} eq $target } @installed; die "'$target' is not installed\n" unless $to_delete; my @dir_to_delete; for ( @{ $to_delete->{libs} } ) { push @dir_to_delete, $_->{dir}; } push @dir_to_delete, $to_delete->{dir}; my $ans = ( $self->{yes} ) ? "Y" : undef; if ( !defined($ans) ) { require ExtUtils::MakeMaker; $ans = ExtUtils::MakeMaker::prompt( "\nThe following perl+lib installation(s) will be deleted:\n\n\t" . join( "\n\t", @dir_to_delete ) . "\n\n... are you sure ? [y/N]", "N" ); } if ( $ans =~ /^Y/i ) { for (@dir_to_delete) { print "Deleting: $_\n" unless $self->{quiet}; App::Perlbrew::Path->new($_)->rmpath; print "Deleted: $_\n" unless $self->{quiet}; } } else { print "\nOK. Not deleting anything.\n\n"; return; } } sub run_command_exec { my $self = shift; my %opts; local (@ARGV) = @{ $self->{original_argv} }; Getopt::Long::Configure('require_order'); my @command_options = ( 'with=s', 'halt-on-error', 'min=s', 'max=s' ); $self->parse_cmdline( \%opts, @command_options ); shift @ARGV; # "exec" $self->parse_cmdline( \%opts, @command_options ); my @exec_with; if ( $opts{with} ) { my %installed = map { $_->{name} => $_ } map { ( $_, @{ $_->{libs} } ) } $self->installed_perls; my $d = ( $opts{with} =~ m/ / ) ? qr( +) : qr(,+); my @with = grep { $_ } map { my ( $p, $l ) = $self->resolve_installation_name($_); $p .= "\@$l" if $l; $p; } split $d, $opts{with}; @exec_with = map { $installed{$_} } @with; } else { @exec_with = grep { not -l $self->root->perls( $_->{name} ); # Skip Aliases } map { ( $_, @{ $_->{libs} } ) } $self->installed_perls; } if ( $opts{min} ) { # TODO use comparable version. # For now, it doesn't produce consistent results for 5.026001 and 5.26.1 @exec_with = grep { $_->{orig_version} >= $opts{min} } @exec_with; } if ( $opts{max} ) { @exec_with = grep { $_->{orig_version} <= $opts{max} } @exec_with; } if ( 0 == @exec_with ) { print "No perl installation found.\n" unless $self->{quiet}; } my $no_header = 0; if ( 1 == @exec_with ) { $no_header = 1; } my $overall_success = 1; for my $i (@exec_with) { my %env = $self->perlbrew_env( $i->{name} ); next if !$env{PERLBREW_PERL}; local %ENV = %ENV; $ENV{$_} = defined $env{$_} ? $env{$_} : '' for keys %env; $ENV{PATH} = join( ':', $env{PERLBREW_PATH}, $ENV{PATH} ); $ENV{MANPATH} = join( ':', $env{PERLBREW_MANPATH}, $ENV{MANPATH} || "" ); $ENV{PERL5LIB} = $env{PERL5LIB} || ""; print "$i->{name}\n==========\n" unless $no_header || $self->{quiet}; if ( my $err = $self->do_system_with_exit_code(@ARGV) ) { my $exit_code = $err >> 8; # return 255 for case when process was terminated with signal, in that case real exit code is useless and weird $exit_code = 255 if $exit_code > 255; $overall_success = 0; unless ( $self->{quiet} ) { print "Command terminated with non-zero status.\n"; print STDERR "Command [" . join( ' ', map { /\s/ ? "'$_'" : $_ } @ARGV ) . # trying reverse shell escapes - quote arguments containing spaces "] terminated with exit code $exit_code (\$? = $err) under the following perl environment:\n"; print STDERR $self->format_info_output; } $self->do_exit_with_error_code($exit_code) if ( $opts{'halt-on-error'} ); } print "\n" unless $self->{quiet} || $no_header; } $self->do_exit_with_error_code(1) unless $overall_success; } sub run_command_clean { my ($self) = @_; my $root = $self->root; my @build_dirs = $root->build->children; for my $dir (@build_dirs) { print "Removing $dir\n"; App::Perlbrew::Path->new($dir)->rmpath; } my @tarballs = $root->dists->children; for my $file (@tarballs) { print "Removing $file\n"; $file->unlink; } print "\nDone\n"; } sub run_command_alias { my ( $self, $cmd, $name, $alias ) = @_; unless ($cmd) { $self->run_command_help("alias"); exit(-1); } my $path_name = $self->root->perls($name) if $name; my $path_alias = $self->root->perls($alias) if $alias; if ( $alias && -e $path_alias && !-l $path_alias ) { die "\nABORT: The installation name `$alias` is not an alias, cannot override.\n\n"; } if ( $cmd eq 'create' ) { $self->assert_known_installation($name); if ( $self->is_installed($alias) && !$self->{force} ) { die "\nABORT: The installation `${alias}` already exists. Cannot override.\n\n"; } $path_alias->unlink; $path_name->symlink($path_alias); } elsif ( $cmd eq 'delete' ) { $self->assert_known_installation($name); unless ( -l $path_name ) { die "\nABORT: The installation name `$name` is not an alias, cannot remove.\n\n"; } $path_name->unlink; } elsif ( $cmd eq 'rename' ) { $self->assert_known_installation($name); unless ( -l $path_name ) { die "\nABORT: The installation name `$name` is not an alias, cannot rename.\n\n"; } if ( -l $path_alias && !$self->{force} ) { die "\nABORT: The alias `$alias` already exists, cannot rename to it.\n\n"; } rename( $path_name, $path_alias ); } elsif ( $cmd eq 'help' ) { $self->run_command_help("alias"); } else { die "\nERROR: Unrecognized action: `${cmd}`.\n\n"; } } sub run_command_display_bashrc { print BASHRC_CONTENT(); } sub run_command_display_cshrc { print CSHRC_CONTENT(); } sub run_command_display_installation_failure_message { my ($self) = @_; } sub run_command_lib { my ( $self, $subcommand, @args ) = @_; unless ($subcommand) { $self->run_command_help("lib"); exit(-1); } my $sub = "run_command_lib_$subcommand"; if ( $self->can($sub) ) { $self->$sub(@args); } else { print "Unknown command: $subcommand\n"; } } sub run_command_lib_create { my ( $self, $name ) = @_; die "ERROR: No lib name\n", $self->run_command_help( "lib", undef, 'return_text' ) unless $name; $name = $self->enforce_localib($name); my ( $perl_name, $lib_name ) = $self->resolve_installation_name($name); if ( !$perl_name ) { my ( $perl_name, $lib_name ) = $self->decompose_locallib($name); die "ERROR: '$perl_name' is not installed yet, '$name' cannot be created.\n"; } my $fullname = $self->compose_locallib( $perl_name, $lib_name ); my $dir = $self->home->child( "libs", $fullname ); if ( -d $dir ) { die "$fullname is already there.\n"; } $dir->mkpath; print "lib '$fullname' is created.\n" unless $self->{quiet}; return; } sub run_command_lib_delete { my ( $self, $name ) = @_; die "ERROR: No lib to delete\n", $self->run_command_help( "lib", undef, 'return_text' ) unless $name; $name = $self->enforce_localib($name); my ( $perl_name, $lib_name ) = $self->resolve_installation_name($name); my $fullname = $self->compose_locallib( $perl_name, $lib_name ); my $current = $self->current_env; my $dir = $self->home->child( "libs", $fullname ); if ( -d $dir ) { if ( $fullname eq $current ) { die "$fullname is currently being used in the current shell, it cannot be deleted.\n"; } $dir->rmpath; print "lib '$fullname' is deleted.\n" unless $self->{quiet}; } else { die "ERROR: '$fullname' does not exist.\n"; } return; } sub run_command_lib_list { my ($self) = @_; my $dir = $self->home->child("libs"); return unless -d $dir; opendir my $dh, $dir or die "open $dir failed: $!"; my @libs = grep { !/^\./ && /\@/ } readdir($dh); my $current = $self->current_env; for (@libs) { print $current eq $_ ? "* " : " "; print "$_\n"; } } sub run_command_upgrade_perl { my ($self) = @_; my $PERL_VERSION_RE = qr/(\d+)\.(\d+)\.(\d+)/; my ($current) = grep { $_->{is_current} } $self->installed_perls; unless ( defined $current ) { print "no perlbrew environment is currently in use\n"; exit(1); } my ( $major, $minor, $release ); if ( $current->{version} =~ /^$PERL_VERSION_RE$/ ) { ( $major, $minor, $release ) = ( $1, $2, $3 ); } else { print "unable to parse version '$current->{version}'\n"; exit(1); } my @available = grep { /^perl-$major\.$minor/ } $self->available_perls; my $latest_available_perl = $release; foreach my $perl (@available) { if ( $perl =~ /^perl-$PERL_VERSION_RE$/ ) { my $this_release = $3; if ( $this_release > $latest_available_perl ) { $latest_available_perl = $this_release; } } } if ( $latest_available_perl == $release ) { print "This perlbrew environment ($current->{name}) is already up-to-date.\n"; exit(0); } my $dist_version = "$major.$minor.$latest_available_perl"; my $dist = "perl-$dist_version"; print "Upgrading $current->{name} to $dist_version\n" unless $self->{quiet}; local $self->{as} = $current->{name}; local $self->{dist_name} = $dist; my @d_options = map { '-D' . $flavor{$_}->{d_option} } keys %flavor; my %sub_config = map { $_ => $Config{$_} } grep { /^config_arg\d/ } keys %Config; for my $value ( values %sub_config ) { my $value_wo_D = $value; $value_wo_D =~ s/^-D//; push @{ $self->{D} }, $value_wo_D if grep { /$value/ } @d_options; } $self->do_install_release( $dist, $dist_version ); } sub list_modules { my ( $self, $env ) = @_; $env ||= $self->current_env; my ( $stdout, $stderr, $success ) = Capture::Tiny::capture( sub { __PACKAGE__->new( "--quiet", "exec", "--with", $env, 'perl', '-MExtUtils::Installed', '-le', 'BEGIN{@INC=grep {$_ ne q!.!} @INC}; print for ExtUtils::Installed->new->modules;', )->run; } ); unless ($success) { unless ( $self->{quiet} ) { print STDERR "Failed to retrive the list of installed modules.\n"; if ( $self->{verbose} ) { print STDERR "STDOUT\n======\n$stdout\nSTDERR\n======\n$stderr\n"; } } return []; } my %rename = ( "ack" => "App::Ack", "libwww::perl" => "LWP", "libintl-perl" => "Locale::Messages", "Role::Identifiable" => "Role::Identifiable::HasTags", "TAP::Harness::Multiple" => "TAP::Harness::ReportByDescription", ); return [map { $rename{$_} || $_ } grep { $_ ne "Perl" } split( /\n/, $stdout )]; } sub run_command_list_modules { my ($self) = @_; my ( $modules, $error ) = $self->list_modules(); print "$_\n" for @$modules; } sub resolve_installation_name { my ( $self, $name ) = @_; die "App::perlbrew->resolve_installation_name requires one argument." unless $name; my ( $perl_name, $lib_name ) = $self->decompose_locallib($name); $perl_name = $name unless $lib_name; $perl_name ||= $self->current_perl; if ( !$self->is_installed($perl_name) ) { if ( $self->is_installed("perl-${perl_name}") ) { $perl_name = "perl-${perl_name}"; } else { return undef; } } return wantarray ? ( $perl_name, $lib_name ) : $perl_name; } # Implementation of the 'clone-modules' command. # # This method accepts a destination and source installation # of Perl to clone modules from and into. # For instance calling # $app->run_command_clone_modules($perl_a, $perl_b); # installs all modules that have been installed on Perl A # to the instance of Perl B. # The source instance is optional, that is if the method # is invoked with a single argument, the currently # running instance is used as source. Therefore the # two following calls are the same: # # $app->run_command_clone_modules( $self->current_perl, $perl_b ); # $app->run_command_clone_modules( $perl_b ); # # Of course, both Perl installation must exist on this # perlbrew enviroment. # # The method extracts the modules installed on the source Perl # instance and put them on a temporary file, such file is then # passed to another instance of the application to # execute cpanm on it. The final result is the installation # of source modules into the destination instance. sub run_command_clone_modules { my $self = shift; # default to use the currently installation my ( $dst_perl, $src_perl ); # the first argument is the destination, the second # optional argument is the source version, default # to use the current installation $dst_perl = pop || $self->current_env; $src_perl = pop || $self->current_env; # check source and destination do exist undef $src_perl if ( !$self->resolve_installation_name($src_perl) ); undef $dst_perl if ( !$self->resolve_installation_name($dst_perl) ); if ( !$src_perl || !$dst_perl || $src_perl eq $dst_perl ) { # cannot understand from where to where or # the user did specify the same versions $self->run_command_help('clone-modules'); exit(-1); } my @modules_to_install = @{ $self->list_modules($src_perl) }; unless (@modules_to_install) { print "\nNo modules installed on $src_perl !\n" unless $self->{quiet}; return; } print "\nInstalling $#modules_to_install modules from $src_perl to $dst_perl ...\n" unless $self->{quiet}; # create a new application to 'exec' the 'cpanm' # with the specified module list my @args = ( qw(--quiet exec --with), $dst_perl, 'cpanm' ); push @args, '--notest' if $self->{notest}; push @args, @modules_to_install; __PACKAGE__->new(@args)->run; } sub format_info_output { my ( $self, $module ) = @_; my $out = ''; $out .= "Current perl:\n"; if ( $self->current_perl ) { $out .= " Name: " . $self->current_env . "\n"; $out .= " Path: " . $self->installed_perl_executable( $self->current_perl ) . "\n"; $out .= " Config: " . $self->configure_args( $self->current_perl ) . "\n"; $out .= join( '', " Compiled at: ", ( map { / Compiled at (.+)\n/ ? $1 : () } `@{[ $self->installed_perl_executable($self->current_perl) ]} -V` ), "\n" ); } else { $out .= "Using system perl." . "\n"; $out .= "Shebang: " . $self->system_perl_shebang . "\n"; } $out .= "\nperlbrew:\n"; $out .= " version: " . $self->VERSION . "\n"; $out .= " ENV:\n"; for ( map { "PERLBREW_$_" } qw(ROOT HOME PATH MANPATH) ) { $out .= " $_: " . ( $self->env($_) || "" ) . "\n"; } if ($module) { my $code = qq{eval "require $module" and do { (my \$f = "$module") =~ s<::></>g; \$f .= ".pm"; print "$module\n Location: \$INC{\$f}\n Version: " . ($module->VERSION ? $module->VERSION : "no VERSION specified" ) } or do { print "$module could not be found, is it installed?" } }; $out .= "\nModule: " . $self->do_capture_current_perl( '-le', $code ); } $out; } sub run_command_info { my ($self) = shift; print $self->format_info_output(@_); } sub run_command_make_shim { my ($self, $program) = @_; unless ($program) { $self->run_command_help("make-shim"); return; } my $output = $self->{output} || $program; if (-f $output) { die "ERROR: $program already exists under current directory.\n"; } my $current_env = $self->current_env or die "ERROR: perlbrew is not activated. make-shim requires an perlbrew environment to be activated.\nRead the usage by running: perlbrew help make-shim\n"; my %env = $self->perlbrew_env( $current_env ); my $shebang = '#!' . $self->env('SHELL'); my $preemble = $self->shell_env(\%env); my $path = $self->shell_env({ PATH => $env{"PERLBREW_PATH"} . ":" . $self->env("PATH") }); my $shim = join( "\n", $shebang, $preemble, $path, 'exec ' . $program . ' "$@"', "\n" ); open my $fh, ">", "$output" or die $!; print $fh $shim; close $fh; chmod 0755, $output; if ( $self->{verbose} ) { print "The shim $output is made.\n"; } } sub run_command_make_pp { my ($self, $program) = @_; my $current_env = $self->current_env or die "ERROR: perlbrew is not activated. make-pp requires an perlbrew environment to be activated.\nRead the usage by running: perlbrew help make-pp\n"; my $path_pp = $self->whereis_in_env("pp", $current_env) or die "ERROR: pp cannot be found in $current_env"; my $input = $self->{input}; my $output = $self->{output}; unless ($input && $output) { $self->run_command_help("make-pp"); return; } unless (-f $input) { die "ERROR: The specified input $input do not exists\n"; } if (-f $output) { die "ERROR: $output already exists.\n"; } my $sitelib = $self->do_capture_current_perl( '-MConfig', '-e', 'print $Config{sitelibexp}', ); my $privlib = $self->do_capture_current_perl( '-MConfig', '-e', 'print $Config{privlibexp}', ); my $locallib; if ($self->current_lib) { require local::lib; my ($current_lib) = grep { $_->{is_current} } $self->local_libs(); my @llpaths = sort { length($a) <=> length($b) } local::lib->lib_paths_for( $current_lib->{dir} ); $locallib = $llpaths[0]; } my $perlversion = $self->do_capture_current_perl( '-MConfig', '-e', 'print $Config{version}', ); my @cmd = ( $path_pp, "-B", # core modules "-a", "$privlib;$perlversion", "-a", "$sitelib;$perlversion", ($locallib ? ("-a", "$locallib;$perlversion") : ()), "-z", "9", "-o", $output, $input, ); $self->do_system(@cmd); } sub whereis_in_env { my ($self, $program, $env) = @_; my %env = $self->perlbrew_env( $env ); my @paths = split /:/, $env{PERLBREW_PATH}; my ($path) = grep { -x $_ } map { App::Perlbrew::Path->new($_, $program) } @paths; return $path; } sub BASHRC_CONTENT() { return "export PERLBREW_SHELLRC_VERSION=$VERSION\n" . ( exists $ENV{PERLBREW_ROOT} ? "export PERLBREW_ROOT=$PERLBREW_ROOT\n" : "" ) . "\n" . <<'RC'; __perlbrew_reinit() { if [[ ! -d "$PERLBREW_HOME" ]]; then mkdir -p "$PERLBREW_HOME" fi [ -f "$PERLBREW_HOME/init" ] && rm "$PERLBREW_HOME/init" echo '# DO NOT EDIT THIS FILE' > "$PERLBREW_HOME/init" command perlbrew env $1 | \grep PERLBREW_ >> "$PERLBREW_HOME/init" . "$PERLBREW_HOME/init" __perlbrew_set_path } __perlbrew_purify () { local path patharray outsep IFS=: read -r${BASH_VERSION+a}${ZSH_VERSION+A} patharray <<< "$1" for path in "${patharray[@]}" ; do case "$path" in (*"$PERLBREW_HOME"*) ;; (*"$PERLBREW_ROOT"*) ;; (*) printf '%s' "$outsep$path" ; outsep=: ;; esac done } __perlbrew_set_path () { export MANPATH=${PERLBREW_MANPATH:-}${PERLBREW_MANPATH:+:}$(__perlbrew_purify "$(manpath 2>/dev/null)") export PATH=${PERLBREW_PATH:-$PERLBREW_ROOT/bin}:$(__perlbrew_purify "$PATH") if [[ -o hashall ]] ; then hash -r fi } __perlbrew_set_env() { local code code="$($perlbrew_command env $@)" || return $? eval "$code" } __perlbrew_activate() { [[ -n $(alias perl 2>/dev/null) ]] && unalias perl 2>/dev/null if [[ -n "${PERLBREW_PERL:-}" ]]; then __perlbrew_set_env "${PERLBREW_PERL:-}${PERLBREW_LIB:+@}$PERLBREW_LIB" fi __perlbrew_set_path } __perlbrew_deactivate() { __perlbrew_set_env unset PERLBREW_PERL unset PERLBREW_LIB __perlbrew_set_path } perlbrew () { local exit_status local short_option export SHELL if [[ $1 == -* ]]; then short_option=$1 shift else short_option="" fi case $1 in (use) if [[ -z "$2" ]] ; then echo -n "Currently using ${PERLBREW_PERL:-system perl}" [ -n "$PERLBREW_LIB" ] && echo -n "@$PERLBREW_LIB" echo else __perlbrew_set_env "$2" && { __perlbrew_set_path ; true ; } exit_status="$?" fi ;; (switch) if [[ -z "$2" ]] ; then command perlbrew switch else perlbrew use $2 && { __perlbrew_reinit $2 ; true ; } exit_status=$? fi ;; (off) __perlbrew_deactivate echo "perlbrew is turned off." ;; (switch-off) __perlbrew_deactivate __perlbrew_reinit echo "perlbrew is switched off." ;; (*) command perlbrew $short_option "$@" exit_status=$? ;; esac hash -r return ${exit_status:-0} } [[ -z "${PERLBREW_ROOT:-}" ]] && export PERLBREW_ROOT="$HOME/perl5/perlbrew" [[ -z "${PERLBREW_HOME:-}" ]] && export PERLBREW_HOME="$HOME/.perlbrew" if [[ ! -n "${PERLBREW_SKIP_INIT:-}" ]]; then if [[ -f "${PERLBREW_HOME:-}/init" ]]; then . "$PERLBREW_HOME/init" fi fi if [[ -f "${PERLBREW_ROOT:-}/bin/perlbrew" ]]; then perlbrew_command="${PERLBREW_ROOT:-}/bin/perlbrew" else perlbrew_command="perlbrew" fi __perlbrew_activate RC } sub BASH_COMPLETION_CONTENT() { return <<'COMPLETION'; if [[ -n ${ZSH_VERSION-} ]]; then autoload -U +X bashcompinit && bashcompinit fi export PERLBREW="command perlbrew" _perlbrew_compgen() { COMPREPLY=( $($PERLBREW compgen $COMP_CWORD ${COMP_WORDS[*]}) ) } complete -F _perlbrew_compgen perlbrew COMPLETION } sub PERLBREW_FISH_CONTENT { return "set -x PERLBREW_SHELLRC_VERSION $VERSION\n" . <<'END'; function __perlbrew_reinit if not test -d "$PERLBREW_HOME" mkdir -p "$PERLBREW_HOME" end echo '# DO NOT EDIT THIS FILE' > "$PERLBREW_HOME/init" command perlbrew env $argv[1] | \grep PERLBREW_ >> "$PERLBREW_HOME/init" __source_init __perlbrew_set_path end function __perlbrew_set_path set -l MANPATH_WITHOUT_PERLBREW (perl -e 'print join ":", grep { index($_, $ENV{PERLBREW_HOME}) < 0 } grep { index($_, $ENV{PERLBREW_ROOT}) < 0 } split/:/,qx(manpath 2> /dev/null);') if test -n "$PERLBREW_MANPATH" set -l PERLBREW_MANPATH $PERLBREW_MANPATH":" set -x MANPATH {$PERLBREW_MANPATH}{$MANPATH_WITHOUT_PERLBREW} else set -x MANPATH $MANPATH_WITHOUT_PERLBREW end set -l PATH_WITHOUT_PERLBREW (eval $perlbrew_command display-pristine-path | perl -pe'y/:/ /') # silencing stderr in case there's a non-existent path in $PATH (see GH#446) if test -n "$PERLBREW_PATH" set -x PERLBREW_PATH (echo $PERLBREW_PATH | perl -pe 'y/:/ /' ) eval set -x PATH $PERLBREW_PATH $PATH_WITHOUT_PERLBREW 2> /dev/null else eval set -x PATH $PERLBREW_ROOT/bin $PATH_WITHOUT_PERLBREW 2> /dev/null end end function __perlbrew_set_env set -l code (eval $perlbrew_command env $argv | perl -pe 's/^(export|setenv)/set -xg/; s/=/ /; s/^unset(env)* (.*)/if test -n "\$$2"; set -eg $2; end/; s/$/;/; y/:/ /') if test -z "$code" return 0; else eval $code end end function __perlbrew_activate functions -e perl if test -n "$PERLBREW_PERL" if test -z "$PERLBREW_LIB" __perlbrew_set_env $PERLBREW_PERL else __perlbrew_set_env $PERLBREW_PERL@$PERLBREW_LIB end end __perlbrew_set_path end function __perlbrew_deactivate __perlbrew_set_env set -x PERLBREW_PERL set -x PERLBREW_LIB set -x PERLBREW_PATH __perlbrew_set_path end function perlbrew test -z "$argv" and echo " Usage: perlbrew <command> [options] [arguments]" and echo " or: perlbrew help" and return 1 switch $argv[1] case use if test ( count $argv ) -eq 1 if test -z "$PERLBREW_PERL" echo "Currently using system perl" else echo "Currently using $PERLBREW_PERL" end else __perlbrew_set_env $argv[2] if test "$status" -eq 0 __perlbrew_set_path end end case switch if test ( count $argv ) -eq 1 command perlbrew switch else perlbrew use $argv[2] if test "$status" -eq 0 __perlbrew_reinit $argv[2] end end case off __perlbrew_deactivate echo "perlbrew is turned off." case switch-off __perlbrew_deactivate __perlbrew_reinit echo "perlbrew is switched off." case '*' command perlbrew $argv end end function __source_init perl -pe 's/^(export|setenv)/set -xg/; s/^unset(env)* (.*)/if test -n "\$$2"; set -eg $2; end/; s/=/ /; s/$/;/;' "$PERLBREW_HOME/init" | source end if test -z "$PERLBREW_ROOT" set -x PERLBREW_ROOT "$HOME/perl5/perlbrew" end if test -z "$PERLBREW_HOME" set -x PERLBREW_HOME "$HOME/.perlbrew" end if test -z "$PERLBREW_SKIP_INIT" -a -f "$PERLBREW_HOME/init" __source_init end set perlbrew_bin_path "$PERLBREW_ROOT/bin" if test -f "$perlbrew_bin_path/perlbrew" set perlbrew_command "$perlbrew_bin_path/perlbrew" else set perlbrew_command perlbrew end set -e perlbrew_bin_path __perlbrew_activate ## autocomplete stuff ############################################# function __fish_perlbrew_needs_command set cmd (commandline -opc) if test (count $cmd) -eq 1 -a $cmd[1] = 'perlbrew' return 0 end return 1 end function __fish_perlbrew_using_command set cmd (commandline -opc) if test (count $cmd) -gt 1 if [ $argv[1] = $cmd[2] ] return 0 end end end for com in (perlbrew help | perl -ne'print lc if s/^COMMAND:\s+//') complete -f -c perlbrew -n '__fish_perlbrew_needs_command' -a $com end for com in switch use; complete -f -c perlbrew -n "__fish_perlbrew_using_command $com" \ -a '(perlbrew list | perl -pe\'s/\*?\s*(\S+).*/$1/\')' end END } sub CSH_WRAPPER_CONTENT { return <<'WRAPPER'; set perlbrew_exit_status=0 if ( "$1" =~ -* ) then set perlbrew_short_option="$1" shift else set perlbrew_short_option="" endif switch ( "$1" ) case use: if ( $%2 == 0 ) then if ( $?PERLBREW_PERL == 0 ) then echo "Currently using system perl" else if ( $%PERLBREW_PERL == 0 ) then echo "Currently using system perl" else echo "Currently using $PERLBREW_PERL" endif endif else set perlbrew_line_count=0 foreach perlbrew_line ( "`\perlbrew env $2:q`" ) eval "$perlbrew_line" @ perlbrew_line_count++ end if ( $perlbrew_line_count == 0 ) then set perlbrew_exit_status=1 else source "$PERLBREW_ROOT/etc/csh_set_path" endif endif breaksw case switch: if ( $%2 == 0 ) then \perlbrew switch else perlbrew use "$2" && source "$PERLBREW_ROOT/etc/csh_reinit" "$2" endif breaksw case off: unsetenv PERLBREW_PERL foreach perlbrew_line ( "`\perlbrew env`" ) eval "$perlbrew_line" end source "$PERLBREW_ROOT/etc/csh_set_path" echo "perlbrew is turned off." breaksw case switch-off: unsetenv PERLBREW_PERL source "$PERLBREW_ROOT/etc/csh_reinit" '' echo "perlbrew is switched off." breaksw default: \perlbrew $perlbrew_short_option:q $argv:q set perlbrew_exit_status=$? breaksw endsw rehash exit $perlbrew_exit_status WRAPPER } sub CSH_REINIT_CONTENT { return <<'REINIT'; if ( ! -d "$PERLBREW_HOME" ) then mkdir -p "$PERLBREW_HOME" endif echo '# DO NOT EDIT THIS FILE' >! "$PERLBREW_HOME/init" \perlbrew env $1 >> "$PERLBREW_HOME/init" source "$PERLBREW_HOME/init" source "$PERLBREW_ROOT/etc/csh_set_path" REINIT } sub CSH_SET_PATH_CONTENT { return <<'SETPATH'; unalias perl if ( $?PERLBREW_PATH == 0 ) then setenv PERLBREW_PATH "$PERLBREW_ROOT/bin" endif setenv PATH_WITHOUT_PERLBREW `perl -e 'print join ":", grep { index($_, $ENV{PERLBREW_ROOT}) } split/:/,$ENV{PATH};'` setenv PATH "${PERLBREW_PATH}:${PATH_WITHOUT_PERLBREW}" setenv MANPATH_WITHOUT_PERLBREW `perl -e 'print join ":", grep { index($_, $ENV{PERLBREW_ROOT}) } split/:/,qx(manpath 2> /dev/null);'` if ( $?PERLBREW_MANPATH == 1 ) then setenv MANPATH "${PERLBREW_MANPATH}:${MANPATH_WITHOUT_PERLBREW}" else setenv MANPATH "${MANPATH_WITHOUT_PERLBREW}" endif SETPATH } sub CSHRC_CONTENT { return "setenv PERLBREW_SHELLRC_VERSION $VERSION\n\n" . <<'CSHRC'; if ( $?PERLBREW_HOME == 0 ) then setenv PERLBREW_HOME "$HOME/.perlbrew" endif if ( $?PERLBREW_ROOT == 0 ) then setenv PERLBREW_ROOT "$HOME/perl5/perlbrew" endif if ( $?PERLBREW_SKIP_INIT == 0 ) then if ( -f "$PERLBREW_HOME/init" ) then source "$PERLBREW_HOME/init" endif endif if ( $?PERLBREW_PATH == 0 ) then setenv PERLBREW_PATH "$PERLBREW_ROOT/bin" endif source "$PERLBREW_ROOT/etc/csh_set_path" alias perlbrew 'source "$PERLBREW_ROOT/etc/csh_wrapper"' CSHRC } sub append_log { my ( $self, $message ) = @_; my $log_handler; open( $log_handler, '>>', $self->{log_file} ) or die "Cannot open log file for appending: $!"; print $log_handler "$message\n"; close($log_handler); } sub INSTALLATION_FAILURE_MESSAGE { my ($self) = @_; return <<FAIL; Installation process failed. To spot any issues, check $self->{log_file} If some perl tests failed and you still want to install this distribution anyway, do: (cd $self->{dist_extracted_dir}; make install) You might also want to try upgrading patchperl before trying again: perlbrew install-patchperl Generally, if you need to install a perl distribution known to have minor test failures, do one of these commands to avoid seeing this message: perlbrew --notest install $self->{dist_name} perlbrew --force install $self->{dist_name} FAIL } 1; __END__ =encoding utf8 =head1 NAME App::perlbrew - Manage perl installations in your C<$HOME> =head1 SYNOPSIS # Installation curl -L https://install.perlbrew.pl | bash # Initialize perlbrew init # See what is available perlbrew available # Install some Perls perlbrew install 5.32.1 perlbrew install perl-5.28.3 perlbrew install perl-5.33.6 # See what were installed perlbrew list # Swith to an installation and set it as default perlbrew switch perl-5.32.1 # Temporarily use another version only in current shell. perlbrew use perl-5.28.3 perl -v # Turn it off and go back to the system perl. perlbrew off # Turn it back on with 'switch', or 'use' perlbrew switch perl-5.32.1 perlbrew use perl-5.32.1 # Exec something with all perlbrew-ed perls perlbrew exec -- perl -E 'say $]' =head1 DESCRIPTION L<perlbrew> is a program to automate the building and installation of perl in an easy way. It provides multiple isolated perl environments, and a mechanism for you to switch between them. Everything are installed unter C<~/perl5/perlbrew>. You then need to include a bashrc/cshrc provided by perlbrew to tweak the PATH for you. You then can benefit from not having to run C<sudo> commands to install cpan modules because those are installed inside your C<HOME> too. For the documentation of perlbrew usage see L<perlbrew> command on L<MetaCPAN|https://metacpan.org/>, or by running C<perlbrew help>, or by visiting L<perlbrew's official website|https://perlbrew.pl/>. The following documentation features the API of C<App::perlbrew> module, and may not be remotely close to what your want to read. =head1 INSTALLATION It is the simplest to use the perlbrew installer, just paste this statement to your terminal: curl -L https://install.perlbrew.pl | bash Or this one, if you have C<fetch> (default on FreeBSD): fetch -o- https://install.perlbrew.pl | sh After that, C<perlbrew> installs itself to C<~/perl5/perlbrew/bin>, and you should follow the instruction on screen to modify your shell rc file to put it in your PATH. The installed perlbrew command is a standalone executable that can be run with system perl. The minimum required version of system perl is 5.8.0, which should be good enough for most of the OSes these days. A fat-packed version of L<patchperl> is also installed to C<~/perl5/perlbrew/bin>, which is required to build old perls. The directory C<~/perl5/perlbrew> will contain all install perl executables, libraries, documentations, lib, site_libs. In the documentation, that directory is referred as C<perlbrew root>. If you need to set it to somewhere else because, say, your C<HOME> has limited quota, you can do that by setting C<PERLBREW_ROOT> environment variable before running the installer: export PERLBREW_ROOT=/opt/perl5 curl -L https://install.perlbrew.pl | bash As a result, different users on the same machine can all share the same perlbrew root directory (although only original user that made the installation would have the permission to perform perl installations.) If you need to install perlbrew using a Perl that isn't either C</usr/bin/perl> or C</usr/local/bin/perl>, set and export the environment variable C<PERLBREW_SYSTEM_PERL> and then install as described above. Note that you must not use a perlbrew-managed perl. You may also install perlbrew from CPAN: cpan App::perlbrew In this case, the perlbrew command is installed as C</usr/bin/perlbrew> or C</usr/local/bin/perlbrew> or others, depending on the location of your system perl installation. Please make sure not to run this with one of the perls brewed with perlbrew. It's the best to turn perlbrew off before you run that, if you're upgrading. perlbrew off cpan App::perlbrew You should always use system cpan (like /usr/bin/cpan) to install C<App::perlbrew> because it will be installed under a system PATH like C</usr/bin>, which is not affected by perlbrew C<switch> or C<use> command. The C<self-upgrade> command will not upgrade the perlbrew installed by cpan command, but it is also easy to upgrade perlbrew by running C<cpan App::perlbrew> again. =head1 PROJECT DEVELOPMENT L<perlbrew project|https://perlbrew.pl/> uses github L<https://github.com/gugod/App-perlbrew/issues> for issue tracking. Issues sent to these two systems will eventually be reviewed and handled. To participate, you need a github account. Please briefly read the short instructions about how to get your work released to CPAN: L<https://github.com/gugod/App-perlbrew/blob/develop/CONTRIBUTING.md> =head1 AUTHOR Kang-min Liu C<< <gugod@gugod.org> >> =head1 COPYRIGHT Copyright (c) 2023 Kang-min Liu C<< <gugod@gugod.org> >>. =head1 LICENCE The MIT License =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. =cut APP_PERLBREW $fatpacked{"CPAN/Perl/Releases.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_PERL_RELEASES'; package CPAN::Perl::Releases; $CPAN::Perl::Releases::VERSION = '5.20240920'; #ABSTRACT: Mapping Perl releases on CPAN to the location of the tarballs use strict; use warnings; use vars qw[@ISA @EXPORT_OK]; use Exporter; @ISA = qw(Exporter); @EXPORT_OK = qw(perl_tarballs perl_versions perl_pumpkins); # Data gathered from using findlinks.pl script in this dists tools/ # directory, run over the src/5.0 of a local CPAN mirror. our $cache = { }; our $data = { "5.004" => { id => 'CHIPS' }, "5.004_01" => { id => 'TIMB' }, "5.004_02" => { id => 'TIMB' }, "5.004_03" => { id => 'TIMB' }, "5.004_04" => { id => 'TIMB' }, "5.004_05" => { id => 'CHIPS' }, "5.005" => { id => 'GSAR' }, "5.005_01" => { id => 'GSAR' }, "5.005_02" => { id => 'GSAR' }, "5.005_03" => { id => 'GBARR' }, "5.005_04" => { id => 'LBROCARD' }, "5.6.0" => { id => 'GSAR' }, "5.6.1-TRIAL1" => { id => 'GSAR' }, "5.6.1-TRIAL2" => { id => 'GSAR' }, "5.6.1-TRIAL3" => { id => 'GSAR' }, "5.6.1" => { id => 'GSAR' }, "5.6.2" => { id => 'RGARCIA' }, "5.7.0" => { id => 'JHI' }, "5.7.2" => { id => 'JHI' }, "5.7.3" => { id => 'JHI' }, "5.8.0" => { id => 'JHI' }, "5.8.1" => { id => 'JHI' }, "5.8.2" => { id => 'NWCLARK' }, "5.8.3" => { id => 'NWCLARK' }, "5.8.4" => { id => 'NWCLARK' }, "5.8.5" => { id => 'NWCLARK' }, "5.8.6" => { id => 'NWCLARK' }, "5.8.7" => { id => 'NWCLARK' }, "5.8.8" => { id => 'NWCLARK' }, "5.8.9" => { id => 'NWCLARK' }, "5.9.0" => { id => 'HVDS' }, "5.9.1" => { id => 'RGARCIA' }, "5.9.2" => { id => 'RGARCIA' }, "5.9.3" => { id => 'RGARCIA' }, "5.9.4" => { id => 'RGARCIA' }, "5.9.5" => { id => 'RGARCIA' }, "5.10.0" => { id => 'RGARCIA' }, "5.10.1" => { id => 'DAPM' }, "5.11.0" => { id => 'JESSE' }, "5.11.1" => { id => 'JESSE' }, "5.11.2" => { id => 'LBROCARD' }, "5.11.3" => { id => 'JESSE' }, "5.11.5" => { id => 'SHAY' }, "5.12.0" => { id => 'JESSE' }, "5.12.1" => { id => 'JESSE' }, "5.12.2" => { id => 'JESSE' }, "5.12.3" => { id => 'RJBS' }, "5.12.4" => { id => 'LBROCARD' }, "5.12.5" => { id => 'DOM' }, "5.13.0" => { id => 'LBROCARD' }, "5.13.2" => { id => 'MSTROUT' }, "5.13.3" => { id => 'DAGOLDEN' }, "5.13.4" => { id => 'FLORA' }, "5.13.5" => { id => 'SHAY' }, "5.13.6" => { id => 'MIYAGAWA' }, "5.13.7" => { id => 'BINGOS' }, "5.13.8" => { id => 'ZEFRAM' }, "5.13.9" => { id => 'JESSE' }, "5.13.10" => { id => 'AVAR' }, "5.13.11" => { id => 'FLORA' }, "5.14.0" => { id => 'JESSE' }, "5.14.1" => { id => 'JESSE' }, "5.14.2-RC1" => { id => 'FLORA' }, "5.14.2" => { id => 'FLORA' }, "5.14.3" => { id => 'DOM' }, "5.14.4-RC1" => { id => 'DAPM' }, "5.14.4-RC2" => { id => 'DAPM' }, "5.14.4" => { id => 'DAPM' }, "5.15.0" => { id => 'DAGOLDEN' }, "5.15.1" => { id => 'ZEFRAM' }, "5.15.3" => { id => 'STEVAN' }, "5.15.4" => { id => 'FLORA' }, "5.15.5" => { id => 'SHAY' }, "5.15.6" => { id => 'DROLSKY' }, "5.15.7" => { id => 'BINGOS' }, "5.15.9" => { id => 'ABIGAIL' }, "5.16.0" => { id => 'RJBS' }, "5.16.1" => { id => 'RJBS' }, "5.16.2" => { id => 'RJBS' }, "5.16.3" => { id => 'RJBS' }, "5.17.0" => { id => 'ZEFRAM' }, "5.17.1" => { id => 'DOY' }, "5.17.2" => { id => 'TONYC' }, "5.17.3" => { id => 'SHAY' }, "5.17.4" => { id => 'FLORA' }, "5.17.5" => { id => 'FLORA' }, "5.17.7" => { id => 'DROLSKY' }, "5.17.8" => { id => 'ARC' }, "5.17.9" => { id => 'BINGOS' }, "5.18.0" => { id => 'RJBS' }, "5.18.1" => { id => 'RJBS' }, "5.19.1" => { id => 'DAGOLDEN' }, "5.19.3" => { id => 'SHAY' }, "5.19.4" => { id => 'SHAY' }, "5.19.5" => { id => 'SHAY' }, "5.19.6" => { id => 'BINGOS' }, "5.19.7" => { id => 'ABIGAIL' }, "5.18.2" => { id => 'RJBS' }, "5.19.9" => { id => 'TONYC' }, "5.19.10" => { id => 'ARC' }, "5.19.11" => { id => 'SHAY' }, "5.20.0" => { id => 'RJBS' }, "5.21.1" => { id => 'WOLFSAGE' }, "5.21.2" => { id => 'ABIGAIL' }, "5.21.3" => { id => 'PCM' }, "5.20.1-RC1" => { id => 'SHAY' }, "5.20.1-RC2" => { id => 'SHAY' }, "5.20.1" => { id => 'SHAY' }, "5.21.4" => { id => 'SHAY' }, "5.18.3" => { id => 'RJBS' }, "5.18.4" => { id => 'RJBS' }, "5.21.5" => { id => 'ABIGAIL' }, "5.21.6" => { id => 'BINGOS' }, "5.21.8" => { id => 'WOLFSAGE' }, "5.20.2-RC1" => { id => 'SHAY' }, "5.20.2" => { id => 'SHAY' }, "5.21.10" => { id => 'SHAY' }, "5.21.11" => { id => 'SHAY' }, "5.22.0" => { id => 'RJBS' }, "5.23.1" => { id => 'WOLFSAGE' }, "5.23.2" => { id => 'WOLFSAGE' }, "5.20.3-RC1" => { id => 'SHAY' }, "5.20.3-RC2" => { id => 'SHAY' }, "5.20.3" => { id => 'SHAY' }, "5.23.3" => { id => 'PCM' }, "5.23.4" => { id => 'SHAY' }, "5.22.1-RC1" => { id => 'SHAY' }, "5.22.1-RC2" => { id => 'SHAY' }, "5.23.5" => { id => 'ABIGAIL' }, "5.22.1-RC3" => { id => 'SHAY' }, "5.22.1-RC4" => { id => 'SHAY' }, "5.22.1" => { id => 'SHAY' }, "5.23.6" => { id => 'DAGOLDEN', noxz => 1 }, "5.23.7" => { id => 'STEVAN' }, "5.23.9" => { id => 'ABIGAIL' }, "5.22.2-RC1" => { id => 'SHAY' }, "5.22.2" => { id => 'SHAY' }, "5.24.0" => { id => 'RJBS' }, "5.25.2" => { id => 'WOLFSAGE' }, "5.22.3-RC1" => { id => 'SHAY' }, "5.24.1-RC1" => { id => 'SHAY' }, "5.25.3" => { id => 'SHAY' }, "5.22.3-RC2" => { id => 'SHAY' }, "5.24.1-RC2" => { id => 'SHAY' }, "5.22.3-RC3" => { id => 'SHAY' }, "5.24.1-RC3" => { id => 'SHAY' }, "5.25.4" => { id => 'BINGOS' }, "5.25.5" => { id => 'STEVAN' }, "5.22.3-RC4" => { id => 'SHAY' }, "5.24.1-RC4" => { id => 'SHAY' }, "5.25.6" => { id => 'ARC' }, "5.25.7" => { id => 'EXODIST' }, "5.22.3-RC5" => { id => 'SHAY' }, "5.24.1-RC5" => { id => 'SHAY', noxz => 1 }, "5.22.3" => { id => 'SHAY' }, "5.24.1" => { id => 'SHAY' }, "5.25.9" => { id => 'ABIGAIL' }, "5.25.10" => { id => 'RENEEB' }, "5.26.0" => { id => 'XSAWYERX' }, "5.27.1" => { id => 'EHERMAN' }, "5.22.4-RC1" => { id => 'SHAY' }, "5.24.2-RC1" => { id => 'SHAY' }, "5.22.4" => { id => 'SHAY' }, "5.24.2" => { id => 'SHAY' }, "5.27.2" => { id => 'ARC' }, "5.27.3" => { id => 'WOLFSAGE' }, "5.24.3-RC1" => { id => 'SHAY' }, "5.26.1-RC1" => { id => 'SHAY' }, "5.27.4" => { id => 'GENEHACK' }, "5.24.3" => { id => 'SHAY' }, "5.26.1" => { id => 'SHAY' }, "5.27.5" => { id => 'SHAY' }, "5.27.6" => { id => 'ETHER' }, "5.27.7" => { id => 'BINGOS' }, "5.27.8" => { id => 'ABIGAIL' }, "5.27.9" => { id => 'RENEEB' }, "5.27.10" => { id => 'TODDR' }, "5.24.4-RC1" => { id => 'SHAY' }, "5.26.2-RC1" => { id => 'SHAY' }, "5.24.4" => { id => 'SHAY' }, "5.26.2" => { id => 'SHAY' }, "5.27.11" => { id => 'XSAWYERX' }, "5.28.0-RC1" => { id => 'XSAWYERX' }, "5.28.0-RC2" => { id => 'XSAWYERX' }, "5.28.0-RC3" => { id => 'XSAWYERX' }, "5.28.0-RC4" => { id => 'XSAWYERX' }, "5.28.0" => { id => 'XSAWYERX' }, "5.29.0" => { id => 'XSAWYERX' }, "5.29.1" => { id => 'SHAY' }, "5.29.2" => { id => 'BINGOS' }, "5.29.3" => { id => 'GENEHACK' }, "5.29.4" => { id => 'ARC' }, "5.29.5" => { id => 'ETHER' }, "5.26.3" => { id => 'SHAY' }, "5.28.1" => { id => 'SHAY' }, "5.29.6" => { id => 'ABIGAIL' }, "5.29.7" => { id => 'ABIGAIL' }, "5.29.8" => { id => 'ATOOMIC' }, "5.29.9" => { id => 'ZAKAME' }, "5.28.2-RC1" => { id => 'SHAY' }, "5.28.2" => { id => 'SHAY' }, "5.29.10" => { id => 'XSAWYERX' }, "5.30.0-RC1" => { id => 'XSAWYERX' }, "5.30.0-RC2" => { id => 'XSAWYERX' }, "5.30.0" => { id => 'XSAWYERX' }, "5.31.0" => { id => 'XSAWYERX' }, "5.31.1" => { id => 'ETHER' }, "5.31.2" => { id => 'SHAY' }, "5.31.4" => { id => 'CORION' }, "5.31.5" => { id => 'SHAY' }, "5.30.1-RC1" => { id => 'SHAY' }, "5.30.1" => { id => 'SHAY' }, "5.31.6" => { id => 'BINGOS' }, "5.31.7" => { id => 'ATOOMIC' }, "5.31.8" => { id => 'WOLFSAGE' }, "5.31.9" => { id => 'RENEEB' }, "5.30.2-RC1" => { id => 'SHAY' }, "5.30.2" => { id => 'SHAY' }, "5.31.10" => { id => 'XSAWYERX' }, "5.31.11" => { id => 'XSAWYERX' }, "5.32.0-RC0" => { id => 'XSAWYERX' }, "5.28.3-RC1" => { id => 'XSAWYERX' }, "5.28.3" => { id => 'XSAWYERX' }, "5.30.3-RC1" => { id => 'XSAWYERX' }, "5.30.3" => { id => 'XSAWYERX' }, "5.32.0-RC1" => { id => 'XSAWYERX' }, "5.32.0" => { id => 'XSAWYERX' }, "5.33.0" => { id => 'XSAWYERX' }, "5.33.1" => { id => 'ETHER' }, "5.33.2" => { id => 'XSAWYERX' }, "5.33.3" => { id => 'SHAY' }, "5.33.5" => { id => 'CORION' }, "5.32.1-RC1" => { id => 'SHAY' }, "5.33.6" => { id => 'HYDAHY' }, "5.32.1" => { id => 'SHAY' }, "5.33.7" => { id => 'RENEEB' }, "5.33.8" => { id => 'ATOOMIC' }, "5.33.9" => { id => 'TODDR' }, "5.34.0-RC1" => { id => 'XSAWYERX' }, "5.34.0-RC2" => { id => 'XSAWYERX' }, "5.34.0" => { id => 'XSAWYERX' }, "5.35.0" => { id => 'RJBS' }, "5.35.1" => { id => 'CORION' }, "5.35.3" => { id => 'ETHER' }, "5.35.4" => { id => 'WOLFSAGE' }, "5.35.5" => { id => 'LEONT' }, "5.35.6" => { id => 'HYDAHY' }, "5.35.8" => { id => 'ATOOMIC' }, "5.35.9" => { id => 'RENEEB' }, "5.34.1-RC1" => { id => 'SHAY' }, "5.34.1-RC2" => { id => 'SHAY' }, "5.34.1" => { id => 'SHAY' }, "5.35.10" => { id => 'XSAWYERX' }, "5.35.11" => { id => 'SHAY' }, "5.36.0-RC2" => { id => 'RJBS' }, "5.36.0-RC3" => { id => 'RJBS' }, "5.36.0" => { id => 'RJBS' }, "5.37.0" => { id => 'RJBS' }, "5.37.1" => { id => 'WOLFSAGE' }, "5.37.2" => { id => 'ATOOMIC' }, "5.37.4" => { id => 'ETHER' }, "5.37.5" => { id => 'TODDR' }, "5.37.6" => { id => 'CORION' }, "5.37.7" => { id => 'HYDAHY' }, "5.37.8" => { id => 'RENEEB' }, "5.37.9" => { id => 'ETHER' }, "5.37.10" => { id => 'YVES' }, "5.36.1-RC1" => { id => 'SHAY' }, "5.36.1-RC2" => { id => 'SHAY' }, "5.36.1-RC3" => { id => 'SHAY' }, "5.37.11" => { id => 'SHAY' }, "5.36.1" => { id => 'SHAY' }, "5.38.0-RC1" => { id => 'RJBS' }, "5.38.0-RC2" => { id => 'RJBS' }, "5.38.0" => { id => 'RJBS' }, "5.39.1" => { id => 'SHAY' }, "5.39.2" => { id => 'PEVANS' }, "5.39.3" => { id => 'WOLFSAGE' }, "5.39.4" => { id => 'HAARG' }, "5.39.5" => { id => 'ETHER' }, "5.34.3" => { id => 'PEVANS' }, "5.36.3" => { id => 'PEVANS' }, "5.38.2" => { id => 'PEVANS' }, "5.39.6" => { id => 'BOOK' }, "5.39.7" => { id => 'CORION' }, "5.39.8" => { id => 'RENEEB' }, "5.39.9" => { id => 'PEVANS' }, "5.39.10" => { id => 'PEVANS' }, "5.40.0-RC1" => { id => 'HAARG' }, "5.40.0-RC2" => { id => 'HAARG' }, "5.40.0" => { id => 'HAARG' }, "5.41.1" => { id => 'BOOK' }, "5.41.2" => { id => 'ETHER' }, "5.41.3" => { id => 'BOOK' }, "5.41.4" => { id => 'CONTRA' }, }; sub perl_tarballs { my $vers = shift; return unless defined $vers; $vers = shift if eval { $vers->isa(__PACKAGE__) }; return unless exists $data->{ $vers }; if ( exists $cache->{ $vers } ) { return { %{ $cache->{ $vers } } }; } my $pumpkin = $data->{ $vers }->{id}; my $path = join '/', substr( $pumpkin, 0, 1 ), substr( $pumpkin, 0, 2 ), $pumpkin; my $sep = ( $vers =~ m!^5\.0! ? '' : '-' ); my $perl = join $sep, 'perl', $vers; my $onlygz = 1 if $vers =~ m!(?-xism:5.(?:00(?:4(?:_0[12345])?|5(?:_0[1234])?|3_07)|1(?:0.0(?:-RC[12])?|6.0-RC0)|6.(?:[02]|1(?:-TRIAL[123])?)|9.[12345]|7.[0123]|8.[01]))! || $data->{ $vers }->{onlygz}; my $onlybz2 = 1 if $data->{ $vers }->{onlybz2}; my $noxz = 1 if $data->{ $vers }->{noxz}; my $lvers; { my $tvers = $vers; $tvers =~ s!\-?(TRIAL|RC)\d*!!g; $tvers =~ s!_!.!g; my @parts = split m!\.!, $tvers; push @parts, 0 if scalar @parts < 3; $lvers = sprintf("%d.%03d%03d",@parts); } my $foo = { }; $foo->{'tar.gz'} = "$path/$perl.tar.gz" unless $onlybz2; $foo->{'tar.bz2'} = "$path/$perl.tar.bz2" unless $onlygz || $lvers > 5.027005; $foo->{'tar.xz'} = "$path/$perl.tar.xz" if $lvers > 5.021005 && !$noxz; delete $foo->{'tar.bz2'} if $pumpkin eq 'SHAY' && $lvers < 5.028000; $cache->{ $vers } = $foo; return { %$foo }; } sub perl_versions { return sort _by_version keys %$data; } sub _by_version { my %v = map { my @v = split(qr/[-._]0*/, $_); $v[2] ||= 0; $v[3] ||= 'Z'; ($_ => sprintf '%d.%03d%03d-%s', @v) } $a, $b; $v{$a} cmp $v{$b}; } sub perl_pumpkins { my %pumps = map { ( $data->{$_}->{id} => 1 ) } keys %$data; return sort keys %pumps; } q|Acme::Why::Did::I::Not::Read::The::Fecking::Memo|; __END__ =pod =encoding UTF-8 =head1 NAME CPAN::Perl::Releases - Mapping Perl releases on CPAN to the location of the tarballs =head1 VERSION version 5.20240920 =head1 SYNOPSIS use CPAN::Perl::Releases qw[perl_tarballs]; my $perl = '5.14.0'; my $hashref = perl_tarballs( $perl ); print "Location: ", $_, "\n" for values %{ $hashref }; =head1 DESCRIPTION CPAN::Perl::Releases is a module that contains the mappings of all C<perl> releases that have been uploaded to CPAN to the C<authors/id/> path that the tarballs reside in. This is static data, but newer versions of this module will be made available as new releases of C<perl> are uploaded to CPAN. =head1 FUNCTIONS =over =item C<perl_tarballs> Takes one parameter, a C<perl> version to search for. Returns an hashref on success or C<undef> otherwise. The returned hashref will have a key/value for each type of tarball. A key of C<tar.gz> indicates the location of a gzipped tar file and C<tar.bz2> of a bzip2'd tar file. The values will be the relative path under C<authors/id/> on CPAN where the indicated tarball will be located. perl_tarballs( '5.14.0' ); Returns a hashref like: { "tar.bz2" => "J/JE/JESSE/perl-5.14.0.tar.bz2", "tar.gz" => "J/JE/JESSE/perl-5.14.0.tar.gz" } Not all C<perl> releases had C<tar.bz2>, but only a C<tar.gz>. Perl tarballs may also be compressed using C<xz> and therefore have a C<tar.xz> entry. =item C<perl_versions> Returns the list of all the perl versions supported by the module in ascending order. C<TRIAL> and C<RC> will be lower than an actual release. =item C<perl_pumpkins> Returns a sorted list of all PAUSE IDs of Perl pumpkins. =back =head1 SEE ALSO L<http://www.cpan.org/src/5.0/> =head1 AUTHOR Chris Williams <chris@bingosnet.co.uk> =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2024 by Chris Williams. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut CPAN_PERL_RELEASES $fatpacked{"Capture/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CAPTURE_TINY'; use 5.006; use strict; use warnings; package Capture::Tiny; # ABSTRACT: Capture STDOUT and STDERR from Perl, XS or external programs our $VERSION = '0.48'; use Carp (); use Exporter (); use IO::Handle (); use File::Spec (); use File::Temp qw/tempfile tmpnam/; use Scalar::Util qw/reftype blessed/; # Get PerlIO or fake it BEGIN { local $@; eval { require PerlIO; PerlIO->can('get_layers') } or *PerlIO::get_layers = sub { return () }; } #--------------------------------------------------------------------------# # create API subroutines and export them # [do STDOUT flag, do STDERR flag, do merge flag, do tee flag] #--------------------------------------------------------------------------# my %api = ( capture => [1,1,0,0], capture_stdout => [1,0,0,0], capture_stderr => [0,1,0,0], capture_merged => [1,1,1,0], tee => [1,1,0,1], tee_stdout => [1,0,0,1], tee_stderr => [0,1,0,1], tee_merged => [1,1,1,1], ); for my $sub ( keys %api ) { my $args = join q{, }, @{$api{$sub}}; eval "sub $sub(&;@) {unshift \@_, $args; goto \\&_capture_tee;}"; ## no critic } our @ISA = qw/Exporter/; our @EXPORT_OK = keys %api; our %EXPORT_TAGS = ( 'all' => \@EXPORT_OK ); #--------------------------------------------------------------------------# # constants and fixtures #--------------------------------------------------------------------------# my $IS_WIN32 = $^O eq 'MSWin32'; ##our $DEBUG = $ENV{PERL_CAPTURE_TINY_DEBUG}; ## ##my $DEBUGFH; ##open $DEBUGFH, "> DEBUG" if $DEBUG; ## ##*_debug = $DEBUG ? sub(@) { print {$DEBUGFH} @_ } : sub(){0}; our $TIMEOUT = 30; #--------------------------------------------------------------------------# # command to tee output -- the argument is a filename that must # be opened to signal that the process is ready to receive input. # This is annoying, but seems to be the best that can be done # as a simple, portable IPC technique #--------------------------------------------------------------------------# my @cmd = ($^X, '-C0', '-e', <<'HERE'); use Fcntl; $SIG{HUP}=sub{exit}; if ( my $fn=shift ) { sysopen(my $fh, qq{$fn}, O_WRONLY|O_CREAT|O_EXCL) or die $!; print {$fh} $$; close $fh; } my $buf; while (sysread(STDIN, $buf, 2048)) { syswrite(STDOUT, $buf); syswrite(STDERR, $buf); } HERE #--------------------------------------------------------------------------# # filehandle manipulation #--------------------------------------------------------------------------# sub _relayer { my ($fh, $apply_layers) = @_; # _debug("# requested layers (@{$layers}) for @{[fileno $fh]}\n"); # eliminate pseudo-layers binmode( $fh, ":raw" ); # strip off real layers until only :unix is left while ( 1 < ( my $layers =()= PerlIO::get_layers( $fh, output => 1 ) ) ) { binmode( $fh, ":pop" ); } # apply other layers my @to_apply = @$apply_layers; shift @to_apply; # eliminate initial :unix # _debug("# applying layers (unix @to_apply) to @{[fileno $fh]}\n"); binmode($fh, ":" . join(":",@to_apply)); } sub _name { my $glob = shift; no strict 'refs'; ## no critic return *{$glob}{NAME}; } sub _open { open $_[0], $_[1] or Carp::confess "Error from open(" . join(q{, }, @_) . "): $!"; # _debug( "# open " . join( ", " , map { defined $_ ? _name($_) : 'undef' } @_ ) . " as " . fileno( $_[0] ) . "\n" ); } sub _close { # _debug( "# closing " . ( defined $_[0] ? _name($_[0]) : 'undef' ) . " on " . fileno( $_[0] ) . "\n" ); close $_[0] or Carp::confess "Error from close(" . join(q{, }, @_) . "): $!"; } my %dup; # cache this so STDIN stays fd0 my %proxy_count; sub _proxy_std { my %proxies; if ( ! defined fileno STDIN ) { $proxy_count{stdin}++; if (defined $dup{stdin}) { _open \*STDIN, "<&=" . fileno($dup{stdin}); # _debug( "# restored proxy STDIN as " . (defined fileno STDIN ? fileno STDIN : 'undef' ) . "\n" ); } else { _open \*STDIN, "<" . File::Spec->devnull; # _debug( "# proxied STDIN as " . (defined fileno STDIN ? fileno STDIN : 'undef' ) . "\n" ); _open $dup{stdin} = IO::Handle->new, "<&=STDIN"; } $proxies{stdin} = \*STDIN; binmode(STDIN, ':utf8') if $] >= 5.008; ## no critic } if ( ! defined fileno STDOUT ) { $proxy_count{stdout}++; if (defined $dup{stdout}) { _open \*STDOUT, ">&=" . fileno($dup{stdout}); # _debug( "# restored proxy STDOUT as " . (defined fileno STDOUT ? fileno STDOUT : 'undef' ) . "\n" ); } else { _open \*STDOUT, ">" . File::Spec->devnull; # _debug( "# proxied STDOUT as " . (defined fileno STDOUT ? fileno STDOUT : 'undef' ) . "\n" ); _open $dup{stdout} = IO::Handle->new, ">&=STDOUT"; } $proxies{stdout} = \*STDOUT; binmode(STDOUT, ':utf8') if $] >= 5.008; ## no critic } if ( ! defined fileno STDERR ) { $proxy_count{stderr}++; if (defined $dup{stderr}) { _open \*STDERR, ">&=" . fileno($dup{stderr}); # _debug( "# restored proxy STDERR as " . (defined fileno STDERR ? fileno STDERR : 'undef' ) . "\n" ); } else { _open \*STDERR, ">" . File::Spec->devnull; # _debug( "# proxied STDERR as " . (defined fileno STDERR ? fileno STDERR : 'undef' ) . "\n" ); _open $dup{stderr} = IO::Handle->new, ">&=STDERR"; } $proxies{stderr} = \*STDERR; binmode(STDERR, ':utf8') if $] >= 5.008; ## no critic } return %proxies; } sub _unproxy { my (%proxies) = @_; # _debug( "# unproxying: " . join(" ", keys %proxies) . "\n" ); for my $p ( keys %proxies ) { $proxy_count{$p}--; # _debug( "# unproxied " . uc($p) . " ($proxy_count{$p} left)\n" ); if ( ! $proxy_count{$p} ) { _close $proxies{$p}; _close $dup{$p} unless $] < 5.008; # 5.6 will have already closed this as dup delete $dup{$p}; } } } sub _copy_std { my %handles; for my $h ( qw/stdout stderr stdin/ ) { next if $h eq 'stdin' && ! $IS_WIN32; # WIN32 hangs on tee without STDIN copied my $redir = $h eq 'stdin' ? "<&" : ">&"; _open $handles{$h} = IO::Handle->new(), $redir . uc($h); # ">&STDOUT" or "<&STDIN" } return \%handles; } # In some cases we open all (prior to forking) and in others we only open # the output handles (setting up redirection) sub _open_std { my ($handles) = @_; _open \*STDIN, "<&" . fileno $handles->{stdin} if defined $handles->{stdin}; _open \*STDOUT, ">&" . fileno $handles->{stdout} if defined $handles->{stdout}; _open \*STDERR, ">&" . fileno $handles->{stderr} if defined $handles->{stderr}; } #--------------------------------------------------------------------------# # private subs #--------------------------------------------------------------------------# sub _start_tee { my ($which, $stash) = @_; # $which is "stdout" or "stderr" # setup pipes $stash->{$_}{$which} = IO::Handle->new for qw/tee reader/; pipe $stash->{reader}{$which}, $stash->{tee}{$which}; # _debug( "# pipe for $which\: " . _name($stash->{tee}{$which}) . " " . fileno( $stash->{tee}{$which} ) . " => " . _name($stash->{reader}{$which}) . " " . fileno( $stash->{reader}{$which}) . "\n" ); select((select($stash->{tee}{$which}), $|=1)[0]); # autoflush # setup desired redirection for parent and child $stash->{new}{$which} = $stash->{tee}{$which}; $stash->{child}{$which} = { stdin => $stash->{reader}{$which}, stdout => $stash->{old}{$which}, stderr => $stash->{capture}{$which}, }; # flag file is used to signal the child is ready $stash->{flag_files}{$which} = scalar( tmpnam() ) . $$; # execute @cmd as a separate process if ( $IS_WIN32 ) { my $old_eval_err=$@; undef $@; eval "use Win32API::File qw/GetOsFHandle SetHandleInformation fileLastError HANDLE_FLAG_INHERIT INVALID_HANDLE_VALUE/ "; # _debug( "# Win32API::File loaded\n") unless $@; my $os_fhandle = GetOsFHandle( $stash->{tee}{$which} ); # _debug( "# Couldn't get OS handle: " . fileLastError() . "\n") if ! defined $os_fhandle || $os_fhandle == INVALID_HANDLE_VALUE(); my $result = SetHandleInformation( $os_fhandle, HANDLE_FLAG_INHERIT(), 0); # _debug( $result ? "# set no-inherit flag on $which tee\n" : ("# can't disable tee handle flag inherit: " . fileLastError() . "\n")); _open_std( $stash->{child}{$which} ); $stash->{pid}{$which} = system(1, @cmd, $stash->{flag_files}{$which}); # not restoring std here as it all gets redirected again shortly anyway $@=$old_eval_err; } else { # use fork _fork_exec( $which, $stash ); } } sub _fork_exec { my ($which, $stash) = @_; # $which is "stdout" or "stderr" my $pid = fork; if ( not defined $pid ) { Carp::confess "Couldn't fork(): $!"; } elsif ($pid == 0) { # child # _debug( "# in child process ...\n" ); untie *STDIN; untie *STDOUT; untie *STDERR; _close $stash->{tee}{$which}; # _debug( "# redirecting handles in child ...\n" ); _open_std( $stash->{child}{$which} ); # _debug( "# calling exec on command ...\n" ); exec @cmd, $stash->{flag_files}{$which}; } $stash->{pid}{$which} = $pid } my $have_usleep = eval "use Time::HiRes 'usleep'; 1"; sub _files_exist { return 1 if @_ == grep { -f } @_; Time::HiRes::usleep(1000) if $have_usleep; return 0; } sub _wait_for_tees { my ($stash) = @_; my $start = time; my @files = values %{$stash->{flag_files}}; my $timeout = defined $ENV{PERL_CAPTURE_TINY_TIMEOUT} ? $ENV{PERL_CAPTURE_TINY_TIMEOUT} : $TIMEOUT; 1 until _files_exist(@files) || ($timeout && (time - $start > $timeout)); Carp::confess "Timed out waiting for subprocesses to start" if ! _files_exist(@files); unlink $_ for @files; } sub _kill_tees { my ($stash) = @_; if ( $IS_WIN32 ) { # _debug( "# closing handles\n"); close($_) for values %{ $stash->{tee} }; # _debug( "# waiting for subprocesses to finish\n"); my $start = time; 1 until wait == -1 || (time - $start > 30); } else { _close $_ for values %{ $stash->{tee} }; waitpid $_, 0 for values %{ $stash->{pid} }; } } sub _slurp { my ($name, $stash) = @_; my ($fh, $pos) = map { $stash->{$_}{$name} } qw/capture pos/; # _debug( "# slurping captured $name from " . fileno($fh) . " at pos $pos with layers: @{[PerlIO::get_layers($fh)]}\n"); seek( $fh, $pos, 0 ) or die "Couldn't seek on capture handle for $name\n"; my $text = do { local $/; scalar readline $fh }; return defined($text) ? $text : ""; } #--------------------------------------------------------------------------# # _capture_tee() -- generic main sub for capturing or teeing #--------------------------------------------------------------------------# sub _capture_tee { # _debug( "# starting _capture_tee with (@_)...\n" ); my ($do_stdout, $do_stderr, $do_merge, $do_tee, $code, @opts) = @_; my %do = ($do_stdout ? (stdout => 1) : (), $do_stderr ? (stderr => 1) : ()); Carp::confess("Custom capture options must be given as key/value pairs\n") unless @opts % 2 == 0; my $stash = { capture => { @opts } }; for ( keys %{$stash->{capture}} ) { my $fh = $stash->{capture}{$_}; Carp::confess "Custom handle for $_ must be seekable\n" unless ref($fh) eq 'GLOB' || (blessed($fh) && $fh->isa("IO::Seekable")); } # save existing filehandles and setup captures local *CT_ORIG_STDIN = *STDIN ; local *CT_ORIG_STDOUT = *STDOUT; local *CT_ORIG_STDERR = *STDERR; # find initial layers my %layers = ( stdin => [PerlIO::get_layers(\*STDIN) ], stdout => [PerlIO::get_layers(\*STDOUT, output => 1)], stderr => [PerlIO::get_layers(\*STDERR, output => 1)], ); # _debug( "# existing layers for $_\: @{$layers{$_}}\n" ) for qw/stdin stdout stderr/; # get layers from underlying glob of tied filehandles if we can # (this only works for things that work like Tie::StdHandle) $layers{stdout} = [PerlIO::get_layers(tied *STDOUT)] if tied(*STDOUT) && (reftype tied *STDOUT eq 'GLOB'); $layers{stderr} = [PerlIO::get_layers(tied *STDERR)] if tied(*STDERR) && (reftype tied *STDERR eq 'GLOB'); # _debug( "# tied object corrected layers for $_\: @{$layers{$_}}\n" ) for qw/stdin stdout stderr/; # bypass scalar filehandles and tied handles # localize scalar STDIN to get a proxy to pick up FD0, then restore later to CT_ORIG_STDIN my %localize; $localize{stdin}++, local(*STDIN) if grep { $_ eq 'scalar' } @{$layers{stdin}}; $localize{stdout}++, local(*STDOUT) if $do_stdout && grep { $_ eq 'scalar' } @{$layers{stdout}}; $localize{stderr}++, local(*STDERR) if ($do_stderr || $do_merge) && grep { $_ eq 'scalar' } @{$layers{stderr}}; $localize{stdin}++, local(*STDIN), _open( \*STDIN, "<&=0") if tied *STDIN && $] >= 5.008; $localize{stdout}++, local(*STDOUT), _open( \*STDOUT, ">&=1") if $do_stdout && tied *STDOUT && $] >= 5.008; $localize{stderr}++, local(*STDERR), _open( \*STDERR, ">&=2") if ($do_stderr || $do_merge) && tied *STDERR && $] >= 5.008; # _debug( "# localized $_\n" ) for keys %localize; # proxy any closed/localized handles so we don't use fds 0, 1 or 2 my %proxy_std = _proxy_std(); # _debug( "# proxy std: @{ [%proxy_std] }\n" ); # update layers after any proxying $layers{stdout} = [PerlIO::get_layers(\*STDOUT, output => 1)] if $proxy_std{stdout}; $layers{stderr} = [PerlIO::get_layers(\*STDERR, output => 1)] if $proxy_std{stderr}; # _debug( "# post-proxy layers for $_\: @{$layers{$_}}\n" ) for qw/stdin stdout stderr/; # store old handles and setup handles for capture $stash->{old} = _copy_std(); $stash->{new} = { %{$stash->{old}} }; # default to originals for ( keys %do ) { $stash->{new}{$_} = ($stash->{capture}{$_} ||= File::Temp->new); seek( $stash->{capture}{$_}, 0, 2 ) or die "Could not seek on capture handle for $_\n"; $stash->{pos}{$_} = tell $stash->{capture}{$_}; # _debug("# will capture $_ on " . fileno($stash->{capture}{$_})."\n" ); _start_tee( $_ => $stash ) if $do_tee; # tees may change $stash->{new} } _wait_for_tees( $stash ) if $do_tee; # finalize redirection $stash->{new}{stderr} = $stash->{new}{stdout} if $do_merge; # _debug( "# redirecting in parent ...\n" ); _open_std( $stash->{new} ); # execute user provided code my ($exit_code, $inner_error, $outer_error, $orig_pid, @result); { $orig_pid = $$; local *STDIN = *CT_ORIG_STDIN if $localize{stdin}; # get original, not proxy STDIN # _debug( "# finalizing layers ...\n" ); _relayer(\*STDOUT, $layers{stdout}) if $do_stdout; _relayer(\*STDERR, $layers{stderr}) if $do_stderr; # _debug( "# running code $code ...\n" ); my $old_eval_err=$@; undef $@; eval { @result = $code->(); $inner_error = $@ }; $exit_code = $?; # save this for later $outer_error = $@; # save this for later STDOUT->flush if $do_stdout; STDERR->flush if $do_stderr; $@ = $old_eval_err; } # restore prior filehandles and shut down tees # _debug( "# restoring filehandles ...\n" ); _open_std( $stash->{old} ); _close( $_ ) for values %{$stash->{old}}; # don't leak fds # shouldn't need relayering originals, but see rt.perl.org #114404 _relayer(\*STDOUT, $layers{stdout}) if $do_stdout; _relayer(\*STDERR, $layers{stderr}) if $do_stderr; _unproxy( %proxy_std ); # _debug( "# killing tee subprocesses ...\n" ) if $do_tee; _kill_tees( $stash ) if $do_tee; # return captured output, but shortcut in void context # unless we have to echo output to tied/scalar handles; my %got; if ( $orig_pid == $$ and ( defined wantarray or ($do_tee && keys %localize) ) ) { for ( keys %do ) { _relayer($stash->{capture}{$_}, $layers{$_}); $got{$_} = _slurp($_, $stash); # _debug("# slurped " . length($got{$_}) . " bytes from $_\n"); } print CT_ORIG_STDOUT $got{stdout} if $do_stdout && $do_tee && $localize{stdout}; print CT_ORIG_STDERR $got{stderr} if $do_stderr && $do_tee && $localize{stderr}; } $? = $exit_code; $@ = $inner_error if $inner_error; die $outer_error if $outer_error; # _debug( "# ending _capture_tee with (@_)...\n" ); return unless defined wantarray; my @return; push @return, $got{stdout} if $do_stdout; push @return, $got{stderr} if $do_stderr && ! $do_merge; push @return, @result; return wantarray ? @return : $return[0]; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Capture::Tiny - Capture STDOUT and STDERR from Perl, XS or external programs =head1 VERSION version 0.48 =head1 SYNOPSIS use Capture::Tiny ':all'; # capture from external command ($stdout, $stderr, $exit) = capture { system( $cmd, @args ); }; # capture from arbitrary code (Perl or external) ($stdout, $stderr, @result) = capture { # your code here }; # capture partial or merged output $stdout = capture_stdout { ... }; $stderr = capture_stderr { ... }; $merged = capture_merged { ... }; # tee output ($stdout, $stderr) = tee { # your code here }; $stdout = tee_stdout { ... }; $stderr = tee_stderr { ... }; $merged = tee_merged { ... }; =head1 DESCRIPTION Capture::Tiny provides a simple, portable way to capture almost anything sent to STDOUT or STDERR, regardless of whether it comes from Perl, from XS code or from an external program. Optionally, output can be teed so that it is captured while being passed through to the original filehandles. Yes, it even works on Windows (usually). Stop guessing which of a dozen capturing modules to use in any particular situation and just use this one. =head1 USAGE The following functions are available. None are exported by default. =head2 capture ($stdout, $stderr, @result) = capture \&code; $stdout = capture \&code; The C<capture> function takes a code reference and returns what is sent to STDOUT and STDERR as well as any return values from the code reference. In scalar context, it returns only STDOUT. If no output was received for a filehandle, it returns an empty string for that filehandle. Regardless of calling context, all output is captured -- nothing is passed to the existing filehandles. It is prototyped to take a subroutine reference as an argument. Thus, it can be called in block form: ($stdout, $stderr) = capture { # your code here ... }; Note that the coderef is evaluated in list context. If you wish to force scalar context on the return value, you must use the C<scalar> keyword. ($stdout, $stderr, $count) = capture { my @list = qw/one two three/; return scalar @list; # $count will be 3 }; Also note that within the coderef, the C<@_> variable will be empty. So don't use arguments from a surrounding subroutine without copying them to an array first: sub wont_work { my ($stdout, $stderr) = capture { do_stuff( @_ ) }; # WRONG ... } sub will_work { my @args = @_; my ($stdout, $stderr) = capture { do_stuff( @args ) }; # RIGHT ... } Captures are normally done to an anonymous temporary filehandle. To capture via a named file (e.g. to externally monitor a long-running capture), provide custom filehandles as a trailing list of option pairs: my $out_fh = IO::File->new("out.txt", "w+"); my $err_fh = IO::File->new("out.txt", "w+"); capture { ... } stdout => $out_fh, stderr => $err_fh; The filehandles must be read/write and seekable. Modifying the files or filehandles during a capture operation will give unpredictable results. Existing IO layers on them may be changed by the capture. When called in void context, C<capture> saves memory and time by not reading back from the capture handles. =head2 capture_stdout ($stdout, @result) = capture_stdout \&code; $stdout = capture_stdout \&code; The C<capture_stdout> function works just like C<capture> except only STDOUT is captured. STDERR is not captured. =head2 capture_stderr ($stderr, @result) = capture_stderr \&code; $stderr = capture_stderr \&code; The C<capture_stderr> function works just like C<capture> except only STDERR is captured. STDOUT is not captured. =head2 capture_merged ($merged, @result) = capture_merged \&code; $merged = capture_merged \&code; The C<capture_merged> function works just like C<capture> except STDOUT and STDERR are merged. (Technically, STDERR is redirected to the same capturing handle as STDOUT before executing the function.) Caution: STDOUT and STDERR output in the merged result are not guaranteed to be properly ordered due to buffering. =head2 tee ($stdout, $stderr, @result) = tee \&code; $stdout = tee \&code; The C<tee> function works just like C<capture>, except that output is captured as well as passed on to the original STDOUT and STDERR. When called in void context, C<tee> saves memory and time by not reading back from the capture handles, except when the original STDOUT OR STDERR were tied or opened to a scalar handle. =head2 tee_stdout ($stdout, @result) = tee_stdout \&code; $stdout = tee_stdout \&code; The C<tee_stdout> function works just like C<tee> except only STDOUT is teed. STDERR is not teed (output goes to STDERR as usual). =head2 tee_stderr ($stderr, @result) = tee_stderr \&code; $stderr = tee_stderr \&code; The C<tee_stderr> function works just like C<tee> except only STDERR is teed. STDOUT is not teed (output goes to STDOUT as usual). =head2 tee_merged ($merged, @result) = tee_merged \&code; $merged = tee_merged \&code; The C<tee_merged> function works just like C<capture_merged> except that output is captured as well as passed on to STDOUT. Caution: STDOUT and STDERR output in the merged result are not guaranteed to be properly ordered due to buffering. =head1 LIMITATIONS =head2 Portability Portability is a goal, not a guarantee. C<tee> requires fork, except on Windows where C<system(1, @cmd)> is used instead. Not tested on any particularly esoteric platforms yet. See the L<CPAN Testers Matrix|http://matrix.cpantesters.org/?dist=Capture-Tiny> for test result by platform. =head2 PerlIO layers Capture::Tiny does its best to preserve PerlIO layers such as ':utf8' or ':crlf' when capturing (only for Perl 5.8.1+) . Layers should be applied to STDOUT or STDERR I<before> the call to C<capture> or C<tee>. This may not work for tied filehandles (see below). =head2 Modifying filehandles before capturing Generally speaking, you should do little or no manipulation of the standard IO filehandles prior to using Capture::Tiny. In particular, closing, reopening, localizing or tying standard filehandles prior to capture may cause a variety of unexpected, undesirable and/or unreliable behaviors, as described below. Capture::Tiny does its best to compensate for these situations, but the results may not be what you desire. =head3 Closed filehandles Capture::Tiny will work even if STDIN, STDOUT or STDERR have been previously closed. However, since they will be reopened to capture or tee output, any code within the captured block that depends on finding them closed will, of course, not find them to be closed. If they started closed, Capture::Tiny will close them again when the capture block finishes. Note that this reopening will happen even for STDIN or a filehandle not being captured to ensure that the filehandle used for capture is not opened to file descriptor 0, as this causes problems on various platforms. Prior to Perl 5.12, closed STDIN combined with PERL_UNICODE=D leaks filehandles and also breaks tee() for undiagnosed reasons. So don't do that. =head3 Localized filehandles If code localizes any of Perl's standard filehandles before capturing, the capture will affect the localized filehandles and not the original ones. External system calls are not affected by localizing a filehandle in Perl and will continue to send output to the original filehandles (which will thus not be captured). =head3 Scalar filehandles If STDOUT or STDERR are reopened to scalar filehandles prior to the call to C<capture> or C<tee>, then Capture::Tiny will override the output filehandle for the duration of the C<capture> or C<tee> call and then, for C<tee>, send captured output to the output filehandle after the capture is complete. (Requires Perl 5.8) Capture::Tiny attempts to preserve the semantics of STDIN opened to a scalar reference, but note that external processes will not be able to read from such a handle. Capture::Tiny tries to ensure that external processes will read from the null device instead, but this is not guaranteed. =head3 Tied output filehandles If STDOUT or STDERR are tied prior to the call to C<capture> or C<tee>, then Capture::Tiny will attempt to override the tie for the duration of the C<capture> or C<tee> call and then send captured output to the tied filehandle after the capture is complete. (Requires Perl 5.8) Capture::Tiny may not succeed resending UTF-8 encoded data to a tied STDOUT or STDERR filehandle. Characters may appear as bytes. If the tied filehandle is based on L<Tie::StdHandle>, then Capture::Tiny will attempt to determine appropriate layers like C<:utf8> from the underlying filehandle and do the right thing. =head3 Tied input filehandle Capture::Tiny attempts to preserve the semantics of tied STDIN, but this requires Perl 5.8 and is not entirely predictable. External processes will not be able to read from such a handle. Unless having STDIN tied is crucial, it may be safest to localize STDIN when capturing: my ($out, $err) = do { local *STDIN; capture { ... } }; =head2 Modifying filehandles during a capture Attempting to modify STDIN, STDOUT or STDERR I<during> C<capture> or C<tee> is almost certainly going to cause problems. Don't do that. =head3 Forking inside a capture Forks aren't portable. The behavior of filehandles during a fork is even less so. If Capture::Tiny detects that a fork has occurred within a capture, it will shortcut in the child process and return empty strings for captures. Other problems may occur in the child or parent, as well. Forking in a capture block is not recommended. =head3 Using threads Filehandles are global. Mixing up I/O and captures in different threads without coordination is going to cause problems. Besides, threads are officially discouraged. =head3 Dropping privileges during a capture If you drop privileges during a capture, temporary files created to facilitate the capture may not be cleaned up afterwards. =head2 No support for Perl 5.8.0 It's just too buggy when it comes to layers and UTF-8. Perl 5.8.1 or later is recommended. =head2 Limited support for Perl 5.6 Perl 5.6 predates PerlIO. UTF-8 data may not be captured correctly. =head1 ENVIRONMENT =head2 PERL_CAPTURE_TINY_TIMEOUT Capture::Tiny uses subprocesses internally for C<tee>. By default, Capture::Tiny will timeout with an error if such subprocesses are not ready to receive data within 30 seconds (or whatever is the value of C<$Capture::Tiny::TIMEOUT>). An alternate timeout may be specified by setting the C<PERL_CAPTURE_TINY_TIMEOUT> environment variable. Setting it to zero will disable timeouts. B<NOTE>, this does not timeout the code reference being captured -- this only prevents Capture::Tiny itself from hanging your process waiting for its child processes to be ready to proceed. =head1 SEE ALSO This module was inspired by L<IO::CaptureOutput>, which provides similar functionality without the ability to tee output and with more complicated code and API. L<IO::CaptureOutput> does not handle layers or most of the unusual cases described in the L</Limitations> section and I no longer recommend it. There are many other CPAN modules that provide some sort of output capture, albeit with various limitations that make them appropriate only in particular circumstances. I'm probably missing some. The long list is provided to show why I felt Capture::Tiny was necessary. =over 4 =item * L<IO::Capture> =item * L<IO::Capture::Extended> =item * L<IO::CaptureOutput> =item * L<IPC::Capture> =item * L<IPC::Cmd> =item * L<IPC::Open2> =item * L<IPC::Open3> =item * L<IPC::Open3::Simple> =item * L<IPC::Open3::Utils> =item * L<IPC::Run> =item * L<IPC::Run::SafeHandles> =item * L<IPC::Run::Simple> =item * L<IPC::Run3> =item * L<IPC::System::Simple> =item * L<Tee> =item * L<IO::Tee> =item * L<File::Tee> =item * L<Filter::Handle> =item * L<Tie::STDERR> =item * L<Tie::STDOUT> =item * L<Test::Output> =back =for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan =head1 SUPPORT =head2 Bugs / Feature Requests Please report any bugs or feature requests through the issue tracker at L<https://github.com/dagolden/Capture-Tiny/issues>. You will be notified automatically of any progress on your issue. =head2 Source Code This is open source software. The code repository is available for public review and contribution under the terms of the license. L<https://github.com/dagolden/Capture-Tiny> git clone https://github.com/dagolden/Capture-Tiny.git =head1 AUTHOR David Golden <dagolden@cpan.org> =head1 CONTRIBUTORS =for stopwords Dagfinn Ilmari Mannsåker David E. Wheeler fecundf Graham Knop Peter Rabbitson =over 4 =item * Dagfinn Ilmari Mannsåker <ilmari@ilmari.org> =item * David E. Wheeler <david@justatheory.com> =item * fecundf <not.com+github@gmail.com> =item * Graham Knop <haarg@haarg.org> =item * Peter Rabbitson <ribasushi@cpan.org> =back =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2009 by David Golden. This is free software, licensed under: The Apache License, Version 2.0, January 2004 =cut CAPTURE_TINY $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP'; package JSON::PP; # JSON-2.0 use 5.008; use strict; use Exporter (); BEGIN { our @ISA = ('Exporter') } use overload (); use JSON::PP::Boolean; use Carp (); use Scalar::Util qw(blessed reftype refaddr); #use Devel::Peek; our $VERSION = '4.16'; our @EXPORT = qw(encode_json decode_json from_json to_json); # instead of hash-access, i tried index-access for speed. # but this method is not faster than what i expected. so it will be changed. use constant P_ASCII => 0; use constant P_LATIN1 => 1; use constant P_UTF8 => 2; use constant P_INDENT => 3; use constant P_CANONICAL => 4; use constant P_SPACE_BEFORE => 5; use constant P_SPACE_AFTER => 6; use constant P_ALLOW_NONREF => 7; use constant P_SHRINK => 8; use constant P_ALLOW_BLESSED => 9; use constant P_CONVERT_BLESSED => 10; use constant P_RELAXED => 11; use constant P_LOOSE => 12; use constant P_ALLOW_BIGNUM => 13; use constant P_ALLOW_BAREKEY => 14; use constant P_ALLOW_SINGLEQUOTE => 15; use constant P_ESCAPE_SLASH => 16; use constant P_AS_NONBLESSED => 17; use constant P_ALLOW_UNKNOWN => 18; use constant P_ALLOW_TAGS => 19; use constant USE_B => $ENV{PERL_JSON_PP_USE_B} || 0; use constant CORE_BOOL => defined &builtin::is_bool; my $invalid_char_re; BEGIN { $invalid_char_re = "["; for my $i (0 .. 0x01F, 0x22, 0x5c) { # '/' is ok $invalid_char_re .= quotemeta chr utf8::unicode_to_native($i); } $invalid_char_re = qr/$invalid_char_re]/; } BEGIN { if (USE_B) { require B; } } BEGIN { my @xs_compati_bit_properties = qw( latin1 ascii utf8 indent canonical space_before space_after allow_nonref shrink allow_blessed convert_blessed relaxed allow_unknown allow_tags ); my @pp_bit_properties = qw( allow_singlequote allow_bignum loose allow_barekey escape_slash as_nonblessed ); for my $name (@xs_compati_bit_properties, @pp_bit_properties) { my $property_id = 'P_' . uc($name); eval qq/ sub $name { my \$enable = defined \$_[1] ? \$_[1] : 1; if (\$enable) { \$_[0]->{PROPS}->[$property_id] = 1; } else { \$_[0]->{PROPS}->[$property_id] = 0; } \$_[0]; } sub get_$name { \$_[0]->{PROPS}->[$property_id] ? 1 : ''; } /; } } # Functions my $JSON; # cache sub encode_json ($) { # encode ($JSON ||= __PACKAGE__->new->utf8)->encode(@_); } sub decode_json { # decode ($JSON ||= __PACKAGE__->new->utf8)->decode(@_); } # Obsoleted sub to_json($) { Carp::croak ("JSON::PP::to_json has been renamed to encode_json."); } sub from_json($) { Carp::croak ("JSON::PP::from_json has been renamed to decode_json."); } # Methods sub new { my $class = shift; my $self = { max_depth => 512, max_size => 0, indent_length => 3, }; $self->{PROPS}[P_ALLOW_NONREF] = 1; bless $self, $class; } sub encode { return $_[0]->PP_encode_json($_[1]); } sub decode { return $_[0]->PP_decode_json($_[1], 0x00000000); } sub decode_prefix { return $_[0]->PP_decode_json($_[1], 0x00000001); } # accessor # pretty printing sub pretty { my ($self, $v) = @_; my $enable = defined $v ? $v : 1; if ($enable) { # indent_length(3) for JSON::XS compatibility $self->indent(1)->space_before(1)->space_after(1); } else { $self->indent(0)->space_before(0)->space_after(0); } $self; } # etc sub max_depth { my $max = defined $_[1] ? $_[1] : 0x80000000; $_[0]->{max_depth} = $max; $_[0]; } sub get_max_depth { $_[0]->{max_depth}; } sub max_size { my $max = defined $_[1] ? $_[1] : 0; $_[0]->{max_size} = $max; $_[0]; } sub get_max_size { $_[0]->{max_size}; } sub boolean_values { my $self = shift; if (@_) { my ($false, $true) = @_; $self->{false} = $false; $self->{true} = $true; if (CORE_BOOL) { BEGIN { CORE_BOOL and warnings->unimport(qw(experimental::builtin)) } if (builtin::is_bool($true) && builtin::is_bool($false) && $true && !$false) { $self->{core_bools} = !!1; } else { delete $self->{core_bools}; } } } else { delete $self->{false}; delete $self->{true}; delete $self->{core_bools}; } return $self; } sub core_bools { my $self = shift; my $core_bools = defined $_[0] ? $_[0] : 1; if ($core_bools) { $self->{true} = !!1; $self->{false} = !!0; $self->{core_bools} = !!1; } else { $self->{true} = $JSON::PP::true; $self->{false} = $JSON::PP::false; $self->{core_bools} = !!0; } return $self; } sub get_core_bools { my $self = shift; return !!$self->{core_bools}; } sub unblessed_bool { my $self = shift; return $self->core_bools(@_); } sub get_unblessed_bool { my $self = shift; return $self->get_core_bools(@_); } sub get_boolean_values { my $self = shift; if (exists $self->{true} and exists $self->{false}) { return @$self{qw/false true/}; } return; } sub filter_json_object { if (defined $_[1] and ref $_[1] eq 'CODE') { $_[0]->{cb_object} = $_[1]; } else { delete $_[0]->{cb_object}; } $_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0; $_[0]; } sub filter_json_single_key_object { if (@_ == 1 or @_ > 3) { Carp::croak("Usage: JSON::PP::filter_json_single_key_object(self, key, callback = undef)"); } if (defined $_[2] and ref $_[2] eq 'CODE') { $_[0]->{cb_sk_object}->{$_[1]} = $_[2]; } else { delete $_[0]->{cb_sk_object}->{$_[1]}; delete $_[0]->{cb_sk_object} unless %{$_[0]->{cb_sk_object} || {}}; } $_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0; $_[0]; } sub indent_length { if (!defined $_[1] or $_[1] > 15 or $_[1] < 0) { Carp::carp "The acceptable range of indent_length() is 0 to 15."; } else { $_[0]->{indent_length} = $_[1]; } $_[0]; } sub get_indent_length { $_[0]->{indent_length}; } sub sort_by { $_[0]->{sort_by} = defined $_[1] ? $_[1] : 1; $_[0]; } sub allow_bigint { Carp::carp("allow_bigint() is obsoleted. use allow_bignum() instead."); $_[0]->allow_bignum; } ############################### ### ### Perl => JSON ### { # Convert my $max_depth; my $indent; my $ascii; my $latin1; my $utf8; my $space_before; my $space_after; my $canonical; my $allow_blessed; my $convert_blessed; my $indent_length; my $escape_slash; my $bignum; my $as_nonblessed; my $allow_tags; my $depth; my $indent_count; my $keysort; sub PP_encode_json { my $self = shift; my $obj = shift; $indent_count = 0; $depth = 0; my $props = $self->{PROPS}; ($ascii, $latin1, $utf8, $indent, $canonical, $space_before, $space_after, $allow_blessed, $convert_blessed, $escape_slash, $bignum, $as_nonblessed, $allow_tags) = @{$props}[P_ASCII .. P_SPACE_AFTER, P_ALLOW_BLESSED, P_CONVERT_BLESSED, P_ESCAPE_SLASH, P_ALLOW_BIGNUM, P_AS_NONBLESSED, P_ALLOW_TAGS]; ($max_depth, $indent_length) = @{$self}{qw/max_depth indent_length/}; $keysort = $canonical ? sub { $a cmp $b } : undef; if ($self->{sort_by}) { $keysort = ref($self->{sort_by}) eq 'CODE' ? $self->{sort_by} : $self->{sort_by} =~ /\D+/ ? $self->{sort_by} : sub { $a cmp $b }; } encode_error("hash- or arrayref expected (not a simple scalar, use allow_nonref to allow this)") if(!ref $obj and !$props->[ P_ALLOW_NONREF ]); my $str = $self->object_to_json($obj); $str .= "\n" if ( $indent ); # JSON::XS 2.26 compatible return $str; } sub object_to_json { my ($self, $obj) = @_; my $type = ref($obj); if($type eq 'HASH'){ return $self->hash_to_json($obj); } elsif($type eq 'ARRAY'){ return $self->array_to_json($obj); } elsif ($type) { # blessed object? if (blessed($obj)) { return $self->value_to_json($obj) if ( $obj->isa('JSON::PP::Boolean') ); if ( $allow_tags and $obj->can('FREEZE') ) { my $obj_class = ref $obj || $obj; $obj = bless $obj, $obj_class; my @results = $obj->FREEZE('JSON'); if ( @results and ref $results[0] ) { if ( refaddr( $obj ) eq refaddr( $results[0] ) ) { encode_error( sprintf( "%s::FREEZE method returned same object as was passed instead of a new one", ref $obj ) ); } } return '("'.$obj_class.'")['.join(',', @results).']'; } if ( $convert_blessed and $obj->can('TO_JSON') ) { my $result = $obj->TO_JSON(); if ( defined $result and ref( $result ) ) { if ( refaddr( $obj ) eq refaddr( $result ) ) { encode_error( sprintf( "%s::TO_JSON method returned same object as was passed instead of a new one", ref $obj ) ); } } return $self->object_to_json( $result ); } return "$obj" if ( $bignum and _is_bignum($obj) ); if ($allow_blessed) { return $self->blessed_to_json($obj) if ($as_nonblessed); # will be removed. return 'null'; } encode_error( sprintf("encountered object '%s', but neither allow_blessed, convert_blessed nor allow_tags settings are enabled (or TO_JSON/FREEZE method missing)", $obj) ); } else { return $self->value_to_json($obj); } } else{ return $self->value_to_json($obj); } } sub hash_to_json { my ($self, $obj) = @_; my @res; encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)") if (++$depth > $max_depth); my ($pre, $post) = $indent ? $self->_up_indent() : ('', ''); my $del = ($space_before ? ' ' : '') . ':' . ($space_after ? ' ' : ''); for my $k ( _sort( $obj ) ) { push @res, $self->string_to_json( $k ) . $del . ( ref $obj->{$k} ? $self->object_to_json( $obj->{$k} ) : $self->value_to_json( $obj->{$k} ) ); } --$depth; $self->_down_indent() if ($indent); return '{}' unless @res; return '{' . $pre . join( ",$pre", @res ) . $post . '}'; } sub array_to_json { my ($self, $obj) = @_; my @res; encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)") if (++$depth > $max_depth); my ($pre, $post) = $indent ? $self->_up_indent() : ('', ''); for my $v (@$obj){ push @res, ref($v) ? $self->object_to_json($v) : $self->value_to_json($v); } --$depth; $self->_down_indent() if ($indent); return '[]' unless @res; return '[' . $pre . join( ",$pre", @res ) . $post . ']'; } sub _looks_like_number { my $value = shift; if (USE_B) { my $b_obj = B::svref_2object(\$value); my $flags = $b_obj->FLAGS; return 1 if $flags & ( B::SVp_IOK() | B::SVp_NOK() ) and !( $flags & B::SVp_POK() ); return; } else { no warnings 'numeric'; # if the utf8 flag is on, it almost certainly started as a string return if utf8::is_utf8($value); # detect numbers # string & "" -> "" # number & "" -> 0 (with warning) # nan and inf can detect as numbers, so check with * 0 return unless length((my $dummy = "") & $value); return unless 0 + $value eq $value; return 1 if $value * 0 == 0; return -1; # inf/nan } } sub value_to_json { my ($self, $value) = @_; return 'null' if(!defined $value); my $type = ref($value); if (!$type) { BEGIN { CORE_BOOL and warnings->unimport('experimental::builtin') } if (CORE_BOOL && builtin::is_bool($value)) { return $value ? 'true' : 'false'; } elsif (_looks_like_number($value)) { return $value; } return $self->string_to_json($value); } elsif( blessed($value) and $value->isa('JSON::PP::Boolean') ){ return $$value == 1 ? 'true' : 'false'; } else { if ((overload::StrVal($value) =~ /=(\w+)/)[0]) { return $self->value_to_json("$value"); } if ($type eq 'SCALAR' and defined $$value) { return $$value eq '1' ? 'true' : $$value eq '0' ? 'false' : $self->{PROPS}->[ P_ALLOW_UNKNOWN ] ? 'null' : encode_error("cannot encode reference to scalar"); } if ( $self->{PROPS}->[ P_ALLOW_UNKNOWN ] ) { return 'null'; } else { if ( $type eq 'SCALAR' or $type eq 'REF' ) { encode_error("cannot encode reference to scalar"); } else { encode_error("encountered $value, but JSON can only represent references to arrays or hashes"); } } } } my %esc = ( "\n" => '\n', "\r" => '\r', "\t" => '\t', "\f" => '\f', "\b" => '\b', "\"" => '\"', "\\" => '\\\\', "\'" => '\\\'', ); sub string_to_json { my ($self, $arg) = @_; $arg =~ s/(["\\\n\r\t\f\b])/$esc{$1}/g; $arg =~ s/\//\\\//g if ($escape_slash); # On ASCII platforms, matches [\x00-\x08\x0b\x0e-\x1f] $arg =~ s/([^\n\t\c?[:^cntrl:][:^ascii:]])/'\\u00' . unpack('H2', $1)/eg; if ($ascii) { $arg = _encode_ascii($arg); } if ($latin1) { $arg = _encode_latin1($arg); } if ($utf8) { utf8::encode($arg); } return '"' . $arg . '"'; } sub blessed_to_json { my $reftype = reftype($_[1]) || ''; if ($reftype eq 'HASH') { return $_[0]->hash_to_json($_[1]); } elsif ($reftype eq 'ARRAY') { return $_[0]->array_to_json($_[1]); } else { return 'null'; } } sub encode_error { my $error = shift; Carp::croak "$error"; } sub _sort { defined $keysort ? (sort $keysort (keys %{$_[0]})) : keys %{$_[0]}; } sub _up_indent { my $self = shift; my $space = ' ' x $indent_length; my ($pre,$post) = ('',''); $post = "\n" . $space x $indent_count; $indent_count++; $pre = "\n" . $space x $indent_count; return ($pre,$post); } sub _down_indent { $indent_count--; } sub PP_encode_box { { depth => $depth, indent_count => $indent_count, }; } } # Convert sub _encode_ascii { join('', map { chr($_) =~ /[[:ascii:]]/ ? chr($_) : $_ <= 65535 ? sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_)); } unpack('U*', $_[0]) ); } sub _encode_latin1 { join('', map { $_ <= 255 ? chr($_) : $_ <= 65535 ? sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_)); } unpack('U*', $_[0]) ); } sub _encode_surrogates { # from perlunicode my $uni = $_[0] - 0x10000; return ($uni / 0x400 + 0xD800, $uni % 0x400 + 0xDC00); } sub _is_bignum { $_[0]->isa('Math::BigInt') or $_[0]->isa('Math::BigFloat'); } # # JSON => Perl # my $max_intsize; BEGIN { my $checkint = 1111; for my $d (5..64) { $checkint .= 1; my $int = eval qq| $checkint |; if ($int =~ /[eE]/) { $max_intsize = $d - 1; last; } } } { # PARSE my %escapes = ( # by Jeremy Muhlich <jmuhlich [at] bitflood.org> b => "\b", t => "\t", n => "\n", f => "\f", r => "\r", '\\' => '\\', '"' => '"', '/' => '/', ); my $text; # json data my $at; # offset my $ch; # first character my $len; # text length (changed according to UTF8 or NON UTF8) # INTERNAL my $depth; # nest counter my $encoding; # json text encoding my $is_valid_utf8; # temp variable my $utf8_len; # utf8 byte length # FLAGS my $utf8; # must be utf8 my $max_depth; # max nest number of objects and arrays my $max_size; my $relaxed; my $cb_object; my $cb_sk_object; my $F_HOOK; my $allow_bignum; # using Math::BigInt/BigFloat my $singlequote; # loosely quoting my $loose; # my $allow_barekey; # bareKey my $allow_tags; my $alt_true; my $alt_false; sub _detect_utf_encoding { my $text = shift; my @octets = unpack('C4', $text); return 'unknown' unless defined $octets[3]; return ( $octets[0] and $octets[1]) ? 'UTF-8' : (!$octets[0] and $octets[1]) ? 'UTF-16BE' : (!$octets[0] and !$octets[1]) ? 'UTF-32BE' : ( $octets[2] ) ? 'UTF-16LE' : (!$octets[2] ) ? 'UTF-32LE' : 'unknown'; } sub PP_decode_json { my ($self, $want_offset); ($self, $text, $want_offset) = @_; ($at, $ch, $depth) = (0, '', 0); if ( !defined $text or ref $text ) { decode_error("malformed JSON string, neither array, object, number, string or atom"); } my $props = $self->{PROPS}; ($utf8, $relaxed, $loose, $allow_bignum, $allow_barekey, $singlequote, $allow_tags) = @{$props}[P_UTF8, P_RELAXED, P_LOOSE .. P_ALLOW_SINGLEQUOTE, P_ALLOW_TAGS]; ($alt_true, $alt_false) = @$self{qw/true false/}; if ( $utf8 ) { $encoding = _detect_utf_encoding($text); if ($encoding ne 'UTF-8' and $encoding ne 'unknown') { require Encode; Encode::from_to($text, $encoding, 'utf-8'); } else { utf8::downgrade( $text, 1 ) or Carp::croak("Wide character in subroutine entry"); } } else { utf8::encode( $text ); } $len = length $text; ($max_depth, $max_size, $cb_object, $cb_sk_object, $F_HOOK) = @{$self}{qw/max_depth max_size cb_object cb_sk_object F_HOOK/}; if ($max_size > 1) { use bytes; my $bytes = length $text; decode_error( sprintf("attempted decode of JSON text of %s bytes size, but max_size is set to %s" , $bytes, $max_size), 1 ) if ($bytes > $max_size); } white(); # remove head white space decode_error("malformed JSON string, neither array, object, number, string or atom") unless defined $ch; # Is there a first character for JSON structure? my $result = value(); if ( !$props->[ P_ALLOW_NONREF ] and !ref $result ) { decode_error( 'JSON text must be an object or array (but found number, string, true, false or null,' . ' use allow_nonref to allow this)', 1); } Carp::croak('something wrong.') if $len < $at; # we won't arrive here. my $consumed = defined $ch ? $at - 1 : $at; # consumed JSON text length white(); # remove tail white space return ( $result, $consumed ) if $want_offset; # all right if decode_prefix decode_error("garbage after JSON object") if defined $ch; $result; } sub next_chr { return $ch = undef if($at >= $len); $ch = substr($text, $at++, 1); } sub value { white(); return if(!defined $ch); return object() if($ch eq '{'); return array() if($ch eq '['); return tag() if($ch eq '('); return string() if($ch eq '"' or ($singlequote and $ch eq "'")); return number() if($ch =~ /[0-9]/ or $ch eq '-'); return word(); } sub string { my $utf16; my $is_utf8; ($is_valid_utf8, $utf8_len) = ('', 0); my $s = ''; # basically UTF8 flag on if($ch eq '"' or ($singlequote and $ch eq "'")){ my $boundChar = $ch; OUTER: while( defined(next_chr()) ){ if($ch eq $boundChar){ next_chr(); if ($utf16) { decode_error("missing low surrogate character in surrogate pair"); } utf8::decode($s) if($is_utf8); return $s; } elsif($ch eq '\\'){ next_chr(); if(exists $escapes{$ch}){ $s .= $escapes{$ch}; } elsif($ch eq 'u'){ # UNICODE handling my $u = ''; for(1..4){ $ch = next_chr(); last OUTER if($ch !~ /[0-9a-fA-F]/); $u .= $ch; } # U+D800 - U+DBFF if ($u =~ /^[dD][89abAB][0-9a-fA-F]{2}/) { # UTF-16 high surrogate? $utf16 = $u; } # U+DC00 - U+DFFF elsif ($u =~ /^[dD][c-fC-F][0-9a-fA-F]{2}/) { # UTF-16 low surrogate? unless (defined $utf16) { decode_error("missing high surrogate character in surrogate pair"); } $is_utf8 = 1; $s .= _decode_surrogates($utf16, $u) || next; $utf16 = undef; } else { if (defined $utf16) { decode_error("surrogate pair expected"); } my $hex = hex( $u ); if ( chr $u =~ /[[:^ascii:]]/ ) { $is_utf8 = 1; $s .= _decode_unicode($u) || next; } else { $s .= chr $hex; } } } else{ unless ($loose) { $at -= 2; decode_error('illegal backslash escape sequence in string'); } $s .= $ch; } } else{ if ( $ch =~ /[[:^ascii:]]/ ) { unless( $ch = is_valid_utf8($ch) ) { $at -= 1; decode_error("malformed UTF-8 character in JSON string"); } else { $at += $utf8_len - 1; } $is_utf8 = 1; } if (!$loose) { if ($ch =~ $invalid_char_re) { # '/' ok if (!$relaxed or $ch ne "\t") { $at--; decode_error(sprintf "invalid character 0x%X" . " encountered while parsing JSON string", ord $ch); } } } $s .= $ch; } } } decode_error("unexpected end of string while parsing JSON string"); } sub white { while( defined $ch ){ if($ch eq '' or $ch =~ /\A[ \t\r\n]\z/){ next_chr(); } elsif($relaxed and $ch eq '/'){ next_chr(); if(defined $ch and $ch eq '/'){ 1 while(defined(next_chr()) and $ch ne "\n" and $ch ne "\r"); } elsif(defined $ch and $ch eq '*'){ next_chr(); while(1){ if(defined $ch){ if($ch eq '*'){ if(defined(next_chr()) and $ch eq '/'){ next_chr(); last; } } else{ next_chr(); } } else{ decode_error("Unterminated comment"); } } next; } else{ $at--; decode_error("malformed JSON string, neither array, object, number, string or atom"); } } else{ if ($relaxed and $ch eq '#') { # correctly? pos($text) = $at; $text =~ /\G([^\n]*(?:\r\n|\r|\n|$))/g; $at = pos($text); next_chr; next; } last; } } } sub array { my $a = $_[0] || []; # you can use this code to use another array ref object. decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)') if (++$depth > $max_depth); next_chr(); white(); if(defined $ch and $ch eq ']'){ --$depth; next_chr(); return $a; } else { while(defined($ch)){ push @$a, value(); white(); if (!defined $ch) { last; } if($ch eq ']'){ --$depth; next_chr(); return $a; } if($ch ne ','){ last; } next_chr(); white(); if ($relaxed and $ch eq ']') { --$depth; next_chr(); return $a; } } } $at-- if defined $ch and $ch ne ''; decode_error(", or ] expected while parsing array"); } sub tag { decode_error('malformed JSON string, neither array, object, number, string or atom') unless $allow_tags; next_chr(); white(); my $tag = value(); return unless defined $tag; decode_error('malformed JSON string, (tag) must be a string') if ref $tag; white(); if (!defined $ch or $ch ne ')') { decode_error(') expected after tag'); } next_chr(); white(); my $val = value(); return unless defined $val; decode_error('malformed JSON string, tag value must be an array') unless ref $val eq 'ARRAY'; if (!eval { $tag->can('THAW') }) { decode_error('cannot decode perl-object (package does not exist)') if $@; decode_error('cannot decode perl-object (package does not have a THAW method)'); } $tag->THAW('JSON', @$val); } sub object { my $o = $_[0] || {}; # you can use this code to use another hash ref object. my $k; decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)') if (++$depth > $max_depth); next_chr(); white(); if(defined $ch and $ch eq '}'){ --$depth; next_chr(); if ($F_HOOK) { return _json_object_hook($o); } return $o; } else { while (defined $ch) { $k = ($allow_barekey and $ch ne '"' and $ch ne "'") ? bareKey() : string(); white(); if(!defined $ch or $ch ne ':'){ $at--; decode_error("':' expected"); } next_chr(); $o->{$k} = value(); white(); last if (!defined $ch); if($ch eq '}'){ --$depth; next_chr(); if ($F_HOOK) { return _json_object_hook($o); } return $o; } if($ch ne ','){ last; } next_chr(); white(); if ($relaxed and $ch eq '}') { --$depth; next_chr(); if ($F_HOOK) { return _json_object_hook($o); } return $o; } } } $at-- if defined $ch and $ch ne ''; decode_error(", or } expected while parsing object/hash"); } sub bareKey { # doesn't strictly follow Standard ECMA-262 3rd Edition my $key; while($ch =~ /[\$\w[:^ascii:]]/){ $key .= $ch; next_chr(); } return $key; } sub word { my $word = substr($text,$at-1,4); if($word eq 'true'){ $at += 3; next_chr; return defined $alt_true ? $alt_true : $JSON::PP::true; } elsif($word eq 'null'){ $at += 3; next_chr; return undef; } elsif($word eq 'fals'){ $at += 3; if(substr($text,$at,1) eq 'e'){ $at++; next_chr; return defined $alt_false ? $alt_false : $JSON::PP::false; } } $at--; # for decode_error report decode_error("'null' expected") if ($word =~ /^n/); decode_error("'true' expected") if ($word =~ /^t/); decode_error("'false' expected") if ($word =~ /^f/); decode_error("malformed JSON string, neither array, object, number, string or atom"); } sub number { my $n = ''; my $v; my $is_dec; my $is_exp; if($ch eq '-'){ $n = '-'; next_chr; if (!defined $ch or $ch !~ /\d/) { decode_error("malformed number (no digits after initial minus)"); } } # According to RFC4627, hex or oct digits are invalid. if($ch eq '0'){ my $peek = substr($text,$at,1); if($peek =~ /^[0-9a-dfA-DF]/){ # e may be valid (exponential) decode_error("malformed number (leading zero must not be followed by another digit)"); } $n .= $ch; next_chr; } while(defined $ch and $ch =~ /\d/){ $n .= $ch; next_chr; } if(defined $ch and $ch eq '.'){ $n .= '.'; $is_dec = 1; next_chr; if (!defined $ch or $ch !~ /\d/) { decode_error("malformed number (no digits after decimal point)"); } else { $n .= $ch; } while(defined(next_chr) and $ch =~ /\d/){ $n .= $ch; } } if(defined $ch and ($ch eq 'e' or $ch eq 'E')){ $n .= $ch; $is_exp = 1; next_chr; if(defined($ch) and ($ch eq '+' or $ch eq '-')){ $n .= $ch; next_chr; if (!defined $ch or $ch =~ /\D/) { decode_error("malformed number (no digits after exp sign)"); } $n .= $ch; } elsif(defined($ch) and $ch =~ /\d/){ $n .= $ch; } else { decode_error("malformed number (no digits after exp sign)"); } while(defined(next_chr) and $ch =~ /\d/){ $n .= $ch; } } $v .= $n; if ($is_dec or $is_exp) { if ($allow_bignum) { require Math::BigFloat; return Math::BigFloat->new($v); } } else { if (length $v > $max_intsize) { if ($allow_bignum) { # from Adam Sussman require Math::BigInt; return Math::BigInt->new($v); } else { return "$v"; } } } return $is_dec ? $v/1.0 : 0+$v; } # Compute how many bytes are in the longest legal official Unicode # character my $max_unicode_length = do { no warnings 'utf8'; chr 0x10FFFF; }; utf8::encode($max_unicode_length); $max_unicode_length = length $max_unicode_length; sub is_valid_utf8 { # Returns undef (setting $utf8_len to 0) unless the next bytes in $text # comprise a well-formed UTF-8 encoded character, in which case, # return those bytes, setting $utf8_len to their count. my $start_point = substr($text, $at - 1); # Look no further than the maximum number of bytes in a single # character my $limit = $max_unicode_length; $limit = length($start_point) if $limit > length($start_point); # Find the number of bytes comprising the first character in $text # (without having to know the details of its internal representation). # This loop will iterate just once on well-formed input. while ($limit > 0) { # Until we succeed or exhaust the input my $copy = substr($start_point, 0, $limit); # decode() will return true if all bytes are valid; false # if any aren't. if (utf8::decode($copy)) { # Is valid: get the first character, convert back to bytes, # and return those bytes. $copy = substr($copy, 0, 1); utf8::encode($copy); $utf8_len = length $copy; return substr($start_point, 0, $utf8_len); } # If it didn't work, it could be that there is a full legal character # followed by a partial or malformed one. Narrow the window and # try again. $limit--; } # Failed to find a legal UTF-8 character. $utf8_len = 0; return; } sub decode_error { my $error = shift; my $no_rep = shift; my $str = defined $text ? substr($text, $at) : ''; my $mess = ''; my $type = 'U*'; for my $c ( unpack( $type, $str ) ) { # emulate pv_uni_display() ? my $chr_c = chr($c); $mess .= $chr_c eq '\\' ? '\\\\' : $chr_c =~ /[[:print:]]/ ? $chr_c : $chr_c eq '\a' ? '\a' : $chr_c eq '\t' ? '\t' : $chr_c eq '\n' ? '\n' : $chr_c eq '\r' ? '\r' : $chr_c eq '\f' ? '\f' : sprintf('\x{%x}', $c) ; if ( length $mess >= 20 ) { $mess .= '...'; last; } } unless ( length $mess ) { $mess = '(end of string)'; } Carp::croak ( $no_rep ? "$error" : "$error, at character offset $at (before \"$mess\")" ); } sub _json_object_hook { my $o = $_[0]; my @ks = keys %{$o}; if ( $cb_sk_object and @ks == 1 and exists $cb_sk_object->{ $ks[0] } and ref $cb_sk_object->{ $ks[0] } ) { my @val = $cb_sk_object->{ $ks[0] }->( $o->{$ks[0]} ); if (@val == 0) { return $o; } elsif (@val == 1) { return $val[0]; } else { Carp::croak("filter_json_single_key_object callbacks must not return more than one scalar"); } } my @val = $cb_object->($o) if ($cb_object); if (@val == 0) { return $o; } elsif (@val == 1) { return $val[0]; } else { Carp::croak("filter_json_object callbacks must not return more than one scalar"); } } sub PP_decode_box { { text => $text, at => $at, ch => $ch, len => $len, depth => $depth, encoding => $encoding, is_valid_utf8 => $is_valid_utf8, }; } } # PARSE sub _decode_surrogates { # from perlunicode my $uni = 0x10000 + (hex($_[0]) - 0xD800) * 0x400 + (hex($_[1]) - 0xDC00); my $un = pack('U*', $uni); utf8::encode( $un ); return $un; } sub _decode_unicode { my $un = pack('U', hex shift); utf8::encode( $un ); return $un; } sub incr_parse { local $Carp::CarpLevel = 1; ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_parse( @_ ); } sub incr_skip { ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_skip; } sub incr_reset { ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_reset; } sub incr_text : lvalue { $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new; if ( $_[0]->{_incr_parser}->{incr_pos} ) { Carp::croak("incr_text cannot be called when the incremental parser already started parsing"); } $_[0]->{_incr_parser}->{incr_text}; } ############################### # Utilities # # shamelessly copied and modified from JSON::XS code. $JSON::PP::true = do { bless \(my $dummy = 1), "JSON::PP::Boolean" }; $JSON::PP::false = do { bless \(my $dummy = 0), "JSON::PP::Boolean" }; sub is_bool { if (blessed $_[0]) { return ( $_[0]->isa("JSON::PP::Boolean") or $_[0]->isa("Types::Serialiser::BooleanBase") or $_[0]->isa("JSON::XS::Boolean") ); } elsif (CORE_BOOL) { BEGIN { CORE_BOOL and warnings->unimport('experimental::builtin') } return builtin::is_bool($_[0]); } return !!0; } sub true { $JSON::PP::true } sub false { $JSON::PP::false } sub null { undef; } ############################### package JSON::PP::IncrParser; use strict; use constant INCR_M_WS => 0; # initial whitespace skipping use constant INCR_M_STR => 1; # inside string use constant INCR_M_BS => 2; # inside backslash use constant INCR_M_JSON => 3; # outside anything, count nesting use constant INCR_M_C0 => 4; use constant INCR_M_C1 => 5; use constant INCR_M_TFN => 6; use constant INCR_M_NUM => 7; our $VERSION = '1.01'; sub new { my ( $class ) = @_; bless { incr_nest => 0, incr_text => undef, incr_pos => 0, incr_mode => 0, }, $class; } sub incr_parse { my ( $self, $coder, $text ) = @_; $self->{incr_text} = '' unless ( defined $self->{incr_text} ); if ( defined $text ) { $self->{incr_text} .= $text; } if ( defined wantarray ) { my $max_size = $coder->get_max_size; my $p = $self->{incr_pos}; my @ret; { do { unless ( $self->{incr_nest} <= 0 and $self->{incr_mode} == INCR_M_JSON ) { $self->_incr_parse( $coder ); if ( $max_size and $self->{incr_pos} > $max_size ) { Carp::croak("attempted decode of JSON text of $self->{incr_pos} bytes size, but max_size is set to $max_size"); } unless ( $self->{incr_nest} <= 0 and $self->{incr_mode} == INCR_M_JSON ) { # as an optimisation, do not accumulate white space in the incr buffer if ( $self->{incr_mode} == INCR_M_WS and $self->{incr_pos} ) { $self->{incr_pos} = 0; $self->{incr_text} = ''; } last; } } unless ( $coder->get_utf8 ) { utf8::decode( $self->{incr_text} ); } my ($obj, $offset) = $coder->PP_decode_json( $self->{incr_text}, 0x00000001 ); push @ret, $obj; use bytes; $self->{incr_text} = substr( $self->{incr_text}, $offset || 0 ); $self->{incr_pos} = 0; $self->{incr_nest} = 0; $self->{incr_mode} = 0; last unless wantarray; } while ( wantarray ); } if ( wantarray ) { return @ret; } else { # in scalar context return defined $ret[0] ? $ret[0] : undef; } } } sub _incr_parse { my ($self, $coder) = @_; my $text = $self->{incr_text}; my $len = length $text; my $p = $self->{incr_pos}; INCR_PARSE: while ( $len > $p ) { my $s = substr( $text, $p, 1 ); last INCR_PARSE unless defined $s; my $mode = $self->{incr_mode}; if ( $mode == INCR_M_WS ) { while ( $len > $p ) { $s = substr( $text, $p, 1 ); last INCR_PARSE unless defined $s; if ( ord($s) > ord " " ) { if ( $s eq '#' ) { $self->{incr_mode} = INCR_M_C0; redo INCR_PARSE; } else { $self->{incr_mode} = INCR_M_JSON; redo INCR_PARSE; } } $p++; } } elsif ( $mode == INCR_M_BS ) { $p++; $self->{incr_mode} = INCR_M_STR; redo INCR_PARSE; } elsif ( $mode == INCR_M_C0 or $mode == INCR_M_C1 ) { while ( $len > $p ) { $s = substr( $text, $p, 1 ); last INCR_PARSE unless defined $s; if ( $s eq "\n" ) { $self->{incr_mode} = $self->{incr_mode} == INCR_M_C0 ? INCR_M_WS : INCR_M_JSON; last; } $p++; } next; } elsif ( $mode == INCR_M_TFN ) { last INCR_PARSE if $p >= $len && $self->{incr_nest}; while ( $len > $p ) { $s = substr( $text, $p++, 1 ); next if defined $s and $s =~ /[rueals]/; last; } $p--; $self->{incr_mode} = INCR_M_JSON; last INCR_PARSE unless $self->{incr_nest}; redo INCR_PARSE; } elsif ( $mode == INCR_M_NUM ) { last INCR_PARSE if $p >= $len && $self->{incr_nest}; while ( $len > $p ) { $s = substr( $text, $p++, 1 ); next if defined $s and $s =~ /[0-9eE.+\-]/; last; } $p--; $self->{incr_mode} = INCR_M_JSON; last INCR_PARSE unless $self->{incr_nest}; redo INCR_PARSE; } elsif ( $mode == INCR_M_STR ) { while ( $len > $p ) { $s = substr( $text, $p, 1 ); last INCR_PARSE unless defined $s; if ( $s eq '"' ) { $p++; $self->{incr_mode} = INCR_M_JSON; last INCR_PARSE unless $self->{incr_nest}; redo INCR_PARSE; } elsif ( $s eq '\\' ) { $p++; if ( !defined substr($text, $p, 1) ) { $self->{incr_mode} = INCR_M_BS; last INCR_PARSE; } } $p++; } } elsif ( $mode == INCR_M_JSON ) { while ( $len > $p ) { $s = substr( $text, $p++, 1 ); if ( $s eq "\x00" ) { $p--; last INCR_PARSE; } elsif ( $s =~ /^[\t\n\r ]$/) { if ( !$self->{incr_nest} ) { $p--; # do not eat the whitespace, let the next round do it last INCR_PARSE; } next; } elsif ( $s eq 't' or $s eq 'f' or $s eq 'n' ) { $self->{incr_mode} = INCR_M_TFN; redo INCR_PARSE; } elsif ( $s =~ /^[0-9\-]$/ ) { $self->{incr_mode} = INCR_M_NUM; redo INCR_PARSE; } elsif ( $s eq '"' ) { $self->{incr_mode} = INCR_M_STR; redo INCR_PARSE; } elsif ( $s eq '[' or $s eq '{' ) { if ( ++$self->{incr_nest} > $coder->get_max_depth ) { Carp::croak('json text or perl structure exceeds maximum nesting level (max_depth set too low?)'); } next; } elsif ( $s eq ']' or $s eq '}' ) { if ( --$self->{incr_nest} <= 0 ) { last INCR_PARSE; } } elsif ( $s eq '#' ) { $self->{incr_mode} = INCR_M_C1; redo INCR_PARSE; } } } } $self->{incr_pos} = $p; $self->{incr_parsing} = $p ? 1 : 0; # for backward compatibility } sub incr_text { if ( $_[0]->{incr_pos} ) { Carp::croak("incr_text cannot be called when the incremental parser already started parsing"); } $_[0]->{incr_text}; } sub incr_skip { my $self = shift; $self->{incr_text} = substr( $self->{incr_text}, $self->{incr_pos} ); $self->{incr_pos} = 0; $self->{incr_mode} = 0; $self->{incr_nest} = 0; } sub incr_reset { my $self = shift; $self->{incr_text} = undef; $self->{incr_pos} = 0; $self->{incr_mode} = 0; $self->{incr_nest} = 0; } ############################### 1; __END__ =pod =head1 NAME JSON::PP - JSON::XS compatible pure-Perl module. =head1 SYNOPSIS use JSON::PP; # exported functions, they croak on error # and expect/generate UTF-8 $utf8_encoded_json_text = encode_json $perl_hash_or_arrayref; $perl_hash_or_arrayref = decode_json $utf8_encoded_json_text; # OO-interface $json = JSON::PP->new->ascii->pretty->allow_nonref; $pretty_printed_json_text = $json->encode( $perl_scalar ); $perl_scalar = $json->decode( $json_text ); # Note that JSON version 2.0 and above will automatically use # JSON::XS or JSON::PP, so you should be able to just: use JSON; =head1 DESCRIPTION JSON::PP is a pure perl JSON decoder/encoder, and (almost) compatible to much faster L<JSON::XS> written by Marc Lehmann in C. JSON::PP works as a fallback module when you use L<JSON> module without having installed JSON::XS. Because of this fallback feature of JSON.pm, JSON::PP tries not to be more JavaScript-friendly than JSON::XS (i.e. not to escape extra characters such as U+2028 and U+2029, etc), in order for you not to lose such JavaScript-friendliness silently when you use JSON.pm and install JSON::XS for speed or by accident. If you need JavaScript-friendly RFC7159-compliant pure perl module, try L<JSON::Tiny>, which is derived from L<Mojolicious> web framework and is also smaller and faster than JSON::PP. JSON::PP has been in the Perl core since Perl 5.14, mainly for CPAN toolchain modules to parse META.json. =head1 FUNCTIONAL INTERFACE This section is taken from JSON::XS almost verbatim. C<encode_json> and C<decode_json> are exported by default. =head2 encode_json $json_text = encode_json $perl_scalar Converts the given Perl data structure to a UTF-8 encoded, binary string (that is, the string contains octets only). Croaks on error. This function call is functionally identical to: $json_text = JSON::PP->new->utf8->encode($perl_scalar) Except being faster. =head2 decode_json $perl_scalar = decode_json $json_text The opposite of C<encode_json>: expects an UTF-8 (binary) string and tries to parse that as an UTF-8 encoded JSON text, returning the resulting reference. Croaks on error. This function call is functionally identical to: $perl_scalar = JSON::PP->new->utf8->decode($json_text) Except being faster. =head2 JSON::PP::is_bool $is_boolean = JSON::PP::is_bool($scalar) Returns true if the passed scalar represents either JSON::PP::true or JSON::PP::false, two constants that act like C<1> and C<0> respectively and are also used to represent JSON C<true> and C<false> in Perl strings. On perl 5.36 and above, will also return true when given one of perl's standard boolean values, such as the result of a comparison. See L<MAPPING>, below, for more information on how JSON values are mapped to Perl. =head1 OBJECT-ORIENTED INTERFACE This section is also taken from JSON::XS. The object oriented interface lets you configure your own encoding or decoding style, within the limits of supported formats. =head2 new $json = JSON::PP->new Creates a new JSON::PP object that can be used to de/encode JSON strings. All boolean flags described below are by default I<disabled> (with the exception of C<allow_nonref>, which defaults to I<enabled> since version C<4.0>). The mutators for flags all return the JSON::PP object again and thus calls can be chained: my $json = JSON::PP->new->utf8->space_after->encode({a => [1,2]}) => {"a": [1, 2]} =head2 ascii $json = $json->ascii([$enable]) $enabled = $json->get_ascii If C<$enable> is true (or missing), then the C<encode> method will not generate characters outside the code range C<0..127> (which is ASCII). Any Unicode characters outside that range will be escaped using either a single \uXXXX (BMP characters) or a double \uHHHH\uLLLLL escape sequence, as per RFC4627. The resulting encoded JSON text can be treated as a native Unicode string, an ascii-encoded, latin1-encoded or UTF-8 encoded string, or any other superset of ASCII. If C<$enable> is false, then the C<encode> method will not escape Unicode characters unless required by the JSON syntax or other flags. This results in a faster and more compact format. See also the section I<ENCODING/CODESET FLAG NOTES> later in this document. The main use for this flag is to produce JSON texts that can be transmitted over a 7-bit channel, as the encoded JSON texts will not contain any 8 bit characters. JSON::PP->new->ascii(1)->encode([chr 0x10401]) => ["\ud801\udc01"] =head2 latin1 $json = $json->latin1([$enable]) $enabled = $json->get_latin1 If C<$enable> is true (or missing), then the C<encode> method will encode the resulting JSON text as latin1 (or iso-8859-1), escaping any characters outside the code range C<0..255>. The resulting string can be treated as a latin1-encoded JSON text or a native Unicode string. The C<decode> method will not be affected in any way by this flag, as C<decode> by default expects Unicode, which is a strict superset of latin1. If C<$enable> is false, then the C<encode> method will not escape Unicode characters unless required by the JSON syntax or other flags. See also the section I<ENCODING/CODESET FLAG NOTES> later in this document. The main use for this flag is efficiently encoding binary data as JSON text, as most octets will not be escaped, resulting in a smaller encoded size. The disadvantage is that the resulting JSON text is encoded in latin1 (and must correctly be treated as such when storing and transferring), a rare encoding for JSON. It is therefore most useful when you want to store data structures known to contain binary data efficiently in files or databases, not when talking to other JSON encoders/decoders. JSON::PP->new->latin1->encode (["\x{89}\x{abc}"] => ["\x{89}\\u0abc"] # (perl syntax, U+abc escaped, U+89 not) =head2 utf8 $json = $json->utf8([$enable]) $enabled = $json->get_utf8 If C<$enable> is true (or missing), then the C<encode> method will encode the JSON result into UTF-8, as required by many protocols, while the C<decode> method expects to be handled an UTF-8-encoded string. Please note that UTF-8-encoded strings do not contain any characters outside the range C<0..255>, they are thus useful for bytewise/binary I/O. In future versions, enabling this option might enable autodetection of the UTF-16 and UTF-32 encoding families, as described in RFC4627. If C<$enable> is false, then the C<encode> method will return the JSON string as a (non-encoded) Unicode string, while C<decode> expects thus a Unicode string. Any decoding or encoding (e.g. to UTF-8 or UTF-16) needs to be done yourself, e.g. using the Encode module. See also the section I<ENCODING/CODESET FLAG NOTES> later in this document. Example, output UTF-16BE-encoded JSON: use Encode; $jsontext = encode "UTF-16BE", JSON::PP->new->encode ($object); Example, decode UTF-32LE-encoded JSON: use Encode; $object = JSON::PP->new->decode (decode "UTF-32LE", $jsontext); =head2 pretty $json = $json->pretty([$enable]) This enables (or disables) all of the C<indent>, C<space_before> and C<space_after> (and in the future possibly more) flags in one call to generate the most readable (or most compact) form possible. =head2 indent $json = $json->indent([$enable]) $enabled = $json->get_indent If C<$enable> is true (or missing), then the C<encode> method will use a multiline format as output, putting every array member or object/hash key-value pair into its own line, indenting them properly. If C<$enable> is false, no newlines or indenting will be produced, and the resulting JSON text is guaranteed not to contain any C<newlines>. This setting has no effect when decoding JSON texts. The default indent space length is three. You can use C<indent_length> to change the length. =head2 space_before $json = $json->space_before([$enable]) $enabled = $json->get_space_before If C<$enable> is true (or missing), then the C<encode> method will add an extra optional space before the C<:> separating keys from values in JSON objects. If C<$enable> is false, then the C<encode> method will not add any extra space at those places. This setting has no effect when decoding JSON texts. You will also most likely combine this setting with C<space_after>. Example, space_before enabled, space_after and indent disabled: {"key" :"value"} =head2 space_after $json = $json->space_after([$enable]) $enabled = $json->get_space_after If C<$enable> is true (or missing), then the C<encode> method will add an extra optional space after the C<:> separating keys from values in JSON objects and extra whitespace after the C<,> separating key-value pairs and array members. If C<$enable> is false, then the C<encode> method will not add any extra space at those places. This setting has no effect when decoding JSON texts. Example, space_before and indent disabled, space_after enabled: {"key": "value"} =head2 relaxed $json = $json->relaxed([$enable]) $enabled = $json->get_relaxed If C<$enable> is true (or missing), then C<decode> will accept some extensions to normal JSON syntax (see below). C<encode> will not be affected in anyway. I<Be aware that this option makes you accept invalid JSON texts as if they were valid!>. I suggest only to use this option to parse application-specific files written by humans (configuration files, resource files etc.) If C<$enable> is false (the default), then C<decode> will only accept valid JSON texts. Currently accepted extensions are: =over 4 =item * list items can have an end-comma JSON I<separates> array elements and key-value pairs with commas. This can be annoying if you write JSON texts manually and want to be able to quickly append elements, so this extension accepts comma at the end of such items not just between them: [ 1, 2, <- this comma not normally allowed ] { "k1": "v1", "k2": "v2", <- this comma not normally allowed } =item * shell-style '#'-comments Whenever JSON allows whitespace, shell-style comments are additionally allowed. They are terminated by the first carriage-return or line-feed character, after which more white-space and comments are allowed. [ 1, # this comment not allowed in JSON # neither this one... ] =item * C-style multiple-line '/* */'-comments (JSON::PP only) Whenever JSON allows whitespace, C-style multiple-line comments are additionally allowed. Everything between C</*> and C<*/> is a comment, after which more white-space and comments are allowed. [ 1, /* this comment not allowed in JSON */ /* neither this one... */ ] =item * C++-style one-line '//'-comments (JSON::PP only) Whenever JSON allows whitespace, C++-style one-line comments are additionally allowed. They are terminated by the first carriage-return or line-feed character, after which more white-space and comments are allowed. [ 1, // this comment not allowed in JSON // neither this one... ] =item * literal ASCII TAB characters in strings Literal ASCII TAB characters are now allowed in strings (and treated as C<\t>). [ "Hello\tWorld", "Hello<TAB>World", # literal <TAB> would not normally be allowed ] =back =head2 canonical $json = $json->canonical([$enable]) $enabled = $json->get_canonical If C<$enable> is true (or missing), then the C<encode> method will output JSON objects by sorting their keys. This is adding a comparatively high overhead. If C<$enable> is false, then the C<encode> method will output key-value pairs in the order Perl stores them (which will likely change between runs of the same script, and can change even within the same run from 5.18 onwards). This option is useful if you want the same data structure to be encoded as the same JSON text (given the same overall settings). If it is disabled, the same hash might be encoded differently even if contains the same data, as key-value pairs have no inherent ordering in Perl. This setting has no effect when decoding JSON texts. This setting has currently no effect on tied hashes. =head2 allow_nonref $json = $json->allow_nonref([$enable]) $enabled = $json->get_allow_nonref Unlike other boolean options, this opotion is enabled by default beginning with version C<4.0>. If C<$enable> is true (or missing), then the C<encode> method can convert a non-reference into its corresponding string, number or null JSON value, which is an extension to RFC4627. Likewise, C<decode> will accept those JSON values instead of croaking. If C<$enable> is false, then the C<encode> method will croak if it isn't passed an arrayref or hashref, as JSON texts must either be an object or array. Likewise, C<decode> will croak if given something that is not a JSON object or array. Example, encode a Perl scalar as JSON value without enabled C<allow_nonref>, resulting in an error: JSON::PP->new->allow_nonref(0)->encode ("Hello, World!") => hash- or arrayref expected... =head2 allow_unknown $json = $json->allow_unknown([$enable]) $enabled = $json->get_allow_unknown If C<$enable> is true (or missing), then C<encode> will I<not> throw an exception when it encounters values it cannot represent in JSON (for example, filehandles) but instead will encode a JSON C<null> value. Note that blessed objects are not included here and are handled separately by c<allow_blessed>. If C<$enable> is false (the default), then C<encode> will throw an exception when it encounters anything it cannot encode as JSON. This option does not affect C<decode> in any way, and it is recommended to leave it off unless you know your communications partner. =head2 allow_blessed $json = $json->allow_blessed([$enable]) $enabled = $json->get_allow_blessed See L<OBJECT SERIALISATION> for details. If C<$enable> is true (or missing), then the C<encode> method will not barf when it encounters a blessed reference that it cannot convert otherwise. Instead, a JSON C<null> value is encoded instead of the object. If C<$enable> is false (the default), then C<encode> will throw an exception when it encounters a blessed object that it cannot convert otherwise. This setting has no effect on C<decode>. =head2 convert_blessed $json = $json->convert_blessed([$enable]) $enabled = $json->get_convert_blessed See L<OBJECT SERIALISATION> for details. If C<$enable> is true (or missing), then C<encode>, upon encountering a blessed object, will check for the availability of the C<TO_JSON> method on the object's class. If found, it will be called in scalar context and the resulting scalar will be encoded instead of the object. The C<TO_JSON> method may safely call die if it wants. If C<TO_JSON> returns other blessed objects, those will be handled in the same way. C<TO_JSON> must take care of not causing an endless recursion cycle (== crash) in this case. The name of C<TO_JSON> was chosen because other methods called by the Perl core (== not by the user of the object) are usually in upper case letters and to avoid collisions with any C<to_json> function or method. If C<$enable> is false (the default), then C<encode> will not consider this type of conversion. This setting has no effect on C<decode>. =head2 allow_tags $json = $json->allow_tags([$enable]) $enabled = $json->get_allow_tags See L<OBJECT SERIALISATION> for details. If C<$enable> is true (or missing), then C<encode>, upon encountering a blessed object, will check for the availability of the C<FREEZE> method on the object's class. If found, it will be used to serialise the object into a nonstandard tagged JSON value (that JSON decoders cannot decode). It also causes C<decode> to parse such tagged JSON values and deserialise them via a call to the C<THAW> method. If C<$enable> is false (the default), then C<encode> will not consider this type of conversion, and tagged JSON values will cause a parse error in C<decode>, as if tags were not part of the grammar. =head2 boolean_values $json->boolean_values([$false, $true]) ($false, $true) = $json->get_boolean_values By default, JSON booleans will be decoded as overloaded C<$JSON::PP::false> and C<$JSON::PP::true> objects. With this method you can specify your own boolean values for decoding - on decode, JSON C<false> will be decoded as a copy of C<$false>, and JSON C<true> will be decoded as C<$true> ("copy" here is the same thing as assigning a value to another variable, i.e. C<$copy = $false>). This is useful when you want to pass a decoded data structure directly to other serialisers like YAML, Data::MessagePack and so on. Note that this works only when you C<decode>. You can set incompatible boolean objects (like L<boolean>), but when you C<encode> a data structure with such boolean objects, you still need to enable C<convert_blessed> (and add a C<TO_JSON> method if necessary). Calling this method without any arguments will reset the booleans to their default values. C<get_boolean_values> will return both C<$false> and C<$true> values, or the empty list when they are set to the default. =head2 core_bools $json->core_bools([$enable]); If C<$enable> is true (or missing), then C<decode>, will produce standard perl boolean values. Equivalent to calling: $json->boolean_values(!!1, !!0) C<get_core_bools> will return true if this has been set. On perl 5.36, it will also return true if the boolean values have been set to perl's core booleans using the C<boolean_values> method. The methods C<unblessed_bool> and C<get_unblessed_bool> are provided as aliases for compatibility with L<Cpanel::JSON::XS>. =head2 filter_json_object $json = $json->filter_json_object([$coderef]) When C<$coderef> is specified, it will be called from C<decode> each time it decodes a JSON object. The only argument is a reference to the newly-created hash. If the code references returns a single scalar (which need not be a reference), this value (or rather a copy of it) is inserted into the deserialised data structure. If it returns an empty list (NOTE: I<not> C<undef>, which is a valid scalar), the original deserialised hash will be inserted. This setting can slow down decoding considerably. When C<$coderef> is omitted or undefined, any existing callback will be removed and C<decode> will not change the deserialised hash in any way. Example, convert all JSON objects into the integer 5: my $js = JSON::PP->new->filter_json_object(sub { 5 }); # returns [5] $js->decode('[{}]'); # returns 5 $js->decode('{"a":1, "b":2}'); =head2 filter_json_single_key_object $json = $json->filter_json_single_key_object($key [=> $coderef]) Works remotely similar to C<filter_json_object>, but is only called for JSON objects having a single key named C<$key>. This C<$coderef> is called before the one specified via C<filter_json_object>, if any. It gets passed the single value in the JSON object. If it returns a single value, it will be inserted into the data structure. If it returns nothing (not even C<undef> but the empty list), the callback from C<filter_json_object> will be called next, as if no single-key callback were specified. If C<$coderef> is omitted or undefined, the corresponding callback will be disabled. There can only ever be one callback for a given key. As this callback gets called less often then the C<filter_json_object> one, decoding speed will not usually suffer as much. Therefore, single-key objects make excellent targets to serialise Perl objects into, especially as single-key JSON objects are as close to the type-tagged value concept as JSON gets (it's basically an ID/VALUE tuple). Of course, JSON does not support this in any way, so you need to make sure your data never looks like a serialised Perl hash. Typical names for the single object key are C<__class_whatever__>, or C<$__dollars_are_rarely_used__$> or C<}ugly_brace_placement>, or even things like C<__class_md5sum(classname)__>, to reduce the risk of clashing with real hashes. Example, decode JSON objects of the form C<< { "__widget__" => <id> } >> into the corresponding C<< $WIDGET{<id>} >> object: # return whatever is in $WIDGET{5}: JSON::PP ->new ->filter_json_single_key_object (__widget__ => sub { $WIDGET{ $_[0] } }) ->decode ('{"__widget__": 5') # this can be used with a TO_JSON method in some "widget" class # for serialisation to json: sub WidgetBase::TO_JSON { my ($self) = @_; unless ($self->{id}) { $self->{id} = ..get..some..id..; $WIDGET{$self->{id}} = $self; } { __widget__ => $self->{id} } } =head2 shrink $json = $json->shrink([$enable]) $enabled = $json->get_shrink If C<$enable> is true (or missing), the string returned by C<encode> will be shrunk (i.e. downgraded if possible). The actual definition of what shrink does might change in future versions, but it will always try to save space at the expense of time. If C<$enable> is false, then JSON::PP does nothing. =head2 max_depth $json = $json->max_depth([$maximum_nesting_depth]) $max_depth = $json->get_max_depth Sets the maximum nesting level (default C<512>) accepted while encoding or decoding. If a higher nesting level is detected in JSON text or a Perl data structure, then the encoder and decoder will stop and croak at that point. Nesting level is defined by number of hash- or arrayrefs that the encoder needs to traverse to reach a given point or the number of C<{> or C<[> characters without their matching closing parenthesis crossed to reach a given character in a string. Setting the maximum depth to one disallows any nesting, so that ensures that the object is only a single hash/object or array. If no argument is given, the highest possible setting will be used, which is rarely useful. See L<JSON::XS/SECURITY CONSIDERATIONS> for more info on why this is useful. =head2 max_size $json = $json->max_size([$maximum_string_size]) $max_size = $json->get_max_size Set the maximum length a JSON text may have (in bytes) where decoding is being attempted. The default is C<0>, meaning no limit. When C<decode> is called on a string that is longer then this many bytes, it will not attempt to decode the string but throw an exception. This setting has no effect on C<encode> (yet). If no argument is given, the limit check will be deactivated (same as when C<0> is specified). See L<JSON::XS/SECURITY CONSIDERATIONS> for more info on why this is useful. =head2 encode $json_text = $json->encode($perl_scalar) Converts the given Perl value or data structure to its JSON representation. Croaks on error. =head2 decode $perl_scalar = $json->decode($json_text) The opposite of C<encode>: expects a JSON text and tries to parse it, returning the resulting simple scalar or reference. Croaks on error. =head2 decode_prefix ($perl_scalar, $characters) = $json->decode_prefix($json_text) This works like the C<decode> method, but instead of raising an exception when there is trailing garbage after the first JSON object, it will silently stop parsing there and return the number of characters consumed so far. This is useful if your JSON texts are not delimited by an outer protocol and you need to know where the JSON text ends. JSON::PP->new->decode_prefix ("[1] the tail") => ([1], 3) =head1 FLAGS FOR JSON::PP ONLY The following flags and properties are for JSON::PP only. If you use any of these, you can't make your application run faster by replacing JSON::PP with JSON::XS. If you need these and also speed boost, you might want to try L<Cpanel::JSON::XS>, a fork of JSON::XS by Reini Urban, which supports some of these (with a different set of incompatibilities). Most of these historical flags are only kept for backward compatibility, and should not be used in a new application. =head2 allow_singlequote $json = $json->allow_singlequote([$enable]) $enabled = $json->get_allow_singlequote If C<$enable> is true (or missing), then C<decode> will accept invalid JSON texts that contain strings that begin and end with single quotation marks. C<encode> will not be affected in any way. I<Be aware that this option makes you accept invalid JSON texts as if they were valid!>. I suggest only to use this option to parse application-specific files written by humans (configuration files, resource files etc.) If C<$enable> is false (the default), then C<decode> will only accept valid JSON texts. $json->allow_singlequote->decode(qq|{"foo":'bar'}|); $json->allow_singlequote->decode(qq|{'foo':"bar"}|); $json->allow_singlequote->decode(qq|{'foo':'bar'}|); =head2 allow_barekey $json = $json->allow_barekey([$enable]) $enabled = $json->get_allow_barekey If C<$enable> is true (or missing), then C<decode> will accept invalid JSON texts that contain JSON objects whose names don't begin and end with quotation marks. C<encode> will not be affected in any way. I<Be aware that this option makes you accept invalid JSON texts as if they were valid!>. I suggest only to use this option to parse application-specific files written by humans (configuration files, resource files etc.) If C<$enable> is false (the default), then C<decode> will only accept valid JSON texts. $json->allow_barekey->decode(qq|{foo:"bar"}|); =head2 allow_bignum $json = $json->allow_bignum([$enable]) $enabled = $json->get_allow_bignum If C<$enable> is true (or missing), then C<decode> will convert big integers Perl cannot handle as integer into L<Math::BigInt> objects and convert floating numbers into L<Math::BigFloat> objects. C<encode> will convert C<Math::BigInt> and C<Math::BigFloat> objects into JSON numbers. $json->allow_nonref->allow_bignum; $bigfloat = $json->decode('2.000000000000000000000000001'); print $json->encode($bigfloat); # => 2.000000000000000000000000001 See also L<MAPPING>. =head2 loose $json = $json->loose([$enable]) $enabled = $json->get_loose If C<$enable> is true (or missing), then C<decode> will accept invalid JSON texts that contain unescaped [\x00-\x1f\x22\x5c] characters. C<encode> will not be affected in any way. I<Be aware that this option makes you accept invalid JSON texts as if they were valid!>. I suggest only to use this option to parse application-specific files written by humans (configuration files, resource files etc.) If C<$enable> is false (the default), then C<decode> will only accept valid JSON texts. $json->loose->decode(qq|["abc def"]|); =head2 escape_slash $json = $json->escape_slash([$enable]) $enabled = $json->get_escape_slash If C<$enable> is true (or missing), then C<encode> will explicitly escape I<slash> (solidus; C<U+002F>) characters to reduce the risk of XSS (cross site scripting) that may be caused by C<< </script> >> in a JSON text, with the cost of bloating the size of JSON texts. This option may be useful when you embed JSON in HTML, but embedding arbitrary JSON in HTML (by some HTML template toolkit or by string interpolation) is risky in general. You must escape necessary characters in correct order, depending on the context. C<decode> will not be affected in any way. =head2 indent_length $json = $json->indent_length($number_of_spaces) $length = $json->get_indent_length This option is only useful when you also enable C<indent> or C<pretty>. JSON::XS indents with three spaces when you C<encode> (if requested by C<indent> or C<pretty>), and the number cannot be changed. JSON::PP allows you to change/get the number of indent spaces with these mutator/accessor. The default number of spaces is three (the same as JSON::XS), and the acceptable range is from C<0> (no indentation; it'd be better to disable indentation by C<indent(0)>) to C<15>. =head2 sort_by $json = $json->sort_by($code_ref) $json = $json->sort_by($subroutine_name) If you just want to sort keys (names) in JSON objects when you C<encode>, enable C<canonical> option (see above) that allows you to sort object keys alphabetically. If you do need to sort non-alphabetically for whatever reasons, you can give a code reference (or a subroutine name) to C<sort_by>, then the argument will be passed to Perl's C<sort> built-in function. As the sorting is done in the JSON::PP scope, you usually need to prepend C<JSON::PP::> to the subroutine name, and the special variables C<$a> and C<$b> used in the subrontine used by C<sort> function. Example: my %ORDER = (id => 1, class => 2, name => 3); $json->sort_by(sub { ($ORDER{$JSON::PP::a} // 999) <=> ($ORDER{$JSON::PP::b} // 999) or $JSON::PP::a cmp $JSON::PP::b }); print $json->encode([ {name => 'CPAN', id => 1, href => 'http://cpan.org'} ]); # [{"id":1,"name":"CPAN","href":"http://cpan.org"}] Note that C<sort_by> affects all the plain hashes in the data structure. If you need finer control, C<tie> necessary hashes with a module that implements ordered hash (such as L<Hash::Ordered> and L<Tie::IxHash>). C<canonical> and C<sort_by> don't affect the key order in C<tie>d hashes. use Hash::Ordered; tie my %hash, 'Hash::Ordered', (name => 'CPAN', id => 1, href => 'http://cpan.org'); print $json->encode([\%hash]); # [{"name":"CPAN","id":1,"href":"http://cpan.org"}] # order is kept =head1 INCREMENTAL PARSING This section is also taken from JSON::XS. In some cases, there is the need for incremental parsing of JSON texts. While this module always has to keep both JSON text and resulting Perl data structure in memory at one time, it does allow you to parse a JSON stream incrementally. It does so by accumulating text until it has a full JSON object, which it then can decode. This process is similar to using C<decode_prefix> to see if a full JSON object is available, but is much more efficient (and can be implemented with a minimum of method calls). JSON::PP will only attempt to parse the JSON text once it is sure it has enough text to get a decisive result, using a very simple but truly incremental parser. This means that it sometimes won't stop as early as the full parser, for example, it doesn't detect mismatched parentheses. The only thing it guarantees is that it starts decoding as soon as a syntactically valid JSON text has been seen. This means you need to set resource limits (e.g. C<max_size>) to ensure the parser will stop parsing in the presence if syntax errors. The following methods implement this incremental parser. =head2 incr_parse $json->incr_parse( [$string] ) # void context $obj_or_undef = $json->incr_parse( [$string] ) # scalar context @obj_or_empty = $json->incr_parse( [$string] ) # list context This is the central parsing function. It can both append new text and extract objects from the stream accumulated so far (both of these functions are optional). If C<$string> is given, then this string is appended to the already existing JSON fragment stored in the C<$json> object. After that, if the function is called in void context, it will simply return without doing anything further. This can be used to add more text in as many chunks as you want. If the method is called in scalar context, then it will try to extract exactly I<one> JSON object. If that is successful, it will return this object, otherwise it will return C<undef>. If there is a parse error, this method will croak just as C<decode> would do (one can then use C<incr_skip> to skip the erroneous part). This is the most common way of using the method. And finally, in list context, it will try to extract as many objects from the stream as it can find and return them, or the empty list otherwise. For this to work, there must be no separators (other than whitespace) between the JSON objects or arrays, instead they must be concatenated back-to-back. If an error occurs, an exception will be raised as in the scalar context case. Note that in this case, any previously-parsed JSON texts will be lost. Example: Parse some JSON arrays/objects in a given string and return them. my @objs = JSON::PP->new->incr_parse ("[5][7][1,2]"); =head2 incr_text $lvalue_string = $json->incr_text This method returns the currently stored JSON fragment as an lvalue, that is, you can manipulate it. This I<only> works when a preceding call to C<incr_parse> in I<scalar context> successfully returned an object. Under all other circumstances you must not call this function (I mean it. although in simple tests it might actually work, it I<will> fail under real world conditions). As a special exception, you can also call this method before having parsed anything. That means you can only use this function to look at or manipulate text before or after complete JSON objects, not while the parser is in the middle of parsing a JSON object. This function is useful in two cases: a) finding the trailing text after a JSON object or b) parsing multiple JSON objects separated by non-JSON text (such as commas). =head2 incr_skip $json->incr_skip This will reset the state of the incremental parser and will remove the parsed text from the input buffer so far. This is useful after C<incr_parse> died, in which case the input buffer and incremental parser state is left unchanged, to skip the text parsed so far and to reset the parse state. The difference to C<incr_reset> is that only text until the parse error occurred is removed. =head2 incr_reset $json->incr_reset This completely resets the incremental parser, that is, after this call, it will be as if the parser had never parsed anything. This is useful if you want to repeatedly parse JSON objects and want to ignore any trailing data, which means you have to reset the parser after each successful decode. =head1 MAPPING Most of this section is also taken from JSON::XS. This section describes how JSON::PP maps Perl values to JSON values and vice versa. These mappings are designed to "do the right thing" in most circumstances automatically, preserving round-tripping characteristics (what you put in comes out as something equivalent). For the more enlightened: note that in the following descriptions, lowercase I<perl> refers to the Perl interpreter, while uppercase I<Perl> refers to the abstract Perl language itself. =head2 JSON -> PERL =over 4 =item object A JSON object becomes a reference to a hash in Perl. No ordering of object keys is preserved (JSON does not preserve object key ordering itself). =item array A JSON array becomes a reference to an array in Perl. =item string A JSON string becomes a string scalar in Perl - Unicode codepoints in JSON are represented by the same codepoints in the Perl string, so no manual decoding is necessary. =item number A JSON number becomes either an integer, numeric (floating point) or string scalar in perl, depending on its range and any fractional parts. On the Perl level, there is no difference between those as Perl handles all the conversion details, but an integer may take slightly less memory and might represent more values exactly than floating point numbers. If the number consists of digits only, JSON::PP will try to represent it as an integer value. If that fails, it will try to represent it as a numeric (floating point) value if that is possible without loss of precision. Otherwise it will preserve the number as a string value (in which case you lose roundtripping ability, as the JSON number will be re-encoded to a JSON string). Numbers containing a fractional or exponential part will always be represented as numeric (floating point) values, possibly at a loss of precision (in which case you might lose perfect roundtripping ability, but the JSON number will still be re-encoded as a JSON number). Note that precision is not accuracy - binary floating point values cannot represent most decimal fractions exactly, and when converting from and to floating point, JSON::PP only guarantees precision up to but not including the least significant bit. When C<allow_bignum> is enabled, big integer values and any numeric values will be converted into L<Math::BigInt> and L<Math::BigFloat> objects respectively, without becoming string scalars or losing precision. =item true, false These JSON atoms become C<JSON::PP::true> and C<JSON::PP::false>, respectively. They are overloaded to act almost exactly like the numbers C<1> and C<0>. You can check whether a scalar is a JSON boolean by using the C<JSON::PP::is_bool> function. =item null A JSON null atom becomes C<undef> in Perl. =item shell-style comments (C<< # I<text> >>) As a nonstandard extension to the JSON syntax that is enabled by the C<relaxed> setting, shell-style comments are allowed. They can start anywhere outside strings and go till the end of the line. =item tagged values (C<< (I<tag>)I<value> >>). Another nonstandard extension to the JSON syntax, enabled with the C<allow_tags> setting, are tagged values. In this implementation, the I<tag> must be a perl package/class name encoded as a JSON string, and the I<value> must be a JSON array encoding optional constructor arguments. See L<OBJECT SERIALISATION>, below, for details. =back =head2 PERL -> JSON The mapping from Perl to JSON is slightly more difficult, as Perl is a truly typeless language, so we can only guess which JSON type is meant by a Perl value. =over 4 =item hash references Perl hash references become JSON objects. As there is no inherent ordering in hash keys (or JSON objects), they will usually be encoded in a pseudo-random order. JSON::PP can optionally sort the hash keys (determined by the I<canonical> flag and/or I<sort_by> property), so the same data structure will serialise to the same JSON text (given same settings and version of JSON::PP), but this incurs a runtime overhead and is only rarely useful, e.g. when you want to compare some JSON text against another for equality. =item array references Perl array references become JSON arrays. =item other references Other unblessed references are generally not allowed and will cause an exception to be thrown, except for references to the integers C<0> and C<1>, which get turned into C<false> and C<true> atoms in JSON. You can also use C<JSON::PP::false> and C<JSON::PP::true> to improve readability. to_json [\0, JSON::PP::true] # yields [false,true] =item JSON::PP::true, JSON::PP::false These special values become JSON true and JSON false values, respectively. You can also use C<\1> and C<\0> directly if you want. =item JSON::PP::null This special value becomes JSON null. =item blessed objects Blessed objects are not directly representable in JSON, but C<JSON::PP> allows various ways of handling objects. See L<OBJECT SERIALISATION>, below, for details. =item simple scalars Simple Perl scalars (any scalar that is not a reference) are the most difficult objects to encode: JSON::PP will encode undefined scalars as JSON C<null> values, scalars that have last been used in a string context before encoding as JSON strings, and anything else as number value: # dump as number encode_json [2] # yields [2] encode_json [-3.0e17] # yields [-3e+17] my $value = 5; encode_json [$value] # yields [5] # used as string, so dump as string print $value; encode_json [$value] # yields ["5"] # undef becomes null encode_json [undef] # yields [null] You can force the type to be a JSON string by stringifying it: my $x = 3.1; # some variable containing a number "$x"; # stringified $x .= ""; # another, more awkward way to stringify print $x; # perl does it for you, too, quite often # (but for older perls) You can force the type to be a JSON number by numifying it: my $x = "3"; # some variable containing a string $x += 0; # numify it, ensuring it will be dumped as a number $x *= 1; # same thing, the choice is yours. You can not currently force the type in other, less obscure, ways. Since version 2.91_01, JSON::PP uses a different number detection logic that converts a scalar that is possible to turn into a number safely. The new logic is slightly faster, and tends to help people who use older perl or who want to encode complicated data structure. However, this may results in a different JSON text from the one JSON::XS encodes (and thus may break tests that compare entire JSON texts). If you do need the previous behavior for compatibility or for finer control, set PERL_JSON_PP_USE_B environmental variable to true before you C<use> JSON::PP (or JSON.pm). Note that numerical precision has the same meaning as under Perl (so binary to decimal conversion follows the same rules as in Perl, which can differ to other languages). Also, your perl interpreter might expose extensions to the floating point numbers of your platform, such as infinities or NaN's - these cannot be represented in JSON, and it is an error to pass those in. JSON::PP (and JSON::XS) trusts what you pass to C<encode> method (or C<encode_json> function) is a clean, validated data structure with values that can be represented as valid JSON values only, because it's not from an external data source (as opposed to JSON texts you pass to C<decode> or C<decode_json>, which JSON::PP considers tainted and doesn't trust). As JSON::PP doesn't know exactly what you and consumers of your JSON texts want the unexpected values to be (you may want to convert them into null, or to stringify them with or without normalisation (string representation of infinities/NaN may vary depending on platforms), or to croak without conversion), you're advised to do what you and your consumers need before you encode, and also not to numify values that may start with values that look like a number (including infinities/NaN), without validating. =back =head2 OBJECT SERIALISATION As JSON cannot directly represent Perl objects, you have to choose between a pure JSON representation (without the ability to deserialise the object automatically again), and a nonstandard extension to the JSON syntax, tagged values. =head3 SERIALISATION What happens when C<JSON::PP> encounters a Perl object depends on the C<allow_blessed>, C<convert_blessed>, C<allow_tags> and C<allow_bignum> settings, which are used in this order: =over 4 =item 1. C<allow_tags> is enabled and the object has a C<FREEZE> method. In this case, C<JSON::PP> creates a tagged JSON value, using a nonstandard extension to the JSON syntax. This works by invoking the C<FREEZE> method on the object, with the first argument being the object to serialise, and the second argument being the constant string C<JSON> to distinguish it from other serialisers. The C<FREEZE> method can return any number of values (i.e. zero or more). These values and the paclkage/classname of the object will then be encoded as a tagged JSON value in the following format: ("classname")[FREEZE return values...] e.g.: ("URI")["http://www.google.com/"] ("MyDate")[2013,10,29] ("ImageData::JPEG")["Z3...VlCg=="] For example, the hypothetical C<My::Object> C<FREEZE> method might use the objects C<type> and C<id> members to encode the object: sub My::Object::FREEZE { my ($self, $serialiser) = @_; ($self->{type}, $self->{id}) } =item 2. C<convert_blessed> is enabled and the object has a C<TO_JSON> method. In this case, the C<TO_JSON> method of the object is invoked in scalar context. It must return a single scalar that can be directly encoded into JSON. This scalar replaces the object in the JSON text. For example, the following C<TO_JSON> method will convert all L<URI> objects to JSON strings when serialised. The fact that these values originally were L<URI> objects is lost. sub URI::TO_JSON { my ($uri) = @_; $uri->as_string } =item 3. C<allow_bignum> is enabled and the object is a C<Math::BigInt> or C<Math::BigFloat>. The object will be serialised as a JSON number value. =item 4. C<allow_blessed> is enabled. The object will be serialised as a JSON null value. =item 5. none of the above If none of the settings are enabled or the respective methods are missing, C<JSON::PP> throws an exception. =back =head3 DESERIALISATION For deserialisation there are only two cases to consider: either nonstandard tagging was used, in which case C<allow_tags> decides, or objects cannot be automatically be deserialised, in which case you can use postprocessing or the C<filter_json_object> or C<filter_json_single_key_object> callbacks to get some real objects our of your JSON. This section only considers the tagged value case: a tagged JSON object is encountered during decoding and C<allow_tags> is disabled, a parse error will result (as if tagged values were not part of the grammar). If C<allow_tags> is enabled, C<JSON::PP> will look up the C<THAW> method of the package/classname used during serialisation (it will not attempt to load the package as a Perl module). If there is no such method, the decoding will fail with an error. Otherwise, the C<THAW> method is invoked with the classname as first argument, the constant string C<JSON> as second argument, and all the values from the JSON array (the values originally returned by the C<FREEZE> method) as remaining arguments. The method must then return the object. While technically you can return any Perl scalar, you might have to enable the C<allow_nonref> setting to make that work in all cases, so better return an actual blessed reference. As an example, let's implement a C<THAW> function that regenerates the C<My::Object> from the C<FREEZE> example earlier: sub My::Object::THAW { my ($class, $serialiser, $type, $id) = @_; $class->new (type => $type, id => $id) } =head1 ENCODING/CODESET FLAG NOTES This section is taken from JSON::XS. The interested reader might have seen a number of flags that signify encodings or codesets - C<utf8>, C<latin1> and C<ascii>. There seems to be some confusion on what these do, so here is a short comparison: C<utf8> controls whether the JSON text created by C<encode> (and expected by C<decode>) is UTF-8 encoded or not, while C<latin1> and C<ascii> only control whether C<encode> escapes character values outside their respective codeset range. Neither of these flags conflict with each other, although some combinations make less sense than others. Care has been taken to make all flags symmetrical with respect to C<encode> and C<decode>, that is, texts encoded with any combination of these flag values will be correctly decoded when the same flags are used - in general, if you use different flag settings while encoding vs. when decoding you likely have a bug somewhere. Below comes a verbose discussion of these flags. Note that a "codeset" is simply an abstract set of character-codepoint pairs, while an encoding takes those codepoint numbers and I<encodes> them, in our case into octets. Unicode is (among other things) a codeset, UTF-8 is an encoding, and ISO-8859-1 (= latin 1) and ASCII are both codesets I<and> encodings at the same time, which can be confusing. =over 4 =item C<utf8> flag disabled When C<utf8> is disabled (the default), then C<encode>/C<decode> generate and expect Unicode strings, that is, characters with high ordinal Unicode values (> 255) will be encoded as such characters, and likewise such characters are decoded as-is, no changes to them will be done, except "(re-)interpreting" them as Unicode codepoints or Unicode characters, respectively (to Perl, these are the same thing in strings unless you do funny/weird/dumb stuff). This is useful when you want to do the encoding yourself (e.g. when you want to have UTF-16 encoded JSON texts) or when some other layer does the encoding for you (for example, when printing to a terminal using a filehandle that transparently encodes to UTF-8 you certainly do NOT want to UTF-8 encode your data first and have Perl encode it another time). =item C<utf8> flag enabled If the C<utf8>-flag is enabled, C<encode>/C<decode> will encode all characters using the corresponding UTF-8 multi-byte sequence, and will expect your input strings to be encoded as UTF-8, that is, no "character" of the input string must have any value > 255, as UTF-8 does not allow that. The C<utf8> flag therefore switches between two modes: disabled means you will get a Unicode string in Perl, enabled means you get an UTF-8 encoded octet/binary string in Perl. =item C<latin1> or C<ascii> flags enabled With C<latin1> (or C<ascii>) enabled, C<encode> will escape characters with ordinal values > 255 (> 127 with C<ascii>) and encode the remaining characters as specified by the C<utf8> flag. If C<utf8> is disabled, then the result is also correctly encoded in those character sets (as both are proper subsets of Unicode, meaning that a Unicode string with all character values < 256 is the same thing as a ISO-8859-1 string, and a Unicode string with all character values < 128 is the same thing as an ASCII string in Perl). If C<utf8> is enabled, you still get a correct UTF-8-encoded string, regardless of these flags, just some more characters will be escaped using C<\uXXXX> then before. Note that ISO-8859-1-I<encoded> strings are not compatible with UTF-8 encoding, while ASCII-encoded strings are. That is because the ISO-8859-1 encoding is NOT a subset of UTF-8 (despite the ISO-8859-1 I<codeset> being a subset of Unicode), while ASCII is. Surprisingly, C<decode> will ignore these flags and so treat all input values as governed by the C<utf8> flag. If it is disabled, this allows you to decode ISO-8859-1- and ASCII-encoded strings, as both strict subsets of Unicode. If it is enabled, you can correctly decode UTF-8 encoded strings. So neither C<latin1> nor C<ascii> are incompatible with the C<utf8> flag - they only govern when the JSON output engine escapes a character or not. The main use for C<latin1> is to relatively efficiently store binary data as JSON, at the expense of breaking compatibility with most JSON decoders. The main use for C<ascii> is to force the output to not contain characters with values > 127, which means you can interpret the resulting string as UTF-8, ISO-8859-1, ASCII, KOI8-R or most about any character set and 8-bit-encoding, and still get the same data structure back. This is useful when your channel for JSON transfer is not 8-bit clean or the encoding might be mangled in between (e.g. in mail), and works because ASCII is a proper subset of most 8-bit and multibyte encodings in use in the world. =back =head1 BUGS Please report bugs on a specific behavior of this module to RT or GitHub issues (preferred): L<https://github.com/makamaka/JSON-PP/issues> L<https://rt.cpan.org/Public/Dist/Display.html?Queue=JSON-PP> As for new features and requests to change common behaviors, please ask the author of JSON::XS (Marc Lehmann, E<lt>schmorp[at]schmorp.deE<gt>) first, by email (important!), to keep compatibility among JSON.pm backends. Generally speaking, if you need something special for you, you are advised to create a new module, maybe based on L<JSON::Tiny>, which is smaller and written in a much cleaner way than this module. =head1 SEE ALSO The F<json_pp> command line utility for quick experiments. L<JSON::XS>, L<Cpanel::JSON::XS>, and L<JSON::Tiny> for faster alternatives. L<JSON> and L<JSON::MaybeXS> for easy migration. L<JSON::PP::Compat5005> and L<JSON::PP::Compat5006> for older perl users. RFC4627 (L<http://www.ietf.org/rfc/rfc4627.txt>) RFC7159 (L<http://www.ietf.org/rfc/rfc7159.txt>) RFC8259 (L<http://www.ietf.org/rfc/rfc8259.txt>) =head1 AUTHOR Makamaka Hannyaharamitu, E<lt>makamaka[at]cpan.orgE<gt> =head1 CURRENT MAINTAINER Kenichi Ishigaki, E<lt>ishigaki[at]cpan.orgE<gt> =head1 COPYRIGHT AND LICENSE Copyright 2007-2016 by Makamaka Hannyaharamitu Most of the documentation is taken from JSON::XS by Marc Lehmann This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut JSON_PP $fatpacked{"JSON/PP/Boolean.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP_BOOLEAN'; package JSON::PP::Boolean; use strict; use warnings; use overload (); overload::unimport('overload', qw(0+ ++ -- fallback)); overload::import('overload', "0+" => sub { ${$_[0]} }, "++" => sub { $_[0] = ${$_[0]} + 1 }, "--" => sub { $_[0] = ${$_[0]} - 1 }, fallback => 1, ); our $VERSION = '4.16'; 1; __END__ =head1 NAME JSON::PP::Boolean - dummy module providing JSON::PP::Boolean =head1 SYNOPSIS # do not "use" yourself =head1 DESCRIPTION This module exists only to provide overload resolution for Storable and similar modules. See L<JSON::PP> for more info about this class. =head1 AUTHOR This idea is from L<JSON::XS::Boolean> written by Marc Lehmann <schmorp[at]schmorp.de> =head1 LICENSE This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut JSON_PP_BOOLEAN $fatpacked{"lib/core/only.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LIB_CORE_ONLY'; package lib::core::only; use strict; use warnings FATAL => 'all'; use Config; sub import { @INC = @Config{qw(privlibexp archlibexp)}; return } =head1 NAME lib::core::only - Remove all non-core paths from @INC to avoid site/vendor dirs =head1 SYNOPSIS use lib::core::only; # now @INC contains only the two core directories To get only the core directories plus the ones for the local::lib in scope: $ perl -mlocal::lib -Mlib::core::only -Mlocal::lib=~/perl5 myscript.pl To attempt to do a self-contained build (but note this will not reliably propagate into subprocesses, see the CAVEATS below): $ PERL5OPT='-mlocal::lib -Mlib::core::only -Mlocal::lib=~/perl5' cpan Please note that it is necessary to use C<local::lib> twice for this to work. First so that C<lib::core::only> doesn't prevent C<local::lib> from loading (it's not currently in core) and then again after C<lib::core::only> so that the local paths are not removed. =head1 DESCRIPTION lib::core::only is simply a shortcut to say "please reduce my @INC to only the core lib and archlib (architecture-specific lib) directories of this perl". You might want to do this to ensure a local::lib contains only the code you need, or to test an L<App::FatPacker|App::FatPacker> tree, or to avoid known bad vendor packages. You might want to use this to try and install a self-contained tree of perl modules. Be warned that that probably won't work (see L</CAVEATS>). This module was extracted from L<local::lib|local::lib>'s --self-contained feature, and contains the only part that ever worked. I apologise to anybody who thought anything else did. =head1 CAVEATS This does B<not> propagate properly across perl invocations like local::lib's stuff does. It can't. It's only a module import, so it B<only affects the specific perl VM instance in which you load and import() it>. If you want to cascade it across invocations, you can set the PERL5OPT environment variable to '-Mlib::core::only' and it'll sort of work. But be aware that taint mode ignores this, so some modules' build and test code probably will as well. You also need to be aware that perl's command line options are not processed in order - -I options take effect before -M options, so perl -Mlib::core::only -Ilib is unlike to do what you want - it's exactly equivalent to: perl -Mlib::core::only If you want to combine a core-only @INC with additional paths, you need to add the additional paths using -M options and the L<lib|lib> module: perl -Mlib::core::only -Mlib=lib # or if you're trying to test compiled code: perl -Mlib::core::only -Mblib For more information on the impossibility of sanely propagating this across module builds without help from the build program, see L<http://www.shadowcat.co.uk/blog/matt-s-trout/tainted-love> - and for ways to achieve the old --self-contained feature's results, look at L<App::FatPacker|App::FatPacker>'s tree function, and at L<App::cpanminus|cpanm>'s --local-lib-contained feature. =head1 AUTHOR Matt S. Trout <mst@shadowcat.co.uk> =head1 LICENSE This library is free software under the same terms as perl itself. =head1 COPYRIGHT (c) 2010 the lib::core::only L</AUTHOR> as specified above. =cut 1; LIB_CORE_ONLY $fatpacked{"local/lib.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LOCAL_LIB'; package local::lib; use 5.006; BEGIN { if ($ENV{RELEASE_TESTING}) { require strict; strict->import; require warnings; warnings->import; } } use Config (); our $VERSION = '2.000029'; $VERSION =~ tr/_//d; BEGIN { *_WIN32 = ($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'symbian') ? sub(){1} : sub(){0}; # punt on these systems *_USE_FSPEC = ($^O eq 'MacOS' || $^O eq 'VMS' || $INC{'File/Spec.pm'}) ? sub(){1} : sub(){0}; } my $_archname = $Config::Config{archname}; my $_version = $Config::Config{version}; my @_inc_version_list = reverse split / /, $Config::Config{inc_version_list}; my $_path_sep = $Config::Config{path_sep}; our $_DIR_JOIN = _WIN32 ? '\\' : '/'; our $_DIR_SPLIT = (_WIN32 || $^O eq 'cygwin') ? qr{[\\/]} : qr{/}; our $_ROOT = _WIN32 ? do { my $UNC = qr{[\\/]{2}[^\\/]+[\\/][^\\/]+}; qr{^(?:$UNC|[A-Za-z]:|)$_DIR_SPLIT}; } : qr{^/}; our $_PERL; sub _perl { if (!$_PERL) { # untaint and validate ($_PERL, my $exe) = $^X =~ /((?:.*$_DIR_SPLIT)?(.+))/; $_PERL = 'perl' if $exe !~ /perl/; if (_is_abs($_PERL)) { } elsif (-x $Config::Config{perlpath}) { $_PERL = $Config::Config{perlpath}; } elsif ($_PERL =~ $_DIR_SPLIT && -x $_PERL) { $_PERL = _rel2abs($_PERL); } else { ($_PERL) = map { /(.*)/ } grep { -x $_ } map { ($_, _WIN32 ? ("$_.exe") : ()) } map { join($_DIR_JOIN, $_, $_PERL) } split /\Q$_path_sep\E/, $ENV{PATH}; } } $_PERL; } sub _cwd { if (my $cwd = defined &Cwd::sys_cwd ? \&Cwd::sys_cwd : defined &Cwd::cwd ? \&Cwd::cwd : undef ) { no warnings 'redefine'; *_cwd = $cwd; goto &$cwd; } my $drive = shift; return Win32::GetCwd() if _WIN32 && defined &Win32::GetCwd && !$drive; local @ENV{qw(PATH IFS CDPATH ENV BASH_ENV)}; delete @ENV{qw(PATH IFS CDPATH ENV BASH_ENV)}; my $cmd = $drive ? "eval { Cwd::getdcwd(q($drive)) }" : 'getcwd'; my $perl = _perl; my $cwd = `"$perl" -MCwd -le "print $cmd"`; chomp $cwd; if (!length $cwd && $drive) { $cwd = $drive; } $cwd =~ s/$_DIR_SPLIT?$/$_DIR_JOIN/; $cwd; } sub _catdir { if (_USE_FSPEC) { require File::Spec; File::Spec->catdir(@_); } else { my $dir = join($_DIR_JOIN, @_); $dir =~ s{($_DIR_SPLIT)(?:\.?$_DIR_SPLIT)+}{$1}g; $dir; } } sub _is_abs { if (_USE_FSPEC) { require File::Spec; File::Spec->file_name_is_absolute($_[0]); } else { $_[0] =~ $_ROOT; } } sub _rel2abs { my ($dir, $base) = @_; return $dir if _is_abs($dir); $base = _WIN32 && $dir =~ s/^([A-Za-z]:)// ? _cwd("$1") : $base ? _rel2abs($base) : _cwd; return _catdir($base, $dir); } our $_DEVNULL; sub _devnull { return $_DEVNULL ||= _USE_FSPEC ? (require File::Spec, File::Spec->devnull) : _WIN32 ? 'nul' : $^O eq 'os2' ? '/dev/nul' : '/dev/null'; } sub import { my ($class, @args) = @_; if ($0 eq '-') { push @args, @ARGV; require Cwd; } my @steps; my %opts; my %attr; my $shelltype; while (@args) { my $arg = shift @args; # check for lethal dash first to stop processing before causing problems # the fancy dash is U+2212 or \xE2\x88\x92 if ($arg =~ /\xE2\x88\x92/) { die <<'DEATH'; WHOA THERE! It looks like you've got some fancy dashes in your commandline! These are *not* the traditional -- dashes that software recognizes. You probably got these by copy-pasting from the perldoc for this module as rendered by a UTF8-capable formatter. This most typically happens on an OS X terminal, but can happen elsewhere too. Please try again after replacing the dashes with normal minus signs. DEATH } elsif ($arg eq '--self-contained') { die <<'DEATH'; FATAL: The local::lib --self-contained flag has never worked reliably and the original author, Mark Stosberg, was unable or unwilling to maintain it. As such, this flag has been removed from the local::lib codebase in order to prevent misunderstandings and potentially broken builds. The local::lib authors recommend that you look at the lib::core::only module shipped with this distribution in order to create a more robust environment that is equivalent to what --self-contained provided (although quite possibly not what you originally thought it provided due to the poor quality of the documentation, for which we apologise). DEATH } elsif( $arg =~ /^--deactivate(?:=(.*))?$/ ) { my $path = defined $1 ? $1 : shift @args; push @steps, ['deactivate', $path]; } elsif ( $arg eq '--deactivate-all' ) { push @steps, ['deactivate_all']; } elsif ( $arg =~ /^--shelltype(?:=(.*))?$/ ) { $shelltype = defined $1 ? $1 : shift @args; } elsif ( $arg eq '--no-create' ) { $opts{no_create} = 1; } elsif ( $arg eq '--quiet' ) { $attr{quiet} = 1; } elsif ( $arg eq '--always' ) { $attr{always} = 1; } elsif ( $arg =~ /^--/ ) { die "Unknown import argument: $arg"; } else { push @steps, ['activate', $arg, \%opts]; } } if (!@steps) { push @steps, ['activate', undef, \%opts]; } my $self = $class->new(%attr); for (@steps) { my ($method, @args) = @$_; $self = $self->$method(@args); } if ($0 eq '-') { print $self->environment_vars_string($shelltype); exit 0; } else { $self->setup_local_lib; } } sub new { my $class = shift; bless {@_}, $class; } sub clone { my $self = shift; bless {%$self, @_}, ref $self; } sub inc { $_[0]->{inc} ||= \@INC } sub libs { $_[0]->{libs} ||= [ \'PERL5LIB' ] } sub bins { $_[0]->{bins} ||= [ \'PATH' ] } sub roots { $_[0]->{roots} ||= [ \'PERL_LOCAL_LIB_ROOT' ] } sub extra { $_[0]->{extra} ||= {} } sub quiet { $_[0]->{quiet} } sub _as_list { my $list = shift; grep length, map { !(ref $_ && ref $_ eq 'SCALAR') ? $_ : ( defined $ENV{$$_} ? split(/\Q$_path_sep/, $ENV{$$_}) : () ) } ref $list ? @$list : $list; } sub _remove_from { my ($list, @remove) = @_; return @$list if !@remove; my %remove = map { $_ => 1 } @remove; grep !$remove{$_}, _as_list($list); } my @_lib_subdirs = ( [$_version, $_archname], [$_version], [$_archname], (map [$_], @_inc_version_list), [], ); sub install_base_bin_path { my ($class, $path) = @_; return _catdir($path, 'bin'); } sub install_base_perl_path { my ($class, $path) = @_; return _catdir($path, 'lib', 'perl5'); } sub install_base_arch_path { my ($class, $path) = @_; _catdir($class->install_base_perl_path($path), $_archname); } sub lib_paths_for { my ($class, $path) = @_; my $base = $class->install_base_perl_path($path); return map { _catdir($base, @$_) } @_lib_subdirs; } sub _mm_escape_path { my $path = shift; $path =~ s/\\/\\\\/g; if ($path =~ s/ /\\ /g) { $path = qq{"$path"}; } return $path; } sub _mb_escape_path { my $path = shift; $path =~ s/\\/\\\\/g; return qq{"$path"}; } sub installer_options_for { my ($class, $path) = @_; return ( PERL_MM_OPT => defined $path ? "INSTALL_BASE="._mm_escape_path($path) : undef, PERL_MB_OPT => defined $path ? "--install_base "._mb_escape_path($path) : undef, ); } sub active_paths { my ($self) = @_; $self = ref $self ? $self : $self->new; return grep { # screen out entries that aren't actually reflected in @INC my $active_ll = $self->install_base_perl_path($_); grep { $_ eq $active_ll } @{$self->inc}; } _as_list($self->roots); } sub deactivate { my ($self, $path) = @_; $self = $self->new unless ref $self; $path = $self->resolve_path($path); $path = $self->normalize_path($path); my @active_lls = $self->active_paths; if (!grep { $_ eq $path } @active_lls) { warn "Tried to deactivate inactive local::lib '$path'\n"; return $self; } my %args = ( bins => [ _remove_from($self->bins, $self->install_base_bin_path($path)) ], libs => [ _remove_from($self->libs, $self->install_base_perl_path($path)) ], inc => [ _remove_from($self->inc, $self->lib_paths_for($path)) ], roots => [ _remove_from($self->roots, $path) ], ); $args{extra} = { $self->installer_options_for($args{roots}[0]) }; $self->clone(%args); } sub deactivate_all { my ($self) = @_; $self = $self->new unless ref $self; my @active_lls = $self->active_paths; my %args; if (@active_lls) { %args = ( bins => [ _remove_from($self->bins, map $self->install_base_bin_path($_), @active_lls) ], libs => [ _remove_from($self->libs, map $self->install_base_perl_path($_), @active_lls) ], inc => [ _remove_from($self->inc, map $self->lib_paths_for($_), @active_lls) ], roots => [ _remove_from($self->roots, @active_lls) ], ); } $args{extra} = { $self->installer_options_for(undef) }; $self->clone(%args); } sub activate { my ($self, $path, $opts) = @_; $opts ||= {}; $self = $self->new unless ref $self; $path = $self->resolve_path($path); $self->ensure_dir_structure_for($path, { quiet => $self->quiet }) unless $opts->{no_create}; $path = $self->normalize_path($path); my @active_lls = $self->active_paths; if (grep { $_ eq $path } @active_lls[1 .. $#active_lls]) { $self = $self->deactivate($path); } my %args; if ($opts->{always} || !@active_lls || $active_lls[0] ne $path) { %args = ( bins => [ $self->install_base_bin_path($path), @{$self->bins} ], libs => [ $self->install_base_perl_path($path), @{$self->libs} ], inc => [ $self->lib_paths_for($path), @{$self->inc} ], roots => [ $path, @{$self->roots} ], ); } $args{extra} = { $self->installer_options_for($path) }; $self->clone(%args); } sub normalize_path { my ($self, $path) = @_; $path = ( Win32::GetShortPathName($path) || $path ) if $^O eq 'MSWin32'; return $path; } sub build_environment_vars_for { my $self = $_[0]->new->activate($_[1], { always => 1 }); $self->build_environment_vars; } sub build_activate_environment_vars_for { my $self = $_[0]->new->activate($_[1], { always => 1 }); $self->build_environment_vars; } sub build_deactivate_environment_vars_for { my $self = $_[0]->new->deactivate($_[1]); $self->build_environment_vars; } sub build_deact_all_environment_vars_for { my $self = $_[0]->new->deactivate_all; $self->build_environment_vars; } sub build_environment_vars { my $self = shift; ( PATH => join($_path_sep, _as_list($self->bins)), PERL5LIB => join($_path_sep, _as_list($self->libs)), PERL_LOCAL_LIB_ROOT => join($_path_sep, _as_list($self->roots)), %{$self->extra}, ); } sub setup_local_lib_for { my $self = $_[0]->new->activate($_[1]); $self->setup_local_lib; } sub setup_local_lib { my $self = shift; # if Carp is already loaded, ensure Carp::Heavy is also loaded, to avoid # $VERSION mismatch errors (Carp::Heavy loads Carp, so we do not need to # check in the other direction) require Carp::Heavy if $INC{'Carp.pm'}; $self->setup_env_hash; @INC = @{$self->inc}; } sub setup_env_hash_for { my $self = $_[0]->new->activate($_[1]); $self->setup_env_hash; } sub setup_env_hash { my $self = shift; my %env = $self->build_environment_vars; for my $key (keys %env) { if (defined $env{$key}) { $ENV{$key} = $env{$key}; } else { delete $ENV{$key}; } } } sub print_environment_vars_for { print $_[0]->environment_vars_string_for(@_[1..$#_]); } sub environment_vars_string_for { my $self = $_[0]->new->activate($_[1], { always => 1}); $self->environment_vars_string; } sub environment_vars_string { my ($self, $shelltype) = @_; $shelltype ||= $self->guess_shelltype; my $extra = $self->extra; my @envs = ( PATH => $self->bins, PERL5LIB => $self->libs, PERL_LOCAL_LIB_ROOT => $self->roots, map { $_ => $extra->{$_} } sort keys %$extra, ); $self->_build_env_string($shelltype, \@envs); } sub _build_env_string { my ($self, $shelltype, $envs) = @_; my @envs = @$envs; my $build_method = "build_${shelltype}_env_declaration"; my $out = ''; while (@envs) { my ($name, $value) = (shift(@envs), shift(@envs)); if ( ref $value && @$value == 1 && ref $value->[0] && ref $value->[0] eq 'SCALAR' && ${$value->[0]} eq $name) { next; } $out .= $self->$build_method($name, $value); } my $wrap_method = "wrap_${shelltype}_output"; if ($self->can($wrap_method)) { return $self->$wrap_method($out); } return $out; } sub build_bourne_env_declaration { my ($class, $name, $args) = @_; my $value = $class->_interpolate($args, '${%s:-}', qr/["\\\$!`]/, '\\%s'); if (!defined $value) { return qq{unset $name;\n}; } $value =~ s/(^|\G|$_path_sep)\$\{$name:-\}$_path_sep/$1\${$name}\${$name:+$_path_sep}/g; $value =~ s/$_path_sep\$\{$name:-\}$/\${$name:+$_path_sep\${$name}}/; qq{${name}="$value"; export ${name};\n} } sub build_csh_env_declaration { my ($class, $name, $args) = @_; my ($value, @vars) = $class->_interpolate($args, '${%s}', qr/["\$]/, '"\\%s"'); if (!defined $value) { return qq{unsetenv $name;\n}; } my $out = ''; for my $var (@vars) { $out .= qq{if ! \$?$name setenv $name '';\n}; } my $value_without = $value; if ($value_without =~ s/(?:^|$_path_sep)\$\{$name\}(?:$_path_sep|$)//g) { $out .= qq{if "\${$name}" != '' setenv $name "$value";\n}; $out .= qq{if "\${$name}" == '' }; } $out .= qq{setenv $name "$value_without";\n}; return $out; } sub build_cmd_env_declaration { my ($class, $name, $args) = @_; my $value = $class->_interpolate($args, '%%%s%%', qr(%), '%s'); if (!$value) { return qq{\@set $name=\n}; } my $out = ''; my $value_without = $value; if ($value_without =~ s/(?:^|$_path_sep)%$name%(?:$_path_sep|$)//g) { $out .= qq{\@if not "%$name%"=="" set "$name=$value"\n}; $out .= qq{\@if "%$name%"=="" }; } $out .= qq{\@set "$name=$value_without"\n}; return $out; } sub build_powershell_env_declaration { my ($class, $name, $args) = @_; my $value = $class->_interpolate($args, '$env:%s', qr/["\$]/, '`%s'); if (!$value) { return qq{Remove-Item -ErrorAction 0 Env:\\$name;\n}; } my $maybe_path_sep = qq{\$(if("\$env:$name"-eq""){""}else{"$_path_sep"})}; $value =~ s/(^|\G|$_path_sep)\$env:$name$_path_sep/$1\$env:$name"+$maybe_path_sep+"/g; $value =~ s/$_path_sep\$env:$name$/"+$maybe_path_sep+\$env:$name+"/; qq{\$env:$name = \$("$value");\n}; } sub wrap_powershell_output { my ($class, $out) = @_; return $out || " \n"; } sub build_fish_env_declaration { my ($class, $name, $args) = @_; my $value = $class->_interpolate($args, '$%s', qr/[\\"'$ ]/, '\\%s'); if (!defined $value) { return qq{set -e $name;\n}; } # fish has special handling for PATH, CDPATH, and MANPATH. They are always # treated as arrays, and joined with ; when storing the environment. Other # env vars can be arrays, but will be joined without a separator. We only # really care about PATH, but might as well make this routine more general. if ($name =~ /^(?:CD|MAN)?PATH$/) { $value =~ s/$_path_sep/ /g; my $silent = $name =~ /^(?:CD)?PATH$/ ? " 2>"._devnull : ''; return qq{set -x $name $value$silent;\n}; } my $out = ''; my $value_without = $value; if ($value_without =~ s/(?:^|$_path_sep)\$$name(?:$_path_sep|$)//g) { $out .= qq{set -q $name; and set -x $name $value;\n}; $out .= qq{set -q $name; or }; } $out .= qq{set -x $name $value_without;\n}; $out; } sub _interpolate { my ($class, $args, $var_pat, $escape, $escape_pat) = @_; return unless defined $args; my @args = ref $args ? @$args : $args; return unless @args; my @vars = map { $$_ } grep { ref $_ eq 'SCALAR' } @args; my $string = join $_path_sep, map { ref $_ eq 'SCALAR' ? sprintf($var_pat, $$_) : do { s/($escape)/sprintf($escape_pat, $1)/ge; $_; }; } @args; return wantarray ? ($string, \@vars) : $string; } sub pipeline; sub pipeline { my @methods = @_; my $last = pop(@methods); if (@methods) { \sub { my ($obj, @args) = @_; $obj->${pipeline @methods}( $obj->$last(@args) ); }; } else { \sub { shift->$last(@_); }; } } sub resolve_path { my ($class, $path) = @_; $path = $class->${pipeline qw( resolve_relative_path resolve_home_path resolve_empty_path )}($path); $path; } sub resolve_empty_path { my ($class, $path) = @_; if (defined $path) { $path; } else { '~/perl5'; } } sub resolve_home_path { my ($class, $path) = @_; $path =~ /^~([^\/]*)/ or return $path; my $user = $1; my $homedir = do { if (! length($user) && defined $ENV{HOME}) { $ENV{HOME}; } else { require File::Glob; File::Glob::bsd_glob("~$user", File::Glob::GLOB_TILDE()); } }; unless (defined $homedir) { require Carp; require Carp::Heavy; Carp::croak( "Couldn't resolve homedir for " .(defined $user ? $user : 'current user') ); } $path =~ s/^~[^\/]*/$homedir/; $path; } sub resolve_relative_path { my ($class, $path) = @_; _rel2abs($path); } sub ensure_dir_structure_for { my ($class, $path, $opts) = @_; $opts ||= {}; my @dirs; foreach my $dir ( $class->lib_paths_for($path), $class->install_base_bin_path($path), ) { my $d = $dir; while (!-d $d) { push @dirs, $d; require File::Basename; $d = File::Basename::dirname($d); } } warn "Attempting to create directory ${path}\n" if !$opts->{quiet} && @dirs; my %seen; foreach my $dir (reverse @dirs) { next if $seen{$dir}++; mkdir $dir or -d $dir or die "Unable to create $dir: $!" } return; } sub guess_shelltype { my $shellbin = defined $ENV{SHELL} && length $ENV{SHELL} ? ($ENV{SHELL} =~ /([\w.]+)$/)[-1] : ( $^O eq 'MSWin32' && exists $ENV{'!EXITCODE'} ) ? 'bash' : ( $^O eq 'MSWin32' && $ENV{PROMPT} && $ENV{COMSPEC} ) ? ($ENV{COMSPEC} =~ /([\w.]+)$/)[-1] : ( $^O eq 'MSWin32' && !$ENV{PROMPT} ) ? 'powershell.exe' : 'sh'; for ($shellbin) { return /csh$/ ? 'csh' : /fish$/ ? 'fish' : /command(?:\.com)?$/i ? 'cmd' : /cmd(?:\.exe)?$/i ? 'cmd' : /4nt(?:\.exe)?$/i ? 'cmd' : /powershell(?:\.exe)?$/i ? 'powershell' : 'bourne'; } } 1; __END__ =encoding utf8 =head1 NAME local::lib - create and use a local lib/ for perl modules with PERL5LIB =head1 SYNOPSIS In code - use local::lib; # sets up a local lib at ~/perl5 use local::lib '~/foo'; # same, but ~/foo # Or... use FindBin; use local::lib "$FindBin::Bin/../support"; # app-local support library From the shell - # Install LWP and its missing dependencies to the '~/perl5' directory perl -MCPAN -Mlocal::lib -e 'CPAN::install(LWP)' # Just print out useful shell commands $ perl -Mlocal::lib PERL_MB_OPT='--install_base /home/username/perl5'; export PERL_MB_OPT; PERL_MM_OPT='INSTALL_BASE=/home/username/perl5'; export PERL_MM_OPT; PERL5LIB="/home/username/perl5/lib/perl5"; export PERL5LIB; PATH="/home/username/perl5/bin:$PATH"; export PATH; PERL_LOCAL_LIB_ROOT="/home/usename/perl5:$PERL_LOCAL_LIB_ROOT"; export PERL_LOCAL_LIB_ROOT; From a F<.bash_profile> or F<.bashrc> file - eval "$(perl -I$HOME/perl5/lib/perl5 -Mlocal::lib)" =head2 The bootstrapping technique A typical way to install local::lib is using what is known as the "bootstrapping" technique. You would do this if your system administrator hasn't already installed local::lib. In this case, you'll need to install local::lib in your home directory. Even if you do have administrative privileges, you will still want to set up your environment variables, as discussed in step 4. Without this, you would still install the modules into the system CPAN installation and also your Perl scripts will not use the lib/ path you bootstrapped with local::lib. By default local::lib installs itself and the CPAN modules into ~/perl5. Windows users must also see L</Differences when using this module under Win32>. =over 4 =item 1. Download and unpack the local::lib tarball from CPAN (search for "Download" on the CPAN page about local::lib). Do this as an ordinary user, not as root or administrator. Unpack the file in your home directory or in any other convenient location. =item 2. Run this: perl Makefile.PL --bootstrap If the system asks you whether it should automatically configure as much as possible, you would typically answer yes. =item 3. Run this: (local::lib assumes you have make installed on your system) make test && make install =item 4. Now we need to setup the appropriate environment variables, so that Perl starts using our newly generated lib/ directory. If you are using bash or any other Bourne shells, you can add this to your shell startup script this way: echo 'eval "$(perl -I$HOME/perl5/lib/perl5 -Mlocal::lib)"' >>~/.bashrc If you are using C shell, you can do this as follows: % echo $SHELL /bin/csh $ echo 'eval `perl -I$HOME/perl5/lib/perl5 -Mlocal::lib`' >> ~/.cshrc After writing your shell configuration file, be sure to re-read it to get the changed settings into your current shell's environment. Bourne shells use C<. ~/.bashrc> for this, whereas C shells use C<source ~/.cshrc>. =back =head3 Bootstrapping into an alternate directory In order to install local::lib into a directory other than the default, you need to specify the name of the directory when you call bootstrap. Then, when setting up the environment variables, both perl and local::lib must be told the location of the bootstrap directory. The setup process would look as follows: perl Makefile.PL --bootstrap=~/foo make test && make install echo 'eval "$(perl -I$HOME/foo/lib/perl5 -Mlocal::lib=$HOME/foo)"' >>~/.bashrc . ~/.bashrc =head3 Other bootstrapping options If you're on a slower machine, or are operating under draconian disk space limitations, you can disable the automatic generation of manpages from POD when installing modules by using the C<--no-manpages> argument when bootstrapping: perl Makefile.PL --bootstrap --no-manpages To avoid doing several bootstrap for several Perl module environments on the same account, for example if you use it for several different deployed applications independently, you can use one bootstrapped local::lib installation to install modules in different directories directly this way: cd ~/mydir1 perl -Mlocal::lib=./ eval $(perl -Mlocal::lib=./) ### To set the environment for this shell alone printenv ### You will see that ~/mydir1 is in the PERL5LIB perl -MCPAN -e install ... ### whatever modules you want cd ../mydir2 ... REPEAT ... If you use F<.bashrc> to activate a local::lib automatically, the local::lib will be re-enabled in any sub-shells used, overriding adjustments you may have made in the parent shell. To avoid this, you can initialize the local::lib in F<.bash_profile> rather than F<.bashrc>, or protect the local::lib invocation with a C<$SHLVL> check: [ $SHLVL -eq 1 ] && eval "$(perl -I$HOME/perl5/lib/perl5 -Mlocal::lib)" If you are working with several C<local::lib> environments, you may want to remove some of them from the current environment without disturbing the others. You can deactivate one environment like this (using bourne sh): eval $(perl -Mlocal::lib=--deactivate,~/path) which will generate and run the commands needed to remove C<~/path> from your various search paths. Whichever environment was B<activated most recently> will remain the target for module installations. That is, if you activate C<~/path_A> and then you activate C<~/path_B>, new modules you install will go in C<~/path_B>. If you deactivate C<~/path_B> then modules will be installed into C<~/pathA> -- but if you deactivate C<~/path_A> then they will still be installed in C<~/pathB> because pathB was activated later. You can also ask C<local::lib> to clean itself completely out of the current shell's environment with the C<--deactivate-all> option. For multiple environments for multiple apps you may need to include a modified version of the C<< use FindBin >> instructions in the "In code" sample above. If you did something like the above, you have a set of Perl modules at C<< ~/mydir1/lib >>. If you have a script at C<< ~/mydir1/scripts/myscript.pl >>, you need to tell it where to find the modules you installed for it at C<< ~/mydir1/lib >>. In C<< ~/mydir1/scripts/myscript.pl >>: use strict; use warnings; use local::lib "$FindBin::Bin/.."; ### points to ~/mydir1 and local::lib finds lib use lib "$FindBin::Bin/../lib"; ### points to ~/mydir1/lib Put this before any BEGIN { ... } blocks that require the modules you installed. =head2 Differences when using this module under Win32 To set up the proper environment variables for your current session of C<CMD.exe>, you can use this: C:\>perl -Mlocal::lib set PERL_MB_OPT=--install_base C:\DOCUME~1\ADMINI~1\perl5 set PERL_MM_OPT=INSTALL_BASE=C:\DOCUME~1\ADMINI~1\perl5 set PERL5LIB=C:\DOCUME~1\ADMINI~1\perl5\lib\perl5 set PATH=C:\DOCUME~1\ADMINI~1\perl5\bin;%PATH% ### To set the environment for this shell alone C:\>perl -Mlocal::lib > %TEMP%\tmp.bat && %TEMP%\tmp.bat && del %TEMP%\tmp.bat ### instead of $(perl -Mlocal::lib=./) If you want the environment entries to persist, you'll need to add them to the Control Panel's System applet yourself or use L<App::local::lib::Win32Helper>. The "~" is translated to the user's profile directory (the directory named for the user under "Documents and Settings" (Windows XP or earlier) or "Users" (Windows Vista or later)) unless $ENV{HOME} exists. After that, the home directory is translated to a short name (which means the directory must exist) and the subdirectories are created. =head3 PowerShell local::lib also supports PowerShell, and can be used with the C<Invoke-Expression> cmdlet. Invoke-Expression "$(perl -Mlocal::lib)" =head1 RATIONALE The version of a Perl package on your machine is not always the version you need. Obviously, the best thing to do would be to update to the version you need. However, you might be in a situation where you're prevented from doing this. Perhaps you don't have system administrator privileges; or perhaps you are using a package management system such as Debian, and nobody has yet gotten around to packaging up the version you need. local::lib solves this problem by allowing you to create your own directory of Perl packages downloaded from CPAN (in a multi-user system, this would typically be within your own home directory). The existing system Perl installation is not affected; you simply invoke Perl with special options so that Perl uses the packages in your own local package directory rather than the system packages. local::lib arranges things so that your locally installed version of the Perl packages takes precedence over the system installation. If you are using a package management system (such as Debian), you don't need to worry about Debian and CPAN stepping on each other's toes. Your local version of the packages will be written to an entirely separate directory from those installed by Debian. =head1 DESCRIPTION This module provides a quick, convenient way of bootstrapping a user-local Perl module library located within the user's home directory. It also constructs and prints out for the user the list of environment variables using the syntax appropriate for the user's current shell (as specified by the C<SHELL> environment variable), suitable for directly adding to one's shell configuration file. More generally, local::lib allows for the bootstrapping and usage of a directory containing Perl modules outside of Perl's C<@INC>. This makes it easier to ship an application with an app-specific copy of a Perl module, or collection of modules. Useful in cases like when an upstream maintainer hasn't applied a patch to a module of theirs that you need for your application. On import, local::lib sets the following environment variables to appropriate values: =over 4 =item PERL_MB_OPT =item PERL_MM_OPT =item PERL5LIB =item PATH =item PERL_LOCAL_LIB_ROOT =back When possible, these will be appended to instead of overwritten entirely. These values are then available for reference by any code after import. =head1 CREATING A SELF-CONTAINED SET OF MODULES See L<lib::core::only> for one way to do this - but note that there are a number of caveats, and the best approach is always to perform a build against a clean perl (i.e. site and vendor as close to empty as possible). =head1 IMPORT OPTIONS Options are values that can be passed to the C<local::lib> import besides the directory to use. They are specified as C<use local::lib '--option'[, path];> or C<perl -Mlocal::lib=--option[,path]>. =head2 --deactivate Remove the chosen path (or the default path) from the module search paths if it was added by C<local::lib>, instead of adding it. =head2 --deactivate-all Remove all directories that were added to search paths by C<local::lib> from the search paths. =head2 --quiet Don't output any messages about directories being created. =head2 --always Always add directories to environment variables, ignoring if they are already included. =head2 --shelltype Specify the shell type to use for output. By default, the shell will be detected based on the environment. Should be one of: C<bourne>, C<csh>, C<cmd>, or C<powershell>. =head2 --no-create Prevents C<local::lib> from creating directories when activating dirs. This is likely to cause issues on Win32 systems. =head1 CLASS METHODS =head2 ensure_dir_structure_for =over 4 =item Arguments: $path =item Return value: None =back Attempts to create a local::lib directory, including subdirectories and all required parent directories. Throws an exception on failure. =head2 print_environment_vars_for =over 4 =item Arguments: $path =item Return value: None =back Prints to standard output the variables listed above, properly set to use the given path as the base directory. =head2 build_environment_vars_for =over 4 =item Arguments: $path =item Return value: %environment_vars =back Returns a hash with the variables listed above, properly set to use the given path as the base directory. =head2 setup_env_hash_for =over 4 =item Arguments: $path =item Return value: None =back Constructs the C<%ENV> keys for the given path, by calling L</build_environment_vars_for>. =head2 active_paths =over 4 =item Arguments: None =item Return value: @paths =back Returns a list of active C<local::lib> paths, according to the C<PERL_LOCAL_LIB_ROOT> environment variable and verified against what is really in C<@INC>. =head2 install_base_perl_path =over 4 =item Arguments: $path =item Return value: $install_base_perl_path =back Returns a path describing where to install the Perl modules for this local library installation. Appends the directories C<lib> and C<perl5> to the given path. =head2 lib_paths_for =over 4 =item Arguments: $path =item Return value: @lib_paths =back Returns the list of paths perl will search for libraries, given a base path. This includes the base path itself, the architecture specific subdirectory, and perl version specific subdirectories. These paths may not all exist. =head2 install_base_bin_path =over 4 =item Arguments: $path =item Return value: $install_base_bin_path =back Returns a path describing where to install the executable programs for this local library installation. Appends the directory C<bin> to the given path. =head2 installer_options_for =over 4 =item Arguments: $path =item Return value: %installer_env_vars =back Returns a hash of environment variables that should be set to cause installation into the given path. =head2 resolve_empty_path =over 4 =item Arguments: $path =item Return value: $base_path =back Builds and returns the base path into which to set up the local module installation. Defaults to C<~/perl5>. =head2 resolve_home_path =over 4 =item Arguments: $path =item Return value: $home_path =back Attempts to find the user's home directory. If no definite answer is available, throws an exception. =head2 resolve_relative_path =over 4 =item Arguments: $path =item Return value: $absolute_path =back Translates the given path into an absolute path. =head2 resolve_path =over 4 =item Arguments: $path =item Return value: $absolute_path =back Calls the following in a pipeline, passing the result from the previous to the next, in an attempt to find where to configure the environment for a local library installation: L</resolve_empty_path>, L</resolve_home_path>, L</resolve_relative_path>. Passes the given path argument to L</resolve_empty_path> which then returns a result that is passed to L</resolve_home_path>, which then has its result passed to L</resolve_relative_path>. The result of this final call is returned from L</resolve_path>. =head1 OBJECT INTERFACE =head2 new =over 4 =item Arguments: %attributes =item Return value: $local_lib =back Constructs a new C<local::lib> object, representing the current state of C<@INC> and the relevant environment variables. =head1 ATTRIBUTES =head2 roots An arrayref representing active C<local::lib> directories. =head2 inc An arrayref representing C<@INC>. =head2 libs An arrayref representing the PERL5LIB environment variable. =head2 bins An arrayref representing the PATH environment variable. =head2 extra A hashref of extra environment variables (e.g. C<PERL_MM_OPT> and C<PERL_MB_OPT>) =head2 no_create If set, C<local::lib> will not try to create directories when activating them. =head1 OBJECT METHODS =head2 clone =over 4 =item Arguments: %attributes =item Return value: $local_lib =back Constructs a new C<local::lib> object based on the existing one, overriding the specified attributes. =head2 activate =over 4 =item Arguments: $path =item Return value: $new_local_lib =back Constructs a new instance with the specified path active. =head2 deactivate =over 4 =item Arguments: $path =item Return value: $new_local_lib =back Constructs a new instance with the specified path deactivated. =head2 deactivate_all =over 4 =item Arguments: None =item Return value: $new_local_lib =back Constructs a new instance with all C<local::lib> directories deactivated. =head2 environment_vars_string =over 4 =item Arguments: [ $shelltype ] =item Return value: $shell_env_string =back Returns a string to set up the C<local::lib>, meant to be run by a shell. =head2 build_environment_vars =over 4 =item Arguments: None =item Return value: %environment_vars =back Returns a hash with the variables listed above, properly set to use the given path as the base directory. =head2 setup_env_hash =over 4 =item Arguments: None =item Return value: None =back Constructs the C<%ENV> keys for the given path, by calling L</build_environment_vars>. =head2 setup_local_lib Constructs the C<%ENV> hash using L</setup_env_hash>, and set up C<@INC>. =head1 A WARNING ABOUT UNINST=1 Be careful about using local::lib in combination with "make install UNINST=1". The idea of this feature is that will uninstall an old version of a module before installing a new one. However it lacks a safety check that the old version and the new version will go in the same directory. Used in combination with local::lib, you can potentially delete a globally accessible version of a module while installing the new version in a local place. Only combine "make install UNINST=1" and local::lib if you understand these possible consequences. =head1 LIMITATIONS =over 4 =item * Directory names with spaces in them are not well supported by the perl toolchain and the programs it uses. Pure-perl distributions should support spaces, but problems are more likely with dists that require compilation. A workaround you can do is moving your local::lib to a directory with spaces B<after> you installed all modules inside your local::lib bootstrap. But be aware that you can't update or install CPAN modules after the move. =item * Rather basic shell detection. Right now anything with csh in its name is assumed to be a C shell or something compatible, and everything else is assumed to be Bourne, except on Win32 systems. If the C<SHELL> environment variable is not set, a Bourne-compatible shell is assumed. =item * Kills any existing PERL_MM_OPT or PERL_MB_OPT. =item * Should probably auto-fixup CPAN config if not already done. =item * On VMS and MacOS Classic (pre-OS X), local::lib loads L<File::Spec>. This means any L<File::Spec> version installed in the local::lib will be ignored by scripts using local::lib. A workaround for this is using C<use lib "$local_lib/lib/perl5";> instead of using C<local::lib> directly. =item * Conflicts with L<ExtUtils::MakeMaker>'s C<PREFIX> option. C<local::lib> uses the C<INSTALL_BASE> option, as it has more predictable and sane behavior. If something attempts to use the C<PREFIX> option when running a F<Makefile.PL>, L<ExtUtils::MakeMaker> will refuse to run, as the two options conflict. This can be worked around by temporarily unsetting the C<PERL_MM_OPT> environment variable. =item * Conflicts with L<Module::Build>'s C<--prefix> option. Similar to the previous limitation, but any C<--prefix> option specified will be ignored. This can be worked around by temporarily unsetting the C<PERL_MB_OPT> environment variable. =back Patches very much welcome for any of the above. =over 4 =item * On Win32 systems, does not have a way to write the created environment variables to the registry, so that they can persist through a reboot. =back =head1 TROUBLESHOOTING If you've configured local::lib to install CPAN modules somewhere in to your home directory, and at some point later you try to install a module with C<cpan -i Foo::Bar>, but it fails with an error like: C<Warning: You do not have permissions to install into /usr/lib64/perl5/site_perl/5.8.8/x86_64-linux at /usr/lib64/perl5/5.8.8/Foo/Bar.pm> and buried within the install log is an error saying C<'INSTALL_BASE' is not a known MakeMaker parameter name>, then you've somehow lost your updated ExtUtils::MakeMaker module. To remedy this situation, rerun the bootstrapping procedure documented above. Then, run C<rm -r ~/.cpan/build/Foo-Bar*> Finally, re-run C<cpan -i Foo::Bar> and it should install without problems. =head1 ENVIRONMENT =over 4 =item SHELL =item COMSPEC local::lib looks at the user's C<SHELL> environment variable when printing out commands to add to the shell configuration file. On Win32 systems, C<COMSPEC> is also examined. =back =head1 SEE ALSO =over 4 =item * L<Perl Advent article, 2011|http://perladvent.org/2011/2011-12-01.html> =back =head1 SUPPORT IRC: Join #toolchain on irc.perl.org. =head1 AUTHOR Matt S Trout <mst@shadowcat.co.uk> http://www.shadowcat.co.uk/ auto_install fixes kindly sponsored by http://www.takkle.com/ =head1 CONTRIBUTORS Patches to correctly output commands for csh style shells, as well as some documentation additions, contributed by Christopher Nehren <apeiron@cpan.org>. Doc patches for a custom local::lib directory, more cleanups in the english documentation and a L<german documentation|POD2::DE::local::lib> contributed by Torsten Raudssus <torsten@raudssus.de>. Hans Dieter Pearcey <hdp@cpan.org> sent in some additional tests for ensuring things will install properly, submitted a fix for the bug causing problems with writing Makefiles during bootstrapping, contributed an example program, and submitted yet another fix to ensure that local::lib can install and bootstrap properly. Many, many thanks! pattern of Freenode IRC contributed the beginnings of the Troubleshooting section. Many thanks! Patch to add Win32 support contributed by Curtis Jewell <csjewell@cpan.org>. Warnings for missing PATH/PERL5LIB (as when not running interactively) silenced by a patch from Marco Emilio Poleggi. Mark Stosberg <mark@summersault.com> provided the code for the now deleted '--self-contained' option. Documentation patches to make win32 usage clearer by David Mertens <dcmertens.perl@gmail.com> (run4flat). Brazilian L<portuguese translation|POD2::PT_BR::local::lib> and minor doc patches contributed by Breno G. de Oliveira <garu@cpan.org>. Improvements to stacking multiple local::lib dirs and removing them from the environment later on contributed by Andrew Rodland <arodland@cpan.org>. Patch for Carp version mismatch contributed by Hakim Cassimally <osfameron@cpan.org>. Rewrite of internals and numerous bug fixes and added features contributed by Graham Knop <haarg@haarg.org>. =head1 COPYRIGHT Copyright (c) 2007 - 2013 the local::lib L</AUTHOR> and L</CONTRIBUTORS> as listed above. =head1 LICENSE This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut LOCAL_LIB s/^ //mg for values %fatpacked; my $class = 'FatPacked::'.(0+\%fatpacked); no strict 'refs'; *{"${class}::files"} = sub { keys %{$_[0]} }; if ($] < 5.008) { *{"${class}::INC"} = sub { if (my $fat = $_[0]{$_[1]}) { my $pos = 0; my $last = length $fat; return (sub { return 0 if $pos == $last; my $next = (1 + index $fat, "\n", $pos) || $last; $_ .= substr $fat, $pos, $next - $pos; $pos = $next; return 1; }); } }; } else { *{"${class}::INC"} = sub { if (my $fat = $_[0]{$_[1]}) { open my $fh, '<', \$fat or die "FatPacker error loading $_[1] (could be a perl installation issue?)"; return $fh; } return; }; } unshift @INC, bless \%fatpacked, $class; } # END OF FATPACK CODE #!/usr/bin/perl use strict; use App::perlbrew; my $app = App::perlbrew->new(@ARGV); $app->run(); __END__ =head1 NAME perlbrew - Perl environment manager. =head1 SYNOPSIS perlbrew command syntax: perlbrew <command> [options] [arguments] Commands: init Initialize perlbrew environment. info Show useful information about the perlbrew installation install Install perl uninstall Uninstall the given installation available List perls available to install lib Manage local::lib directories. alias Give perl installations a new name upgrade-perl Upgrade the current perl list List perl installations use Use the specified perl in current shell off Turn off perlbrew in current shell switch Permanently use the specified perl as default switch-off Permanently turn off perlbrew (revert to system perl) exec Execute programs with specified perl environments. list-modules List installed CPAN modules for the current Perl version in use clone-modules Re-installs all CPAN modules from one installation to another self-install Install perlbrew itself under PERLBREW_ROOT/bin self-upgrade Upgrade perlbrew itself. install-patchperl Install patchperl install-cpanm Install cpanm, a friendly companion. install-cpm Install cpm, a faster but still friendly companion. install-multiple Install multiple versions and flavors of perl download Download the specified perl distribution tarball. clean Purge tarballs and build directories version Display version help Read more detailed instructions Generic command options: -q --quiet Be quiet on informative output message. -v --verbose Tell me more about it. See `perlbrew help` for the full documentation of perlbrew, or See `perlbrew help <command>` for detail description of the command. =head1 CONFIGURATION =over 4 =item PERLBREW_ROOT By default, perlbrew builds and installs perls into C<$ENV{HOME}/perl5/perlbrew> directory. To use a different directory, set this environment variable in your C<bashrc> to the directory in your shell RC before sourcing perlbrew's RC. It is possible to share one perlbrew root with multiple user account on the same machine. Therefore people do not have to install the same version of perl over an over. Let's say C</opt/perl5> is the directory we want to share. All users should be able append this snippet to their bashrc to make it effective: export PERLBREW_ROOT=/opt/perl5 source ${PERLBREW_ROOT}/etc/bashrc After doing so, everyone's PATH should include C</opt/perl5/bin> and C</opt/perl5/perls/${PERLBREW_PERL}/bin>. Each user can invoke C<perlbrew switch> and C<perlbrew use> to independently switch to different perl environment of their choice. However, only the user with write permission to C<$PERLBREW_ROOT> may install CPAN modules. This is both good and bad depending on the working convention of your team. If you wish to install CPAN modules only for yourself, you should use the C<lib> command to construct a personal local::lib environment. local::lib environments are personal, and are not shared between different users. For more detail, read C<perlbrew help lib> and the documentation of L<local::lib>. If you want even a cooler module isolation and wish to install CPAN modules used for just one project, you should use L<carton> for this purpose. It is also possible to set this variable before installing perlbrew to make perlbrew install itself under the given PERLBREW_ROOT: export PERLBREW_ROOT=/opt/perl5 curl -L https://install.perlbrew.pl | bash After doing this, the perlbrew executable is installed as C</opt/perl5/bin/perlbrew> =item PERLBREW_HOME By default, perlbrew stores per-user setting to C<$ENV{HOME}/.perlbrew> directory. To use a different directory, set this environment variable in your shell RC before sourcing perlbrew's RC. In some cases, say, your home directory is on NFS and shared across multiple machines, you may wish to have several different perlbrew setting per-machine. To do so, you can use the C<PERLBREW_HOME> environment variable to tell perlbrew where to look for the initialization file. Here's a brief bash snippet for the given scenario. if [ "$(hostname)" == "machine-a" ]; then export PERLBREW_HOME=~/.perlbrew-a elif [ "$(hostname)" == "machine-b" ]; then export PERLBREW_HOME=~/.perlbrew-b fi source ~/perl5/perlbrew/etc/bashrc =item PERLBREW_CONFIGURE_FLAGS This environment variable specify the list of command like flags to pass through to 'sh Configure'. By default it is '-de'. =item PERLBREW_CPAN_MIRROR The CPAN mirror url of your choice. By default, "https://cpan.metacpan.org" is used. =back =head1 COMMAND: INIT Usage: perlbrew init The C<init> command should be manually invoked whenever you (the perlbrew user) upgrade or reinstall perlbrew. If the upgrade is done with C<self-upgrade> command, or by running the one-line installer manually, this command is invoked automatically. =head1 COMMAND: INFO =over 4 =item B<info> [module] Usage: perlbrew info [ <module> ] Display useful information about the perlbrew installation. If a module is given the version and location of the module is displayed. =back =head1 COMMAND: INSTALL Usage: perlbrew install [options] <perl-release> perlbrew install [options] /path/to/perl-5.14.0.tar.gz perlbrew install [options] /path/to/perl/git/checkout/dir perlbrew install [options] https://example.com/mirror/perl-5.12.3.tar.gz Build and install the wanted perl. The last argument can be a short string designating a specific version which can be known from the output of C<perlbrew available>, a path to a pre-downloaded tarball, a path to a git-checkout of perl5 repo, or a URL to a tarball. The format of <perl-release> looks like: =over 4 =item perl-<version> =item perl-stable =item perl-blead =item <version> =item stable =item blead =back Version numbers usually look like "5.x.xx", or "perl-5.xx.x-RCx" for release candidates. Version "stable" is a special token that means whatever the latest stable version is at the moment. Version "blead" is also a special token that means whatever the latest version in the repository, which is downloaded from this specific URL regardless of mirror settings: https://github.com/Perl/perl5/archive/blead.tar.gz The specified perl is downloaded from the official CPAN website or from the mirror site configured before. Version number alone without the "perl-" prefix means the official release provided by perl5 porters. Options for C<install> command: -f --force Force installation -j $n Parallel building and testing. ex. C<perlbrew install -j 5 perl-5.14.2> -n --notest Skip testing --switch Automatically switch to this Perl once successfully installed, as if with `perlbrew switch <version>` --as Install the given version of perl by a name. ex. C<perlbrew install perl-5.6.2 --as legacy-perl> --noman Skip installation of manpages --thread Build perl with usethreads enabled --multi Build perl with usemultiplicity enabled --64int Build perl with use64bitint enabled --64all Build perl with use64bitall enabled --ld Build perl with uselongdouble enabled --debug Build perl with DEBUGGING enabled --clang Build perl using the clang compiler --no-patchperl Skip calling patchperl -D,-U,-A Switches passed to perl Configure script. ex. C<perlbrew install perl-5.10.1 -D usemymalloc -U versiononly> --destdir $path Install perl as per 'make install DESTDIR=$path' --sitecustomize $filename Specify a file to be installed as sitecustomize.pl --mirror $URL Specify a CPAN-mirror URL. The default value of this is "https://www.cpan.org" By default, all installations are configured after their name like this: sh Configure -de -Dprefix=$PERLBREW_ROOT/perls/<name> =head1 COMMAND: INSTALL-MULTIPLE Usage: perlbrew install-multiple [options] <perl-version-1> <perl-version-2> ... Build and install the given versions of perl. C<install-multiple> accepts the same set of options as the command C<install> plus the following ones: --both $flavor Where $flavor is one of C<thread>, C<multi>, C<ld>, C<64int>, C<64all>, C<debug> and C<clang>. For every given perl version, install two flavors, one with the flag C<--$flavor> set and the other with out. C<--both> can be passed multiple times with different values and in that case, all the possible combinations are generated. --common-variations equivalent to C<--both thread --both ld --both 64int> --all-variations generates all the possible flavor combinations --append $string Appends the given string to the generated names For instance: perlbrew install-multiple 5.18.0 blead --both thread --both debug Installs the following perls: perl-blead perl-blead-debug perl-blead-thread-multi perl-blead-thread-multi-debug perl-5.18.0 perl-5.18.0-debug perl-5.18.0-thread-multi perl-5.18.0-thread-multi-debug (note that the C<multi> flavor is selected automatically because C<thread> requires it) Another example using custom compilation flags: perlbrew install-multiple 5.18.0 --both thread -Doptimize='-O3' --append='-O3' =head1 COMMAND: UNINSTALL Usage: perlbrew uninstall <name> Uninstalls the given perl installation. The name is the installation name as in the output of `perlbrew list`. This effectively deletes the specified perl installation, and all libs associated with it. =head1 COMMAND: USE Usage: perlbrew B<use> [perl-<version> | <version> | <name>] Use the given version perl in current shell. This will not effect newly opened shells. Without a parameter, shows the version of perl currently in use. =head1 COMMAND: SWITCH Usage: perlbrew switch [ <name> ] Switch to the given version, and makes it the default for this and all future terminal sessions. Without a parameter, shows the version of perl currently selected. =head1 COMMAND: LIST Usage: perlbrew list List all perl installations inside perlbrew root specified by C<$PERLBREW_ROOT> environment variable. By default, the value is C<~/perl5/perlbrew>. If there are libs associated to some perl installations, they will be included as part of the name. The output items in this list can be the argument in various other commands. =head1 COMMAND: AVAILABLE Usage: perlbrew available [--all] List the recently available versions of perl on CPAN. By default, the latest sub-version of each stable versions are listed. To get a list of all perls ever released, inculding development and RC versions, run the command with C<--all> option. =head1 COMMAND: OFF Usage: perlbrew off Temporarily disable perlbrew in the current shell. Effectively re-enables the default system Perl, whatever that is. This command works only if you add the statement of `source $PERLBREW_ROOT/etc/bashrc` in your shell initialization (bashrc / zshrc). =head1 COMMAND: SWITCH-OFF Usage: perlbrew switch-off Permananently disable perlbrew. Use C<switch> command to re-enable it. Invoke C<use> command to enable it only in the current shell. Re-enables the default system Perl, whatever that is. =head1 COMMAND: ALIAS Usage: perlbrew alias [-f] create <name> <alias> Create an alias for the installation named <name>. Usage: perlbrew alias [-f] rename <old_alias> <new_alias> Rename the alias to a new name. Usage: perlbrew alias delete <alias> Delete the given alias. =head1 COMMAND: EXEC Usage: perlbrew exec [options] <command> <args...> Options for C<exec> command: --with perl-version,... - only use these versions --min n.nnnnn - minimum perl version (format is the same as in 'use 5.012') --max n.nnnnn - maximum perl version --halt-on-error - stop on first nonzero exit status Execute command for each perl installations, one by one. For example, run a Hello program: perlbrew exec perl -e 'print "Hello from $]\n"' The output looks like this: perl-5.12.2 ========== Hello word from perl-5.012002 perl-5.13.10 ========== Hello word from perl-5.013010 perl-5.14.0 ========== Hello word from perl-5.014000 Notice that the command is not executed in parallel. When C<--with> argument is provided, the command will be only executed with the specified perl installations. The following command install Moose module into perl-5.12, regardless the current perl: perlbrew exec --with perl-5.12 cpanm Moose Multiple installation names can be provided: perlbrew exec --with perl-5.12,perl-5.12-debug,perl-5.14.2 cpanm Moo They are split by either spaces or commas. When spaces are used, it is required to quote the whole specification as one argument, but then commas can be used in the installation names: perlbrew exec --with '5.12 5.12,debug 5.14.2@nobita @shizuka' cpanm Moo As demonstrated above, "perl-" prefix can be omitted, and lib names can be specified too. Lib names can appear without a perl installation name, in such cases it is assumed to be "current perl". At the moment, any specified names that fails to be resolved as a real installation names are silently ignored in the output. Also, the command exit status are not populated back. =head1 COMMAND: ENV Usage: perlbrew env [ <name> ] Low-level command. Invoke this command to see the list of environment variables that are set by C<perlbrew> itself for shell integration. The output is something similar to this (if your shell is bash/zsh): export PERLBREW_ROOT=/Users/gugod/perl5/perlbrew export PERLBREW_VERSION=0.31 export PERLBREW_PATH=/Users/gugod/perl5/perlbrew/bin:/Users/gugod/perl5/perlbrew/perls/current/bin export PERLBREW_PERL=perl-5.14.1 tcsh / csh users should see 'setenv' statements instead of `export`. =head1 COMMAND: SYMLINK-EXECUTABLES Usage: perlbrew symlink-executables [ <name> ] Low-level command. This command is used to create the C<perl> executable symbolic link to, say, C<perl5.13.6>. This is only required for development version of perls. You don't need to do this unless you have been using old perlbrew to install perls, and you find yourself confused because the perl that you just installed appears to be missing after invoking `use` or `switch`. perlbrew changes its installation layout since version 0.11, which generates symlinks to executables in a better way. If you just upgraded perlbrew (from 0.11 or earlier versions) and C<perlbrew switch> failed to work after you switch to a development release of perl, say, perl-5.13.6, run this command: perlbrew symlink-executables perl-5.13.6 This essentially creates this symlink: ${PERLBREW_ROOT}/perls/perl-5.13.6/bin/perl -> ${PERLBREW_ROOT}/perls/perl-5.13.6/bin/perl5.13.6 Newly installed perls, whether they are development versions or not, does not need manually treatment with this command. =head1 COMMAND: INSTALL-CPANM Usage: perlbrew install-cpanm Install the C<cpanm> standalone executable in C<$PERLBREW_ROOT/bin>. For more rationale about the existence of this command, read <https://perlbrew.pl/Perlbrew-and-Friends.html> Usage: perlbrew install-cpm Install the C<cpm> standalone executable in C<$PERLBREW_ROOT/bin>. =head1 COMMAND: INSTALL-PATCHPERL Usage: perlbrew install-patchperl Install the C<patchperl> standalone executable in C<$PERLBREW_ROOT/bin>. This is automatically invoked if your perlbrew installation is done with the installer, but not with cpan. For more rationale about the existence of this command, read <https://perlbrew.pl/Perlbrew-and-Friends.html> =head1 COMMAND: SELF-UPGRADE Usage: perlbrew self-upgrade This command upgrades Perlbrew to its latest version. =head1 COMMAND: SELF-INSTALL Usage: perlbrew self-install NOTICE: You should not need to run this command in your daily routine. This command installs perlbrew itself to C<$PERLBREW_ROOT/bin>. It is intended to be used by the perlbrew installer. However, you could manually do the following to re-install only the C<perlbrew> executable: curl https://raw.githubusercontent.com/gugod/App-perlbrew/master/perlbrew -o perlbrew perl ./perlbrew self-install It is slightly different from running the perlbrew installer because C<patchperl> is not installed in this case. =head1 COMMAND: CLEAN Usage: perlbrew clean Removes all previously downloaded Perl tarballs and build directories. =head1 COMMAND: VERSION Usage: perlbrew version Show the version of perlbrew. =head1 COMMAND: LIB Usage: perlbrew lib <action> <lib-name> perlbrew lib list perlbrew lib create <lib-name> perlbrew lib delete <lib-name> The `lib` command is used to manipulate local::lib roots inside perl installations. Effectively it is similar to `perl -Mlocal::lib=/path/to/lib-name`, but a little bit more than just that. A lib name can be a short name, containing alphanumeric, like 'awesome', or a full name, prefixed by a perl installation name and a '@' sign, for example, 'perl-5.14.2@awesome'. Here are some a brief examples to invoke the `lib` command: # Create lib perl-5.12.3@shizuka perlbrew lib create perl-5.12.3@shizuka # Create lib perl-5.14.2@nobita and perl-5.14.2@shizuka perlbrew use perl-5.14.2 perlbrew lib create nobita perlbrew lib create shizuka # See the list of use/switch targets perlbrew list # Activate a lib in current shell perlbrew use perl-5.12.3@shizuka perlbrew use perl-5.14.2@nobita perlbrew use perl-5.14.2@shizuka # Activate a lib as default perlbrew switch perl-5.12.3@shizuka perlbrew switch perl-5.14.2@nobita perlbrew switch perl-5.14.2@shizuka # Delete lib perl-5.14.2@nobita and perl-5.14.2@shizuka perlbrew use perl-5.14.2 perlbrew lib delete nobita perlbrew lib delete shizuka # Delete lib perl-5.12.3@shizuka perlbrew lib delete perl-5.12.3@shizuka Short lib names are local to current perl. A lib name 'nobita' can refer to 'perl-5.12.3@nobita' or 'perl-5.14.2@nobita', whichever is activated in the current shell. When C<use>ing or C<switch>ing to a lib, always provide the long name. A simple rule: the argument to C<use> or C<switch> command should appear in the output of C<perlbrew list>. =head1 COMMAND: UPGRADE-PERL Usage: perlbrew upgrade-perl Running this command upgrades the currently activated perl to its latest released brothers. If you have a shell with 5.32.0 activated, it upgrades it to 5.32.1. Minor Perl releases (ex. 5.x.*) are binary compatible with one another, so this command offers you the ability to upgrade older perlbrew environments in place. =head1 COMMAND: DOWNLOAD Usage: perlbrew download <perl-release> Examples: perlbrew download perl-5.14.2 perlbrew download perl-5.16.1 perlbrew download perl-5.17.3 Download the specified version of perl distribution tarball under the directory C<< $PERLBREW_ROOT/dists/ >>. The argument C<perl-release> should be one of the items from C<perlbrew available> command. =head1 COMMAND: LIST-MODULES Usage: perlbrew list-modules List all installed cpan modules for the current perl. This command can be used in conjunction with `perlbrew exec` to migrate your module installation to different perl. The following command re-installs all modules under perl-5.16.0: perlbrew list-modules | perlbrew exec --with perl-5.16.0 cpanm Note that this installs the I<latest> versions of the Perl modules on the new perl, which are not necessarily the I<same> module versions you had installed previously. =head1 COMMAND: CLONE-MODULES Usage: perlbrew clone-modules [options] <destination> perlbrew clone-modules [options] <source> <destination> Options: --notest Skip all module tests This command re-installs all CPAN modules found from one installation to another. For example, this lists all modules under '5.26.1' and re-installs them under '5.27.7': perlbrew clone-modules 5.26.1 5.27.7 The argument "source" is optional and defaults to the currently activated one. However if none is activated (perlbrew is switched off), it is an error. Note that this does not guarantee that the versions of modules stay the same in the destination. =head1 COMMAND: MAKE-SHIM Usage: perlbrew make-shim <program> perlbrew make-shim -o <shim-name> <program> perlbrew make-shim --output <shim-name> <program> This commands produce an executable file under current directory named C<program>, or C<shim-name> if given after C<--output> (or C<-o> for short). The output is a shell-wrapper, a shim, of the named program inside current perlbrew environment. When the shim is executed, the original C<program> is then executed with all relevant environment variable set to the perlbrew environment it is installed in, regardless which perlbrew environment is currently activated. The shim can also be moved to different directories and, such as the conventional C<~/.local/bin>, so it is always available. For example, you may find C<tldr> from L<App::tldr> a handy tool and decide to install it inside your daily working environment: perlbrew use perl-5.36.1 cpm install -g App::tldr But when you occasionally have to switch to a different environment, C<PATH> would be tweaked and the command C<tldr> would went missing, and that is the expected outcome: perlbrew use perl-5.18.4 tldr perl #=> error: command not found It would be nice if C<tldr> can be made universally available. One way to mitigate such needs is to prepare install the C<tldr> program outside of C<PERLBREW_ROOT>, while still utilize perlbrew environment to run it. For example, prepare a conventional directory C<~/.local/bin> and put that in C<PATH>, then: perlbrew use perl-5.36.1 cd /tmp perlbrew make-shim tldr mv /tmp/tldr ~/.local/bin/tldr This C<~/.local/bin/tldr> is a shell-wrapper of the actual C<tldr> program, and it internally activates the perlbrew environment C<perl-5.36.1>. Running the tldr shim will then always run the actual C<tldr>, no matter which perlbrew environment is activated, or even if perlbrew is turned off. The only requirements is that the perlbrew environment C<perl-5.36.1> and the installation of C<App::tldr> has to remain. =head1 COMMAND: MAKE-PP Usage: perlbrew make-pp -i <path> -o <path> perlbrew make-pp --input <path> --output <path> This command takes a path of a perl program (the input), and produce a PAR-packed version of that program to the specified path (the output). Essentially this is a wrapper of C<pp> from L<PAR::Packer>, hence the name. This requires the current perlbrew environment to have L<PAR> and L<PAR::Packer> installed first. Otherwise C<make-pp> bails out. In addition, if the current perl is not a perlbrew-managed perl, or if the given output path is already occupied, <make-pp> also bails out. The produced file is a standalone binary executable containing these content: 1. The input perl program 2. perl runtime 3. all core perl libs of current perl 4. the entire site lib 5. the entire local lib (managed by `perlbrew lib` command), if active. It is expected that the executable can then be running on a different machine of the same OS and arch. Noted that this approach is the maximum overkill for packing one program as it'll be definitely packaing a lot more then the exact list of runtime dependencies of the named program. C<make-pp> is meant for a lazy solution for a non-trivial problem of perfectly determing the runtime dependencies of an arbitarary program. =head1 SEE ALSO L<App::perlbrew>, L<App::cpanminus>, L<Devel::PatchPerl> =cut