Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

3617 lines (3231 sloc) 127.848 kB
# Some POD is after __END__
use strict;
use lib "/home/k/pause/lib";
use version 0.47; # 0.46 had leading whitespace and ".47" problems
use CPAN (); # only for CPAN::Version
use CPAN::Checksums 1.050; # 1.050 introduced atomic writing
use CPAN::DistnameInfo ();
use Cwd ();
use DBI;
use Data::Dumper ();
use DirHandle ();
use Dumpvalue ();
use DynaLoader ();
use Exporter ();
use ExtUtils::MakeMaker ();
use ExtUtils::Manifest;
use Fcntl qw();
use File::Basename ();
use File::Copy ();
use File::Spec ();
use File::Temp 0.14 (); # begin of OO interface
use HTTP::Date ();
use JSON ();
use List::Util ();
use List::MoreUtils ();
use Mail::Send ();
use PAUSE ();
use PAUSE::MailAddress ();
use Safe;
use Text::Format;
{
my $HAVE_YAML = eval { require YAML; 1; };
my $HAVE_YAML_SYCK = eval { require YAML::Syck; 1; };
my $HAVE_YAML_XS = eval { require YAML::XS; 1; };
$PAUSE::dist::YAML_MODULE =
$HAVE_YAML_XS ? "YAML::XS" :
$HAVE_YAML_SYCK ? "YAML::Syck" :
$HAVE_YAML ? "YAML" :
die "Found neither YAML::XS nor YAML::Syck nor YAML installed";
}
$Data::Dumper::Indent = 1;
# "MAIN" at the end of file to guarantee all packages are inintialized
{
package PAUSE::mldistwatch::Constants;
# constants used for index_status:
use constant EDUALOLDER => 50; # pumpkings only
use constant EDUALYOUNGER => 30; # pumpkings only
use constant EOPENFILE => 21;
use constant EMISSPERM => 20;
use constant EPARSEVERSION => 10;
use constant EOLDRELEASE => 4;
use constant EMTIMEFALLING => 3; # deprecated after rev 478
use constant EVERFALLING => 2;
use constant OK => 1;
}
{
package PAUSE::mldistwatch;
###### data initialization ######
use DB_File;
use Fcntl qw(O_RDWR O_CREAT);
use File::Find;
use File::Path qw(rmtree mkpath);
our $Id = q$Id$;
# ISA_REGULAR_PERL means a perl release for public consumption
# (and must exclude developer releases like 5.9.4). I need to
# rename it from ISAPERL to ISA_REGULAR_PERL to avoid
# confusion with CPAN.pm. CPAN.pm has a different regex for
# ISAPERL because there we want to protect the user from
# developer releases too, but here we want to index a distro
# with very special treatment that is only reserved for "real"
# perl distros. (The exclusion of developer releases was
# accidentally lost in rev 815)
our $ISA_REGULAR_PERL = qr{
/
(
perl-5[._-](\d{3}(_[0-4][0-9])?|\d*[02468]\.\d+)
|
perl5[._](00\d(_[0-4][0-9])?)
|
ponie-[\d.\-]
)
(?:
\.tar[._-]gz
|
\.tar\.bz2
)
\z
}x;
}
package PAUSE::mldistwatch;
our $MAINTAIN_SYMLINKTREE = 1;
use Fcntl qw(:flock);
# this class shows that it was born as spaghetticode
sub new {
my $class = shift;
my $opt = shift;
my $fh;
unless ($opt->{pick}) { # pick files shall not block full run
my $pidfile = File::Spec->catfile( $PAUSE::Config->{PID_DIR}, 'mldistwatch.pid');
if (open $fh, "+>>", $pidfile) {
if (flock $fh, LOCK_EX|LOCK_NB) {
truncate $fh, 0 or die;
seek $fh, 0, 0;
my $ofh = select $fh;
$|=1;
print $fh $$, "\n";
select $ofh;
} else {
die "other mldistwatch job running, ".
"will not run at the same time";
}
} else {
die "Could not open pidfile[$pidfile]: $!";
}
}
my $tarbin = "/usr/local/bin/tar";
$tarbin = "/bin/tar" unless -x $tarbin;
die "No tarbin found" unless -x $tarbin;
my $unzipbin = "/usr/local/bin/unzip";
$unzipbin = "/usr/bin/unzip" unless -x $unzipbin;
die "No unzip found" unless -x $unzipbin;
my $self = bless {
TARBIN => $tarbin,
UNZIPBIN => $unzipbin,
OPT => $opt,
PIDFH => $fh,
}, $class;
$self->{VERBOSE} = -t STDOUT ? 2 : 1;
if ($opt->{pick}) {
for my $pick (@{$opt->{pick}}) {
$pick =~ s|^.*authors/id/|| if $pick =~ m|authors/id/./../|;
$self->{PICK}{$pick} = 1;
}
}
if ($opt->{'skip-locking'}) {
$self->{'SKIP-LOCKING'} = 1;
}
$self->verbose(1,"Starting");
$self;
}
sub sleep {
my($self) = @_;
my $sleep = $self->{OPT}{sleep} ||= 1;
sleep $sleep;
}
sub verbose {
my($self,$level,@what) = @_;
our $Id;
unless (@what) {
@what = ("warning: verbose called without \@what: ", $level);
$level = 1;
}
return if $level > $self->{VERBOSE};
unless (exists $self->{INTRODUCED}) {
my $now = scalar localtime;
require Data::Dumper;
unshift @what, "Running $0, $Id, $now",
Data::Dumper->new([$self],[qw()])->Indent(1)->Useqq(1)->Dump;
$self->{INTRODUCED} = undef;
}
my $logfh;
if (my $logfile = $self->{OPT}{logfile}) {
open $logfh, ">>", $logfile or die;
unshift @what, scalar localtime;
push @what, "\n";
} else {
$logfh = *STDOUT;
}
print $logfh @what;
}
sub work {
my $self = shift;
my $startdir = Cwd::cwd();
my $MLROOT = $self->mlroot;
chdir $MLROOT
or die "Couldn't chdir to $MLROOT";
$self->init_all();
$self->verbose(2,"Registering new users\n");
$self->set_ustatus_to_active();
my $testdir = File::Temp::tempdir(
"mldistwatch_work_XXXX",
DIR => "/tmp",
CLEANUP => 0,
) or die "Could not make a tmp directory";
chdir $testdir
or die("Couldn't change to $testdir: $!");
$self->checkfornew($testdir);
chdir $startdir or die "Could not chdir to '$startdir'";
rmtree $testdir;
return if $self->{OPT}{pick};
$self->work2;
}
sub work2 {
my $self = shift;
$self->rewrite02();
my $MLROOT = $self->mlroot;
chdir $MLROOT
or die "Couldn't chdir to $MLROOT: $!";
$self->rewrite01();
$self->rewrite03();
$self->rewrite06();
$self->overwrite07();
$self->verbose(1, sprintf(
"\nFinished rewrite03 and everything at %s\n",
scalar localtime
));
}
sub debug_mem {
my($self) = @_;
return unless $self->{OPT}{debug_mem};
my @caller = caller;
open my $ps, "ps -o pid,vsize -p $$ |";
open my $log, ">>", "/tmp/debug_mem.log" or die;
print $log scalar localtime, "\n";
print $log $caller[2], "\n";
print $log +<$ps>;
close $log or die;
}
sub filter_dups {
my($self,$array) = @_;
my($fh) = File::Temp->new(
DIR => "/tmp",
TEMPLATE => "mldistwatch_filterdups_XXXX",
);
print $fh map {"$_\n"} @$array;
close $fh;
my $filename = $fh->filename;
#system "wc -l $filename";
system "sort --output=$filename --unique $filename";
#system "wc -l $filename";
open $fh, $filename;
local $/ = "\n";
@$array = <$fh>;
#warn sprintf "scalar \@\$array: %d", scalar @$array;
#warn "Press RET to continue";
#<>;
chomp @$array;
return;
}
sub set_ustatus_to_active {
my $self = shift;
my $db = $self->connect;
my $active = $db->selectall_hashref("SELECT userid
FROM users
WHERE ustatus='active'",
"userid");
my %seen;
$self->debug_mem;
my @new_active_users;
while (my $file = each %{$self->{ALLfound}}) {
my($user) = $file =~ m|./../([^/]+)/|;
unless (defined $user){
$self->verbose(1,"Warning: user not defined for file[$file]\n");
next;
}
next if exists $active->{$user};
push @new_active_users, $user;
}
$self->filter_dups(\@new_active_users);
$self->debug_mem;
return unless @new_active_users;
$self->verbose(2,"Info: new_active_users[@new_active_users]");
my $sth = $db->prepare("UPDATE users
SET ustatus='active', ustatus_ch=? WHERE ustatus<>'nologin' AND userid=?");
for my $user (@new_active_users) {
$sth->execute(PAUSE->_now_string, $user);
}
$sth->finish;
}
sub connect {
my $self = shift;
return $self->{DBH} if $self->{DBH};
my $dbh = DBI->connect(
$PAUSE::Config->{MOD_DATA_SOURCE_NAME},
$PAUSE::Config->{MOD_DATA_SOURCE_USER},
$PAUSE::Config->{MOD_DATA_SOURCE_PW},
{
RaiseError => 1 }
) or die $DBI::errstr;
$self->{DBH} = $dbh;
}
sub disconnect {
my $self = shift;
return unless $self->{DBH};
$self->{DBH}->disconnect;
delete $self->{DBH};
}
sub DESTROY {
my $self = shift;
$self->disconnect;
}
sub init_all {
my $self = shift;
$self->verbose(2,"Running manifind\n");
$self->{ALLfound} = $self->manifind;
$self->verbose(2,"Collecting distmtimes from DB\n");
$self->{ALLlasttime} = $self->dbfind;
}
sub dbfind {
my($self) = @_;
my %found;
my($fh) = File::Temp->new(
DIR => "/tmp",
TEMPLATE => "mldistwatch_dbfind_XXXX",
);
tie %found, 'DB_File', $fh->filename, O_RDWR|O_CREAT, 0644, $DB_HASH;
my $dbh = $self->connect;
my $sth = $dbh->prepare("SELECT dist, distmtime FROM distmtimes");
$sth->execute;
my($dist,$distmtime);
RECORD: while (($dist,$distmtime) = $sth->fetchrow_array) {
if ($self->{PICK}){
my $hit;
for my $pd (keys %{$self->{PICK}}) {
$hit++ if $pd eq $dist;
}
next RECORD unless $hit;
}
$found{$dist} = $distmtime;
}
$sth->finish;
\%found;
}
sub clean_up_filename {
my($self,$filename) = @_;
$filename =~ s|^\./||;
return $filename;
}
sub manifind {
my($self) = @_;
my %found;
return $self->{PICK} if $self->{PICK};
my($fh) = File::Temp->new(
DIR => "/tmp",
TEMPLATE => "mldistwatch_manifind_XXXX",
);
tie %found, 'DB_File', $fh->filename, O_RDWR|O_CREAT, 0644, $DB_HASH;
my $wanted = sub {
return if m|CHECKSUMS$|;
return if -d $_;
my $name = $self->clean_up_filename($File::Find::name);
$found{$name} = undef;
};
find(
{wanted => $wanted},
"."
);
return \%found;
}
sub _newcountokay {
my ($self, $count) = @_;
my $MIN = $PAUSE::Config->{ML_MIN_FILES};
return $count >= $MIN;
}
sub checkfornew {
my($self,$testdir) = @_;
local $/ = "";
my $dbh = $self->connect;
my $time = time;
my $alert;
my @all;
my($fh) = File::Temp->new(
DIR => "/tmp",
TEMPLATE => "mldistwatch_all_XXXX",
UNLINK=>1,
);
tie @all, 'DB_File', $fh->filename, O_RDWR|O_CREAT, 0644, $DB_RECNO or die;
{
$self->debug_mem;
my %seen;
@all = keys %{$self->{ALLfound}};
push @all, keys %{$self->{ALLlasttime}};
$self->filter_dups(\@all);
$self->debug_mem;
}
my $all = scalar @all;
die "Panic: unusual small number of files involved ($all)"
if !$self->{PICK} && ! $self->_newcountokay($all);
$self->verbose(2, "Starting BIGLOOP over $all files\n");
BIGLOOP: for (my $i=0;scalar @all;$self->empty_dir($testdir)) {
my $dist = shift @all;
#
# Examine all files, even CHECKSUMS and READMEs
#
$i++;
$self->verbose(2,". $dist ..") unless $i%256;
my $dio = PAUSE::dist->new(
MAIN => $self,
DIST => $dist,
DBH => $dbh,
ALERT => "",
TIME => $time,
TARBIN => $self->{TARBIN},
UNZIPBIN => $self->{UNZIPBIN},
PICK => $self->{PICK},
'SKIP-LOCKING' => $self->{'SKIP-LOCKING'},
);
if ($dio->ignoredist){
delete $self->{ALLlasttime}{$dist};
delete $self->{ALLfound}{$dist};
next BIGLOOP;
}
if (exists $self->{ALLfound}{$dist}) {
unless ($dio->mtime_ok($self->{ALLlasttime}{$dist})){
delete $self->{ALLlasttime}{$dist};
delete $self->{ALLfound}{$dist};
next BIGLOOP;
}
} else {
$dio->delete_goner;
delete $self->{ALLlasttime}{$dist};
delete $self->{ALLfound}{$dist};
next BIGLOOP;
}
unless ($dio->lock) {
$self->verbose(1,"Could not obtain a lock on $dist\n");
next BIGLOOP;
}
$self->verbose(1,"\n Examining $dist ...\n");
$0 = "mldistwatch: $dist";
my $userid = PAUSE::dir2user($dist);
$dio->{USERID} = $userid;
# >99% of all distros are already registered by the
# newfilehook but the few coming though mirror(1) are not.
# Registering *everything* that comes here should catch them
# and if we re-register this or that it should not hurt. But
# everything older than a day does not belong here, like when
# people re-index an old distro.
{
my $MLROOT = $self->mlroot;
for my $f ("$MLROOT/$dist") {
local $^T = time;
if (-M $f < 1) {
PAUSE::newfile_hook($f);
}
}
}
$dio->examine_dist; # checks for perl, developer, version, etc. and untars
if ($dio->skip){
delete $self->{ALLlasttime}{$dist};
delete $self->{ALLfound}{$dist};
next BIGLOOP;
}
$dio->read_dist;
$dio->extract_readme_and_yaml;
if ($dio->{YAML_CONTENT}{distribution_type}
&& $dio->{YAML_CONTENT}{distribution_type} =~ m/^(script)$/) {
next BIGLOOP;
}
$dio->check_blib;
$dio->check_multiple_root;
$dio->check_world_writable;
$dio->examine_pms; # will switch user
$dio->mail_summary;
$self->sleep;
$dio->set_indexed;
$alert .= $dio->alert; # now $dio can go out of scope
}
untie @all;
undef $fh;
if ($alert) {
$self->verbose(1,$alert); # summary
if ($PAUSE::Config->{TESTHOST} || $self->{OPT}{testhost}) {
} else {
our $Id;
my($msg) = Mail::Send->new(
To => $PAUSE::Config->{ADMIN},
Subject => "Upload Permission or Version mismatch"
);
$msg->add("From", "PAUSE <$PAUSE::Config->{UPLOAD}>");
my $fh = $msg->open($PAUSE::Config->{ML_MAILER});
print $fh "Not indexed.\n\t$Id\n\n", $alert;
$fh->close;
}
}
}
sub empty_dir {
my($self,$testdir) = @_;
chdir $testdir or die "Could not chdir to '$testdir': $!"; # reassure
my($dh) = DirHandle->new(".");
for my $dirent ($dh->read) {
next if $dirent eq "." || $dirent eq "..";
rmtree $dirent;
}
$dh->close;
}
sub rewrite02 {
my $self = shift;
our $Id;
#
# Rewriting 02packages.details.txt
#
$self->verbose(1,"\n\nEntering rewrite02\n");
my $dbh = $self->connect;
my $MLROOT = $self->mlroot;
my $repfile = "$MLROOT/../../modules/02packages.details.txt";
my $list = "";
my $olist = "";
local($/) = "\n";
if (
-f "$repfile.gz" and
open F, "$PAUSE::Config->{GZIP} --stdout --uncompress $repfile.gz|"
) {
while (<F>) {
next if 1../^$/;
$olist .= $_;
}
close F;
}
my $date = HTTP::Date::time2str();
my $sth = $dbh->prepare(qq{SELECT package, version, dist, file
FROM packages
WHERE status='index'});
# the status='noindex' is there so we can manually disable
# indexing of packages if need be (2004-05-04 we had such a case)
$sth->execute;
my(@row,@listing02);
my $numrows = $sth->rows;
$self->verbose(2,"numrows[$numrows]\n");
while (@row = $sth->fetchrow_array) {
my($one,$two);
my $infile = $row[0];
$infile =~ s/^.+:://;
next unless $row[3];
next unless index($row[3],"$infile.pm")>=0
or $row[3]=~/VERSION/i # VERSION is Russ Allbery's idea to
# force inclusion
or $row[3] eq "missing in META.yml, tolerated by PAUSE indexer";
$row[1] =~ s/^\+//;
$one=30;
$two=8;
if (length($row[0])>$one) {
$one += 8 - length($row[1]);
$two = length($row[1]);
}
push @listing02, sprintf "%-${one}s %${two}s %s\n", @row;
}
my $numlines = @listing02;
die "Absurd small number of lines"
unless $numlines > $PAUSE::Config->{ML_MIN_INDEX_LINES};
my $header = qq{File: 02packages.details.txt
URL: http://www.perl.com/CPAN/modules/02packages.details.txt
Description: Package names found in directory \$CPAN/authors/id/
Columns: package name, version, path
Intended-For: Automated fetch routines, namespace documentation.
Written-By: $Id
Line-Count: $numlines
Last-Updated: $date\n\n};
$list .= join "", sort {lc $a cmp lc $b} @listing02;
if ($list ne $olist) {
my $F;
if (open $F, ">", "$repfile.new") {
print $F $header;
print $F $list;
} else {
$self->verbose(1,"Couldn't open >02packages\n");
}
close $F or die "Couldn't close: $!";
rename "$repfile.new", $repfile or
$self->verbose(1,"Couldn't rename to '$repfile': $!");
PAUSE::newfile_hook($repfile);
0==system "$PAUSE::Config->{GZIP} --best --rsyncable --stdout $repfile > $repfile.gz.new"
or $self->verbose(1,"Couldn't gzip for some reason");
rename "$repfile.gz.new", "$repfile.gz" or
$self->verbose(1,"Couldn't rename to '$repfile.gz': $!");
PAUSE::newfile_hook("$repfile.gz");
}
}
sub rewrite01 {
my($self) = shift;
#
# Rewriting 01modules.index.html
#
$self->verbose(1, "\nEntering rewrite01\n");
my $dbh = $self->connect;
my $MLROOT = $self->mlroot;
my $repfile = "$MLROOT/../../modules/01modules.index.html";
my $list = "";
my $olist = "";
local $/;
local *F;
if (open F, $repfile) {
while (<F>) {
$olist .= $_;
}
close F;
} else {
$self->verbose(1,"Couldn't open $repfile $!\n");
}
my(%firstlevel,%achapter);
my $sth = $dbh->prepare("SELECT modid, chapterid FROM mods");
$sth->execute;
while (my($modid,$chapterid) = $sth->fetchrow_array) {
my($root,$colo) = $modid =~ /^([^:]+)(::)?/;
$firstlevel{$root}++;
# the determination of %achapter was introduced with rev 211.
# Alternatives were tried in 212 and 214, but they had
# uncountable misfits. 215 then was very similar to 211 but we
# did sort above query by chapterid and got tons of misfits.
# So we do not really have a solution. Every solution is
# wrong, even the pre-211 solution. OK, I've taken out the
# order by clause and retested, cheap_chapter deviates from
# old chapter for Exception, Sort, and User, that's all.
if ($colo) {
if (! exists $achapter{$root}) {
$achapter{"$root\::"} ||= $chapterid;
}
} else {
delete $achapter{"$root\::"};
$achapter{$root} ||= $chapterid;
}
}
my(@chaptitle);
$sth = $dbh->prepare("SELECT chapterid, shorttitle FROM chapters");
$sth->execute;
while (my($chapterid, $shorttitle) = $sth->fetchrow_array) {
$chaptitle[$chapterid] = sprintf "%02d_%s", $chapterid, $shorttitle;
}
$sth = $dbh->prepare("SELECT package, dist FROM packages");
$sth->execute;
my(@listing01,%count,$count);
my(%seen);
my(%usercache,%userdircache,$i);
while (my($pkg,$pkgdist) = $sth->fetchrow_array) {
my %pkg = (rootpack => $pkg, dist => $pkgdist);
$pkg{rootpack} =~ s/:.*//;
# We don't want to list perl distribution
next if $pkg{dist} =~ m|/perl-?5|;
if ($seen{$pkg{dist},$pkg{rootpack}}++) {
next;
}
if ($firstlevel{$pkg{rootpack}}) {
#print "01 will have: $pkg{rootpack}/$pkg{dist}\n";
} else {
next;
}
$i++;
@pkg{qw/size mtime/} =
(stat "$MLROOT/$pkg{dist}")[7,9];
next unless defined $pkg{size}; # somebody removed it while we were running
$count++ unless $count{$pkg{dist}}++;
$pkg{size} =
$pkg{size} > 700000 ?
sprintf "%.1fM", $pkg{size}/1024/1024 :
$pkg{size} > 700 ?
sprintf "%dk", $pkg{size}/1024+0.5 :
"1k";
# my(@parts) = split /\//, $pkg{dist};
my $directory = File::Basename::dirname($pkg{dist});
my $user = $usercache{$directory} ||= PAUSE::dir2user($pkg{dist});
my $f = File::Basename::basename($pkg{dist});
my $userdir = $userdircache{$user} ||= PAUSE::user2dir($user);
die "no user for dist[$pkg{dist}]" unless $user;
# die "no user in database with id[$user]" unless $User{$user};
$pkg{userid} = $user;
# $pkg{fullname} = $User{$user};
$pkg{userdir} = $userdir;
$pkg{useridfiller} = " "x(10-length($user));
$pkg{filenameonly} = $f;
$pkg{filenamefiller} =
" "x(38-length($f)-length($pkg{size}));
$pkg{mtimestr} =
substr(HTTP::Date::time2str($pkg{mtime}),5,11);
$pkg{young} =
$pkg{mtime} > $^T - 60 * 60 * 24 * 14 ? " +" : "";
push @listing01, [@pkg{qw/rootpack userdir userid useridfiller
dist filenameonly filenamefiller size
mtimestr young mtime/}];
# now the symlinks.
# we just wrote something like
# Sybase MEWP sybperl-2.03.tar.gz 91.8 31 Jan 1996
# we are in authors/id/
$pkg{rootpack} =~ s/\*$//; # XXX seems stemming from already deleted code
{
my $d = CPAN::DistnameInfo->new("authors/id/$pkg{dist}");
my $exte = $d->extension;
($pkg{readme} = $pkg{dist}) =~
s/\.\Q$exte\E/.readme/;
}
$pkg{readmefn} = File::Basename::basename($pkg{readme});
$pkg{chapterid} = $achapter{$pkg{rootpack}}
|| $achapter{"$pkg{rootpack}\::"};
if (defined $pkg{chapterid}) {
if (defined $chaptitle[$pkg{chapterid}]) {
$pkg{chapter} = $chaptitle[$pkg{chapterid}]
} else {
$pkg{chapter} = "99_Not_In_Modulelist";
$self->verbose(1,"\nfound no chapterid for $pkg{rootpack}\n");
}
} else {
$pkg{chapter} = "99_Not_In_Modulelist";
$self->verbose(1,"found no chapter for $pkg{rootpack}\n");
}
$self->verbose(2,".") if !($i % 16);
if ($MAINTAIN_SYMLINKTREE) {
my $bymod = "$MLROOT/../../modules/".
"by-module/$pkg{rootpack}/$pkg{filenameonly}";
my $bycat = "$MLROOT/../../modules/".
"by-category/$pkg{chapter}/$pkg{rootpack}/$pkg{filenameonly}";
next if -e $bymod and -e $bycat;
$self->chdir_ln_chdir($MLROOT,
"../../../authors/id/$pkg{dist}",
"../../modules/by-module/$pkg{rootpack}".
"/$pkg{filenameonly}");
$self->chdir_ln_chdir($MLROOT,
"../../../authors/id/$pkg{readme}",
"../../modules/by-module/$pkg{rootpack}".
"/$pkg{readmefn}")
if -f $pkg{readme};
$self->chdir_ln_chdir($MLROOT,
"../../../authors/id/$userdir",
"../../modules/by-module/$pkg{rootpack}/$pkg{userid}");
$self->chdir_ln_chdir($MLROOT,
"../../../../authors/id/$pkg{dist}",
"../../modules/by-category/$pkg{chapter}".
"/$pkg{rootpack}/$pkg{filenameonly}");
$self->chdir_ln_chdir($MLROOT,
"../../../../authors/id/$pkg{readme}",
"../../modules/by-category/$pkg{chapter}".
"/$pkg{rootpack}/$pkg{readmefn}")
if -f $pkg{readme};
$self->chdir_ln_chdir($MLROOT,
"../../../../authors/id/$userdir",
"../../modules/by-category/$pkg{chapter}".
"/$pkg{rootpack}/$pkg{userid}");
}
}
$list = qq{<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"><html><head><title>Modules
on CPAN alphabetically</title></head><body>
<h1>CPAN\'s $count modules distributions</h1>
<h3>in alphabetical order by modules contained in the distributions</h3>
<i>} .
scalar gmtime() .
qq{ GMT</i>
<p>The list contains modules distribution files on CPAN for modules that
are <b>not</b> included in the perl standard distribution but
<b>are</b> included in the current release of <a
href="00modlist.long.html">Perl Module List</a>. To keep the size of
this list acceptable, it does not list which modules are in each
package. To get at those, it is recommended to use the CPAN.pm module
or read the detailed <a
href="02packages.details.txt.gz">listing</a>.</p>
<p>Column <b><code>module/category</code></b> contains the module or
category name, column <b><code>author/maintainer</code></b> the userid
of the author or maintainer which is a hyperlink to her homedirectory.
The filename in column <b><code>current distribution file</code></b>
is a link to the real file. The last column <b><code>young</code></b>
contains a plus sign if the file is younger than two weeks.</p>
<p><i>See also:</i></p>
<ul>
<li> <a href="01modules.mtime.html">Most recent uploads</a> sorted by uploadtime.</li>
<li> <a href="../CPAN.html">CPAN\'s <b>front page</b></a> by Jon Orwant.</li>
<li> <a href="00modlist.long.html">The <b>Module List</b></a>
by Tim Bunce and Andreas K&ouml;nig</li>
<li> <a href="../authors/00whois.html"><b>Who is who</b></a></li>
<li> The detailed <a href="02packages.details.txt.gz">listing</a> of all
packages found in these distribution files</li>
</ul>
<hr />
<pre>
module/ author/ current distribution file size uploaded young
category maintainer
};
#'
$list .= join("",
map {sprintf(
qq{%-12s<a href="../authors/id/%s">%s</a>%s<a
href="../authors/id/%s">%s</a> %s %s %s%s\n},
@$_
)}
sort {lc $a->[0] cmp lc $b->[0] # package(root)
or
$a->[2] cmp $b->[2] # userid
or
lc $a->[5] cmp lc $b->[5] # filename
} @listing01
);
$list .= q{</pre></body></html>};
my($comparelist) = $list;
$comparelist =~ s/.+?<hr\b//s; # delete the intro (date!)
$olist =~ s/.+?<hr\b//s;
if ($comparelist ne $olist) {
if (open F, ">$repfile.new") {
print F $list;
close F;
rename "$repfile.new", $repfile or die;
PAUSE::newfile_hook($repfile);
$self->write_01sorted(\@listing01);
} else {
$self->verbose(1,"Couldn't open 01modules...\n");
}
}
}
sub xmlquote {
my @x = @_;
foreach my $it (@x) {
$it = '' unless defined $it;
$it =~ s<([^\n\r\t\x20\x21\x23\x27-\x3b\x3d\x3F-\x5B\x5D-\x7E])>
<'&#'.(ord($1)).';'>seg;
# turn strange things into decimal-numeric entities, no questions asked.
}
return join '', @x unless wantarray;
return @x;
}
sub write_01sorted {
my($self, $listing) = @_;
my($n) = 150;
my $html = qq{\n<html><head>
<title>Modules on CPAN sorted by upload date</title>
<link rel="alternate" type="application/rss+xml" title="RSS"
href="./01modules.mtime.rss" />
</head>
<body>
<h1>CPAN\'s $n most recent uploads</h1>
<h3>ordered by timestamp of the distributions</h3>
A description of the list can be found in
<a href="01modules.index.html">01modules.index.html</a>.
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;
<a href="./01modules.mtime.rss"
style="
border: 3px solid;
border-color: #FC9 #630 #330 #F96;
background: #F60;
color: #FFF !important;
margin: 0;
padding: 0 3px;
font: bold .7em verdana, sans-serif;
text-decoration: none !important;
"
>RSS</a>
<hr />
<pre>
author/ distribution file size uploaded
maintainer
};
my $rss = qq{<?xml version="1.0"?>
<rss version="2.0"
xmlns:sy="http://purl.org/rss/1.0/modules/syndication/"
><channel>
<title>Recent CPAN Uploads</title>
<description>The $n most recent modules uploaded to CPAN</description>
<link>http://www.cpan.org/modules/01modules.mtime.html</link>
<language>en</language>
<sy:updateFrequency>3</sy:updateFrequency>
<sy:updatePeriod>daily</sy:updatePeriod>
<sy:updateBase>1970-01-01T12:24+00:00</sy:updateBase>
<ttl>480</ttl>
<webMaster>cpan&#64;perl.org</webMaster>
};
my(%seen);
for my $l (
sort {$b->[10] <=> lc $a->[10] # mtime
} @$listing
) {
next if $seen{$l->[4]}++; # dist
my %package;
@package{qw{package userdir userid
useridfiller dist filenameonly
filenamefiller size mtimestr young mtime}}
= xmlquote( @$l );
## DB<2> x \%package
## 0 HASH(0x8c42664)
## 'dist' => 'W/WS/WSNYDER/SystemPerl-1.150.tar.gz'
## 'filenamefiller' => ' '
## 'filenameonly' => 'SystemPerl-1.150.tar.gz'
## 'mtime' => 1088685199
## 'mtimestr' => '01 Jul 2004'
## 'package' => 'SystemC'
## 'size' => '73k'
## 'userdir' => 'W/WS/WSNYDER'
## 'userid' => 'WSNYDER'
## 'useridfiller' => ' '
## 'young' => ' +'
$package{filenamefiller} =
" "x(40-length($package{filenameonly})-length($package{size}));
$package{'useridpretty'} = ucfirst(
$package{'useridlc'} = lc $package{'userid'}
);
{
my $d = CPAN::DistnameInfo->new("authors/id/$package{dist}");
my $exte = $d->extension;
($package{basename}) =
$package{filenameonly} =~ /^(.*)\.(?:\Q$exte\E)/;
}
$html .= sprintf(
qq{<a href="../authors/id/%s">%s</a>%s<a
href="../authors/id/%s">%s</a> %s %s %s\n},
@package{qw{userdir userid useridfiller dist filenameonly
filenamefiller size mtimestr}}
);
$rss .= sprintf qq{
<item>
<title>%s : %s</title>
<link>http://www.cpan.org/modules/by-authors/id/%s/%s</link>
<description>%s uploaded %s (%s) on %s</description>
<guid isPermaLink="false">%s</guid>
<comments>http://search.cpan.org/~%s/%s/</comments>
</item>
},
@package{qw{basename useridpretty
userdir filenameonly
useridpretty dist size mtimestr
filenameonly
useridlc package
}};
last unless --$n;
}
$html .= qq{</pre></body></html>\n};
$rss .= "\n</channel></rss>\n";
my $MLROOT = $self->mlroot;
my $rssfile = "$MLROOT/../../modules/01modules.mtime.rss";
# $self->verbose(1,"Writing $rssfile\n");
if (open my $F, ">", "$rssfile.new") {
print $F $rss;
close $F;
rename "$rssfile.new", $rssfile or die;
PAUSE::newfile_hook($rssfile);
} else {
die "Could not write-open >$rssfile:$!";
}
my $repfile = "$MLROOT/../../modules/01modules.mtime.html";
# $self->verbose(1,"Writing $repfile\n");
if (open my $F, ">", "$repfile.new") {
print $F $html;
close $F;
rename "$repfile.new", $repfile or die;
PAUSE::newfile_hook($repfile);
} else {
die "Could not write-open >$repfile:$!";
}
}
sub rewrite03 {
my($self) = shift;
our $Id;
#
# Rewriting 03modlist.data
#
$self->verbose(1,"\nEntering rewrite03\n");
my $MLROOT = $self->mlroot;
my $repfile = "$MLROOT/../../modules/03modlist.data";
my $list = "";
my $olist = "";
local($/) = "\n";
if (
-f "$repfile.gz" and
open F, "$PAUSE::Config->{GZIP} --stdout --uncompress $repfile.gz|"
) {
if ($] > 5.007) {
require Encode;
binmode F, ":utf8";
}
while (<F>) {
next if 1../^\s*$/;
$olist .= $_;
}
close F;
} else {
$self->verbose(1,"Couldn't open $repfile $!\n");
}
my $date = HTTP::Date::time2str();
my $dbh = $self->connect;
my $sth = $dbh->prepare(qq{SELECT modid, statd, stats, statl,
stati, statp, description, userid, chapterid
FROM mods WHERE mlstatus = "list"});
$sth->execute;
my $header = sprintf qq{File: 03modlist.data
Description: These are the data that are published in the module
list, but they may be more recent than the latest posted
modulelist. Over time we\'ll make sure that these data
can be used to print the whole part two of the
modulelist. Currently this is not the case.
Modcount: %d
Written-By: %s
Date: %s
}, $sth->rows, $Id, $date;
$list = qq{
package CPAN::Modulelist;
# Usage: print Data::Dumper->new([CPAN::Modulelist->data])->Dump or similar
# cannot 'use strict', because we normally run under Safe
# use strict;
sub data {
my \$result = {};
my \$primary = "modid";
for (\@\$CPAN::Modulelist::data){
my %hash;
\@hash{\@\$CPAN::Modulelist::cols} = \@\$_;
\$result->{\$hash{\$primary}} = \\%hash;
}
\$result;
}
};
$list .= Data::Dumper->new([
$sth->{NAME},
$self->as_ds($sth)
],
["CPAN::Modulelist::cols",
"CPAN::Modulelist::data"]
)->Dump;
$list =~ s/^\s+//gm;
if ($list ne $olist) {
my $F;
if (open $F, ">", "$repfile.new") {
if ($] > 5.007) {
require Encode;
binmode $F, ":utf8";
}
print $F $header;
print $F $list;
} else {
$self->verbose(1,"Couldn't open >03...\n");
}
close $F or die "Couldn't close: $!";
rename "$repfile.new", $repfile or
$self->verbose(1,"Couldn't rename to '$repfile': $!");
PAUSE::newfile_hook($repfile);
0==system "$PAUSE::Config->{GZIP} --best --rsyncable --stdout $repfile > $repfile.gz.new"
or $self->verbose(1,"Couldn't gzip for some reason");
rename "$repfile.gz.new", "$repfile.gz" or
$self->verbose(1,"Couldn't rename to '$repfile.gz': $!");
PAUSE::newfile_hook("$repfile.gz");
}
}
sub rewrite06 {
my($self) = shift;
our $Id;
#
# Rewriting 06perms.txt
#
$self->verbose(1,"\nEntering rewrite06\n");
my $MLROOT = $self->mlroot;
my $repfile = "$MLROOT/../../modules/06perms.txt";
my $list = "";
my $olist = "";
local($/) = "\n";
if (
-f "$repfile.gz" and
open F, "$PAUSE::Config->{GZIP} --stdout --uncompress $repfile.gz|"
) {
while (<F>) {
next if 1../^\s*$/;
$olist .= $_;
}
close F;
} else {
$self->verbose(1,"Couldn't open $repfile $!\n");
}
my $date = HTTP::Date::time2str();
my $dbh = $self->connect;
my @query = (
qq{SELECT mods.modid,
mods.userid,
"m"
FROM mods
},
qq{SELECT primeur.package,
primeur.userid,
"f"
FROM primeur
},
qq{SELECT perms.package,
perms.userid,
"c"
FROM perms
},
);
my %seen;
{
for my $query (@query) {
my $sth = $dbh->prepare($query);
$sth->execute();
if ($sth->rows > 0) {
while (my @row = $sth->fetchrow_array()) {
$seen{join ",", @row[0,1]} ||= $row[2];
}
}
$sth->finish;
}
}
my $header = sprintf qq{File: 06perms.txt
Description: CSV file of upload permission to the CPAN per namespace
best-permission is one of "m" for "modulelist", "f" for
"first-come", "c" for "co-maint"
Columns: package,userid,best-permission
Line-Count: %d
Written-By: %s
Date: %s
}, scalar keys %seen, $Id, $date;
{
for my $k (sort keys %seen) {
$list .= sprintf "%s,%s\n", $k, $seen{$k};
}
}
if ($list ne $olist) {
my $F;
if (open $F, ">:utf8", "$repfile.new") {
print $F $header;
print $F $list;
} else {
$self->verbose(1,"Couldn't open >06...\n");
}
close $F or die "Couldn't close: $!";
rename "$repfile.new", $repfile or
$self->verbose(1,"Couldn't rename to '$repfile': $!");
PAUSE::newfile_hook($repfile);
0==system "$PAUSE::Config->{GZIP} --best --rsyncable --stdout $repfile > $repfile.gz.new"
or $self->verbose(1,"Couldn't gzip for some reason");
rename "$repfile.gz.new", "$repfile.gz" or
$self->verbose(1,"Couldn't rename to '$repfile.gz': $!");
PAUSE::newfile_hook("$repfile.gz");
}
}
sub overwrite07 {
my($self) = @_;
my $fromdir = $PAUSE::Config->{FTP_RUN} or $self->verbose(1,"FTP_RUN not defined");
$fromdir .= "/mirroryaml";
-d $fromdir or $self->verbose(1,"directory '$fromdir' not found");
my $mlroot = $PAUSE::Config->{MLROOT} or $self->verbose(1,"MLROOT not defined");
my $todir = "$mlroot/../../modules";
-d $todir or $self->verbose(1,"directory '$todir' not found");
for my $exte (qw(json yml)) {
my $f = "$fromdir/mirror.$exte";
my $t = "$todir/07mirror.$exte";
rename $f, $t or $self->verbose(1,"Could not rename $f -> $t: $!");
PAUSE::newfile_hook($t);
}
}
sub chdir_ln_chdir {
my($self,$postdir,$from,$to) = @_;
chdir $postdir or die "Couln't chdir to $postdir";
my($dir) = File::Basename::dirname($to);
mkpath $dir;
chdir $dir or die "Couldn't chdir to $dir $!";
my $pwd = Cwd::cwd();
unless (-e $from){
require Carp;
Carp::confess("not exists: from[$from]dir[$dir]pwd[$pwd]");
# return;
}
if (-l $from) {
$self->verbose(1,"Won't create symlink[$to] to symlink[$from] in pwd[$pwd]\n");
return;
}
$to = File::Basename::basename($to);
if (-l $to) {
my($foundlink) = readlink $to or die "Couldn't read link $to in $dir";
if ($foundlink eq $from) {
# $self->verbose(2,"Keeping old symlink $from in dir $dir file $to\n");
return;
}
}
if (-l $to) {
$self->verbose(1, qq{unlinking symlink $to in $dir\n});
unlink $to or die qq{Couldn\'t unlink $to $!};
} elsif (-f $to) {
$self->verbose(1, "unlinking file $to in dir $dir\n");
unlink $to or die qq{Couldn\'t unlink $to $!};
} elsif (-d $to) {
$self->verbose(1,"ALERT: Have to rmtree $to in dir $dir\n");
rmtree $to;
}
symlink $from, $to or die "Couldn't symlink $from, $to $!";
chdir $postdir or die "Couldn't chdir to $postdir $!"
}
sub as_ds {
my($self,$sth) = @_;
my $result;
# If we produce the datastructure as it would seem natural,
# i.e. each primary key became key in a hash, and each table row
# would be represented as a hash, we would produce 250k instead of
# 60. After compression the ratio is still 2:1.
$result = [];
while (my @row = $sth->fetchrow_array) {
if ($] > 5.007) {
require Encode;
for (@row) {
defined && /[^\000-\177]/ && Encode::_utf8_on($_);
}
}
push @$result, \@row;
}
$result;
}
sub mlroot {
my $self = shift;
return $self->{MLROOT} if defined $self->{MLROOT};
my $mlroot = $PAUSE::Config->{MLROOT};
$mlroot =~ s|/+$||; # I found the trailing slash annoying
$self->{MLROOT} = $mlroot;
}
#####################################################################
######################### start of packages #########################
#####################################################################
{
package PAUSE::dist;
use vars qw(%CHECKSUMDONE $AUTOLOAD $YAML_MODULE);
# package PAUSE::dist
sub DESTROY {}
# package PAUSE::dist;
sub new {
my($me) = shift;
bless { @_ }, ref($me) || $me;
}
# package PAUSE::dist;
sub ignoredist {
my $self = shift;
my $dist = $self->{DIST};
if ($dist =~ m|/\.|) {
$self->verbose(1,"Warning: dist[$dist] has illegal filename\n");
return 1;
}
return 1 if $dist =~ /(\.readme|\.sig|\.meta|CHECKSUMS)$/;
# Stupid to have code that needs to be maintained in two places,
# here and in edit.pm:
return 1 if $dist =~ m!CNANDOR/(?:mp_(?:app|debug|doc|lib|source|tool)|VISEICat(?:\.idx)?|VISEData)!;
if ($self->{PICK}) {
return 1 unless $self->{PICK}{$dist};
}
return;
}
# package PAUSE::dist;
sub delete_goner {
my $self = shift;
my $dist = $self->{DIST};
if ($self->{PICK} && $self->{PICK}{$dist}) {
$self->verbose(1,"Warning: parameter pick '$dist' refers to a goner, ignoring");
return;
}
my $dbh = $self->connect;
$dbh->do("DELETE FROM packages WHERE dist='$dist'");
$dbh->do("DELETE FROM distmtimes WHERE dist='$dist'");
}
# package PAUSE::dist;
sub writechecksum {
my($self, $dir) = @_;
return if $CHECKSUMDONE{$dir}++;
local($CPAN::Checksums::CAUTION) = 1;
local($CPAN::Checksums::SIGNING_PROGRAM) =
$PAUSE::Config->{CHECKSUMS_SIGNING_PROGRAM};
local($CPAN::Checksums::SIGNING_KEY) =
$PAUSE::Config->{CHECKSUMS_SIGNING_KEY};
eval { CPAN::Checksums::updatedir($dir); };
if ($@) {
$self->verbose(1,"CPAN::Checksums::updatedir died with error[$@]");
return; # a die might cause even more trouble
}
return unless -e "$dir/CHECKSUMS"; # e.g. only files-to-ignore
PAUSE::newfile_hook("$dir/CHECKSUMS");
}
# package PAUSE::dist;
sub mtime_ok {
my $self = shift;
my $otherts = shift || 0;
my $dist = $self->{DIST};
my $dbh = $self->connect;
unless ($otherts){ # positive $otherts means it was alive last time
# Hahaha: he didn't think of the programmer who wants to
# introduce locking:
# $dbh->do("DELETE FROM distmtimes WHERE dist='$dist'");
local($dbh->{RaiseError}) = 0;
# this may fail if we have a race condition, but we'll
# decide later if this is the case:
$dbh->do("INSERT INTO distmtimes (dist) VALUES ('$dist')");
}
my $MLROOT = $self->mlroot;
my $mtime = (stat "$MLROOT/$dist")[9];
my $dirname = File::Basename::dirname("$MLROOT/$dist");
my $checksumtime = (stat "$dirname/CHECKSUMS")[9] || 0;
if ($mtime) {
# ftp-mirroring can send us up to one day old files
my $sane_checksumtime = $mtime + 86400;
if ($sane_checksumtime > $checksumtime) {
$self->writechecksum($dirname); # may do nothing
$checksumtime = (stat "$dirname/CHECKSUMS")[9] || 0;
if ($sane_checksumtime > $checksumtime # still too old
&&
time > $sane_checksumtime # and now in the past
) {
utime(
$sane_checksumtime,
$sane_checksumtime,
"$dirname/CHECKSUMS",
);
}
}
if ($mtime > $otherts) {
$dbh->do(
qq{UPDATE distmtimes SET distmtime=?, distmdatetime=?
WHERE dist=?},
undef,
$mtime,
PAUSE->_time_string($mtime),
$dist,
);
$self->verbose(1,"DEBUG5: mtime assigned [$mtime] to dist[$dist]\n");
return 1;
}
}
if ($self->{PICK}{$dist}) {
return 1;
}
return;
}
# package PAUSE::dist;
sub alert {
my $self = shift;
my $what = shift;
if (defined $what) {
$self->{ALERT} ||= "";
$self->{ALERT} .= " $what";
} else {
return $self->{ALERT};
}
}
# package PAUSE::dist;
sub untar {
my $self = shift;
my $dist = $self->{DIST};
local *TARTEST;
my $tarbin = $self->{TARBIN};
my $MLROOT = $self->mlroot;
my $tar_opt = "tzf";
if ($dist =~ /\.(?:tar\.bz2|tbz)$/) {
$tar_opt = "tjf";
}
open TARTEST, "$tarbin $tar_opt $MLROOT/$dist |";
while (<TARTEST>) {
if (m:^\.\./: || m:/\.\./: ) {
$self->verbose(1,"\n\n ALERT: Updir detected in $dist!\n\n");
$self->alert("ALERT: Updir detected in $dist!");
$self->{COULD_NOT_UNTAR}++;
return;
}
}
unless (close TARTEST) {
$self->verbose(1,"\nCould not untar $dist!\n");
$self->alert("\nCould not untar $dist!\n");
$self->{COULD_NOT_UNTAR}++;
return;
}
$tar_opt = "xzf";
if ($dist =~ /\.(?:tar\.bz2|tbz)$/) {
$tar_opt = "xjf";
}
$self->verbose(1,"Going to untar. Running '$tarbin' '$tar_opt' '$MLROOT/$dist'\n");
unless (system($tarbin,$tar_opt,"$MLROOT/$dist")==0) {
$self->verbose(1, "Some error occurred during unzipping. Let's retry with -v:\n");
unless (system("$tarbin v$tar_opt $MLROOT/$dist")==0) {
$self->verbose(1, "Some error occurred during unzipping again; giving up\n");
}
}
$self->verbose(1,"untarred '$MLROOT/$dist'\n");
return 1;
}
# package PAUSE::dist;
sub skip { shift->{SKIP} }
sub isa_regular_perl {
my($self,$dist) = @_;
scalar $dist =~ /$PAUSE::mldistwatch::ISA_REGULAR_PERL/;
}
# package PAUSE::dist;
sub examine_dist {
my($self) = @_;
my $dist = $self->{DIST};
my $MLROOT = $self->mlroot;
my($suffix,$skip);
$suffix = $skip = "";
# should use CPAN::DistnameInfo but note: "zip" not contained
# because special-cased in line 1525 below;
my $suffqr = qr/\.(tgz|tbz|tar[\._-]gz|tar\.bz2|tar\.Z)$/;
if ($self->isa_regular_perl($dist)) {
my($u) = PAUSE::dir2user($dist); # =~ /([A-Z][^\/]+)/; # XXX dist2user
$self->verbose(1,"perl dist $dist from $u. Is he a trusted guy?\n");
use DBI;
my $adbh = DBI->connect(
$PAUSE::Config->{AUTHEN_DATA_SOURCE_NAME},
$PAUSE::Config->{AUTHEN_DATA_SOURCE_USER},
$PAUSE::Config->{AUTHEN_DATA_SOURCE_PW},
) or die $DBI::errstr;
my $query = "SELECT * FROM grouptable
WHERE user= ?
AND ugroup='pumpking'";
my $sth = $adbh->prepare($query);
$sth->execute($u);
if ($sth->rows > 0){
$skip = 0;
$self->verbose(1,"Yes.\n");
} else {
$skip = 1;
$self->verbose(1,"NO! Skip set to [$skip]\n");
}
$sth->finish;
$adbh->disconnect;
if ($dist =~ $suffqr) {
$suffix = $1;
} else {
$self->verbose(1,"A perl distro ($dist) with an unusual suffix!\n");
$self->alert("A perl distro ($dist) with an unusual suffix!");
}
unless ($skip) {
$skip = 1 unless $self->untar;
}
} else { # ! isa_regular_perl
if (
$dist =~ /\d\.\d+_\d/
||
$dist =~ /TRIAL/
||
$dist =~ m|/perl-\d+\.\d+\.\d+-RC\d+\.|x
) {
$self->verbose(1," developer release\n");
$self->{SUFFIX} = "N/A";
$self->{SKIP} = 1;
return;
}
if ($dist =~ $suffqr) {
$suffix = $1;
$skip = 1 unless $self->untar;
} elsif ($dist =~ /\.pm\.(Z|gz)$/) {
# By not setting suffix we prohibit extracting README
my $file = File::Basename::basename($dist);
File::Copy::copy "$MLROOT/$dist", $file;
my $willunzip = $file;
$willunzip =~ s/\.(Z|gz)$//;
unless (PAUSE::gunzip($file,$willunzip)) {
$self->verbose(1," no gunzip on $file\n");
}
} elsif ($dist =~ /\.zip$/) {
$suffix = "zip";
my $unzipbin = $self->{UNZIPBIN};
my $system = "$unzipbin $MLROOT/$dist > /dev/null 2>&1";
unless (system($system)==0) {
$self->verbose(1,
"Some error occurred during unzippping. ".
"Let's read unzip -t:\n");
system("$unzipbin -t $MLROOT/$dist");
}
} else {
$self->verbose(1," no dist\n");
$skip = 1;
}
}
$self->{SUFFIX} = $suffix;
$self->{SKIP} = $skip;
}
# package PAUSE::dist
sub connect {
my($self) = @_;
my $main = $self->{MAIN};
$main->connect;
}
# package PAUSE::dist
sub disconnect {
my($self) = @_;
my $main = $self->{MAIN};
$main->disconnect;
}
# package PAUSE::dist
sub mlroot {
my($self) = @_;
my $main = $self->{MAIN};
$main->mlroot;
}
# package PAUSE::dist;
sub mail_summary {
my($self) = @_;
my $distro = $self->{DIST};
my $author = PAUSE::dir2user($distro);
my @m;
push @m, "The following report has been written by the PAUSE namespace indexer.
Please contact modules\@perl.org if there are any open questions.
$PAUSE::mldistwatch::Id\n";
my $time = gmtime;
my $MLROOT = $self->mlroot;
my $mtime = gmtime((stat "$MLROOT/$distro")[9]);
my $nfiles = scalar @{$self->{MANIFOUND}};
my $pmfiles = grep /\.pm$/, @{$self->{MANIFOUND}};
my $dbh = $self->connect;
my $sth = $dbh->prepare("SELECT asciiname, fullname
FROM users
WHERE userid=?");
$sth->execute($author);
my($u) = $sth->fetchrow_hashref;
my $asciiname = $u->{asciiname} || $u->{fullname} || "name unknown";
my $substrdistro = substr $distro, 5;
my($distrobasename) = $substrdistro =~ m|.*/(.*)|;
my $versions_from_metayaml = $self->{VERSION_FROM_YAML_OK} ? "yes" : "no";
my $yaml_module_version = $PAUSE::dist::YAML_MODULE->VERSION;
push @m, qq{
User: $author ($asciiname)
Distribution file: $distrobasename
Number of files: $nfiles
*.pm files: $pmfiles
README: $self->{README}
META.yml: $self->{YAML}
YAML-Parser: $PAUSE::dist::YAML_MODULE $yaml_module_version
META-driven index: $versions_from_metayaml
Timestamp of file: $mtime UTC
Time of this run: $time UTC\n\n};
my $tf = Text::Format->new(firstIndent=>0);
my $status_over_all;
if (0) {
} elsif ($self->{HAS_MULTIPLE_ROOT}) {
push @m, $tf->format(qq{The distribution does not unpack
into a single directory and is therefore not being
indexed. Hint: try 'make dist' or 'Build dist'. (The
directory entries found were: @{$self->{HAS_MULTIPLE_ROOT}})});
push @m, qq{\n\n};
$status_over_all = "Failed";
} elsif ($self->{HAS_WORLD_WRITABLE}) {
push @m, $tf->format(qq[The distribution contains the
following world writable directories or files and is
therefore considered a security breach and as such not
being indexed: @{$self->{HAS_WORLD_WRITABLE}} . See
also http://use.perl.org/~bart/journal/38127]);
push @m, qq{\n\n};
if ($self->{HAS_WORLD_WRITABLE_FIXEDFILE}) {
push @m, $tf->format(qq[For your convenience PAUSE has
tried to write a new tarball with all the
world-writable bits removed. The file is put on
the CPAN as
'$self->{HAS_WORLD_WRITABLE_FIXEDFILE}' along with
your upload and will be indexed automatically
unless there are other errors that prevent that.
Please watch for a separate indexing report.]);
push @m, qq{\n\n};
} else {
my $err = join "\n", @{$self->{HAS_WORLD_WRITABLE_FIXINGERRORS}||[]};
$self->alert("Fixing a world-writable tarball failed: $err");
}
$status_over_all = "Failed";
} elsif ($self->{HAS_BLIB}) {
push @m, $tf->format(qq{The distribution contains a blib/
directory and is therefore not being indexed. Hint:
try 'make dist'.});
push @m, qq{\n\n};
$status_over_all = "Failed";
} else {
my $inxst = $self->{INDEX_STATUS};
if ($inxst && ref $inxst && %$inxst) {
my $Lstatus = 0;
my $intro_written;
for my $p (sort {
$inxst->{$b}{status} <=> $inxst->{$a}{status}
or
$a cmp $b
} keys %$inxst) {
my $status = $inxst->{$p}{status};
unless (defined $status_over_all) {
if ($status) {
if ($status > PAUSE::mldistwatch::Constants::OK) {
$status_over_all =
PAUSE::mldistwatch::Constants::heading($status)
|| "UNKNOWN (status=$status)";
} else {
$status_over_all = "OK";
}
} else {
$status_over_all = "Unknown";
}
push @m, "Status of this distro: $status_over_all\n";
push @m, "="x(length($status_over_all)+23), "\n\n";
}
unless ($intro_written++) {
push @m, qq{The following packages (grouped by }.
qq{status) have been found in the distro:\n\n};
}
if ($status != $Lstatus) {
my $heading =
PAUSE::mldistwatch::Constants::heading($status) ||
"UNKNOWN (status=$status)";
push @m, sprintf "Status: %s
%s\n\n", $heading, "="x(length($heading)+8);
}
my $tf13 = Text::Format->new(
bodyIndent => 13,
firstIndent => 13,
);
my $verb_status = $tf13->format($inxst->{$p}{verb_status});
$verb_status =~ s/^\s+//; # otherwise this line is too long
# magic words, see also report02() around line 573, same wording there,
# exception prompted by JOESUF/libapreq2-2.12.tar.gz
$inxst->{$p}{infile} ||= "missing in META.yml, tolerated by PAUSE indexer";
push @m, sprintf(" module: %s
version: %s
in file: %s
status: %s\n",
$p,
$inxst->{$p}{version},
$inxst->{$p}{infile},
$verb_status,
);
$Lstatus = $status;
}
} else {
warn sprintf "st[%s]", Data::Dumper::Dumper($inxst);
if ($pmfiles > 0) {
if ($self->version_from_yaml_ok) {
push @m, qq{Nothing in this distro has been
indexed, because according to META.yml this
package does not provide any modules.\n\n};
$status_over_all = "Empty_provides";
} else {
push @m, qq{No or no indexable package
statements could be found in the distro (maybe a
script or documentation distribution or a
developer release?)\n\n};
$status_over_all = "Empty_no_pm";
}
} else {
# no need to write a report at all
return;
}
}
}
push @m, qq{__END__\n};
my $pma = PAUSE::MailAddress->new_from_userid($author);
if ($PAUSE::Config->{TESTHOST} || $self->{MAIN}{OPT}{testhost}) {
if ($self->{PICK}) {
local $"="";
warn "Unsent Report [@m]";
}
} else {
my $to = sprintf "%s, %s", $pma->address, $PAUSE::Config->{ADMIN};
my $failed = "";
if ($status_over_all ne "OK") {
$failed = "Failed: ";
}
my($msg) = Mail::Send
->new(
To => $to,
Subject => $failed."PAUSE indexer report $substrdistro",
);
$msg->add("From", "PAUSE <$PAUSE::Config->{UPLOAD}>");
my $fh = $msg->open($PAUSE::Config->{ML_MAILER});
print $fh @m;
$fh->close;
$self->verbose(1,"-->> Sent \"indexer report\" mail about $substrdistro\n");
}
}
# package PAUSE::dist;
sub index_status {
my($self,$pack,$version,$infile,$status,$verb_status) = @_;
$self->{INDEX_STATUS}{$pack} = {
version => $version,
infile => $infile,
status => $status,
verb_status => $verb_status,
};
}
# package PAUSE::dist;
sub check_blib {
my($self) = @_;
if (grep m|^[^/]+/blib/|, @{$self->{MANIFOUND}}) {
$self->{HAS_BLIB}++;
return;
}
# sometimes they package their stuff deep inside a hierarchy
my @found = @{$self->{MANIFOUND}};
my $endless = 0;
DIRDOWN: while () {
# step down directories as long as possible
my %seen;
my @top = grep { s|/.*||; !$seen{$_}++ } map { $_ } @found;
if (@top == 1) {
# print $top[0];
my $success = 0;
for (@found){ # note, we modify found, not top!
s|\Q$top[0]\E/|| && $success++;
}
last DIRDOWN unless $success; # no directory to step down anymore
if (++$endless > 10) {
$self->alert("ENDLESS LOOP detected in $self->{DIST}!");
last DIRDOWN;
}
next DIRDOWN;
}
# more than one entry in this directory means final check
if (grep m|^blib/|, @found) {
$self->{HAS_BLIB}++;
}
last DIRDOWN;
}
}
# package PAUSE::dist;
sub check_multiple_root {
my($self) = @_;
my %seen;
my @top = grep { s|/.*||; !$seen{$_}++ } map { $_ } @{$self->{MANIFOUND}};
if (@top > 1) {
$self->verbose(1,"HAS_MULTIPLE_ROOT: top[@top]");
$self->{HAS_MULTIPLE_ROOT} = \@top;
} else {
$self->{DISTROOT} = $top[0];
}
}
# package PAUSE::dist;
sub check_world_writable {
my($self) = @_;
my @files = @{$self->{MANIFOUND}};
my @dirs = List::MoreUtils::uniq map {File::Basename::dirname($_) . "/"} @files;
my $Ldirs = @dirs;
while () {
@dirs = List::MoreUtils::uniq map {($_,File::Basename::dirname($_) . "/")} @dirs;
my $dirs = @dirs;
last if $dirs == $Ldirs;
$Ldirs = $dirs;
}
my @ww = grep {my @stat = stat $_; $stat[2] & 2} @dirs, @files;
if (@ww) {
# XXX todo: set a variable if we could successfully build the
# new tarball and make it visible for debugging and later
# visible for the user
# we are now in temp dir and in front of us is
# $self->{DISTROOT}, e.g. 'Tk-Wizard-2.142' (the directory, not necessarily the significant part of the distro name)
my @wwfixingerrors;
for my $wwf (@ww) {
my @stat = stat $wwf;
unless (chmod $stat[2] &~ 0022, $wwf) {
push @wwfixingerrors, "error during 'chmod $stat[2] &~ 0022, $wwf': $!";
}
}
my $fixedfile = "$self->{DISTROOT}-withoutworldwriteables.tar.gz";
my $todir = File::Basename::dirname($self->{DIST}); # M/MA/MAKAROW
my $to_abs = "$self->{MAIN}{MLROOT}/$todir/$fixedfile";
if (! length $self->{DISTROOT}) {
push @wwfixingerrors, "Alert: \$self->{DISTROOT} is empty, cannot fix";
} elsif ($self->{DIST} =~ /-withoutworldwriteables/) {
push @wwfixingerrors, "Sanity check failed: incoming file '$self->{DIST}' already has '-withoutworldwriteables' in the name";
} elsif (-e $to_abs) {
push @wwfixingerrors, "File '$to_abs' already exists, won't overwrite";
} elsif (0 != system (tar => "czf",
$to_abs,
$self->{DISTROOT}
)) {
push @wwfixingerrors, "error during 'tar ...': $!";
}
$self->verbose(1,"HAS_WORLD_WRITABLE: ww[@ww]");
$self->{HAS_WORLD_WRITABLE} = \@ww;
if (@wwfixingerrors) {
$self->{HAS_WORLD_WRITABLE_FIXINGERRORS} = \@wwfixingerrors;
} else {
$self->{HAS_WORLD_WRITABLE_FIXEDFILE} = $fixedfile;
}
}
}
# package PAUSE::dist;
sub filter_pms {
my($self) = @_;
my @pmfile;
# very similar code is in PAUSE::package::filter_ppps
MANI: for my $mf ( @{$self->{MANIFOUND}} ) {
next unless $mf =~ /\.pm(?:\.PL)?$/i;
my($inmf) = $mf =~ m!^[^/]+/(.+)!; # go one directory down
next if $inmf =~ m!^(?:t|inc)/!;
if ($self->{YAML_CONTENT}){
my $no_index = $self->{YAML_CONTENT}{no_index}
|| $self->{YAML_CONTENT}{private}; # backward compat
if (ref($no_index) eq 'HASH') {
my %map = (
file => qr{\z},
directory => qr{/},
);
for my $k (qw(file directory)) {
next unless my $v = $no_index->{$k};
my $rest = $map{$k};
if (ref $v eq "ARRAY") {
for my $ve (@$v) {
$ve =~ s|/+$||;
if ($inmf =~ /^$ve$rest/){
$self->verbose(1,"skipping inmf[$inmf] due to ve[$ve]");
next MANI;
} else {
$self->verbose(1,"NOT skipping inmf[$inmf] due to ve[$ve]");
}
}
} else {
$v =~ s|/+$||;
if ($inmf =~ /^$v$rest/){
$self->verbose(1,"skipping inmf[$inmf] due to v[$v]");
next MANI;
} else {
$self->verbose(1,"NOT skipping inmf[$inmf] due to v[$v]");
}
}
}
} else {
# noisy:
# $self->verbose(1,"no keyword 'no_index' or 'private' in YAML_CONTENT");
}
} else {
# $self->verbose(1,"no YAML_CONTENT"); # too noisy
}
push @pmfile, $mf;
}
$self->verbose(1,"pmfile[@pmfile]\n");
\@pmfile;
}
# package PAUSE::dist;
sub examine_pms {
my $self = shift;
return if $self->{HAS_BLIB};
return if $self->{HAS_MULTIPLE_ROOT};
return if $self->{HAS_WORLD_WRITABLE};
return if $self->{COULD_NOT_UNTAR}; # XXX not yet reached, we
# need to re-examine what
# happens without SKIP.
# Currently SKIP shadows
# the event of
# could_not_untar
my $dist = $self->{DIST};
my $binary_dist;
# ftp://ftp.funet.fi/pub/CPAN/modules/05bindist.convention.html
$binary_dist = 1 if $dist =~ /\d-bin-\d+-/i;
my $pmfiles = $self->filter_pms;
my($yaml,$provides,$indexingrule);
if (my $version_from_yaml_ok = $self->version_from_yaml_ok) {
$yaml = $self->{YAML_CONTENT};
$provides = $yaml->{provides};
if (!$indexingrule && $provides && "HASH" eq ref $provides) {
$indexingrule = 2;
}
}
if (!$indexingrule && @$pmfiles) { # examine files
$indexingrule = 1;
}
if (0) {
} elsif (1==$indexingrule) { # examine files
for my $pmfile (@$pmfiles) {
if ($binary_dist) {
next unless $pmfile =~ /\b(Binary|Port)\b/; # XXX filename good,
# package would be
# better
} elsif ($pmfile =~ m|/blib/|) {
$self->alert("Still a blib directory detected:
dist[$dist]pmfile[$pmfile]
");
next;
}
$self->chown_unsafe;
my $fio = PAUSE::pmfile->new(
DIO => $self,
PMFILE => $pmfile,
TIME => $self->{TIME},
USERID => $self->{USERID},
YAML_CONTENT => $self->{YAML_CONTENT},
);
$fio->examine_fio;
}
} elsif (2==$indexingrule) { # no pmfiles but at least a yaml
while (my($k,$v) = each %$provides) {
$v->{infile} = "$v->{file}";
my @stat = stat File::Spec->catfile($self->{DISTROOT}, $v->{file});
if (@stat) {
$v->{filemtime} = $stat[9];
} else {
$v->{filemtime} = 0;
}
unless (defined $v->{version}) {
# 2009-09-23 get a bugreport due to
# RKITOVER/MooseX-Types-0.20.tar.gz not
# setting version for MooseX::Types::Util
$v->{version} = "undef";
}
# going from a distro object to a package object
# is only possible via a file object
my $fio = PAUSE::pmfile->new
(
DIO => $self,
PMFILE => $v->{infile},
TIME => $self->{TIME},
USERID => $self->{USERID},
YAML_CONTENT => $self->{YAML_CONTENT},
);
my $pio = PAUSE::package
->new(
PACKAGE => $k,
DIST => $dist,
FIO => $fio,
PP => $v,
TIME => $self->{TIME},
PMFILE => $v->{infile},
USERID => $self->{USERID},
YAML_CONTENT => $self->{YAML_CONTENT},
);
$pio->examine_pkg;
}
} else {
$self->alert("Does this work out elsewhere? Neither yaml nor pmfiles indexing in dist[$dist]???");
}
}
# package PAUSE::dist
sub chown_unsafe {
my($self) = @_;
return if $self->{CHOWN_UNSAFE_DONE};
use File::Find;
my(undef,undef,$uid,$gid) = getpwnam($PAUSE::Config->{ML_CHOWN_USER});
die "user $PAUSE::Config->{ML_CHOWN_USER} not found, cannot continue" unless defined $uid;
find(sub {
chown $uid, $gid, $_;
},
"."
);
$self->{CHOWN_UNSAFE_DONE}++;
}
# package PAUSE::dist;
sub read_dist {
my $self = shift;
my(@manifind) = sort keys %{ExtUtils::Manifest::manifind()};
my $manifound = @manifind;
$self->{MANIFOUND} = \@manifind;
my $dist = $self->{DIST};
unless (@manifind){
$self->verbose(1,"NO FILES! in dist $dist?");
return;
}
$self->verbose(1,"Found $manifound files in dist $dist, first $manifind[0]\n");
}
# package PAUSE::dist;
sub extract_readme_and_yaml {
my $self = shift;
my($suffix) = $self->{SUFFIX};
return unless $suffix;
my $dist = $self->{DIST};
my $MLROOT = $self->mlroot;
my @manifind = @{$self->{MANIFOUND}};
my(@readme) = grep /(^|\/)readme/i, @manifind;
my($sans) = $dist =~ /(.*)\.\Q$suffix\E$/;
if (@readme) {
my $readme;
if ($sans =~ /-bin-?(.*)/) {
my $vers_arch = quotemeta $1;
my @grep;
while ($vers_arch) {
if (@grep = grep /$vers_arch/, @readme) {
@readme = @grep;
last;
}
$vers_arch =~ s/^[^\-]+-?//;
}
}
$readme = $readme[0];
for (1..$#readme) {
$readme = $readme[$_] if length($readme[$_]) < length($readme);
}
$self->{README} = $readme;
File::Copy::copy $readme, "$MLROOT/$sans.readme";
utime((stat $readme)[8,9], "$MLROOT/$sans.readme");
PAUSE::newfile_hook("$MLROOT/$sans.readme");
} else {
$self->{README} = "No README found";
$self->verbose(1,"No readme in $dist\n");
}
my $yaml = List::Util::reduce { length $a < length $b ? $a : $b }
grep !m|/t/|, grep m|/META\.yml$|, @manifind;
if (defined $yaml) {
if (-s $yaml) {
$self->{YAML} = $yaml;
File::Copy::copy $yaml, "$MLROOT/$sans.meta";
utime((stat $yaml)[8,9], "$MLROOT/$sans.meta");
PAUSE::newfile_hook("$MLROOT/$sans.meta");
my $yamlloadfile = \&{"$YAML_MODULE\::LoadFile"};
eval { $self->{YAML_CONTENT} = $yamlloadfile->($yaml); };
if ($@) {
$self->verbose(1,"Error while parsing YAML: $@");
if ($@ =~ /msg: Unrecognized implicit value/) {
# let's retry, but let's not expect that this
# will work. MakeMaker 6.16 had a bug that
# could be fixed like this, at least for
# Pod::Simple
my $cat = do { open my($f), $yaml or die; local $/; <$f> };
$cat =~ s/:(\s+)(\S+)$/:$1"$2"/mg;
my $yamlload = \&{"$YAML_MODULE\::Load"};
eval { $self->{YAML_CONTENT} = $yamlload->($cat); };
if ($@) {
$self->{YAML_CONTENT} = {};
$self->{YAML} = "META.yml found but error ".
"encountered while loading: $@";
}
} else {
$self->{YAML_CONTENT} = {};
$self->{YAML} = "META.yml found but error ".
"encountered while loading: $@";
}
}
} else {
$self->{YAML} = "Empty META.yml found, ignoring\n";
}
} else {
$self->{YAML} = "No META.yml found";
$self->verbose(1,"No META.yml in $dist");
}
}
# package PAUSE::dist
sub version_from_yaml_ok {
my($self) = @_;
return $self->{VERSION_FROM_YAML_OK} if exists $self->{VERSION_FROM_YAML_OK};
my $ok = 0;
my $c = $self->{YAML_CONTENT};
if (exists $c->{provides}) {
if (exists $c->{generated_by}) {
if (my($v) = $c->{generated_by} =~ /Module::Build version ([\d\.]+)/) {
if ($v eq "0.250.0") {
$ok++;
} elsif ($v >= 0.19) {
if ($v < 0.26) {
# RSAVAGE/Javascript-SHA1-1.01.tgz had an
# empty provides hash. Ron did not find
# the reason why this happened, but let's
# not go overboard, 0.26 seems a good
# threshold from the statistics: there
# are not many empty provides hashes from
# 0.26 up.
if (keys %{$c->{provides}}) {
$ok++;
} else {
$ok = 0;
}
} else {
$ok++;
}
} else {
$ok = 0;
}
} else {
$ok++;
}
} else {
$ok++;
}
}
return $self->{VERSION_FROM_YAML_OK} = $ok;
}
# package PAUSE::dist
sub verbose {
my($self,$level,@what) = @_;
my $main = $self->{MAIN};
$main->verbose($level,@what);
}
# package PAUSE::dist
sub lock {
my($self) = @_;
if ($self->{'SKIP-LOCKING'}) {
$self->verbose(1,"forcing indexing without a lock");
return 1;
}
my $dist = $self->{DIST};
my $dbh = $self->connect;
my $rows_affected = $dbh->do(
"UPDATE distmtimes SET indexing_at=?
WHERE dist='$dist'
AND indexing_at IS NULL",
undef,
PAUSE->_now_string,
);
return 1 if $rows_affected > 0;
my $sth = $dbh->prepare("SELECT * FROM distmtimes WHERE dist=?");
$sth->execute($dist);
if ($sth->rows) {
my $row = $sth->fetchrow_hashref();
require Data::Dumper;
$self->verbose(1,
sprintf(
"Cannot get lock, current record is[%s]",
Data::Dumper->new([$row],
[qw(row)],
)->Indent(1)->Useqq(1)->Dump,
));
} else {
$self->verbose(1,"Weird: first we get no lock, then the record is gone???");
}
return;
}
# package PAUSE::dist
sub set_indexed {
my($self) = @_;
my $dist = $self->{DIST};
my $dbh = $self->connect;
my $rows_affected = $dbh->do(
"UPDATE distmtimes SET indexed_at=? WHERE dist='$dist'",
undef,
PAUSE->_now_string,
);
$rows_affected > 0;
}
}
{
package PAUSE::mldistwatch::Constants;
our $heading =
{
EMISSPERM() => "Permission missing",
EDUALOLDER() => "An older dual-life module stays reference",
EDUALYOUNGER() => "Dual-life module stays reference",
EVERFALLING() => "Decreasing version number",
EMTIMEFALLING() => "Decreasing mtime on a file (category to be deprecated)",
EOLDRELEASE() => "Release seems outdated",
EPARSEVERSION() => "Version parsing problem",
EOPENFILE() => "Problem while reading the distribtion",
OK() => "Successfully indexed",
};
sub heading ($) {
my($status) = shift;
# warn "status[$status]";
$heading->{$status};
}
}
{
package PAUSE::pmfile;
use vars qw($AUTOLOAD);
sub parent {
my($self) = @_;
$self->{DIO};
}
sub DESTROY {}
sub verbose {
my($self,$level,@what) = @_;
my $main = $self->{DIO};
$main->verbose($level,@what);
}
# package PAUSE::pmfile;
sub new {
my($me) = shift;
bless { @_ }, ref($me) || $me;
}
# package PAUSE::pmfile;
sub simile {
my($self,$file,$package) = @_;
# MakeMaker gives them the chance to have the file Simple.pm in
# this directory but have the package HTML::Simple in it.
# Afaik, they wouldn't be able to do so with deeper nested packages
$file =~ s|.*/||;
$file =~ s|\.pm(?:\.PL)?||;
my $ret = $package =~ m/\b\Q$file\E$/;
$ret ||= 0;
unless ($ret) {
# Apache::mod_perl_guide stuffs it into Version.pm
$ret = 1 if lc $file eq 'version';
}
$self->verbose(1,"simile: file[$file] package[$package] ret[$ret]\n");
$ret;
}
# package PAUSE::pmfile;
sub alert {
my $self = shift;
my $what = shift;
my $dio = $self->{DIO};
$dio->alert($what);
}
sub connect {
my($self) = @_;
my $dio = $self->{DIO};
$dio->connect;
}
sub disconnect {
my($self) = @_;
my $dio = $self->{DIO};
$dio->disconnect;
}
sub mlroot {
my($self) = @_;
my $dio = $self->{DIO};
$dio->mlroot;
}
# package PAUSE::pmfile;
sub filter_ppps {
my($self,@ppps) = @_;
my @res;
# very similar code is in PAUSE::dist::filter_pms
MANI: for my $ppp ( @ppps ) {
if ($self->{YAML_CONTENT}){
my $no_index = $self->{YAML_CONTENT}{no_index}
|| $self->{YAML_CONTENT}{private}; # backward compat
if (ref($no_index) eq 'HASH') {
my %map = (
package => qr{\z},
namespace => qr{::},
);
for my $k (qw(package namespace)) {
next unless my $v = $no_index->{$k};
my $rest = $map{$k};
if (ref $v eq "ARRAY") {
for my $ve (@$v) {
$ve =~ s|::$||;
if ($ppp =~ /^$ve$rest/){
$self->verbose(1,"skipping ppp[$ppp] due to ve[$ve]");
next MANI;
} else {
$self->verbose(1,"NOT skipping ppp[$ppp] due to ve[$ve]");
}
}
} else {
$v =~ s|::$||;
if ($ppp =~ /^$v$rest/){
$self->verbose(1,"skipping ppp[$ppp] due to v[$v]");
next MANI;
} else {
$self->verbose(1,"NOT skipping ppp[$ppp] due to v[$v]");
}
}
}
} else {
$self->verbose(1,"no keyword 'no_index' or 'private' in YAML_CONTENT");
}
} else {
# $self->verbose(1,"no YAML_CONTENT"); # too noisy
}
push @res, $ppp;
}
$self->verbose(1,"res[@res]");
@res;
}
# package PAUSE::pmfile;
sub examine_fio {
# fio: file object
my $self = shift;
my $dist = $self->{DIO}{DIST};
my $dbh = $self->connect;
my $pmfile = $self->{PMFILE};
my($filemtime) = (stat $pmfile)[9];
$self->{MTIME} = $filemtime;
unless ($self->version_from_yaml_ok) {
$self->{VERSION} = $self->parse_version;
if ($self->{VERSION} =~ /^\{.*\}$/) {
# JSON error message
} elsif ($self->{VERSION} =~ /[_\s]/){ # ignore developer releases and "You suck!"
delete $self->{DIO}; # circular reference
return;
}
}
my($ppp) = $self->packages_per_pmfile;
my @keys_ppp = $self->filter_ppps(sort keys %$ppp);
$self->verbose(1,"will check keys_ppp[@keys_ppp]\n");
#
# Immediately after each package (pmfile) examined contact
# the database
#
my ($package);
DBPACK: foreach $package (@keys_ppp) {
# What do we need? dio, fio, pmfile, time, dist, dbh, alert?
my $pio = PAUSE::package
->new(
PACKAGE => $package,
DIST => $dist,
PP => $ppp->{$package}, # hash containing
# version
TIME => $self->{TIME},
PMFILE => $pmfile,
FIO => $self,
USERID => $self->{USERID},
YAML_CONTENT => $self->{YAML_CONTENT},
);
$pio->examine_pkg;
} # end foreach package
delete $self->{DIO}; # circular reference
}
# package PAUSE::pmfile
sub version_from_yaml_ok {
my($self) = @_;
return $self->{VERSION_FROM_YAML_OK} if exists $self->{VERSION_FROM_YAML_OK};
$self->{VERSION_FROM_YAML_OK} = $self->{DIO}->version_from_yaml_ok;
}
# package PAUSE::pmfile;
sub packages_per_pmfile {
my $self = shift;
my $ppp = {};
my $pmfile = $self->{PMFILE};
my $filemtime = $self->{MTIME};
my $version = $self->{VERSION};
open my $fh, "<", "$pmfile" or return $ppp;
local $/ = "\n";
my $inpod = 0;
PLINE: while (<$fh>) {
chomp;
my($pline) = $_;
$inpod = $pline =~ /^=(?!cut)/ ? 1 :
$pline =~ /^=cut/ ? 0 : $inpod;
next if $inpod;
next if substr($pline,0,4) eq "=cut";
$pline =~ s/\#.*//;
next if $pline =~ /^\s*$/;
if ($pline =~ /\b__(?:END|DATA)__\b/
and $pmfile !~ /\.PL$/ # PL files may well have code after __DATA__
){
last PLINE;
}
my $pkg;
if (
$pline =~ m{
(.*)
\bpackage\s+
([\w\:\']+)
\s*
( $ | [\}\;] )
}x) {
$pkg = $2;
if ($pkg eq "DB"){
# XXX if pumpkin and perl make him comaintainer! I
# think I always made the pumpkins comaint on DB
# without further ado (?)
next PLINE;
}
}
if ($pkg) {
# Found something
# from package
$pkg =~ s/\'/::/;
next PLINE unless $pkg =~ /^[A-Za-z]/;
next PLINE unless $pkg =~ /\w$/;
next PLINE if $pkg eq "main";
# Perl::Critic::Policy::TestingAndDebugging::ProhibitShebangWarningsArg
# database for modid in mods, package in packages, package in perms
# alter table mods modify modid varchar(128) binary NOT NULL default '';
# alter table packages modify package varchar(128) binary NOT NULL default '';
next PLINE if length($pkg) > 128;
#restriction
$ppp->{$pkg}{parsed}++;
$ppp->{$pkg}{infile} = $pmfile;
if ($self->simile($pmfile,$pkg)) {
$ppp->{$pkg}{simile} = $pmfile;
if ($self->version_from_yaml_ok) {
my $provides = $self->{DIO}{YAML_CONTENT}{provides};
if (exists $provides->{$pkg}) {
if (exists $provides->{$pkg}{version}) {
my $v = $provides->{$pkg}{version};
if ($v =~ /[_\s]/){ # ignore developer releases and "You suck!"
next PLINE;
} else {
$ppp->{$pkg}{version} = $self->normalize_version($v);
}
} else {
$ppp->{$pkg}{version} = "undef";
}
}
} else {
$ppp->{$pkg}{version} ||= "";
$ppp->{$pkg}{version} ||= $version;
local($^W)=0;
$ppp->{$pkg}{version} =
$version
if $version
> $ppp->{$pkg}{version} ||
$version
gt $ppp->{$pkg}{version};
}
} else { # not simile
#### it comes later, it would be nonsense
#### to set to "undef". MM_Unix gives us
#### the best we can reasonably consider
$ppp->{$pkg}{version} =
$version
unless defined $ppp->{$pkg}{version} &&
length($ppp->{$pkg}{version});
}
$ppp->{$pkg}{filemtime} = $filemtime;
$ppp->{$pkg}{pause_reg} = time;
} else {
# $self->verbose(2,"no pkg found");
}
}
$fh->close;
$ppp;
}
# package PAUSE::pmfile;
{
no strict;
sub parse_version_safely {
my($parsefile) = @_;
my $result;
local *FH;
local $/ = "\n";
open(FH,$parsefile) or die "Could not open '$parsefile': $!";
my $inpod = 0;
while (<FH>) {
$inpod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod;
next if $inpod || /^\s*#/;
chop;
# next unless /\$(([\w\:\']*)\bVERSION)\b.*\=/;
next unless /([\$*])(([\w\:\']*)\bVERSION)\b.*\=/;
my $current_parsed_line = $_;
my $eval = qq{
package ExtUtils::MakeMaker::_version;
local $1$2;
\$$2=undef; do {
$_
}; \$$2
};
local $^W = 0;
$result = eval($eval);
# warn "current_parsed_line[$current_parsed_line]\$\@[$@]";
if ($@){
die +{
eval => $eval,
line => $current_parsed_line,
file => $parsefile,
err => $@,
} if $@;
}
last;
} #;
close FH;
$result = "undef" unless defined $result;
return $result;
}
}
sub _module_version {
my $leaf = shift;
(my $pkg = $leaf) =~ s/\.pm//;
my ($module, $version, $in_pkg, %version);
local *FH;
local $_;
open(FH,$leaf) or return;
my $inpod;
while(<FH>) {
$inpod = $1 ne 'cut' if /^=(\w+)/;
next if $inpod or /^\s*#/;
if(/^\s*package\s+(([\w]+(?:'|::))*([\w]+))/) {
$module ||= $1 if $3 eq $pkg;
$in_pkg = $1;
}
elsif (my($for_pkg, $rhs) = /[\$*]([\w\:\']*)\bVERSION\b.*\=(.*)/) {
$for_pkg ||= $in_pkg or next;
$for_pkg =~ s/::$//;
$version{$for_pkg} = $rhs;
}
if ($module and $version{$module}) {
require Safe;
require version;
local $^W = 0;
my $s = Safe->new;
$s->share_from('main', ['*version::']);
$s->share_from('version', ['&qv']);
$s->reval('$VERSION = ' . $version{$module});
$version = $s->reval('$VERSION');
# Handle version objects
($version = $version->normal) =~ s/^v// if ref($version) eq
'version';
if ($version{$module} =~ /\bv?(\d+([_.]\d+){2,})/) {
my $v = $1;
my $q = pack "U*", ($v =~ /\d+/g);
$version = $v if $version eq $q;
}
last;
}
}
close(FH);
return $module ? ($module, $version) : ();
}
# package PAUSE::pmfile;
sub parse_version {
my $self = shift;
use strict;
my $pmfile = $self->{PMFILE};
my $pmcp = $pmfile;
for ($pmcp) {
s/([^\\](\\\\)*)@/$1\\@/g; # thanks to Raphael Manfredi for the
# solution to escape @s and \
}
my($v);
$self->disconnect; # no guarantee that the connection survives the fork!
{
package main; # seems necessary
my($pid,$kid);
die "Can't fork: $!" unless defined($pid = open($kid, "-|"));
if ($pid) { # parent
$v = <$kid>;
# warn ">>>>>>>>read v[$v]<<<<<<<<";
close $kid;
} else {
my($gnam,$gpw,$gid,$gmem) = getgrnam($PAUSE::Config->{ML_CHOWN_GROUP});
die "Could not determine GID of $PAUSE::Config->{ML_CHOWN_GROUP}" unless $gid;
my($uname,$upw,$uid,$ugid,$q,$c,$gcos,$udir,$ushell) =
getpwnam($PAUSE::Config->{ML_CHOWN_USER});
die "Could not determine UID of $PAUSE::Config->{ML_CHOWN_USER}" unless $uid;
$( = $gid; $) = "$gid $gid";
$< = $> = $uid;
# XXX Limit Resources too
my($comp) = Safe->new("_pause::mldistwatch");
my $eval = qq{
local(\$^W) = 0;
PAUSE::pmfile::parse_version_safely("$pmcp");
};
$comp->permit("entereval"); # for MBARBON/Module-Info-0.30.tar.gz
$comp->share("*PAUSE::pmfile::parse_version_safely");
$comp->share("*version::new");
$comp->share("*version::numify");
$comp->share_from('main', ['*version::',
'*Exporter::',
'*DynaLoader::']);
$comp->share_from('version', ['&qv']);
# $comp->permit("require"); # no strict!
{
no strict;
local $PAUSE::Config;
$v = $comp->reval($eval);
}
if ($@){ # still in the child process, out of Safe::reval
my $err = $@;
# warn ">>>>>>>err[$err]<<<<<<<<";
if (ref $err) {
if ($err->{line} =~ /[\$*]([\w\:\']*)\bVERSION\b.*\=(.*)/) {
$v = $comp->reval($2);
}
if ($@) {
warn sprintf("reval failed: err[%s] for eval[%s]",
JSON::objToJson($err,{pretty => 1}),
$eval,
);
$v = JSON::objToJson($err);
}
} else {
$v = JSON::objToJson({ openerr => $err });
}
}
if (defined $v) {
$v = $v->numify if ref($v) eq 'version';
} else {
$v = "";
}
print $v;
exit;
}
}
return $self->normalize_version($v);
}
# package PAUSE::pmfile
sub normalize_version {
my($self,$v) = @_;
$v = "undef" unless defined $v;
my $dv = Dumpvalue->new;
my $sdv = $dv->stringify($v,1); # second argument prevents ticks
$self->verbose(1,"sdv[$sdv]\n");
return $v if $v eq "undef";
return $v if $v =~ /^\{.*\}$/; # JSON object
$v =~ s/^\s+//;
$v =~ s/\s+\z//;
if ($v =~ /_/) {
# XXX should pass something like EDEVELOPERRELEASE up e.g.
# SIXTEASE/XML-Entities-0.0306.tar.gz had nothing but one
# such modules and the mesage was not helpful that "nothing
# was found".
return $v ;
}
my $vv = version->new($v)->numify;
if ($vv eq $v) {
# the boring 3.14
} else {
my $forced = $self->force_numeric($v);
if ($forced eq $vv) {
} elsif ($forced =~ /^v(.+)/) {
# rare case where a v1.0.23 slipped in (JANL/w3mir-1.0.10.tar.gz)
$vv = version->new($1)->numify;
} else {
# warn "Unequal forced[$forced] and vv[$vv]";
if ($forced == $vv) {
# the trailing zeroes would cause unnecessary havoc
$vv = $forced;
}
}
}
return $vv;
}
# package PAUSE::pmfile;
sub force_numeric {
my($self,$v) = @_;
$v = CPAN::Version->readable($v);
if (
$v =~
/^(\+?)(\d*)(\.(\d*))?/ &&
# "$2$4" ne ''
(
defined $2 && length $2
||
defined $4 && length $4
)
) {
my $two = defined $2 ? $2 : "";
my $three = defined $3 ? $3 : "";
$v = "$two$three";
}
# no else branch! We simply say, everything else is a string.
$v;
}
}
=comment
Now we have a table primeur and we have a new terminology:
people in table "perms" are co-maintainers or maintainers
people in table "primeur" are maintainers
packages in table "packages" live there independently from permission
tables.
packages in table "mods" have an official owner. That one overrules
both tables "primeur" and "perms".
P1.0 If there is a registered maintainer in mods, put him into perms
unconditionally.
P2.0 If perms knows about this package but current user is not in
perms for this package, return.
P2.1 but if user is primeur or perl, go on
P2.2 but if there is no primeur, make this user primeur
P3.0 Give this user an entry in perms now, no matter how many there are.
P4.0 Work out how packages table needs to be updated.
P4.1 We know this package: complicated UPDATE
P4.2 We don't know it: simple INSERT
package in packages package in primeur
1 1 easy nothing add'l to do
0 0 easy 4.2
1 0 error 4.1
0 1 complicated(*) 4.2
(*) This happens when a package is removed from CPAN completely.
=cut
{
package PAUSE::package;
use vars qw($AUTOLOAD);
sub verbose {
my($self,$level,@what) = @_;
my $parent = $self->parent;
if ($parent) {
require Scalar::Util;
if (Scalar::Util::blessed($parent)) {
$parent->verbose($level,@what);
} else {
require Carp;
Carp::cluck("Could not find a sane parent[$parent] to log level[$level]what[@what]");
}
} else {
require Carp;
Carp::cluck("Could not find a parent to log level[$level]what[@what]");
}
}
sub parent {
my($self) = @_;
$self->{FIO} || $self->{DIO};
}
sub DESTROY {}
# package PAUSE::package;
sub new {
my($me) = shift;
bless { @_ }, ref($me) || $me;
}
# package PAUSE::package;
sub alert {
my $self = shift;
my $what = shift;
my $parent = $self->parent;
$parent->alert($what);
}
# package PAUSE::package;
# return value nonsensical
sub give_regdowner_perms {
my $self = shift;
my $dbh = $self->connect;
my $package = $self->{PACKAGE};
local($dbh->{RaiseError}) = 0;
my $sth_mods = $dbh->prepare("SELECT userid
FROM mods
WHERE modid = ?");
# warn "Going to execute [SELECT userid FROM mods WHERE modid = '$package']";
$sth_mods->execute($package) or die "FAILED";
if ($sth_mods->rows>0) { # make sure we regard the owner as the owner
my($mods_userid) = $sth_mods->fetchrow_array;
local($dbh->{RaiseError}) = 0;
local($dbh->{PrintError}) = 0;
my $query = "INSERT INTO perms (package, userid) VALUES (?,?)";
my $ret = $dbh->do($query, {}, $package, $mods_userid);
my $err = "";
$err = $dbh->errstr unless defined $ret;
$ret ||= "";
$self->verbose(1,"into perms package[$package]mods_userid".
"[$mods_userid]ret[$ret]err[$err]\n");
}
}
# perm_check: we're both guessing and setting.
# P2.1: returns 1 if user is owner or perl; makes him
# co-maintainer at the same time
# P2.0: otherwise returns false if the package is already known in
# perms table AND the user is not among the co-maintainers
# but if the package is not yet known in the perms table this makes
# him co-maintainer AND returns 1
# package PAUSE::package;
sub perm_check {
my $self = shift;
my $dist = $self->{DIST};
my $package = $self->{PACKAGE};
my $pp = $self->{PP};
my $dbh = $self->connect;
my($userid) = $self->{USERID};
my $ins_perms = "INSERT INTO perms (package, userid) VALUES ".
"('$package', '$userid')";
if ($self->{FIO}{DIO} && $self->{FIO}{DIO}->isa_regular_perl($dist)) {
local($dbh->{RaiseError}) = 0;
local($dbh->{PrintError}) = 0;
my $ret = $dbh->do($ins_perms);
my $err = "";
$err = $dbh->errstr unless defined $ret;
$ret ||= "";
# print "(primeur)ins_perms[$ins_perms]ret[$ret]err[$err]\n";
return 1; # P2.1, P3.0
}
my($is_primeur) = $dbh->prepare(qq{SELECT package, userid
FROM primeur
WHERE package = ? AND userid = ?}
);
$is_primeur->execute($package,$userid);
if ($is_primeur->rows) {
local($dbh->{RaiseError}) = 0;
local($dbh->{PrintError}) = 0;
my $ret = $dbh->do($ins_perms);
my $err = "";
$err = $dbh->errstr unless defined $ret;
$ret ||= "";
# print "(primeur)ins_perms[$ins_perms]ret[$ret]err[$err]\n";
return 1; # P2.1, P3.0
}
my($has_primeur) = $dbh->prepare(qq{SELECT package
FROM primeur
WHERE package = ?});
$has_primeur->execute($package);
if ($has_primeur->rows == 0) {
my($has_owner) = $dbh->prepare(qq{SELECT modid
FROM mods
WHERE modid = ?});
$has_owner->execute($package);
if ($has_owner->rows == 0) {
# package has neither owner in mods nor maintainer in primeur
local($dbh->{RaiseError}) = 0;
my $ret = $dbh->do($ins_perms);
my $err = "";
$err = $dbh->errstr unless defined $ret;
$ret ||= "";
$self->verbose(1,"(ownerless)ins_perms[$ins_perms]ret[$ret]err[$err]\n");
return 1; # P2.2, P3.0
}
}
my($sth_perms) = $dbh->prepare(qq{SELECT package, userid
FROM perms
WHERE package = ?}
);
$sth_perms->execute($package);
if ($sth_perms->rows) {
# we have a package that is already known
for ($package,
$pp->{version},
$dist,
$pp->{infile}) {
$_ ||= '';
}
my($p,$owner,@owner);
while (($p,$owner) = $sth_perms->fetchrow_array) {
push @owner, $owner; # array for debugging statement
}
if ($self->{FIO}{DIO}->isa_regular_perl($dist)) {
# seems ok: perl is always right
} elsif (! grep { $_ eq $userid } @owner) {
# we must not index this and we have to inform somebody
my $owner = eval { PAUSE::owner_of_module($package, $dbh) };
$self->index_status($package,
$pp->{version},
$pp->{infile},
PAUSE::mldistwatch::Constants::EMISSPERM,
qq{Not indexed because permission missing.
Current registered primary maintainer is $owner.
Hint: you can always find the legitimate maintainer(s) on PAUSE under "View Permissions".},
);
$self->alert(qq{not owner:
package[$package]
version[$pp->{version}]
file[$pp->{infile}]
dist[$dist]
userid[$userid]
owners[@owner]
owner[$owner]
});
return; # early return
}
} else {
# package has no existence in perms yet, so this guy is OK
local($dbh->{RaiseError}) = 0;
my $ret = $dbh->do($ins_perms);
my $err = "";
$err = $dbh->errstr unless defined $ret;
$ret ||= "";
$self->verbose(1,"(uploader)ins_perms[$ins_perms]ret[$ret]err[$err]\n");
}
$self->verbose(1,sprintf( # just for debugging
"02maybe: %-25s %10s %-16s (%s) %s\n",
$package,
$pp->{version},
$pp->{infile},
$pp->{filemtime},
$dist
));
return 1;
}
# package PAUSE::package;
sub connect {
my($self) = @_;
my $parent = $self->parent;
$parent->connect;
}
# package PAUSE::package;
sub disconnect {
my($self) = @_;
my $parent = $self->parent;
$parent->disconnect;
}
# package PAUSE::package;
sub mlroot {
my($self) = @_;
my $fio = $self->parent;
$fio->mlroot;
}
# package PAUSE::package;
sub examine_pkg {
my $self = shift;
my $dbh = $self->connect;
my $package = $self->{PACKAGE};
my $dist = $self->{DIST};
my $pp = $self->{PP};
my $pmfile = $self->{PMFILE};
# should they be cought earlier? Maybe.
# but as an ultimate sanity check suggested by Richard Soderberg
# XXX should be in a separate sub and be tested
if ($package !~ /^\w[\w\:\']*\w?\z/
||
$package !~ /\w\z/
||
$package =~ /:/ && $package !~ /::/
||
$package =~ /\w:\w/
||
$package =~ /:::/
){
$self->verbose(1,"package[$package] did not pass the ultimate sanity check");
delete $self->{FIO}; # circular reference
return;
}
# set perms for registered owner in any case
$self->give_regdowner_perms; # (P1.0)
# Query all users with perms for this package
unless ($self->perm_check){ # (P2.0&P3.0)
delete $self->{FIO}; # circular reference
return;
}
# Parser problem
if ($pp->{version} && $pp->{version} =~ /^\{.*\}$/) { # JSON parser error
my $err = JSON::jsonToObj($pp->{version});
if ($err->{openerr}) {
$self->index_status($package,
"undef",
$pp->{infile},
PAUSE::mldistwatch::Constants::EOPENFILE,
qq{The PAUSE indexer was not able to
read the file. It issued the following error: C< $err->{openerr} >},
);
} else {
$self->index_status($package,
"undef",
$pp->{infile},
PAUSE::mldistwatch::Constants::EPARSEVERSION,
qq{The PAUSE indexer was not able to
parse the following line in that file: C< $err->{line} >
Note: the indexer is running in a Safe compartement and
cannot provide the full functionality of perl in the
VERSION line. It is trying hard, but sometime it fails.
As a workaround, please consider writing a proper
META.yml that contains a 'provides' attribute (currently
only supported by Module::Build) or contact the CPAN
admins to investigate (yet another) workaround against
"Safe" limitations.)},
);
}
delete $self->{FIO}; # circular reference
return;
}
# Sanity checks
for (
$package,
$pp->{version},
$dist
) {
if (!defined || /^\s*$/ || /\s/){ # for whatever reason I come here
delete $self->{FIO}; # circular reference
return; # don't screw up 02packages
}
}
$self->checkin;
delete $self->{FIO}; # circular reference
}
# package PAUSE::package;
sub update_package {
# we come here only for packages that have opack and package
my $self = shift;
my $sth_pack = shift;
my $dbh = $self->connect;
my $package = $self->{PACKAGE};
my $dist = $self->{DIST};
my $pp = $self->{PP};
my $pmfile = $self->{PMFILE};
my $fio = $self->{FIO};
my($opack,$oldversion,$odist,$ofilemtime,$ofile) = $sth_pack->fetchrow_array;
$self->verbose(1,"opack[$opack]oldversion[$oldversion]".
"odist[$odist]ofiletime[$ofilemtime]ofile[$ofile]\n");
my $MLROOT = $self->mlroot;
my $odistmtime = (stat "$MLROOT/$odist")[9];
my $tdistmtime = (stat "$MLROOT/$dist")[9] ;
# decrementing Version numbers are quite common :-(
my $ok = 0;
my $distorperlok = File::Basename::basename($dist) !~ m|/perl|;
# this dist is not named perl-something (lex ILYAZ)
my $isaperl = $self->{FIO}{DIO}->isa_regular_perl($dist);
$distorperlok ||= $isaperl;
# or it is THE perl dist
my($something1) = File::Basename::basename($dist) =~ m|/perl(.....)|;
# or it is called perl-something (e.g. perl-ldap) AND...
my($something2) = File::Basename::basename($odist) =~ m|/perl(.....)|;
# and we compare against another perl-something AND...
my($oisaperl) = $self->{FIO}{DIO}->isa_regular_perl($odist);
# the file we're comparing with is not the perl dist
$distorperlok ||= $something1 && $something2 &&
$something1 eq $something2 && !$oisaperl;
$self->verbose(1, "package[$package]infile[$pp->{infile}]".
"distorperlok[$distorperlok]oldversion[$oldversion]".
"odist[$odist]\n");
# Until 2002-08-01 we always had
# if >ver OK
# elsif <ver
# else
# if 0ver
# if <=old OK
# else
# elsif =ver && <=old && ( !perl || perl && operl) OK
# From now we want to have the primary decision on isaperl. If it
# is a perl, we only index if the other one is also perl or there
# is no other. Otherwise we leave the decision tree unchanged
# except that we can simplify the complicated last line to
# elsif =ver && <=old OK
# AND we need to accept falling version numbers if old dist is a
# perl
# relevant postings/threads:
# http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2002-07/msg01579.html
# http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2002-08/msg00062.html
if (! $distorperlok) {
} elsif ($isaperl) {
if ($oisaperl) {
if (CPAN::Version->vgt($pp->{version},$oldversion)) {
$ok++;
} elsif (CPAN::Version->vgt($oldversion,$pp->{version})) {
} elsif (CPAN::Version->vcmp($pp->{version},$oldversion)==0
&&
$tdistmtime >= $odistmtime) {
$ok++;
}
} else {
if (CPAN::Version->vgt($pp->{version},$oldversion)) {
$self->index_status($package,
$pp->{version},
$pp->{infile},
PAUSE::mldistwatch::Constants::EDUALOLDER,
qq{Not indexed because $ofile
seems to have a dual life in $odist. Although the other package is at
version [$oldversion], the indexer lets the other dist continue to be
the reference version, shadowing the one in the core. Maybe harmless,
maybe needs resolving.},
);
} else {
$self->index_status($package,
$pp->{version},
$pp->{infile},
PAUSE::mldistwatch::Constants::EDUALYOUNGER,
qq{Not indexed because $ofile
has a dual life in $odist. The other version is at $oldversion, so
not indexing seems okay.},
);
}
}
} elsif (CPAN::Version->vgt($pp->{version},$oldversion)) {
# higher VERSION here
$self->verbose(1, "$package version better ".
"[$pp->{version} > $oldversion] $dist wins\n");
$ok++;
} elsif (CPAN::Version->vgt($oldversion,$pp->{version})) {
# lower VERSION number here
if ($odist ne $dist) {
$self->index_status($package,
$pp->{version},
$pmfile,
PAUSE::mldistwatch::Constants::EVERFALLING,
qq{Not indexed because $ofile in $odist
has a higher version number ($oldversion)},
);
$self->alert(qq{decreasing VERSION number [$pp->{version}]
in package[$package]
dist[$dist]
oldversion[$oldversion]
pmfile[$pmfile]
}); # });
} elsif ($oisaperl) {
$ok++; # new on 2002-08-01
} else {
# we get a different result now than we got in a previous run
$self->alert("Taking back previous version calculation. odist[$odist]oversion[$oldversion]dist[$dist]version[$pp->{version}].");
$ok++;
}
} else {
# 2004-01-04: Stas Bekman asked to change logic here. Up
# to rev 478 we did not index files with a version of 0
# and with a falling timestamp. These strange timestamps
# typically happen for developers who work on more than
# one computer. Files that are not changed between
# releases keep two different timestamps from some
# arbitrary checkout in the past. Stas correctly suggests,
# we should check these cases for distmtime, not filemtime.
# so after rev. 478 we deprecate the EMTIMEFALLING constant
if ($pp->{version} eq "undef"||$pp->{version} == 0) { # no version here,
if ($tdistmtime >= $odistmtime) { # but younger or same-age dist
$self->verbose(1, "$package noversion comp $dist vs $odist: >=\n");
$ok++;
} else {
$self->index_status(
$package,
$pp->{version},
$pp->{infile},
PAUSE::mldistwatch::Constants::EOLDRELEASE,
qq{Not indexed because $ofile in $odist
also has a zero version number and the distro has a more recent modification time.}
);
}
} elsif (CPAN::Version
->vcmp($pp->{version},
$oldversion)==0) { # equal version here
$self->verbose(1, "$package version eq comp $dist vs $odist\n");
if ($tdistmtime >= $odistmtime) { # but younger or same-age dist
$ok++;
} else {
$self->index_status(
$package,
$pp->{version},
$pp->{infile},
PAUSE::mldistwatch::Constants::EOLDRELEASE,
qq{Not indexed because $ofile in $odist
has the same version number and the distro has a more recent modification time.}
);
}
} else {
$self->verbose(1, "Nothing interesting in dist[$dist]package[$package]\n");
}
}
if ($ok) { # sanity check
if ($self->{FIO}{DIO}{VERSION_FROM_YAML_OK}) {
# nothing to argue at the moment, e.g. lib_pm.PL
} elsif (
! $pp->{simile}
&&
(!$fio || $fio->simile($ofile,$package)) # if we have no fio, we can't check simile
) {
$self->verbose(1,
"Warning: we ARE NOT simile BUT WE HAVE BEEN ".
"simile some time earlier:\n");
$self->verbose(1,Data::Dumper::Dumper($pp), "\n");
$ok = 0;
}
}
if ($ok) {
my $query = qq{UPDATE packages SET version = ?, dist = ?, file = ?,
filemtime = ?, pause_reg = ? WHERE package = ?};
$self->verbose(1,"Q: [$query]$pp->{version},$dist,$pp->{infile},$pp->{filemtime},$self->{TIME},$package\n");
$dbh->do($query,
undef,
$pp->{version},
$dist,
$pp->{infile},
$pp->{filemtime},
$self->{TIME},
$package,
);
$self->index_status($package,
$pp->{version},
$pp->{infile},
PAUSE::mldistwatch::Constants::OK,
"indexed",
);
}
}
# package PAUSE::package;
sub index_status {
my($self) = shift;
my $dio;
if (my $fio = $self->{FIO}) {
$dio = $fio->{DIO};
} else {
$dio = $self->{DIO};
}
$dio->index_status(@_);
}
# package PAUSE::package;
sub insert_into_package {
my $self = shift;
my $dbh = $self->connect;
my $package = $self->{PACKAGE};
my $dist = $self->{DIST};
my $pp = $self->{PP};
my $pmfile = $self->{PMFILE};
$self->verbose(1,"First time here, eh?\n");
my $query = qq{INSERT INTO packages
(package, version, dist, file, filemtime, pause_reg)
VALUES (?,?,?,?,?,?)
};
$self->verbose(1,"Q: [$query]$package,$pp->{version},$dist,$pp->{infile},$pp->{filemtime},$self->{TIME}\n");
$dbh->do($query,
undef,
$package,
$pp->{version},
$dist,
$pp->{infile},
$pp->{filemtime},
$self->{TIME},
);
$self->index_status($package,
$pp->{version},
$pp->{infile},
PAUSE::mldistwatch::Constants::OK,
"indexed",
);
}
# package PAUSE::package;
# returns always the return value of print, so basically always 1
sub checkin_into_primeur {
my $self = shift;
my $dbh = $self->connect;
my $package = $self->{PACKAGE};
my $dist = $self->{DIST};
my $pp = $self->{PP};
my $pmfile = $self->{PMFILE};
# we cannot do that yet, first we must fill primeur with the
# values we believe are correct now.
# We come here, no matter if this package is in primeur or not. We
# know, it must get in there if it isn't yet. No update, just an
# insert, please. Should be similar to give_regdowner_perms(), but
# this time with this user.
# print ">>>>>>>>checkin_into_primeur not yet implemented<<<<<<<<\n";
local($dbh->{RaiseError}) = 0;
local($dbh->{PrintError}) = 0;
my $userid;
my $dio = $self->parent->parent;
if (exists $dio->{YAML_CONTENT}{x_authority}) {
$userid = $dio->{YAML_CONTENT}{x_authority};
$userid =~ s/^cpan://i;
# validate userid existing
} else {
$userid = $self->{USERID} or die;
}
my $query = "INSERT INTO primeur (package, userid) VALUES (?,?)";
my $ret = $dbh->do($query, {}, $package, $userid);
my $err = "";