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.