Beefy Boxes and Bandwidth Generously Provided by pair Networks
Don't ask to ask, just ask
 
PerlMonks  

comment on

( #3333=superdoc: print w/replies, xml ) Need Help??
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.

In reply to Janitors Thread Retitler v2 by davido

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":



  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Titles consisting of a single word are discouraged, and in most cases are disallowed outright.
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.
  • Log In?
    Username:
    Password:

    What's my password?
    Create A New User
    Chatterbox?
    and the web crawler heard nothing...

    How do I use this? | Other CB clients
    Other Users?
    Others chanting in the Monastery: (4)
    As of 2021-01-24 19:11 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?
      Notices?