http://qs321.pair.com?node_id=411280
Category: PerlMonks Related Scripts
Author/Contact Info davido
Description:

There is a newer version of this code posted at Janitors Thread Retitler v2. Both of these have been replaced by Janitors Thread Retitler v3.1.

This is a new retitler for the Janitors to use in retitling entire threads. It won't work if you're not a janitor, as it requires an edit page only available to the Monastery's cleanup crew. If you're a Janitor, and are tired of manually retitling nodes one by one, and would like an alternative to Janitors' Tools - Bulk node retitler, read on.

Usage is:

retitle -id NNNNNN -title "New Title Here" [-debug]

To configure for your system you just need to configure the script with your username and password, on or around line 13 and 14, $user and $passwd.

It works by fetching the XML Node Thread ticker for the thread specified by the command-line arg "-id NNNNNN". It walks the thread's XML footprint picking each node ID along the way. It then grabs the original title of the root node, and asks for confirmation before proceeding.

Finally, it uses the editor's view to update the titles for each node id. It leaves "Re:" and "Re^N:" alone, and skips any node whos title is different from the root node's title. That way if someone has intentionally used a different title in a followup it will leave that alone.

In debug mode, this script simply skips the final step where it normally would submit the change.

It requires WWW::Mechanize version 0.74 or newer. The version currently available on ActiveState PPM is 0.72, so if you're an ActiveState user you'll have to upgrade WWW::Mechanize through some other means. The most recent version is 1.05, but anything from 0.74 on is fine.

This was my first dive into using WWW::Mechanize to fill in forms, and it was an educational experience. I'm aware that a similar tool already exists, but I wanted to work through it myself for the practice. My tool uses the XML ticker, which may be less fragile than Corion's bulk-node retitler (no offense to Corion; it was he who pointed out this fact, and the XML ticker wasn't available when he wrote his retitler).

Since it's a learning experience, I welcome any comments or suggestions for improvement.

Janitors, enjoy!

Updated to expand usefulness to older style "Re: Re:" titles too.

use strict;
use warnings;

use Getopt::Long;

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

# Use your own username and password here.
my $site = "http://www.perlmonks.org/";
my $user   = 'someuser';
my $passwd = 'somepassword';
# ----------------------------------------

our $DEBUG = 0;

my( $target, $new_title );

GetOptions( 'id=i'    => \$target, 
            'title=s' => \$new_title,
            'debug'   => \$DEBUG );
            
unless( defined( $target ) 
        and defined( $new_title )
        and ( $target =~ m/\d+/ ) 
        and ( length( $new_title ) > 3 ) 
    ) {
        die   "Usage: retitle -id nnnnnn -title \"New title...\""
            . " [-debug].\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 );

sleep 2;

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

print "Original Title: '$old_title'. Continue? (y/n):\n";
my $ok = <STDIN>;
die "Stopped.\n" unless $ok =~ m/^y/i;

foreach my $id ( @node_ids ) {
    sleep 2;
    edit_title( $id, $agent, $old_title, $new_title );
}



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_title {
    my( $target, $agent, $from, $to ) = @_;
    $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 );
    unless( $DEBUG ) {
        $agent->click_button( 'value' => 'update' );
        $agent->success() or
            die "Couldn't edit $old_title.\n";
    }
}