Beefy Boxes and Bandwidth Generously Provided by pair Networks
Just another Perl shrine
 
PerlMonks  

Janitors Thread Retitler v2

by davido (Cardinal)
on Dec 14, 2004 at 09:02 UTC ( [id://414646]=sourcecode: print w/replies, xml ) Need Help??
Category: PerlMonks Related Scripts
Author/Contact Info davido
Description:

This script has been replaced by Janitors Thread Retitler v3.1.

This script is for use by Janitors. It won't work for you if you're not a Janitor (unless you're a janitor you don't need it).

This is an improved version of Janitors Thread Retitler v1. I have made the following changes and improvements by popular request. I believe I've implemented just about all of the suggestions. Hopefully this will make the script more usable.

  • Added a -from command line arg. This arg. is optional. If supplied, it allows you to specify on the command line the original node title. This will bypass the runtime "are you sure?" query, allowing the script to run without interaction.
  • Added a sanity check for empty node ID lists.
  • Changed the submit click method to expand compatibility to older versions of WWW::Mechanize.
  • Removed requirement for WWW::Mechanize 0.74 or newer.
  • Added logic to allow subthreads as base targets.
  • Improved command line argument names, and allowed abbreviations.
  • Added janitor edit attribution in base node. This can be customized or squelched.
  • Added help/usage/POD/manpage (aided by Pod::Usage).
  • Updated: Added ENV settings for user/passwd, per Corion's suggestion.

Please run the script with the -help option to learn about the improvements to its user interface. Also, please run it once in -debug mode to test it before firing it off live for the first time.

Note that even though its flexibility has been greatly expanded, it may still be used exactly as the original version if you prefer to not learn its new features.

I believe at this point I've addressed the bulk of the suggestions / needs discussed in the thread for the original Janitors Thread Retitler v1. But I'm still open for suggestions on how this might be made more useful.

Update:

Still working on...:
  • Implement .ini profile for default janitor attribution text.
  • Add -u switch (-unconsider) to automate unconsidering base node.
  • Implement tye's regexp approach for title text substitution.
  • Allow user/passwd to be read from .ini file if not found in %ENV.
  • Implement multiple janitor attribution texts, to be selected by keyword from command line arg. Ex: -attr "old" would pull in the text associated with the keyword 'old' in the INI file. ...this may or may not ever get done. ;)
  • Patches welcome!!!

use strict;
use warnings;

use Getopt::Long;
use Pod::Usage;

use WWW::Mechanize;
use XML::Simple;

my $site = "http://www.perlmonks.org/";

# env vars must contain username and password.
my( $user, $passwd ) = ( $ENV{PMUSER}, $ENV{PMPASS} );

our $DEBUG = 0;

my( $target, $new_title, $from, $attribution, $help, $man );

GetOptions( 'id|i=i'          => \$target, 
            'to|title|t=s'          => \$new_title,
            'from|f=s'        => \$from,
            'attrib|attr|a:s' => \$attribution,
            'help|h|man|m|?'  => \$help,
            'debug|d'         => \$DEBUG );

# $DEBUG = 1; # Force debug mode.

if( $help ) {
    pod2usage( -exitstatus => 0, -verbose => 2 );
    exit;
}

unless( defined( $target ) 
        and defined( $new_title )
        and ( $target =~ m/\d+/ ) 
        and ( length( $new_title ) > 3 ) 
    ) {
        die   "Usage: retitle -id nnnnnn -to \"New title...\""
            . " [-from \"Old title...\"] [-debug].\n"; 
}

if ( defined $attribution ) {
    if ( length( $attribution ) == 0 ) {
        # -attrib used on command line without text.
        # Do not attribute edit.
        $attribution = '';
    } else {
        # -attrib used on command line with text.
        # Massage the supplied text.
        $attribution = "\n<p><small>Retitled by [$user]: "
                     . "$attribution</small></p>\n";
    }
} else {
    # -attrib not used on the command line.
    # Use default attribution.
    $attribution = "\n<p><small>Retitled by [$user].</small></p>\n";
}

my $login = "op=login;user=$user;passwd=$passwd;expires=+10y;";

my $agent = WWW::Mechanize->new( 'autocheck' => 1 );

$agent->env_proxy();

my @node_ids = sort { $a <=> $b } 
    get_node_ids( $target, $login, $agent );

die "Zero nodes found.\n" unless @node_ids;

sleep 2;

my $old_title = get_root_title( $node_ids[0], $agent );

if ( defined( $from ) ) {
    unless ( $from eq $old_title ) {
        die "Title mismatch:\n\tLooked for => '$from'.\n"
          . "\tFound => '$old_title'.\n";
    }
} else {
    print "Original Title: '$old_title'. Continue? (y/n):\n";
    my $ok = <STDIN>;
    die "Stopped.\n" unless $ok =~ m/^y/i;
}

$old_title =~ s/^Re(?:\^\d+)?:\s*//;  # Facilitate following 
                                      # subthreads as base targets.

foreach my $id ( @node_ids ) {
    sleep 2;
    edit_node( $id, $agent, $old_title, $new_title, $attribution );
    $attribution = ''; # Only give attribution in root node.
}



sub get_node_ids {
    my( $target, $login, $agent ) = @_;
    print "Fetching thread node ID's for id = $target.\n";
    $agent->get(  
          $site . '?'
        . $login
        . "node_id=180684;id=$target"
    );

    $agent->success() 
        or die "Unable to fetch thread for id = $target.\n";
    
    my $xmlref = XMLin( $agent->content(), 
                        ForceArray => 1, 
                        KeepRoot => 1 );
    my @node_ids = traverse( $xmlref );
    print "\tFetched " 
        . scalar( @node_ids ) 
        . " node IDs.\n\n";
    return @node_ids;
}

sub traverse {
    my @nodes;
    foreach my $key ( keys %{$_[0]} ) {
        if ( ref( $_[0]->{$key} ) ) {
            push @nodes, traverse( $_[0]->{$key} );
        }
        if ( $key =~ m/^\d+$/ ) {
            push @nodes, $key;
        }
    }
    return @nodes;
}

sub get_root_title {
    my( $target, $agent ) = @_;
    print "Fetching title for id = $target.\n";
    $agent->get(
          "$site?displaytype=xml;node_id="
        . $target
    );
    $agent->success()
        or die "Unable to fetch title for id = $target.\n";
    my $xmlref = XMLin( $agent->content(), 
                        ForceArray => 1, 
                        KeepRoot => 1 );
    print   "\tTitle: ", 
            $xmlref->{'node'}{$target}{'title'}, 
            "\n\n";
    return $xmlref->{'node'}{$target}{'title'};
}

sub edit_node {
    my( $target, $agent, $from, $to, $attrib ) = @_;
    $agent->get(
          "$site?displaytype=editors;node_id="
        . $target
    );
    $agent->success()
        or die "Unable to fetch editors form for id://$target.\n";
    my $form = $agent->form_name('edit_node');
    unless ( $form ) { 
        die "Couldn't find 'edit_node'.\n"; 
    };
    my $old_title = $form->value( 'update_title', 1 );
    if ( $old_title !~ m/^(?:Re(?:\^\d+)?:\s*)*\Q$from\E$/i ) {
        print "$old_title doesn't match $from. Skipping node.\n";
        return;
    }
    my $new_title = $old_title;
    $new_title =~ 
        s/^(Re(?:\^\d+)?:\s*)*\Q$from\E$/(defined($1)?$1:'').$to/ie;
    print   "Retitling ($target):\n\t'$old_title' =>\n"
          . "\t'$new_title'.\n\n";
    $agent->field( 'update_title', $new_title );
    my $doctext = $form->value( 'update_doctext', 1 );
    $doctext = $doctext . $attrib;
    $agent->field( 'update_doctext', $doctext );
    unless( $DEBUG ) {
        # Stolen from Corion's version at castaway's suggestion:
        $agent->current_form->value( 'blah', 'update' );
        $agent->click( 'blah' );
        # davido's original:
        # $agent->click_button( 'value' => 'update' );
        $agent->success() or
            die "Couldn't edit $old_title.\n";
    }
}

__END__

=head1 NAME
retitle.pl
Bulk Thread Retitler

=head1 SYNOPSIS
retitle -id nnnnnn [-from "Orig title"] -to "New title"
        [-attrib "Attribution text"] [-help] [-debug]

=head1 OPTIONS

=over 8
=item B<-help>
Print this help message and exit.

=item B<-id nnnnn>
Target node ID.  (Required arg.)

=item B<-from "Orig title">
Original title to match.  If supplied, script runs without prompting.
Without this arg, script runs in interactive (prompt) mode.

=item B<-to "New title">
New title.  (Required arg.)

=item B<-attrib ["Attribution text"]>
Supply -attrib without text to cancel editor attribution.
Supply -attrib with text to specify additional info after editor
attribution.
If -attrib is not specified on the command line, a default
attribution is used.

=item B<-i -f -t -h -? -a -attr>
All legal abbreviations of command line options.

=head1 DESCRIPTION

B<Bulk Thread Retitler> will follow a target thread (or target 
subthread) retitling its nodes.  Janitor attribution will be 
appended on the base node (optionally this can be squelched).
If a -from title isn't supplied, the script will fetch original 
title from the target ID and prompt for the go-ahead to continue.
Otherwise, the script runs without further interaction.

It is neccessary to set ENV variables PMUSER and PMPASS.

Log In?
Username:
Password:

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

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

    No recent polls found