diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/CPANPLUS/Module')
-rw-r--r-- | Master/tlpkg/tlperl/lib/CPANPLUS/Module/Author.pm | 232 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/CPANPLUS/Module/Author/Fake.pm | 80 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/CPANPLUS/Module/Checksums.pm | 251 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/CPANPLUS/Module/Fake.pm | 86 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/CPANPLUS/Module/Signature.pm | 65 |
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; |