sourcecode
ar0n
<code>
#!/usr/bin/perl -w
use strict;
use Term::ReadPassword;
use HTTP::Request::Common 'POST';
use HTTP::Cookies;
use LWP::UserAgent;
use HTML::TokeParser;
use Getopt::Long;
use constant TINYNODE => 16046;
use constant PM => 'http://www.perlmonks.org/index.pl';
$| = 1;
{
my ($ua, $req);
my ($homenode, $username, $password, $file);
my ($realname, $email, $image, $location);
my ($verbose, $significant);
my ($setpublic, $scratchfile, $scratchpad);
GetOptions(
"username=s" => \$username,
"password=s" => \$password,
"name=s" => \$realname,
"email=s" => \$email,
"image=s" => \$image,
"location=s" => \$location,
"homenode=s" => \$file,
"contentofpad=s"=> \$scratchfile,
"makepublic" => \$setpublic,
"significant" => \$significant,
"verbose" => \$verbose
);
unless ( defined $username ) {
$username = "";
until ( $username =~ /\S/ ) {
print "Username: ";
chomp($username = <STDIN>);
}
}
unless ( defined $password ) {
$password = "";
until ( $password =~ /\S/ ) {
$password = read_password("Password: ")
}
}
die usage()
unless $username && $password;;
die "Can't find $file\n"
if defined $file and not -f $file;
$homenode = join "", do { local @ARGV = $file; <> } if defined $file;
die "Can't find $scratchfile\n"
if defined $scratchfile and not -f $scratchfile;
$scratchpad = join "", do { local @ARGV = $scratchfile; <> } if defined $scratchfile;
die "Can't find image $image\n"
if defined $image and not -f $image;
$ua = new LWP::UserAgent( agent => "Homenode Updater" );
$ua->cookie_jar( HTTP::Cookies->new() );
print "Logging in... "
if $verbose;
die "Couldn't log in. Is your username/password right?\n"
unless $ua->request(
POST PM, [
node_id => TINYNODE,
op => 'login',
user => $username,
passwd => $password
]
)->as_string() =~ /userpass/;
print "done.\n"
if $verbose;
print "Fetching... "
if $verbose;
my $html = $ua->request(
POST PM, [
displaytype => "edit",
node => $username
]
)->content();
print "done.\n"
if $verbose;
print "Parsing... "
if $verbose;
my %default = parse($html);
print "done.\n"
if $verbose;
print "Updating... "
if $verbose;
my $content = [
displaytype => "edit",
node => $username,
user_realname => $realname || $default{user_realname} || "",
user_passwd1 => $password,
user_passwd2 => $password,
user_email => $email || $default{user_email} || "",
user_doctext => (defined $homenode ? $homenode : $default{user_doctext}) || "",
user_scratchpad => (defined $scratchpad ? $scratchpad : $default{user_scratchpad}) || "",
setscratchpublic => ($setpublic ? "on" : $default{setscratchpublic}) || "",
setsetting_location => $location || $default{setsetting_location} || "",
significantupdate => $significant ? "on" : "",
sexisgood => "stumbit"
];
push @$content, imgsrc_file => [$image]
if defined $image;
$ua->request(
POST PM,
Content_Type => 'form-data',
Content => $content
);
print "done.\n"
if $verbose;
}
sub usage
{
return <<"EOT";
Usage: $0 -u username -p password [ options ]
Options:
-i <file> Home node picture
-h <file> File containing home node contents
-c <file> File containing scratchpad contents
-m Make scratchpad public
-n <string> Your real name
-e <string> Your email address
-l <string> Your location
-s Significant update
-v Be a little verbose
EOT
}
sub parse
{
my $html = shift;
my %default;
my @params = qw( user_realname user_email user_passwd1 user_passwd2 setsetting_location );
my $p = new HTML::TokeParser ( \$html );
while ( my $token = $p->get_tag("textarea") ) {
$default{user_doctext} = $p->get_text if $token->[1]{name} eq "user_doctext";
$default{user_scratchpad} = $p->get_text if $token->[1]{name} eq "user_scratchpad";
}
while ( my $token = $p->get_tag("input") ) {
next unless exists $token->[1]{name};
$default{ $token->[1]{name} } = $token->[1]{value} || "" if grep { $_ eq $token->[1]{name} } @params;
$default{setscratchpublic} = "on" if $token->[1]{name} eq 'setscratchpublic' && $token->[1]{checked};
}
return %default;
}
</code>
<p>
hup is a home node updater. You can use it on the command line, or from a
crontab, to automate updating your homenode. As always,
suggestions <!-- are not --> welcome. <!-- Why? Because it's fucking perfect,
you moron. -->
</p>
<p>
<b>Updates</b><br />
<ul>
<li>2001-11-14 -- Added scratchpad support, courtesy of [thatguy]<!-- thanks -->.</li>
<li>2002-01-19 -- Miscellaneous fixes. No longer warns when certain fields are empty; prompts for username and password</li>
</ul>
</p>
PerlMonks Related Scripts
<tt>/msg [ar0n]</tt>