Initial Commit

database/perl/vendor/lib/CPANPLUS/Module/Author.pm

@@ -0,0 +1,234 @@
+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';
+use vars qw[$VERSION];
+$VERSION = "0.9910";
+
+local $Params::Check::VERBOSE = 1;
+
+=pod
+
+=head1 NAME
+
+CPANPLUS::Module::Author - CPAN author object for CPANPLUS
+
+=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. Don't 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 don't
+        ### 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:

database/perl/vendor/lib/CPANPLUS/Module/Author/Fake.pm

@@ -0,0 +1,82 @@
+package CPANPLUS::Module::Author::Fake;
+
+
+use CPANPLUS::Module::Author;
+use CPANPLUS::Internals;
+use CPANPLUS::Error;
+
+use strict;
+use vars            qw[@ISA $VERSION];
+use Params::Check   qw[check];
+
+$VERSION = "0.9910";
+
+@ISA = qw[CPANPLUS::Module::Author];
+
+$Params::Check::VERBOSE = 1;
+
+=pod
+
+=head1 NAME
+
+CPANPLUS::Module::Author::Fake - dummy author object for CPANPLUS
+
+=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:

database/perl/vendor/lib/CPANPLUS/Module/Checksums.pm

@@ -0,0 +1,259 @@
+package CPANPLUS::Module::Checksums;
+
+use strict;
+use vars qw[@ISA $VERSION];
+
+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 ];
+$VERSION = "0.9910";
+
+=head1 NAME
+
+CPANPLUS::Module::Checksums - checking the checksum of a distribution
+
+=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::SHA' => '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 $sha = $href->{ $self->package }->{'sha256'};
+
+    unless( defined $sha ) {
+        msg(loc("No 'sha256' checksum known for '%1'",$self->package),$verbose);
+
+        return $self->status->checksum_ok(1);
+    }
+
+    $self->status->checksum_value($sha);
+
+
+    my $fh = FileHandle->new( $self->status->fetch ) or return;
+    binmode $fh;
+
+    my $ctx = Digest::SHA->new(256);
+    $ctx->addfile( $fh );
+
+    my $hexdigest = $ctx->hexdigest;
+    my $flag = $hexdigest eq $sha;
+    $flag
+        ? msg(loc("Checksum matches for '%1'", $self->package),$verbose)
+        : error(loc("Checksum does not match for '%1': " .
+                    "SHA256 is '%2' but should be '%3'",
+                    $self->package, $hexdigest, $sha),$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 );
+
+    # If the user specified a fetchdir, then every CHECKSUMS file will always
+    # be stored there, not in an author-specific subdir.  Thus, in this case,
+    # we need to always re-fetch the CHECKSUMS file and hence need to set the
+    # TTL to something small.
+    my $have_fetchdir =
+        $self->parent->configure_object->get_conf('fetchdir') ne '';
+    my $ttl = $have_fetchdir ? 0.001 : 3600;
+    my $file = $clone->fetch( ttl => $ttl, %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;

database/perl/vendor/lib/CPANPLUS/Module/Fake.pm

@@ -0,0 +1,87 @@
+package CPANPLUS::Module::Fake;
+
+
+use CPANPLUS::Error;
+use CPANPLUS::Module;
+use CPANPLUS::Module::Author::Fake;
+use CPANPLUS::Internals;
+
+use strict;
+use vars            qw[@ISA $VERSION];
+use Params::Check   qw[check];
+
+$VERSION = "0.9910";
+@ISA = qw[CPANPLUS::Module];
+$Params::Check::VERBOSE = 1;
+
+=pod
+
+=head1 NAME
+
+CPANPLUS::Module::Fake - fake module object for internal use
+
+=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:

database/perl/vendor/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];
+use vars qw[$VERSION];
+$VERSION = "0.9910";
+
+### 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;