perlhist.pl

#!/usr/bin/env perl 
#===============================================================================
#
#         FILE:  perlhist.pl
#
#        USAGE:  ./perlhist.pl  
#
#  DESCRIPTION:  
#
#      OPTIONS:  ---
# REQUIREMENTS:  ---
#         BUGS:  ---
#        NOTES:  ---
#       AUTHOR:  Yongbin Yu (yyb), [email protected]
#      COMPANY:  
#      VERSION:  1.0
#      CREATED:  06/20/2010 22:59:47
#     REVISION:  ---
#===============================================================================

use utf8;
use 5.010;

use strict;
use warnings;

use File::Basename;
use File::Which qw(which);
use File::Spec::Functions;
use Data::Dumper;
my %Months = qw(
    Jan 1
    Feb 2
    Mar 3 
    Apr 4
    May 5
    Jun 6
    Jul 7
    Aug 8
    Sep 9
    Oct 10
    Nov 11
    Dec 12
    );

my $perldoc = find_perldoc();

open my ( $doc ), "$perldoc -m perlhist |" or die;
1 until( <$doc> =~ /=head1 THE RECORDS/ );
1 until( <$doc> =~ /=====================/ );

my $previous_maintainer;

until( (my $line = <$doc>) =~ /=head2 SELECTED RELEASE SIZES/ )  
    {
    next if $line =~ /^\s+$/;
    my( $maintainer, $version, $date) = unpack( 'A9 A14 A12', $line );
    next unless $version;

    $maintainer =~ s/^\s+|\s+$//;
    $maintainer ||= $previous_maintainer;
    $previous_maintainer = $maintainer;

    $version =~ s/^\s*|\s*$//g;
    $date =~ s/^\s*|\s*$//g;

    my($year,$month,$day) = split /-/,$date;
    next if $month eq '???' || $day eq '??';
    warn "Month is undefined; $line\n" unless defined $month;

    $month = $Months{$month};

    say join "\t", $maintainer, $version, sprintf( "%4d%02d%02d",$year,$month,$day);
    }


sub find_perldoc 
    {
    # need to find the right perldoc for the perl we are running
    my $dirname = dirname $^X; $dirname = '' if $dirname eq '.';
    my $basename = basename $^X;

    my $perldoc = catfile($dirname ? $dirname : (),'perldoc');
    say "perldoc is $perldoc";

    print "x: [$^X] d: [$dirname] b: [$basename] \n";

    my $path = which($perldoc);
    print "$path\n";

    die "$path is not executable\n" unless -x $path;

    return $path;
    }