App-MechaCPAN
view release on metacpan or search on metacpan
lib/App/MechaCPAN.pm view on Meta::CPAN
use Exporter qw/import/;
BEGIN
{
our @EXPORT_OK = qw/
url_re git_re git_extract_re
has_git has_updated_git min_git_ver
can_https
logmsg info success error
dest_dir get_project_dir
fetch_file inflate_archive
file_digest_chk get_cpan_checksums
humane_tmpname humane_tmpfile humane_tmpdir
parse_cpanfile
run run_qvf restart_script
rel_start_to_abs
/;
our %EXPORT_TAGS = ( go => [@EXPORT_OK] );
}
our $VERSION = '0.32';
my @commands = qw/
perl
install
deploy
/;
foreach my $cmd ( @commands )
{
my $pkg = __PACKAGE__ . "::" . ucfirst($cmd);
local $@;
my ($file, $line) = ( __FILE__, __LINE__+1);
eval qq{#line $line "$file"\nrequire $pkg};
die $@
if $@;
}
my $loaded_at_compile;
my $restarted_key = 'APP_MECHACPAN_RESTARTED';
my $is_restarted_process = delete $ENV{$restarted_key};
{
no warnings 'void';
INIT
{
$loaded_at_compile = 1;
}
}
$loaded_at_compile //= 0;
our @args = (
'diag-run!',
'verbose|v!',
'quiet|q!',
'no-log!',
'directory|d=s',
'build-reusable-perl!',
'verify!',
'help|h!',
);
# Timeout when there's no output in seconds
our $TIMEOUT = $ENV{MECHACPAN_TIMEOUT} // 60;
our $VERBOSE; # Print output from sub commands to STDERR
our $QUIET; # Do not print any progress to STDERR
our $LOGFH; # File handle to send the logs to
our $LOG_ON = 1; # Default if to log or not
our $PROJ_DIR; # The directory given with -d or pwd if not provided
our $CHKSIGS; # Check signatures on/off/best attempt (undef)
# In certain blocks, you may see `no warnings 'uninitialized'`. Several subs
# end up doing a lot of work with comparisions that don't distinguish between
# undef and the empty string, so these warnings create more noise than useful
# feedback, and the code to silence them are not meaningfully better
sub main
{
my @argv = @_;
if ( $0 =~ m/zhuli/ )
{
no warnings 'uninitialized';
if ( $argv[0] =~ m/^do the thing/i )
{
success( "zhuli$$", 'Running deployment' )
unless $is_restarted_process;
$argv[0] = 'deploy';
}
if ( $argv[0] =~ m/^do$/i
&& $argv[1] =~ m/^the$/i
&& $argv[2] =~ m/^thing$/i )
{
success( "zhuli$$", 'Running deployment' )
unless $is_restarted_process;
@argv = ( 'deploy', @argv[ 3 .. $#argv ] );
}
}
my @args = (
@App::MechaCPAN::args,
@App::MechaCPAN::Perl::args,
@App::MechaCPAN::Install::args,
@App::MechaCPAN::Deploy::args,
);
@args = keys %{ { map { $_ => 1 } @args } };
if ( !@argv )
{
my $prog = ( File::Spec->splitpath($0) )[2] || 'mechacpan';
my @options = map {
my ($names) = m/^([^=:!+]+)/;
join( ', ', map { length > 1 ? "--$_" : "-$_" } split /\|/, $names );
} @App::MechaCPAN::args;
my $orig_fh = select STDERR;
lib/App/MechaCPAN.pm view on Meta::CPAN
say "";
say "Global Options:";
say " $_"
foreach @options;
say "";
say "Run '$prog --help' for full documentation.";
select $orig_fh;
return -1;
}
my $options = {};
my $getopt_ret
= Getopt::Long::GetOptionsFromArray( \@argv, $options, @args );
return -1
if !$getopt_ret;
if ( $options->{help} )
{
require Pod::Usage;
Pod::Usage::pod2usage(
-input => $INC{ _inc_pkg(__PACKAGE__) },
-verbose => 2,
-exitval => 'NOEXIT',
-output => \*STDOUT,
);
return 0;
}
my $merge_options = sub
{
my $arg = shift;
if ( ref $arg eq 'HASH' )
{
$options = { %$arg, %$options };
return 0;
}
return 1;
};
@argv = grep { $merge_options->($_) } @argv;
my $orig_dir = cwd;
if ( exists $options->{directory} )
{
if ( !-d $options->{directory} )
{
die "Cannot find directory: $options->{directory}\n";
}
chdir $options->{directory};
}
# Once we've established the project directory, we need to attempt to
# restart the script.
&restart_script();
local $PROJ_DIR = cwd;
local $LOGFH;
local $VERBOSE = $options->{verbose} // $VERBOSE;
local $QUIET = $options->{quiet} // $QUIET;
local $CHKSIGS = $options->{verify} // $CHKSIGS;
my $cmd;
if ( $options->{'build-reusable-perl'} )
{
$cmd = 'Perl';
$options->{'build-reusable'} = delete $options->{'build-reusable-perl'};
if ( lc $argv[0] eq 'perl' )
{
info("Option build-reusable-perl implies the perl command, it can be omitted");
shift @argv;
}
}
$cmd = $cmd // ucfirst lc shift @argv;
my $pkg = join( '::', __PACKAGE__, $cmd );
my $action = eval { $pkg->can('go') };
my $munge = eval { $pkg->can('munge_args') };
if ( !defined $action )
{
warn "Could not find action to run: $cmd\n";
return -1;
}
if ( $options->{'diag-run'} )
{
warn "Would run '$cmd'\n";
chdir $orig_dir;
return 0;
}
$options->{is_restarted_process} = $is_restarted_process;
if ( defined $munge )
{
@argv = $pkg->$munge( $options, @argv );
}
my $dest_dir = &dest_dir;
if ( !-d $dest_dir )
{
mkdir $dest_dir;
}
_setup_log($dest_dir)
unless $options->{'no-log'};
local $@;
my $ret = eval { $pkg->$action( $options, @argv ) || 0; };
chdir $orig_dir;
if ( !defined $ret )
{
error($@);
return -1;
}
return $ret;
lib/App/MechaCPAN.pm view on Meta::CPAN
$dst_path = File::Spec->catpath( @splitpath[ 0 .. 1 ] );
$dst_file = $splitpath[2];
}
$dst_path = File::Spec->rel2abs( $dst_path, "$proj_dir" )
unless File::Spec->file_name_is_absolute($dst_path);
$result = File::Spec->catdir( $dst_path, $dst_file );
}
mkdir $dst_path
unless -d $dst_path;
my $where = $ff->fetch( to => $dst_path );
if ( !defined $where )
{
my $tmpfile = File::Spec->catdir( $dst_path, $ff->output_file );
if ( -e $tmpfile && !-s )
{
unlink $tmpfile;
}
my $error = $ff->error || "Could not download $url";
die "$error\n";
}
if ( $where ne $result )
{
copy( $where, $result );
$result->seek( 0, 0 )
if fileno $result;
unlink $where;
}
if ( defined $slurp )
{
open my $slurp_fh, '<', $result;
$$slurp = do { local $/; <$slurp_fh> };
$result->seek( 0, 0 )
if fileno $result;
}
return $result;
}
sub file_digest_chk
{
my ( $path, $expected ) = @_;
require Digest::SHA;
my $actual = Digest::SHA->new('sha256')->addfile( "$path", 'b' )->hexdigest;
$expected = uc $expected;
$actual = uc $actual;
die "Expected and Actual Digest differs: $actual ne $expected"
if $expected ne $actual;
return;
}
sub _verify_checksums_body
{
my $chksum_body = shift;
# CHECKSUMS has a very regular pattern. If it doesn't match, we must refuse
# loudly since it appears to be tampered with.
my @result;
my @content = split /\r?\n/, $chksum_body;
while ( @content && $content[0] eq '' )
{
shift @content;
}
while ( @content && $content[-1] eq '' )
{
pop @content;
}
# Check the file header and the PGP header
{
my $header = shift @content;
my $pgp_header = shift @content;
# First line must be that the PGP is also valid perl
push @result, $header;
croak "CHECKSUMS file failed validation: header-line mismatch"
if $header ne q{0&&<<''; # this PGP-signed message is also valid perl};
# Second line MUST be the PGP signed message start
push @result, $pgp_header;
croak "CHECKSUMS file failed validation: PGP header mismatch"
if $pgp_header ne q{-----BEGIN PGP SIGNED MESSAGE-----};
}
# We're now safely in the PGP signed message. Grab all the PGP headers
while ( defined( my $pgp_line = shift @content ) )
{
push @result, $pgp_line;
last
if $pgp_line eq '';
}
# Now read the perl hash header start, which is any number of comments
# followed by a hash definition
while ( defined( my $perl_intro = shift @content ) )
{
push @result, $perl_intro;
last
if $perl_intro eq '$cksum = {'; # } This confuses vim and annoys me
next
if $perl_intro =~ m/^[#]/xms;
my $linenum = scalar @result;
croak "CHECKSUMS file failed validation: Unexpected perl code $linenum";
}
my ($indent) = $content[0] =~ m/^(\s+)/;
lib/App/MechaCPAN.pm view on Meta::CPAN
)
(?: =[A-Za-z0-9+\/]{4}\s*\n )? # The optional checksum
\Q-----END PGP PUBLIC KEY BLOCK-----\E
.* # Everything after the armor
\Z
}{$1}xms;
require MIME::Base64;
$keyring = MIME::Base64::decode_base64($keyring);
# Verify that this is the CPAN key by checking the primary key.
_cpan_key_chk($keyring);
open my $keyring_fh, '>', $cache_path;
print $keyring_fh $keyring;
$keyring_path = $cache_path;
}
return $keyring_path;
}
#gpgv, sqv, gpg, sq, and rnp
my @verifier = (
sub
{
return
if !eval { run(qw/gpgv --version/); 1 };
return sub
{
my ( $file, $keyring ) = @_;
run_qvf( "gpgv", "--keyring", "$keyring", "$file" );
};
},
sub
{
my $out = eval { run(qw/sqv --version/) };
return
if !defined $out;
my ($major) = $out =~ m/(\d+)\.\d+(?:\.\d+)?/;
return
if !defined $major || $major < 1;
return sub
{
my ( $file, $keyring ) = @_;
run_qvf( "sqv", "--keyring", "$keyring", "$file" );
};
},
sub
{
return
if !eval { run(qw/gpg --version/); 1 };
return sub
{
my ( $file, $keyring ) = @_;
run_qvf( "gpg", "--no-default-keyring", "--keyring", "$keyring",
"--verify", "$file" );
};
},
sub
{
my $out = eval { run(qw/sq --version/) };
return
if !defined $out;
my ($major) = $out =~ m/(\d+)\.\d+(?:\.\d+)?/;
return
if !defined $major || $major < 1;
return sub
{
my ( $file, $keyring ) = @_;
run_qvf( "sq", "verify", "--signer-file", "$keyring", "$file" );
};
},
sub
{
return
if !eval { run(qw/rnp --version/); 1 };
return sub
{
my ( $file, $keyring ) = @_;
run_qvf( "rnp", "--keyfile", "$keyring", "--verify", "$file" );
};
},
);
sub _resolve_verifier
{
state $verify_fn;
if ( !defined $verify_fn )
{
foreach my $verify (@verifier)
{
my $fn = $verify->();
if ( defined $fn )
{
$verify_fn = $fn;
last;
}
}
}
return $verify_fn;
}
sub get_cpan_checksums
{
my $url = shift;
my $key = shift;
# If verify is off, don't check any part of the CHECKSUMS
return
if defined $CHKSIGS && !$CHKSIGS;
die "CHECKSUMS URL must be HTTPS, not '$url'"
unless $url =~ m{\Ahttps://}xmsi;
die "CHECKSUMS URL must end with CHECKSUMS, not '$url'"
unless $url =~ m{CHECKSUMS\z}xmsi;
# Even if verification is optional, not downloading the CHECKSUMS is fatal
my $checksums = '';
fetch_file( $url, \$checksums );
$checksums = App::MechaCPAN::_verify_checksums_body($checksums);
# If $CHKSIGS is true, we must verify that CHECKSUMS has a valid signature
# If $CHKSIGS is undef, we will verify that CHECKSUMS has a valid signature
# if possible, but won't throw errors if can't.
# In both cases, the CHECKSUMS is used to validate the checksums of the
# downloaded file
# If $CHKSIGS is otherwise false, we already did an early return above
my $verify_fn = _resolve_verifier();
if ( !defined $verify_fn )
{
die "Could not find verification program and verification was required"
if $CHKSIGS;
logmsg "CHECKSUMS signature not checked: PGP verifier not found";
}
else
{
my $keyring = cpan_keyring();
my $chk_file = humane_tmpfile('CHECKSUMS');
$chk_file->print($checksums);
$chk_file->flush;
$verify_fn->( "$chk_file", $keyring );
logmsg "VALID: $url";
}
my $result = do
{
require Safe;
my $safe = Safe->new("App::MechaCPAN::reval");
local $@;
my $chksum = $safe->reval($checksums);
die "Failed to parse CHECKSUMS: $@"
if $@;
die "Failed to get HASH from CHECKSUMS"
if ref $chksum ne 'HASH';
$chksum;
};
# If a module name is passed ($key), then we check if it is listed in the
# CHECKSUMS file. If it is missing, it depends on $CHKSIGS. If it is true
# (strict verify), an error will be produced. If it is undef (best-effort)
# then a log entry will be added, and nothing will be returned, whcih will
# match the no-verify path above.
if ( defined $key && !exists $result->{$key} )
{
die "Could not find module '$key' in CHECKSUMS"
if $CHKSIGS;
logmsg "Could not find '$key' in CHECKSUMS, not attempting to verify";
return;
}
return $result;
}
my @inflate = (
# System tar
sub
{
my $src = shift;
my $humane_qr = humane_qr;
return
unless $src =~ m{ [.]tar[.] (?: xz | gz | bz2|bzip2 ) $humane_qr? $}xms;
state $tar;
if ( !defined $tar )
{
my $tar_version_str = eval { run(qw/tar --version/); };
$tar = defined $tar_version_str;
}
return
unless $tar;
my $unzip
= $src =~ m/gz $humane_qr? $/xms ? 'gzip'
: $src =~ m/(bz2|bzip2) $humane_qr? $/xms ? 'bzip2'
: 'xz';
# Instead of relying on a shell to pipe contents from unzip to tar, both
# gnutar and bsdtar accept the use-compress-program option. bsdtar needs
# the -d option so it will decompress, while gnutar automatically adds it
# but it is harmless to add.
run( 'tar', '--use-compress-program', "$unzip -d", '-xf', $src );
return 1;
},
# Archive::Tar
sub
{
my $src = shift;
require Archive::Tar;
my $tar = Archive::Tar->new;
$tar->error(1);
my $ret = $tar->read( "$src", 1, { extract => 1 } );
die $tar->error
unless $ret;
},
);
sub _path_escapes_dir
{
my $path = shift;
lib/App/MechaCPAN.pm view on Meta::CPAN
user@host:~/project/$ ls -la
drwxr-xr-x 6 user users 20480 Jan 18 13:00 .
drwxr-xr-x 25 user users 4096 Jan 18 13:00 ..
drwxr-xr-x 8 user users 4096 Jan 18 13:05 .git
-rw-r--r-- 1 user users 7 Jan 18 13:06 .perl-version
-rw-r--r-- 1 user users 109 Jan 18 13:06 cpanfile
drwxr-xr-x 3 user users 4096 Jan 18 13:10 lib
user@host:~/project/$ mechacpan deploy
That command will do 2 things:
=over
=item Install perl
It will install perl into the directory local/perl. It will use the version in C<.perl-version> to decide what version will be installed.
=item Install modules
Then it will use the installed perl to install all the module dependencies that are listed in the cpanfile.
=back
=head1 COMMANDS
=head2 Perl
user@host:~$ mechacpan perl 5.24
The L<perl|App::MechaCPAN::Perl> command is used to install L<perl> into C<local/>. This removes the packages dependency on the operating system perl. By default, it tries to be helpful and include C<lib/> and C<local/> into C<@INC> automatically, bu...
=head2 Install
user@host:~$ mechacpan install Catalyst
The L<install|App::MechaCPAN::Install> command is used for installing specific modules. All modules are installed into the C<local/> directory. See See L<App::MechaCPAN::Install> for more details.
=head2 Deploy
user@host:~$ mechacpan deploy
The L<deploy|App::MechaCPAN::Deploy> command is used for automating a deployment. It will install both L<perl> and all the modules specified from the C<cpanfile>. If there is a C<cpanfile.snapshot> that was created by L<Carton>, C<deploy> will treat ...
=head1 OPTIONS
Besides the options that the individual commands take, C<App::MechaCPAN> takes several that are always available.
=head2 --verbose
By default only informational descriptions of what is happening is shown. Turning verbose on will show every command and all output produced by running each command. Note that this is B<not> the opposite of quiet.
=head2 --quiet
Using quiet means that the normal information descriptions are hidden. Note that this is B<not> the opposite of verbose, turning both options on means no descriptions will be show, but all output from all commands will be.
=head2 --no-log
A log is normally outputted into the C<local/logs> directory. This option will prevent a log from being created.
=head2 --verify
When C<--verify> is given, a verification of the CPAN C<CHECKSUMS> file during module install is required. Note that packages from L<BackPAN|https://backpan.perl.org/> will not verify when C<--verify> is given. This process includes three steps after...
=over
=item 1. Confirm the shape of CHECKSUMS
C<CHECKSUMS> files contain all the files and the file checksums for a CPAN author's uploads. This file is compared against a rigid definition to ensure that it does not appear to be doing anything malicious.
=item 2. Confirm the signature of CHECKSUMS
Once the C<CHECKSUMS> structure has been examined, the embedded signature is verified. The C<CHECKSUMS> file is signed using the PAUSE Batch Signing Key (C<2E66 557A B97C 19C7 91AF 8E20 328D A867 450F 89EC>, accessible at L<https://www.cpan.org/modu...
=item 3. Compare the sha256 of the downloaded module to CHECKSUMS
Once the CHECKSUMS file has been checked, the size, CPAN author path, and the C<sha256> value of the downloaded module archive are compared against the values from the CHECKSUMS file. These values must match.
=back
You can also disable C<CHECKSUMS> verification completely with C<--no-verify>. That will prevent all of these steps from running at all.
When neither option is provided then the signature checking step is attempted, but will not produce an error if the external verification program could not be found, or the file is from backpan and has no corrisponding C<CHECKSUMS> entry. An error is...
If L<MetaCPAN|https://metacpan.org> was used to find a module, the search will include the SHA256 of the package, which will be checked against the downloaded archive. This check cannot be disabled currently.
The verification programs that can be used are: L<gpgv|https://www.gnupg.org/>, L<sqv|https://sequoia-pgp.org/>, L<gpg|https://www.gnupg.org/>, L<sq|https://sequoia-pgp.org/>, and L<rnp|https://www.rnpgp.org/>.
=head2 --directory=<path>
Changes to a specified directory before any processing is done. This allows you to specify what directory you want C<local/> to be in. If this isn't provided, the current working directory is used instead.
=head2 --build-reusable-perl
Giving this options will override the mode of operation and generate a reusable, relocatable L<perl> archive. This accepts the same parameters as the L<Perl|App::MechaCPAN::Perl> command (i.e. L</devel> and L</threads>) to generate the binary. Note t...
Once you have a reusable binary archive, L<App::MechaCPAN::Perl> can use that archive as a source file and install the binaries into the local directory. This can be handy if you are building a lot of identical systems and only want to build L<perl> ...
The exact parameters included in the archive name are:
=over
=item * The version built
=item * The architecture name, as found in the first piece of $Config{archname}
=item * The Operating System, as found in $Config{osname}
=item * Optionally notes if it was built with threads
=item * The name of the libc used
=item * The version of the libc used
=item * The C<so> version of libraries used, with common libaries being abbreviated
=back
An example archive name would be C<perl-v5.36.0-x86_64-linux-glibc-2.35-y1.1n2.0u1.tar.xz>
=head2 C<$ENV{MECHACPAN_TIMEOUT}>
Every command that C<App::MechaCPAN> runs is given an idle timeout before it is killed and a failure is returned. This timeout is reset every time the command outputs to C<STDOUT> or C<STDERR>. Using the environment variable C<MECHACPAN_TIMEOUT>, you...
=head1 SCRIPT RESTART WARNING
This module B<WILL> restart the running script B<IF> it's used as a module (e.g. with C<use>) and the perl that is running is not the version installed in C<local/>. It does this at two points: First right before run-time and Second right after a per...
The scripts and modules that come with C<App::MechaCPAN> are prepared to handle this. If you use C<App::MechaCPAN> as a module, you should to be prepared to handle it as well.
This means that any END and DESTROY blocks B<WILL NOT RUN>. Anything created with File::Temp will be cleaned up, however.
=head1 AUTHOR
Jon Gentle E<lt>cpan@atrodo.orgE<gt>
=head1 COPYRIGHT
Copyright 2017- Jon Gentle
=head1 LICENSE
( run in 1.478 second using v1.01-cache-2.11-cpan-600a1bdf6e4 )