Recently in Perl Category

Here is a stripped down script to load a Microsoft Access database table using Win32::ODBC. This loaded about 100k rows per minute on my machine, which is WinXP, Access 2003, Active State Perl 5.8.8 and a Core 2 6600 processor at 2.4GHz.

use strict;
use warnings;

use Win32::ODBC;

$| = 1;

my $dsn = "LinkManagerTest";
my $db = new Win32::ODBC($dsn)
    or die "Connect to database $dsn failed: " . Win32::ODBC::Error();

my $rows_added = 0;
my $error_code;

while (<>) {
    chomp;

    print STDERR "."     unless $. % 100;
    print STDERR " $.\n" unless $. % 5000;

    my ($source, $source_link, $url, $site_name) = split /\t/;

    my $insert = qq{
        insert into Links (
            URL,
            SiteName,
            Source,
            SourceLink
        )
        values (
            '$url',
            '$site_name',
            '$source',
            '$source_link'
        )
    };

    $error_code = $db->Sql($insert);

    if ($error_code) {
        print "\nSQL update failed on line $. with error code $error_code\n";
        print "SQL statement:\n$insert\n\n";
        print "Error:\n" . $db->Error() . "\n\n";
    }
    else {
        $rows_added++;
    }

    $db->Transact('SQL_COMMIT') unless $. % 1000;
}

$db->Transact('SQL_COMMIT');
$db->Close();

print "\n";
print "Lines Read: $.\n";
print "Rows Added: $rows_added\n";

exit 0;

Gabor Szabo just wrote a Learning Perl post on the issue of how beginners find good Perl learning materials.  He suggested linking to some good material, so here we go.

# extract_zip.pl - very simple zip extract example

use strict;
use warnings;
use Archive::Zip qw( :ERROR_CODES :CONSTANTS );

my $zip_name = "example.zip";

my $zip = Archive::Zip->new($zip_name);
unless (defined $zip) {
	die "Unable to open $zip_name\n";
}

print "The zip file contains ", $zip->numberOfMembers(), " members:\n";

for my $member_name ($zip->memberNames()) {
	print "  Extracting $member_name\n";
	my $status = $zip->extractMemberWithoutPaths($member_name);
	die "\nExtracting $member_name from $zip_name failed\n" if $status != AZ_OK;
}

exit 1;

There is a spot in our real estate system that's always needed a cache to hold some data obtained from the internet. I finally got around to it using Cache::FileCache. Not the latest and greatest, but available on my increasingly antiquated system. It was hard to find a some decent example code, so here is some I wrote.

#!/usr/bin/perl

# tCacheFile.pl - try out Cache::FileCache
# 04/29/2011  Bill Ruppert

use strict;
use warnings;
use Cache::FileCache;

# Setup cache
my $cache = new Cache::FileCache({ 
	namespace           => 'FruitCache',
	default_expires_in  => '100 days',
	cache_root          => 'C:/tools/cache/',
	auto_purge_interval => '1 day',
});

# Cache some items
$cache->set('Orange', 'A round citrus fruit');
$cache->set('Lemon',  'A yellow pointed sour citrus fruit');
$cache->set('Apple',  'A red roundish fruit good for pies');

# Get all items in cache
print "Get all items in cache:\n";
for ($cache->get_keys()) {
	my $data = $cache->get($_);
	printf "  %-10s: %s\n", $_, $data;
}

# Mix cache hits and misses
print "\nTry some hits and misses:\n";
for (qw( Lemon Kiwi Orange Melon Apple )) {
	my $data = $cache->get($_);
	$data = "Not cached!" unless defined $data;
	printf "  %-10s: %s\n", $_, $data;
}

exit 1;

I've been reading about Google's new DNS service with great interest.  I had to switch to OpenDNS some time ago when my ISP began redirecting 404's to a search page.  This wreaked havoc on my link verification tools.

While reading, I came upon a shell script at http://www.manu-j.com/blog/opendns-alternative-google-dns-rocks/ that I wanted to try.  Since I run WinXP, I translated it to Perl and spruced it up a bit.  I installed the utility from http://members.shaw.ca/nicholas.fong/dig/ and away we went...

# dnstimes.pl - test dns server times

use strict;
use warnings;

my @urls = qw(
	lifehacker.com
	facebook.com
	manu-j.com
	reddit.com
	tb4.fr
	bbc.co.uk
	cindyruppert.com
);

my %dns_servers = (
	Level_3	=> '4.2.2.2',
	Google	=> '8.8.8.8',
	OpenDNS	=> '208.67.222.222',
);

for my $dns_firm (sort keys %dns_servers) {
	my $dns_ip = $dns_servers{$dns_firm};
	for my $url (@urls) {
		my $result = `dig \@$dns_ip $url`;
		my ($time) = $result =~ /Query time: (\d+)/s;
		print "$dns_firm\t$url\t$time\n";
	}
}

Figuring this out was somewhat painful, so I thought I would blog it.

I want to use the same form yaml for several different actions (update, create, view) andI had a list of field names I wanted to remove that were not relevant for create.

The remove_element method only works on the immediate children of the invoking object (as does get element), so $form->remove_element does not usually work.  I found a posting on the HTML::FormFu list where Carl Franks showed the idiom $element->parent->remove_element($element);

So my code became:

# remove fields not needed for this action
for (qw(created_by created_time changed_by changed_time version)) {
	my $element = $form->get_all_element({name => $_});
	if ($element) {
		$element->parent->remove_element($element);
	}
}


Works great!

One of my sites was coming up with a graybar, so I wanted to check it against other hosts, besides the default.  I tried a couple of the websites that I normally do this with, and they weren't working.  So, I wrote the following few lines.

use strict;
use warnings;
 
use WWW::Google::PageRank;

my @hosts = (
	"toolbarqueries.google.com",
	"209.85.227.147",
	"209.85.227.104",
);

for my $host (@hosts) {
	print "\n$host\n";
	my $pr = WWW::Google::PageRank->new(host => $host)
		or die $!;
	for my $domain (@ARGV) {
		$domain =~ s{http://}{};
		$domain =~ s{/$}{};
		my $pagerank = $pr->get("http://$domain/");
		print "    $pagerank  $domain\n";
	}
}

Here is a script that deletes old files.  In the Unix environment this is an easy job for a one line script using find.  This Perl version has the -test option, to allow you to see what will happen, and prints some totals.

#!/usr/bin/perl

# delold.pl - delete old files

#-----------------------------------------------------------
# 05/24/2009  WR  Written
#-----------------------------------------------------------

use strict;
use warnings;
use Win32::Autoglob;
use Getopt::Long;

$| = 1;

sub print_usage;
sub abort_usage;

# option defaults
my $days_back    = 10;
my $test_flag    = 0;
my $verbose_flag = 0;
my $quiet_flag   = 0;

# get options
GetOptions (
    'days=i'  => \$days_back,
    'test'    => \$test_flag,
    'verbose' => \$verbose_flag,
    'quiet'   => \$quiet_flag,
    'usage'   => sub {print_usage; exit 1},
) or abort_usage "Invalid option";

my $time = time();

my $files_to_delete = 0;
my $files_total     = 0;
my $files_failed    = 0;

FILE:
for my $file (@ARGV) {

    # must exist, must be a plain old file
    next FILE if !-e $file;
    next FILE if !-f $file;

    $files_total++;

    # modified age in days
    my ($mtime) = (stat($file))[9];
    my $modified_age = ($time - $mtime) / (3600 * 24);

    # skip if too young
    next FILE if $modified_age < $days_back;
    
    $files_to_delete++;

    if ($test_flag || $verbose_flag) {
        printf "Age: %-6.1f  File: %s\n",
            $modified_age,
            $file;
    }

    # skip if we are testing
    next FILE if $test_flag;

    # delete the file
    if (!unlink $file) {
        warn "Failed to delete file $file\n";
        $files_failed++;
    }

}

if ($test_flag) {
    print "\nTest Flag is set, no deletes done!\n";
}

my $files_remaining = $files_total - $files_to_delete + $files_failed;

if (!$quiet_flag || $test_flag) {
    print "\n";
    print "Total files:      $files_total\n";
    print "Files to delete:  $files_to_delete\n";
    print "Failed to delete: $files_failed\n";
    print "Files remaining:  $files_remaining\n";
}

exit 1;

sub abort_usage {
    print STDERR join("\n", @_), "\n" if @_;
    print_usage;
    exit 0;
}

sub print_usage {
    print STDERR <<END;
Usage: delold.pl [Options] files...
Options:
    --days n      - Set age of files to keep.
                    Files over "days" old will be deleted.
                    Default is 10 days.
    --test        - Print file names to be deleted with age,
                    but do not actually delete.
                    Default is false.
    --verbose     - Print file name and age while deleting.
                    Default is false.
    --quiet       - Suppress printing of totals after deleting.
                    Default is false.
    --usage       - print this message and exit
END
}

The Perl community is making an effort to improve visibility.  I added "Perl programming" to the top of the blog in support of this effort.

Here is a quick script I wrote to load SQLite tables from CSV files.  I exported the files from Microsoft Access.  The first row has to have correct column names.

Text::xSV is the best CSV file handler I could find on CPAN.  It correctly handles files with embedded newlines as well as very large files.  SQL::Abstract makes it very easy to use straight DBI to speed up the load without going through an ORM. 

I prepare each row separately because I may have cases where there are trailing unused fields, and some Microsoft programs (Outlook comes to mind) do not attempt to output empty fields for them.  If the speed difference is important, you may want to try to guarantee the exact number of fields in each row so you can prepare once.

#!/usr/bin/perl

# load_csv.pl - Load a db table from a csv file.
#               First row must be field names.
# 04/28/2009  W. Ruppert

use strict;
use warnings;
use Text::xSV;
use DBI;
use SQL::Abstract;

$| = 1;

sub usage {
    my ($msg) = @_;
    warn "$msg\n" if $msg;
    die "Usage: load_csv.pl db table csvfile\n";
}

# get parms
my $db        = shift || usage "No database name";
my $table     = shift || usage "No table name";
my $data_file = shift || usage "No csv data file";

usage "No such file: $db"        unless -e $db;
usage "No such file: $data_file" unless -e $data_file;

# setup csv file
my $csv = new Text::xSV;
$csv->open_file("$data_file");
$csv->read_header();

my $sql = SQL::Abstract->new;

# connect to db
my $dbh = DBI->connect("dbi:SQLite:$db", "","",
        { RaiseError => 1, PrintError => 0 }
) or die "can't connect\n";

$dbh->do('begin');

my $max_commit  = 1000;
my $inserted    = 0;

# process csv rows
while (my %fieldvals = $csv->fetchrow_hash) {

    # SQL::Abstract sets up the DBI variables
    my($stmt, @bind) = $sql->insert($table, \%fieldvals);

    # insert the row
    my $sth = $dbh->prepare($stmt);
    $inserted += $sth->execute(@bind);

    # progress bar
    print "*"            unless $inserted % 10;
    print " $inserted\n" unless $inserted % 500;

    # commit every once in a while
    unless ($inserted % $max_commit) {
        $dbh->do('commit');
        $dbh->do('begin');
    }
}

$dbh->do('commit');
$dbh->disconnect;

print "\nInserted $inserted records\n";
exit 1;