Beefy Boxes and Bandwidth Generously Provided by pair Networks
P is for Practical
 
PerlMonks  

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

by diotalevi (Canon)
on Aug 20, 2004 at 17:09 UTC ( [id://384652]=sourcecode: print w/replies, xml ) Need Help??
Category: Utility scripts
Author/Contact Info
Description:

I am posting this script here to perhaps gather any feedback about the implementation or design before I submit this to CPAN.


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 http://ratings.cpan.org. For example, to submit a review of the modules you used in your source directory:

$ submit-cpan-ratings ~/src/a_script ~/src/a_directory ~/whatever

You'll be told which modules were found, and what the versions are. As each module is checked, http://search.cpan.org and 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.

#!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 passwo
+rd),
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_mod
+ules )
      . "\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 fro
+m
    # 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 su
+bmitted. 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 $mo
+dule->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 ot
+hers!\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";
        };
    }
}
Replies are listed 'Best First'.
Re: submit-cpan-ratings - upload ratings to CPAN for stuff you've used
by stvn (Monsignor) on Aug 20, 2004 at 18:45 UTC
Re: submit-cpan-ratings - upload ratings to CPAN for stuff you've used
by belg4mit (Prior) on Aug 23, 2004 at 21:26 UTC
    The idea's nice, but I don't see why I should have to install a slough of stuff to use it. Also, it seems as though it does not use SSL to authenticate, or offer the option, tsk tsk? Finally, reading the description (as opposed to the POD) I'd figured it was going to handle modules in site_perl.

    --
    I'm not belgian but I play one on TV.

      http://ratings.cpan.org doesn't use SSL so neither do I.

      Most of the stuff in this module are already core in perl5. The additions are AppConfig::Std which makes being a perl-script with embedded documentation exceedingly nice (and configuration, etc). It also lets me piggy-back on cpan-upload's .pause file which makes the entire process even easier. I also avoided reams of plumbing work dealing with HTML parsing and the like by using WWW::Mechanize. I'm not sure what additional modules you thought were excessive but getting those two in makes it Just Right.

      I have no idea what in the POD would lead you to think I was going to examine site_perl.

        No, I said the description implies reading site_perl; which seems like a good feature to add since it's not there; the POD then clarifies that this not the case.

        --
        I'm not belgian but I play one on TV.

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: sourcecode [id://384652]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others perusing the Monastery: (6)
As of 2024-03-28 08:18 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found