#!/usr/bin/perl
#                              -*- Mode: Perl -*- 
# $Basename: mkpackages $
# $Revision: 1.10 $
# Author          : Ulrich Pfeifer
# Created On      : Wed Jan  7 15:04:13 1998
# Last Modified By: Ulrich Pfeifer
# Last Modified On: Sun Sep 18 19:50:54 2005
# Language        : CPerl
# Update Count    : 56
# Status          : Unknown, Use with caution!
# 
# (C) Copyright 1998,2005 Ulrich Pfeifer, all rights reserved.
# 
# 

use strict;
use IO::File;
use File::Find;

my $VERSION = "0.020";

my $CPAN = shift;

die "No such directory '$CPAN'\n" unless -d $CPAN;

mkdir "$CPAN/site", 0755 or die "mkdir $CPAN/site: $!"
  unless -d "$CPAN/site";

unless (-f "$CPAN/site/01mailrc.txt.gz" ) {
  new IO::File "|gzip >$CPAN/site/01mailrc.txt.gz"
    or die "touch $CPAN/site/01mailrc.txt.gz: $!\n";
}

if (-f "$CPAN/site/02packages.details.txt.gz") {
  rename
    "$CPAN/site/02packages.details.txt.gz",
    "$CPAN/site/02packages.details.txt.gz.bak"
      or die "renaming $CPAN/site/02packages.details.txt.gz\n";
}

my $fh = new IO::File "|gzip >$CPAN/site/02packages.details.txt.gz"
  or die "Generating $CPAN/site/02packages.details.txt.gz: $!\n";

my %VERSION;
my %PATH;
my $DEBUG;

find(\&wanted, "$CPAN/authors/id");

sub register {
  my ($file, $package, $version, $path) = @_;

  warn "($file, $package, $version, $path)\n" if $DEBUG;
  if ($file =~ /\.pm$/) {
    next if exists $VERSION{$package} and $VERSION{$package} ge $version;
    ($PATH{$package} = $path) =~ s!$CPAN/authors/id/!!;
    $VERSION{$package} =
      (defined $version and $version ne '') ? $version : 'undef';
  }
}

sub wanted {
  return unless /\.tar\.(gz|Z)$/;
  return unless -f $_;

  my $readme_file;
  if (/\.tar\.(gz|Z)$/) {
    warn "processing $File::Find::name ...\n";
    $readme_file = $_;
    $readme_file =~ s/\.tar\.(gz|Z)$/\/README/;
    warn "README file $readme_file\n" if $DEBUG;
    my $fh = new IO::File "gzip -cd $_|"
      or die "gzip $File::Find::name: $!\n";
    my ($file, $package, $version);
    my $in_buf  = '';
    my $out_buf = '';

    my $in_readme = 0;
  BLOCK:
    while ($fh->sysread($in_buf, 512)) {
      if ($in_buf =~ /^(\S*?)\0/) {
        $file = $1;
        warn "file=$file\n" if $DEBUG and length $file;
        if ($file eq $readme_file) {
            $in_readme = 1;
            my $output_filename = $readme_file;
            $output_filename =~ s/\/README$/\.readme/; # Assumes Unix paths
            open README_FILE, ">$output_filename" ||
               die "Could not open .readme file $output_filename $!";
            warn "Creating README file: $output_filename\n" if $DEBUG;
        } else {
            $in_readme = 0;
            close README_FILE;
        }
        undef $package;
        undef $version;
        $out_buf = '';
        next BLOCK;
      }

      if ($in_readme) {
          print README_FILE substr($in_buf, 0, index($in_buf, "\0"));
      }

      $out_buf .= $in_buf;
      while ($out_buf =~ s/^([^\n]*)\n//) {
        local $_ = $1;
        if (/^\s* package \s* ((\w+::)*\w+) \s* ;/x) {
          $package = $1;
          warn "package=$package\n" if $DEBUG;
        } elsif (/^ \s* (?: \$ (\w+::)* VERSION \s* = \s* )+ (.*) $/x) {
          warn 'package foo; ' . $2 . "\n" if $DEBUG;
          $version = eval 'package foo; ' . $2;
          warn "version=$version\n" if $DEBUG;
          register($file, $package, $version, $File::Find::name)
            if $file and $package;
        }
      }
    }
  }
}
print STDERR "$0 VERSION $VERSION\n";
my $lines = keys %VERSION;
my $date  = gmtime;
$fh->print (<<EOH)
File:         02packages.details.txt
URL:          http://www.perl.com/CPAN/site/02packages.details.txt
Description:  Package names found in directory $CPAN/authors/id/
Columns:      package name, version, path
Intended-For: Automated fetch routines, namespace documentation.
Line-Count:   $lines
Written-By:   $0 $VERSION Ulrich Pfeifer <pfeifer\@wait.de>
Last-Updated: $date GMT

EOH
  ;
for my $pack (sort keys %VERSION) {
  $fh->printf("%-30s\t%s\t%s\n", $pack,  $VERSION{$pack}, $PATH{$pack});
}

#
# part2: generating checksums
#

use Digest::MD5;
my $context = Digest::MD5->new;

find(\&chksum, "$CPAN/authors/id");

sub chksum {
  return unless -d $_;
  my $dpath = $_;
  opendir AD, "$dpath" or
    die "Could not read '$dpath': $!\n";

  my $chksum = new IO::File "> $dpath/CHECKSUMS"
    or die "Could not write '$dpath/CHECKSUMS': $!\n";
  my $found_one;
  $chksum->printf("# CHECKSUMS file written on %s $0 $VERSION \n\$cksum = {\n",
                  scalar localtime time);

  for my $file (grep /\.tar\.(gz|Z)$/, readdir AD) {
    my $path = "$dpath/$file";
    my $fh = new IO::File "<$path"
      or die "Reading $path: $!\n";
    $context->reset;
    $context->addfile($fh);
    my $size = -s $path;
    my $md5  = $context->hexdigest;
    $fh = new IO::File "gzip -cd $path|"
      or die "Reading $path: $!\n";
    $context->reset;
    $context->addfile($fh);
    my $md5_ungz = $context->hexdigest;
    $chksum->print("'$file' => {
  shortname  => '$file',
  size       => $size,
  md5        => '$md5',
  'md5-ungz' => '$md5_ungz',
},
");
    $found_one++;
  }
  closedir AD;
  $chksum->print("}\n");
  unlink "$dpath/CHECKSUMS" unless $found_one;
}
closedir DIR;

__END__

=head1 NAME

mkpackages -- generate CPAN.pm conformant 02packages.details.txt.gz

=head1 SYNOPSIS

B<mkpackages> I<pseudo_CPAN_root>

=head1 WARNING

This is not even alpha software and will be made obsolete by CPAN.pm
extensions some day.

=head1 DESCRIPTION

This programs traverses I<pseudo_CPAN_root>F</authors/id> and
generates I<pseudo_CPAN_root>F</site/02packages.details.txt.gz>.

It also will extract a README files from TAR balls in the
F</authors/id> directories.

=head1 FILES

=over

=item I<pseudo_CPAN_root>F</site/02packages.details.txt.gz>

=item I<pseudo_CPAN_root>F</site/01mailrc.txt.gz>

Generated as empty file if missing.

=item I<pseudo_CPAN_root>F</autors/id/**/CHECKSUMS>

F<CHECKSUMS> fiels are generated in al directories below
I<pseudo_CPAN_root>F</autors/id/>.

=back

=head1 SEE ALSO

CPAN::Site(3)

=head1 AUTHOR

Ulrich Pfeifer E<lt>F<pfeifer@wait.de>E<gt>

=cut
