#!/usr/local/bin/dperl
# -w

use strict;
use File::Find;
use Getopt::Std;
use diagnostics;
use Data::Dumper;

$Data::Dumper::Indent = 1;
$Data::Dumper::Sortkeys = 1;    # sub { shift <=> shift };

my %diags;      # pairsof( =item(.*) => linenum) by scanning perldiag.
+pod
my %stmts;      # source statement calls to Perl_croak(*) or Perl_warn
+er(*)
my ($ct_croak, $ct_diag);

# controls extraction of info when already doc'd in perldiag
our ($opt_p, $opt_s, $opt_e, $opt_u, $opt_d, $opt_r, $opt_x);

sub usage {
    die<<EOH;
  usage: $0 [options] # scans perl source, finds diagnostics
      -p : dump perldiags
      -s : dump source statements which match to diagnostics
      -e : output existing diagnostics too
      -u : print unmatched croaks
      -d : dump info about the source of the diagnostics
      -r <pat>: only report stuff matching regex (ex: Win, POSIX)
      -x : print items dropped in match()
EOH
}


main: { # i just like the indent.
    #$, = "\n";

    getopts('pseudr:x') or usage;
    $ct_croak = $ct_diag = 0;
    # check pod
    open(my $fh, "./pod/perldiag.pod")
        or die "bad open on perldiag\n";

    my $lnum = -1;
    while (my $line = <$fh>) {
        $lnum++;
        chomp $line;
        # print "$line\n";
        if ($line =~ m/^=item (.*)$/) {
            $diags{$1} = $lnum;
        }
    }
    $ct_diag = keys %diags;
    print "found $ct_diag diagnostic msgs defined in perldiag.pod\n";
    print "diags from perldiag.pod", Dumper {reverse %diags}  if $opt_
+p;

    find({ wanted => \&lookin, no_chdir => 1}, '.');

    print "found $ct_croak croaks in code\n";

    if ($opt_s) {
        my (@found, %useddiags);
        foreach my $diag (keys %diags) {
            push my @new, grep /\Q$diag\E/, keys %stmts;
            if (@new) {
                push @found, @new;
                $useddiags{$diag} = \@new;
            }
        }
        print "\ndiags-which-matched ", Dumper(\%useddiags);
        # print sort @found;

        #delete @stmts{@found};
        #print "\n\ncroaks w/o diag match\n", sort keys %stmts;
    }

    my %crks = %stmts;
    delete @crks{keys %diags};

    if ($opt_u) {
        print "croaks unmatched by diag\n";
        print Dumper([sort keys %crks]);
    }
    print "croaks unmatched by diags: ", scalar keys %stmts, "\n";
    print "croaks unmatched by diags: ", scalar keys %crks, "\n";
    #print "total matched: ", scalar keys %crks, "\n";

    print "OK now do a SWAG\n";

    # want hash, w the Perl_croak statement's fmt string as key, and
    # val is hash, w whole statement as key, and an array of "$file:
    # $line" items

    my %items;
    my @itempairs = map { (/.*?\"(.*)\".*/) ? ($1,$_) : ()
                          } sort keys %stmts;

    while (my $fmt = shift @itempairs) {
        my $statement = shift @itempairs;
        # store what we know about the croak
        push @{$items{$fmt}}, {$statement => $stmts{$statement}};
    }

    if ($opt_r) {
        foreach (keys %items) {
            delete $items{$_} unless $_ =~ /$opt_r/o;
        }
    }
    if ($opt_d) {
        foreach (sort keys %items) {
            print "=item $_\n\n  " . Dumper ($items{$_}) . "\n";
        }
    }
    # match(\%items);
    markup_perldiag(\%items);
    print "done\n";
}

sub match {
    my ($items) = @_;
    my %dropped;
    foreach my $k (keys %$items) {
        $dropped{$k} = delete $items->{$k} if &diagnostics::transmo($i
+tems->{k});
    }
    #print Dumper $items;
    print Dumper \%dropped if $opt_x;
    print "after crosscheck, have ", scalar keys %$items, " items \n";
}

sub lookin {
    # File::Find callback
    # print "looking in $_\n";
    return unless -f $_;
    return unless /[chml]$/;
    open(my $fh, $_)
        or die "bad open on $_\n";

    # slurp so match works across newlines
    local $/ = undef;
    my ($fullbuf, $buf);
    $fullbuf = $buf = <$fh>;

    my $atline; # approx point of match
    while ($buf =~ m/(Perl_(croak|warn)\w*\s*\(.*?\).*?;)/smg) {

        # save match b4 finding line
        my $match = $1;

        # find line where call is made
        my ($where) = pos($buf) || 'unknown line';
        my $sofar = $`;
        $atline = scalar (my @newlines = ($sofar =~ m/(\n)/sg));
        $atline++;

        $ct_croak++;

        # clean up match
        chomp $match;
        #print "in $_: <$match>\n";
        $match =~ s/^aTHX_\s*//;
        $match =~ s/\s+/ /smg;

        # copy before doing 2 different things with value
        my $matchitem = $match;

        # strip out all but double quoted 'fmt' string
        # this needs rework to handle concats
        $match =~ s/^ \"//;
        $match =~ s/ \"\s*$//;

        # do positive match to find concatenations
        # - commas either side delimit
        $matchitem =~ s/^.*?(\w* \s? ".*?" \s? \w*).*?$/$1/x;

        # try to store some useful info about where match occurred
        push @{$stmts{$match}}, "$_: $atline";
        #push @{$croakargs{$match}}, $matchitem;
    }
    return;

    # way slow ($`), doesnt work like i hoped
    foreach my $match (keys %stmts) {
        # now find line-number.
        # start with original buffer, and search for specific match
        # just found above, then count newlines in the pre-match
        $fullbuf = /\Q$match/ms;
        my $pre = $`;
        my @lines = $pre =~ m/(\n)/msg;

        push @{$stmts{$match}}, "$_:" . scalar @lines;
    }
}

# get the sortable key for an item
sub get_item_key {
  my($item) = @_;

  # remove POD formatting
  $item =~ s/[A-Z]<(.*?)>/$1/g;

  # remove printf-style escapes
  # note: be careful not to remove things like %hash
  $item =~ s/%(?:[scg]|lx|#o)//g;

  # remove all non-letter characters
  $item =~ tr/A-Za-z//cd;

  return lc $item;
}

sub markup_perldiag {
    my ($items) = @_;
    my $fh; # re-used several times, relies on tacit close b4 reopen

    open($fh, "./pod/perldiag.pod")
        or die "bad open on perldiag\n";

    local $/ = undef;
    my $buf = <$fh>;    # slurp it

    # pull all existing items into
    my ($header, %existing_items) = split (/^(?:=item (.*?)\n)/sm, $bu
+f);

    # store items with new key thats stripped of all \W
    # this matches sort-order as doc'd in $header text

    # but play games to prevent items that differ only by \W
    # from collapsing into 1 hash element
    foreach my $k (sort keys %existing_items) {
        my $alpha = get_item_key($k);
        $alpha++ if exists $existing_items{$alpha};
        $existing_items{$alpha} = [ "=item $k\n", delete $existing_ite
+ms{$k} ];
    }

    my %newitems;
    foreach my $k (keys %$items) {
        my $alpha = get_item_key($k);
        if (0) {
            $alpha =~ s/%\w+//g;
            $alpha =~ s/\W//g;
        }
        my $label = $k;
        $label =~ s/\\n/ /g;
        $label =~ s/\\"//g;     #" balance quote for emacs
        $label =~ s/\\\\//g;
        $newitems{$alpha} = [ "=item $label\n", $items->{$k}[0] ];
    }

    my %h = (%existing_items, %newitems);

    open($fh, "> ./pod/perldiag.pod.new")
        or die "bad open on perldiag\n";

    open(my $fhd, "> ./pod/perldiag.pod.dump")
        or die "bad open on perldiag\n";

    print $fh $header;
    foreach (sort keys %h) {
        # print original entry 1st;
        print $fh "$h{$_}->[0]";
        print $fhd "$h{$_}->[0]";

        if (exists $existing_items{$_}) {
            print $fh "$existing_items{$_}->[1]";
            print $fhd "$existing_items{$_}->[1]";
        }
        if (exists $newitems{$_}
            and (not exists $existing_items{$_} or $opt_e))
        {
            my ($str,$dump) = extract_msg($_, $newitems{$_});
            print $fh $str;
            print $fhd $str,$dump;
        }
    }
    return;
}

sub extract_msg {
    # given:
    # 1: an item-name (reduced for sorting)
    # 2: [ item-name (not reduced), { source-statement, [ @line-number
+s] }
    # returns: a warning-cat-string (for incl into perldiag.pod), a du
+mp-string
    my ($k, $v) = @_;

    my $item = $v->[0];
    my ($call) = keys %{ $v->[1] };
    my ($str,$dump);

    if ($call =~ /packWARN\(WARN_(\w+)\)/) {
        my $type = lc $1;
        $str = "\n(W $type).";
    }
    elsif ($call =~ /packWARN2\(WARN_(\w+),\s*WARN_(\w+)\)/) {
        my $type = lc $1;
        my $type2 = lc $2;
        $str = "\n(W $type, $type2).";
    }
    elsif ($call =~ /Perl_warn/) {
        $str = "\n(W).";
    }
    elsif ($call =~ /Perl_croak/) {
        $str = "\n(F).";
    }
    $dump = Data::Dumper->Dump ([$v->[1]], ['in-code-at']) . "\n";

    if ($opt_r) {
        chomp $item;
        $item =~ s|::|/|; # only once
        $item =~ s/\(.*\)//;
        $item =~ s/=item usage: //; # yeah, not very general !
        chomp $item;
        $str .= " See L<$item> for information, proper use.";
    }
    $str .= "\n\n";
    return ($str,$dump);
}

__END__



    # this doesnt produce anything useful
    if (0) {

    # do set differences
    %dgs = %diags;
    %crks = %stmts;


        my (@founddiags, @foundcroaks);
        @founddiags = grep defined $_, delete @dgs{keys %stmts};
        @foundcroaks = grep defined $_, delete @crks{keys %diags};

        print "\n\nunmatched diagnostics:\n", sort keys %dgs;
        print "\n\nunmatched croaks:\n", sort keys %crks;

        %diffs = (%dgs, %crks);

        foreach $k (sort keys %diffs) {
            # print "in $diffs{$k}: $k\n";
        }

        print "\n\nmatched diagnostics:\n", sort @founddiags;
        print "\n\nmatched diagnostics:\n", Dumper (\@founddiags);
        print "\n\nmatched croaks:\n", sort @foundcroaks;
        print "\n\nmatched croaks:\n", Dumper(\@foundcroaks);
    }
[download]