Recently in Script 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;

I wanted to fetch visitors and page views by month for the past year for our website, and quickly found the Net::Google::Analytics module. It and Net::Google::AuthSub installed easily. However, the snippet in the synopsis did not compile ($i was undefined) and was obviously missing a loop over the retrieved data. Anyway, here is a working snippet that retrieves and formats some data for easy loading into a spreadsheet. 

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";
	}
}

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
}