a collection of random perl scripts

knock.pl

#!/usr/bin/perl
# Copyright 2009 - Paul Miller - GPL
# trivial port knocker script

use strict;
use IO::Socket::INET;
use Getopt::Long;

my ($h, @p);
GetOptions("host=s"=>\$h, "port=s"=>\@p);

die "no host?" unless $h;
for my $p (@p) {
    my ($port) = $p =~ m/(\d+)/;
    my $proto  = "tcp"; $proto = "udp" if $p =~ m/u/;
    my $socket = IO::Socket::INET->new(PeerAddr=>"$h:$port", Proto=>$proto,  Blocking=>0)
        or die "Error opening socket ($proto:$port): $!";

    print $socket "packet conntents\n" if $proto eq "udp";
    print "knocked $proto:$port\n";
}

if(@ARGV) {
    exec(@ARGV) or die "weird: $!";
}

perlmonks_rss.pl

#!/usr/bin/perl

use strict;
use CGI::RSS;
use HTML::TreeBuilder;
use XML::Twig;
use File::Copy;
use WWW::Mechanize;

use Getopt::Std;
my %o; getopts("f", \%o);

my $node  = "jettero";
my $link  = "https://voltar.org/pm/";
my $entry = "http://perlmonks.org/"; # some people use www or .com

BEGIN { chmod 0700, $0 or die $!; } # make sure this isn't mistaken for a CGI
umask 0077; # anything we create right now is owner only stuff

my $mech = WWW::Mechanize->new;
if( $o{f} or (not -f "search.html") or ((stat _)[9] < (time - 3600*24)) ) {
    my $url = "$entry/?node_id=6364;user=$node;length=50;orderby=nf;start=0;showtype=;sexisgood=Search";

    print "fetching $url\n";
    $mech->get( $url, ":content_file"=>"search.html" );
}

my $tree = HTML::TreeBuilder->new;
   $tree->parse_file("search.html");
   $tree->elementify;

my $twig = XML::Twig->new;
   $twig->parse( $tree->as_XML );

my @writeups_table = $twig->get_xpath('//table[@id="writeups"]');
die "couldn't find writeups table" unless @writeups_table;
die "foudn too many writeups tables" if @writeups_table != 1;
my @links = map  { my $r = [$_->text]; push @$r, $_->att_xml_string('href'); push @$r, $r->[-1]=~ m/(\d+)$/; $r }
            grep { ref $_ } map { my ($l) = $_->get_xpath("a"); $l }
            grep { ref $_ } map { my @td  = $_->get_xpath("td"); $td[1] }
            $writeups_table[0]->get_xpath("tr");

for my $r (@links) {
    my $nodeid  = $r->[2];
    my $xmlfile = ".$nodeid.xml";
    if( not -f $xmlfile ) {
        my $url = "$entry?displaytype=xml;node_id=$nodeid";

        print "fetching $url\n";
        $mech->get( $url, ":content_file"=>$xmlfile );

        sleep 1;
    }
}

umask 0022; # make sure apache can read this output
open my $out, ">", "feed_new.rss" or die $!;
my $stdout = select $out;
END { close $out; copy( "feed_new.rss", "index.xml" ) }

my $rss = new CGI::RSS;
   $rss->header; # must call this even if we don't print it

print $rss->begin_rss(title=>"$entry?node=$node", link=>$link, desc=>"Posts by $node at Perlmonks.");

print "\n\n";
for my $r ( @links ) {
    my ($link_title, $link_node, $nodeid) = @$r;

    my $desc = eval {
        $twig->parsefile(".$nodeid.xml");

        my ($f) = $twig->get_xpath('//field[@name="doctext"]');
        my $t = $f->text;
           $t =~ s/<(?:code|c)>/<pre><tt>/g;
           $t =~ s/<\/(?:code|c)>/<\/tt><\/pre>/g;

        $t;
    };

    warn "problem with $nodeid: $@" unless $desc;

    print $rss->item(
        $rss->title( $rss->escapeHTML($link_title) ),
        $rss->link( $rss->escapeHTML("$entry$link_node") ),
        $rss->guid( $rss->escapeHTML("$entry$link_node") ),
        ($desc ? $rss->description( $rss->escapeHTML($desc) ) : ()),
    ), "\n";

}
print $rss->finish_rss;

pm.pl

#!/usr/bin/perl
# Copyright 2009 - Paul Miller - GPL
# trivial perl module lister

use strict;
use warnings;
no warnings 'uninitialized';

use version;
use ExtUtils::Installed;
use Module::CoreList;

my $inst = new ExtUtils::Installed;
my @filt = map {qr/$_/} @ARGV;
my @mods = @filt ? ( grep {my $m=$_; grep {$m =~ $_} @filt} $inst->modules)
                 : $inst->modules;

my $max = 0; for (@mods) { $max = length $_ if length $_ > $max }

my $format = "\%-${max}s \%-12s \%s\n";
printf $format, qw(Module Version FirstInCore);

open my $out, "|-", qw(less -eS) or die $!;
for my $m (@mods) {
    printf $out $format, $m, 
        do {
            my $v = $inst->version($m);

            if( $v =~ m/[^[:print:]]/ ) {
                $v = version->new($v);
                $v =~ s/^v//;
            }
                  
        "v$v" },

        Module::CoreList->first_release($m);
}
close $out;