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
Retitled by [$user]: "
. "$attribution
\n";
}
} else {
# -attrib not used on the command line.
# Use default attribution.
$attribution = "\nRetitled by [$user].
\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 = ;
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 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.