#!perl

=pod

=head1 NAME

submit-cpan-ratings - upload ratings to CPAN for stuff you've used

=head1 SYNOPSIS

B<submit-cpan-ratings> [OPTIONS] I<file1> .. I<directory1> ..

=head1 DESCRIPTION

B<submit-cpan-ratings> is a script which automates the process of
finding the modules you've used in your code and submitting module
reviews to L<http://ratings.cpan.org>. For example, to submit a review
of the modules you used in your source directory:

  % submit-cpan-ratings ~/src

You'll be told which modules were found, and what the versions are. As each
module is checked, L<http://search.cpan.org> and L<http://ratings.cpan.org>
will be used to find the proper module name and version.

If the module you used isn't on cpan under the name you called it or
if the version you're using isn't available for rating you won't be
able to submit a rating.

This uses the same .pause file that the L<cpan-upload> script uses for
you PAUSE credentials.

=head1 OPTIONS

=over 4

=item -user <string>

Your PAUSE or L<http://ratings.cpan.org> username.

=item -password <string>

The password for your username.

=item -non_interactive | -ni

submit-cpan-ratings should not prompt for any missing information (eg
password), it should just warn or die, as appropriate.

=item -help

Displays a short help message with the OPTIONS section from the
B<submit-cpan-ratings> documentation.

=item -doc

Display the full documentation for B<submit-cpan-ratings>.

=item -verbose

Turns on verbose information as the script runs.

=item -debug

Turns on debugging information. Useful mainly for the developer,
it displays the HTTP request and response.

=item -version

Display the version number of the B<cpan-upload> script.

=back

=head1 CONFIGURATION FILE

You can provide the configuration information needed via a .pause file
in your home directory.  If you rate modules at all regularly you will
want to set up one of these.

This is the same file as used by L<cpan-upload>.

=over 4

=item B<user> I<username>

This is used to specify your PAUSE username.
This just saves you from typing it every time you run the script.

=item B<password> I<password>

This is used to specify your PAUSE password.

=item B<non_interactive>

Specifies that cpan-upload should never prompt the user (eg for password),
but should take a default action.

=back

The following is a sample .pause file:

    # example .pause for user jjore
    # the user is your registered PAUSE or ratings.cpan.org username
    user JJORE
    password thisisnotmyrealpassword

    non_interactive

Note that your .pause must not be readable by others, since it can
contain your PAUSE password. The B<submit-cpan-ratings> script refuses
to run if your config file can be read by others.

=head1 POSSIBLE TODO ITEMS

Also, let me know if you ever have occasion to wish that the features below
had been implemented. I probably won't do them unless someone
would like to see them in.

I'd be happy to hear any more suggestions.

=over 4

=item *

Ignore modules that have already been rated at the same version by
this user. Maybe prompt the user if there is a rating under a previous
version.

=item *

Open $ENV{'EDITOR'} for getting the comments.

=back

=head1 SEE ALSO

=over 4

=item ratings.cpan.org

The home page for the ratings system of CPAN.

=item www.cpan.org

The home page for the Comprehensive Perl Archive Network.

=head1 SCRIPT CATEGORIES

CPAN

=head1 AUTHOR

Joshua b. Jore E<lt>jjore@cpan.orgE<gt>

=head1 COPYRIGHT

Copyright (c) 2004 Joshua b. Jore

This script is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

use strict;
use AppConfig::Std ();
use File::Spec     ();
use File::Find 'find';
use Memoize 'memoize';
use List::Util qw( max first );
use WWW::Mechanize ();
use Carp 'confess';
use vars qw( $VERSION $PROGRAM $CONFIG
  $PM_FILES_RX
  $MODULE_GUESSING_RX $SEARCH_CPAN_URL $WWW $SEARCH_CPAN $RATINGS_CPAN $RATINGS_CPAN_URL );

# require Term::ReadKey in initialize();

$VERSION            = '0.01';
$PM_FILES_RX        = qr/.\.pm$/i;
$MODULE_GUESSING_RX = qr/^\s*(?:use|require)\s+([A-Z][\w\:\']+)/m;
$SEARCH_CPAN_URL    = 'http://search.cpan.org';
$RATINGS_CPAN_URL   = 'http://ratings.cpan.org';

main(@ARGV);
exit 0;

sub main {
    $| = 1;

    initialize(@_);

    my @used_modules =
        grep $_->{'version'},
        map +{
            module  => $_,
            version => get_installed_module_version($_), },
        sort
        grep !!$_,
        map snap_to_fit_module_names($_),
        unique( map guess_at_module_names($_),
                find_pm_files(@_) );

    if ( not @used_modules ) {
        print "No modules were detected\n";
        return;
    }

    print "Modules used:\n"
      . join( "", map "   $_->{'module'}-$_->{'version'}\n", @used_modules )
      . "\n";

    for (@used_modules) {
        eval {
            rate_module($_);
            1;
        }
          or print $@;
    }

    return;
}

sub rate_module {
    my $module  = $_[0]{'module'};
    my $version = $_[0]{'version'};

    $RATINGS_CPAN->get($RATINGS_CPAN_URL);
    defined( $RATINGS_CPAN->follow_link( text_regex => qr/Search/i ) )
      or confess("Couldn't find the Search link on $RATINGS_CPAN_URL");

    $RATINGS_CPAN->set_visible($module);

    if ( not defined $RATINGS_CPAN->click ) {
        warn
"Didn't get a result back from searching for $module on $RATINGS_CPAN_URL.\n";
        return;
    }

    my $module_rx = $module;
    $module_rx =~ s/^\W+//;
    $module_rx =~ s/\W+$//;
    $module_rx =~ s/\W+/\\W+/g;

    if ( not defined
         $RATINGS_CPAN->follow_link( text_regex => qr/^$module_rx$/ ) ) {
        warn "$module_rx couldn't be found on $RATINGS_CPAN_URL.\n";
        return;
    }

    # I may have to log-in now.
    if ( first { $_->name =~ /Login/i }
         $RATINGS_CPAN->current_form->inputs ) {

        $RATINGS_CPAN->set_visible( $CONFIG->user, $CONFIG->password );
        defined( $RATINGS_CPAN->click )
          or confess("The login page on $RATINGS_CPAN_URL didn't work");

        # Check to see if the user was successfully authenticated. If not,
        # just bail noisily.
        if ( first { $_->name =~ /login/i }
            $RATINGS_CPAN->current_form->inputs )
        {
            warn "Couldn't authenticate to $RATINGS_CPAN_URL as "
              . $CONFIG->user . ".\n";
            exit;
        }
    }

    # Find the version select widget on the page and get some info from
    # it.
    my $version_widget = first { $_->name =~ /version/i }
                         $RATINGS_CPAN->current_form->inputs;
    my @available_versions = $version_widget->possible_values;
    my $version_field      = $version_widget->name;

    # Validate the version being used against the page.
    if ( not first { $version eq $_ } @available_versions ) {
        warn "$module-$version is not available for rating on $RATINGS_CPAN_URL.\n";
        return;
    }

    $RATINGS_CPAN->select( $version_field, $version );

    # Solicit a comment or return if nothing was provided.
    my $review;
    do {
        print
"Review $module-$version (enter two blank lines to finish your review):\n";

        $review = do {
            local $/ = "\n\n\n";
            <STDIN>;
        };
        $review =~ s/^\s+//;
        $review =~ s/\s+$//;

        return if not $review;
    } until ( answer_ok('Use this review?') );
    _debug( "Setting review to $review" );
    $RATINGS_CPAN->field( 'review', $review );

    # These are the radio buttons on the web page for rating modules.
    my @keys = ( 'Docmentation',
                 'Interface',
                 'Ease of Use',
                 'Overall' );
    # Use this value for some sprintf lengths.
    my $max_length = max( map length(), @keys );

    # Solicit a rating. Don't continue on until at least the Overall
    # rating has been filled in.
    my %rating;
    do {
        print "\nRate $module-$version\n";
        for my $key (@keys) {
            printf "  %-${max_length}s (1-5) ", $key;
            print "[$rating{$key}] " if $rating{$key};
            $rating{$key} = ( <STDIN> =~ /([1-5])/ )[0];
        }
      } until (
        do {
            print "\n  Ratings for $module-$version\n"
              . join( "",
                      map sprintf( "    %-${max_length}s: $rating{$_}\n",
                                   $_ ),
                      @keys )
              . "\n\n";

            $rating{'Overall'}
               and answer_ok('Use this rating?');
          }
      );

    for ( 1 .. 3 ) {
        _debug( "Setting rating_$_ to $rating{ $keys[ $_ - 1 ] }" );
        $RATINGS_CPAN->field( "rating_$_", $rating{ $keys[ $_ - 1 ] } )
    }

    _debug( "Setting rating_overall to $rating{ 'Overall' }" );
    $RATINGS_CPAN->field( "rating_overall", $rating{ 'Overall' } );

    return if not answer_ok( 'Upload your review/rating?' );

    print "Thank you! Now uploading your rating for $module-$version.\n";
    my $before = $RATINGS_CPAN->content;
    defined( $RATINGS_CPAN->click )
        or confess( "Couldn't submit rating" );

    if ( not $RATINGS_CPAN->content =~ /Thank you/i ) {
        print "Whoops! Something bad happened and the review wasn't submitted. Probably.\n";
        print $RATINGS_CPAN->content ne $before ? "It changed" : " It didn't change";
#       print $RATINGS_CPAN->content;
exit;
    }
}

sub answer_ok {
    print "$_[0] (Y/n) ";

    local $/ = "\n";
    my $answer = <STDIN>;
    $answer =~ s/^\s+//;
    $answer =~ s/\s+$//;
    $answer eq '' or $answer =~ /^y/i;
}

sub unique {
    my %h;
    grep !$h{$_}++, @_;
}

sub get_installed_module_version {
    my $module = shift;

    $module =~ s/\W+/::/g;

    if ( $^O =~ /win32/i ) {
        return `$^X -M$module -e "eval { require $module and print $module->VERSION }"`;
    } else {
        my $sleep_count = 0;
        my $pid;
        my $kid;
        do {
            $pid = open $kid, "-|";
            unless ( defined $pid ) {
                warn "Cannot fork: $!";
                die "bailing out" if $sleep_count++ > 6;
                sleep 10;
            }
        } until defined $pid;

        if ( $pid ) { # parent
            return scalar <$kid>;
        } else {
            exit
                eval {
                    eval "require $module"
                    and
                    print $module->VERSION;
                }
                ? 0
                : 1;
        }
    }
}

sub snap_to_fit_module_names {
    my $maybe_module = shift;

    # Don't -> Don::t
    $maybe_module =~ s/\'/::/g;
    return unless length $maybe_module;

    $SEARCH_CPAN->set_visible($maybe_module);
    $SEARCH_CPAN->click;

    my $module = (
        sort { length($a) <=> length($b) }
          map $_->text =~ /^((?:[a-z]\w+(?:::|\'|-)?)+)/i,
        $SEARCH_CPAN->find_all_links( text_regex => qr/\Q$maybe_module/ )
    )[0];

    $module =~ s/\W+$//;
    $module;
}
BEGIN { memoize('snap_to_fit_module_names') }

sub guess_at_module_names {
    my $pm_file = shift;

    local *FH;
    local $/;

    open FH, "< $pm_file\0" or die "Can't open $pm_file: $!";
    <FH> =~ /$MODULE_GUESSING_RX/g;
}

sub find_pm_files {
    my @found = grep -f, @_;

    my @dirs = grep !-f, @_;
    if (@dirs) {
        find(
            sub {
                return unless -f and -r and $_ =~ $PM_FILES_RX;
                push @found, $File::Find::name;
                1;
            },
            @dirs
        );
    }

    @found;
}

sub initialize {

    # Turn off buffering on STDOUT
    $| = 1;
    ( $PROGRAM = $0 ) =~ s!^.*/!!;

    # Create an AppConfig::Std object, and define our interface
    # The EXPAND flag on password tells AppConfig not to try and
    # expand any embedded variables - eg if you have a $ sign
    # in your password.
    my $home = $ENV{'HOME'}
      || ( getpwuid $< )[7];

    my $config_file = File::Spec->catfile( $home, ".pause" );
    if ( -e $config_file && ( ( stat($config_file) )[2] & 0043 ) != 0 ) {
        die "$PROGRAM: your config file $config_file is readable by others!\n";
    }

    $CONFIG = AppConfig::Std->new( { CREATE => 1 } );
    $CONFIG->define('user');
    $CONFIG->define( 'password',        { EXPAND => 0 } );
    $CONFIG->define( 'non_interactive', { ALIAS  => 'ni', ARGCOUNT => 0 } );

    # Read the user's config file, if they have one,
    # then parse the command-line.
    if ( -f $config_file ) {
        $CONFIG->file($config_file) or exit 1;
    }
    $CONFIG->args( \@_ )
      or die "run \"$PROGRAM -help\" to see valid options\n";

    # Check we have the information we need
    die "No files specified for examination\n" unless @_;

    die "No ratings.cpan.org user specified\n" unless $CONFIG->user;
    if ( not $CONFIG->password ) {
        if ( $CONFIG->non_interactive ) {
            die "No password specified\n";
        }
        else {
            require Term::ReadKey;
            $| = 1;
            print "Password: ";
            Term::ReadKey::ReadMode('noecho');
            chop( my $password = <STDIN> );
            Term::ReadKey::ReadMode('restore');
            $CONFIG->set( 'password' => $password );
            print "\n";
        }
    }

    $CONFIG->verbose(1) if $CONFIG->debug && !$CONFIG->verbose;

    $SEARCH_CPAN = WWW::Mechanize->new( agent => "$0/$VERSION" );
    $SEARCH_CPAN->get($SEARCH_CPAN_URL);

    $RATINGS_CPAN = WWW::Mechanize->new( agent => "$0/$VERSION" );;
    $RATINGS_CPAN->get($RATINGS_CPAN_URL);

    # Display banner at the start of the run
    _verbose("$PROGRAM v$VERSION\n");
}

BEGIN {
    for my $sub ( qw( debug verbose ) ) {
        no strict 'refs';
        *{"_$sub"} = sub {
            # Displays the message strings passed if in $sub mode.
            
            return unless $CONFIG->$sub;
            print join( '', @_ ) . "\n";
        };
    }
}