summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/CPANPLUS/Module
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/CPANPLUS/Module')
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Module/Author.pm232
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Module/Author/Fake.pm80
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Module/Checksums.pm251
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Module/Fake.pm86
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Module/Signature.pm65
5 files changed, 714 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Module/Author.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Module/Author.pm
new file mode 100644
index 00000000000..92940fa51ff
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Module/Author.pm
@@ -0,0 +1,232 @@
+package CPANPLUS::Module::Author;
+
+use strict;
+
+use CPANPLUS::Error;
+use CPANPLUS::Internals::Constants;
+use Params::Check qw[check];
+use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
+
+local $Params::Check::VERBOSE = 1;
+
+=pod
+
+=head1 NAME
+
+CPANPLUS::Module::Author
+
+=head1 SYNOPSIS
+
+ my $author = CPANPLUS::Module::Author->new(
+ author => 'Jack Ashton',
+ cpanid => 'JACKASH',
+ _id => INTERNALS_OBJECT_ID,
+ );
+
+ $author->cpanid;
+ $author->author;
+ $author->email;
+
+ @dists = $author->distributions;
+ @mods = $author->modules;
+
+ @accessors = CPANPLUS::Module::Author->accessors;
+
+=head1 DESCRIPTION
+
+C<CPANPLUS::Module::Author> creates objects from the information in the
+source files. These can then be used to query on.
+
+These objects should only be created internally. For C<fake> objects,
+there's the C<CPANPLUS::Module::Author::Fake> class.
+
+=head1 ACCESSORS
+
+An objects of this class has the following accessors:
+
+=over 4
+
+=item author
+
+Name of the author.
+
+=item cpanid
+
+The CPAN id of the author.
+
+=item email
+
+The email address of the author, which defaults to '' if not provided.
+
+=item parent
+
+The C<CPANPLUS::Internals::Object> that spawned this module object.
+
+=back
+
+=cut
+
+my $tmpl = {
+ author => { required => 1 }, # full name of the author
+ cpanid => { required => 1 }, # cpan id
+ email => { default => '' }, # email address of the author
+ _id => { required => 1 }, # id of the Internals object that spawned us
+};
+
+### autogenerate accessors ###
+for my $key ( keys %$tmpl ) {
+ no strict 'refs';
+ *{__PACKAGE__."::$key"} = sub {
+ my $self = shift;
+ $self->{$key} = $_[0] if @_;
+ return $self->{$key};
+ }
+}
+
+sub parent {
+ my $self = shift;
+ my $obj = CPANPLUS::Internals->_retrieve_id( $self->_id );
+
+ return $obj;
+}
+
+=pod
+
+=head1 METHODS
+
+=head2 $auth = CPANPLUS::Module::Author->new( author => AUTHOR_NAME, cpanid => CPAN_ID, _id => INTERNALS_ID [, email => AUTHOR_EMAIL] )
+
+This method returns a C<CPANPLUS::Module::Author> object, based on the given
+parameters.
+
+Returns false on failure.
+
+=cut
+
+sub new {
+ my $class = shift;
+ my %hash = @_;
+
+ ### don't check the template for sanity
+ ### -- we know it's good and saves a lot of performance
+ local $Params::Check::SANITY_CHECK_TEMPLATE = 0;
+
+ my $object = check( $tmpl, \%hash ) or return;
+
+ return bless $object, $class;
+}
+
+=pod
+
+=head2 @mod_objs = $auth->modules()
+
+Return a list of module objects this author has released.
+
+=cut
+
+sub modules {
+ my $self = shift;
+ my $cb = $self->parent;
+
+ my $aref = $cb->_search_module_tree(
+ type => 'author',
+ ### XXX, depending on backend, this is either an object
+ ### or the cpanid string. Dont know an elegant way to
+ ### solve this right now, so passing both
+ allow => [$self, $self->cpanid],
+ );
+ return @$aref if $aref;
+ return;
+}
+
+=pod
+
+=head2 @dists = $auth->distributions()
+
+Returns a list of module objects representing all the distributions
+this author has released.
+
+=cut
+
+sub distributions {
+ my $self = shift;
+ my %hash = @_;
+
+ local $Params::Check::ALLOW_UNKNOWN = 1;
+ local $Params::Check::NO_DUPLICATES = 1;
+
+ my $mod;
+ my $tmpl = {
+ module => { default => '', store => \$mod },
+ };
+
+ my $args = check( $tmpl, \%hash ) or return;
+
+ ### if we didn't get a module object passed, we'll find one ourselves ###
+ unless( $mod ) {
+ my @list = $self->modules;
+ if( @list ) {
+ $mod = $list[0];
+ } else {
+ error( loc( "This author has released no modules" ) );
+ return;
+ }
+ }
+
+ my $file = $mod->checksums( %hash );
+ my $href = $mod->_parse_checksums_file( file => $file ) or return;
+
+ my @rv;
+ for my $name ( keys %$href ) {
+
+ ### shortcut asap, so we avoid extra ops. On big checksums files
+ ### the call to clone() takes up a lot of time.
+ ### .meta files are now also in the checksums file,
+ ### which means we have to filter out things that dont
+ ### match our regex
+ next if $mod->package_extension( $name ) eq META_EXT;
+
+ ### used to do this wiht ->clone. However, that calls ->dslip,
+ ### (which is wrong anyway, as we're doing a different module),
+ ### which in turn calls ->contains, which scans the entire
+ ### module tree using _search_module_tree, which uses P::C
+ ### and is therefor VERY VERY slow.
+ ### so let's do this the direct way for speed ups.
+ my $dist = CPANPLUS::Module::Fake->new(
+ module => do { my $m = $mod->package_name( $name );
+ $m =~ s/-/::/g; $m;
+ },
+ version => $mod->package_version( $name ),
+ package => $name,
+ path => $mod->path, # same author after all
+ author => $mod->author, # same author after all
+ mtime => $href->{$name}->{'mtime'}, # release date
+ );
+
+ push @rv, $dist;
+ }
+
+ return @rv;
+}
+
+
+=pod
+
+=head1 CLASS METHODS
+
+=head2 accessors ()
+
+Returns a list of all accessor methods to the object
+
+=cut
+
+sub accessors { return keys %$tmpl };
+
+1;
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Module/Author/Fake.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Module/Author/Fake.pm
new file mode 100644
index 00000000000..3156c5c7abb
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Module/Author/Fake.pm
@@ -0,0 +1,80 @@
+package CPANPLUS::Module::Author::Fake;
+
+
+use CPANPLUS::Module::Author;
+use CPANPLUS::Internals;
+use CPANPLUS::Error;
+
+use strict;
+use vars qw[@ISA];
+use Params::Check qw[check];
+
+@ISA = qw[CPANPLUS::Module::Author];
+
+$Params::Check::VERBOSE = 1;
+
+=pod
+
+=head1 NAME
+
+CPANPLUS::Module::Author::Fake
+
+=head1 SYNOPSIS
+
+ my $auth = CPANPLUS::Module::Author::Fake->new(
+ author => 'Foo Bar',
+ email => 'luser@foo.com',
+ cpanid => 'FOO',
+ _id => $cpan->id,
+ );
+
+=head1 DESCRIPTION
+
+A class for creating fake author objects, for shortcut use internally
+by CPANPLUS.
+
+Inherits from C<CPANPLUS::Module::Author>.
+
+=head1 METHODS
+
+=head2 new( _id => DIGIT )
+
+Creates a dummy author object. It can take the same options as
+C<< CPANPLUS::Module::Author->new >>, but will fill in default ones
+if none are provided. Only the _id key is required.
+
+=cut
+
+sub new {
+ my $class = shift;
+ my %hash = @_;
+
+ my $tmpl = {
+ author => { default => 'CPANPLUS Internals' },
+ email => { default => 'cpanplus-info@lists.sf.net' },
+ cpanid => { default => 'CPANPLUS' },
+ _id => { default => CPANPLUS::Internals->_last_id },
+ };
+
+ my $args = check( $tmpl, \%hash ) or return;
+
+ my $obj = CPANPLUS::Module::Author->new( %$args ) or return;
+
+ unless( $obj->_id ) {
+ error(loc("No '%1' specified -- No CPANPLUS object associated!",'_id'));
+ return;
+ }
+
+ ### rebless object ###
+ return bless $obj, $class;
+}
+
+1;
+
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Module/Checksums.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Module/Checksums.pm
new file mode 100644
index 00000000000..e1a2bbdb6ad
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Module/Checksums.pm
@@ -0,0 +1,251 @@
+package CPANPLUS::Module::Checksums;
+
+use strict;
+use vars qw[@ISA];
+
+
+use CPANPLUS::Error;
+use CPANPLUS::Internals::Constants;
+
+use FileHandle;
+
+use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
+use Params::Check qw[check];
+use Module::Load::Conditional qw[can_load];
+
+$Params::Check::VERBOSE = 1;
+
+@ISA = qw[ CPANPLUS::Module::Signature ];
+
+=head1 NAME
+
+CPANPLUS::Module::Checksums
+
+=head1 SYNOPSIS
+
+ $file = $modobj->checksums;
+ $bool = $mobobj->_validate_checksum;
+
+=head1 DESCRIPTION
+
+This is a class that provides functions for checking the checksum
+of a distribution. Should not be loaded directly, but used via the
+interface provided via C<CPANPLUS::Module>.
+
+=head1 METHODS
+
+=head2 $mod->checksums
+
+Fetches the checksums file for this module object.
+For the options it can take, see C<CPANPLUS::Module::fetch()>.
+
+Returns the location of the checksums file on success and false
+on error.
+
+The location of the checksums file is also stored as
+
+ $mod->status->checksums
+
+=cut
+
+sub checksums {
+ my $mod = shift or return;
+
+ my $file = $mod->_get_checksums_file( @_ );
+
+ return $mod->status->checksums( $file ) if $file;
+
+ return;
+}
+
+### checks if the package checksum matches the one
+### from the checksums file
+sub _validate_checksum {
+ my $self = shift; #must be isa CPANPLUS::Module
+ my $conf = $self->parent->configure_object;
+ my %hash = @_;
+
+ my $verbose;
+ my $tmpl = {
+ verbose => { default => $conf->get_conf('verbose'),
+ store => \$verbose },
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+ ### if we can't check it, we must assume it's ok ###
+ return $self->status->checksum_ok(1)
+ unless can_load( modules => { 'Digest::MD5' => '0.0' } );
+ #class CPANPLUS::Module::Status is runtime-generated
+
+ my $file = $self->_get_checksums_file( verbose => $verbose ) or (
+ error(loc(q[Could not fetch '%1' file], CHECKSUMS)), return );
+
+ $self->_check_signature_for_checksum_file( file => $file ) or (
+ error(loc(q[Could not verify '%1' file], CHECKSUMS)), return );
+ #for whole CHECKSUMS file
+
+ my $href = $self->_parse_checksums_file( file => $file ) or (
+ error(loc(q[Could not parse '%1' file], CHECKSUMS)), return );
+
+ my $size = $href->{ $self->package }->{'size'};
+
+ ### the checksums file tells us the size of the archive
+ ### but the downloaded file is of different size
+ if( defined $size ) {
+ if( not (-s $self->status->fetch == $size) ) {
+ error(loc( "Archive size does not match for '%1': " .
+ "size is '%2' but should be '%3'",
+ $self->package, -s $self->status->fetch, $size));
+ return $self->status->checksum_ok(0);
+ }
+ } else {
+ msg(loc("Archive size is not known for '%1'",$self->package),$verbose);
+ }
+
+ my $md5 = $href->{ $self->package }->{'md5'};
+
+ unless( defined $md5 ) {
+ msg(loc("No 'md5' checksum known for '%1'",$self->package),$verbose);
+
+ return $self->status->checksum_ok(1);
+ }
+
+ $self->status->checksum_value($md5);
+
+
+ my $fh = FileHandle->new( $self->status->fetch ) or return;
+ binmode $fh;
+
+ my $ctx = Digest::MD5->new;
+ $ctx->addfile( $fh );
+
+ my $flag = $ctx->hexdigest eq $md5;
+ $flag
+ ? msg(loc("Checksum matches for '%1'", $self->package),$verbose)
+ : error(loc("Checksum does not match for '%1': " .
+ "MD5 is '%2' but should be '%3'",
+ $self->package, $ctx->hexdigest, $md5),$verbose);
+
+
+ return $self->status->checksum_ok(1) if $flag;
+ return $self->status->checksum_ok(0);
+}
+
+
+### fetches the module objects checksum file ###
+sub _get_checksums_file {
+ my $self = shift;
+ my %hash = @_;
+
+ my $clone = $self->clone;
+ $clone->package( CHECKSUMS );
+
+ my $file = $clone->fetch( ttl => 3600, %hash ) or return;
+
+ return $file;
+}
+
+sub _parse_checksums_file {
+ my $self = shift;
+ my %hash = @_;
+
+ my $file;
+ my $tmpl = {
+ file => { required => 1, allow => FILE_READABLE, store => \$file },
+ };
+ my $args = check( $tmpl, \%hash );
+
+ my $fh = OPEN_FILE->( $file ) or return;
+
+ ### loop over the header, there might be a pgp signature ###
+ my $signed;
+ while (local $_ = <$fh>) {
+ last if /^\$cksum = \{\s*$/; # skip till this line
+ my $header = PGP_HEADER; # but be tolerant of whitespace
+ $signed = 1 if /^${header}\s*$/;# due to crossplatform linebreaks
+ }
+
+ ### read the filehandle, parse it rather than eval it, even though it
+ ### *should* be valid perl code
+ my $dist;
+ my $cksum = {};
+ while (local $_ = <$fh>) {
+
+ if (/^\s*'([^']+)' => \{\s*$/) {
+ $dist = $1;
+
+ } elsif (/^\s*'([^']+)' => '?([^'\n]+)'?,?\s*$/ and defined $dist) {
+ $cksum->{$dist}{$1} = $2;
+
+ } elsif (/^\s*}[,;]?\s*$/) {
+ undef $dist;
+
+ } elsif (/^__END__\s*$/) {
+ last;
+
+ } else {
+ error( loc("Malformed %1 line: %2", CHECKSUMS, $_) );
+ }
+ }
+
+ return $cksum;
+}
+
+sub _check_signature_for_checksum_file {
+ my $self = shift;
+
+ my $conf = $self->parent->configure_object;
+ my %hash = @_;
+
+ ### you don't want to check signatures,
+ ### so let's just return true;
+ return 1 unless $conf->get_conf('signature');
+
+ my($force,$file,$verbose);
+ my $tmpl = {
+ file => { required => 1, allow => FILE_READABLE, store => \$file },
+ force => { default => $conf->get_conf('force'), store => \$force },
+ verbose => { default => $conf->get_conf('verbose'), store => \$verbose },
+ };
+
+ my $args = check( $tmpl, \%hash ) or return;
+
+ my $fh = OPEN_FILE->($file) or return;
+
+ my $signed;
+ while (local $_ = <$fh>) {
+ my $header = PGP_HEADER;
+ $signed = 1 if /^$header$/;
+ }
+
+ if ( !$signed ) {
+ msg(loc("No signature found in %1 file '%2'",
+ CHECKSUMS, $file), $verbose);
+
+ return 1 unless $force;
+
+ error( loc( "%1 file '%2' is not signed -- aborting",
+ CHECKSUMS, $file ) );
+ return;
+
+ }
+
+ if( can_load( modules => { 'Module::Signature' => '0.06' } ) ) {
+ # local $Module::Signature::SIGNATURE = $file;
+ # ... check signatures ...
+ }
+
+ return 1;
+}
+
+
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Module/Fake.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Module/Fake.pm
new file mode 100644
index 00000000000..84d0233cf83
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Module/Fake.pm
@@ -0,0 +1,86 @@
+package CPANPLUS::Module::Fake;
+
+
+use CPANPLUS::Error;
+use CPANPLUS::Module;
+use CPANPLUS::Module::Author::Fake;
+use CPANPLUS::Internals;
+
+use strict;
+use vars qw[@ISA];
+use Params::Check qw[check];
+
+@ISA = qw[CPANPLUS::Module];
+$Params::Check::VERBOSE = 1;
+
+=pod
+
+=head1 NAME
+
+CPANPLUS::Module::Fake
+
+=head1 SYNOPSIS
+
+ my $obj = CPANPLUS::Module::Fake->new(
+ module => 'Foo',
+ path => 'ftp/path/to/foo',
+ author => CPANPLUS::Module::Author::Fake->new,
+ package => 'fake-1.1.tgz',
+ _id => $cpan->_id,
+ );
+
+=head1 DESCRIPTION
+
+A class for creating fake module objects, for shortcut use internally
+by CPANPLUS.
+
+Inherits from C<CPANPLUS::Module>.
+
+=head1 METHODS
+
+=head2 new( module => $mod, path => $path, package => $pkg, [_id => DIGIT] )
+
+Creates a dummy module object from the above parameters. It can
+take more options (same as C<< CPANPLUS::Module->new >> but the above
+are required.
+
+=cut
+
+sub new {
+ my $class = shift;
+ my %hash = @_;
+
+ local $Params::Check::ALLOW_UNKNOWN = 1;
+
+ my $tmpl = {
+ module => { required => 1 },
+ path => { required => 1 },
+ package => { required => 1 },
+ _id => { default => CPANPLUS::Internals->_last_id },
+ author => { default => '' },
+ };
+
+ my $args = check( $tmpl, \%hash ) or return;
+
+ $args->{author} ||= CPANPLUS::Module::Author::Fake->new(
+ _id => $args->{_id} );
+
+ my $obj = CPANPLUS::Module->new( %$args ) or return;
+
+ unless( $obj->_id ) {
+ error(loc("No '%1' specified -- No CPANPLUS object associated!",'_id'));
+ return;
+ }
+
+ ### rebless object ###
+ return bless $obj, $class;
+}
+
+1;
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Module/Signature.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Module/Signature.pm
new file mode 100644
index 00000000000..cec6f2906b0
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Module/Signature.pm
@@ -0,0 +1,65 @@
+package CPANPLUS::Module::Signature;
+
+use strict;
+
+
+use Cwd;
+use CPANPLUS::Error;
+use Params::Check qw[check];
+use Module::Load::Conditional qw[can_load];
+
+
+### detached sig, not actually used afaik --kane ###
+#sub get_signature {
+# my $self = shift;
+#
+# my $clone = $self->clone;
+# $clone->package( $self->package . '.sig' );
+#
+# return $clone->fetch;
+#}
+
+sub check_signature {
+ my $self = shift;
+ my $cb = $self->parent;
+ my $conf = $cb->configure_object;
+ my %hash = @_;
+
+ my $verbose;
+ my $tmpl = {
+ verbose => {default => $conf->get_conf('verbose'), store => \$verbose},
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+ my $dir = $self->status->extract or (
+ error( loc( "Do not know what dir '%1' was extracted to; ".
+ "Cannot check signature", $self->module ) ),
+ return );
+
+ my $cwd = cwd();
+ unless( $cb->_chdir( dir => $dir ) ) {
+ error(loc( "Could not chdir to '%1', cannot verify distribution '%2'",
+ $dir, $self->module ));
+ return;
+ }
+
+
+ ### check prerequisites
+ my $flag;
+ my $use_list = { 'Module::Signature' => '0.06' };
+ if( can_load( modules => $use_list, verbose => 1 ) ) {
+ my $rv = Module::Signature::verify();
+
+ unless ($rv eq Module::Signature::SIGNATURE_OK() or
+ $rv eq Module::Signature::SIGNATURE_MISSING()
+ ) {
+ $flag++; # whoops, bad sig
+ }
+ }
+
+ $cb->_chdir( dir => $cwd );
+ return $flag ? 0 : 1;
+}
+
+1;