Recently in Script Category

I want to keep the comments open on this blog, but I keep getting hit with tons of comment spam, particularly from China. has an excellent list of Chinese IP blocks at  The following script reads the data file and formats the CIDR's into .htaccess "deny from" format.  The output can be pasted into your .htacces file.  You do need to have an "order allow, deny" at the start and "allow from all" at the end!

Since I wrote the post Net::Google::Analytics Extended Example Google updated the API and the Perl module was modifed to accomodate. That example is broken and I am providing an updated version here.

There are two major changes. First, Google started using OAuth2 for authentication so that code is different. There are plenty of details in the API docs.

Second, the Perl module has a bit smoother interface. I'm not sure if this was an API change or a module enhancement, I think the latter. In any case the new code is a lot cleaner.

Load an Access database

| No Comments
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 (<>) {

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

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

    my $insert = qq{
        insert into Links (
        values (

    $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 {

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


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

exit 0;
There is an update to this post, stuff changed.

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. 

The hardest thing for me was getting the correct profile number.  I thought it was the number in the web page code that looked like UA-191234-1, but it's not.  You have to go to account settings and thenedit the profile of the web site to see the magic number - it's the "Profle ID:" at the top of the page.

# Fetch some Google Analytics data

use strict;
use warnings;

use Net::Google::Analytics;
use Net::Google::AuthSub;

my $user    = ''; # your account user id here
my $pass    = 'xxxxxx';        # your password here!

my $profile    = '14883391';
my $start_date = '2010-10-01';
my $end_date   = '2011-09-30';

# Login

my $auth = Net::Google::AuthSub->new(service => 'analytics');
my $response = $auth->login($user, $pass);
if (!$response->is_success) {
    die 'Login failed: ' . $response->error . "\n";

# Datafeed request

my $analytics = Net::Google::Analytics->new();

my $data_feed = $analytics->data_feed;
my $req = $data_feed->new_request();


my $res = $data_feed->retrieve($req);

if (($res->{is_success} || 0) ne 1) {
    die "Lookup failed\n";

# Print tab separated header line

my $entry = $res->entries->[0];

for my $dimension (@{$entry->dimensions}) {
    my $name = $dimension->name;
    $name =~ s/^ga\://;
    print "$name\t";

for my $metric (@{$entry->metrics}) {
    my $name = $metric->name;
    $name =~ s/^ga\://;
    print "$name\t";

print "\n";

# Print tab separated values

for my $entry (@{$res->entries}) {
    for my $dimension (@{$entry->dimensions}) {
        my $value = $dimension->value;
        print "$value\t";
    for my $metric (@{$entry->metrics}) {
        my $value = $metric->value;
        print "$value\t";
    print "\n";

exit 1;

Comparing DNS Servers in Perl

| No Comments
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 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 and away we went...

# - test dns server times

use strict;
use warnings;

my @urls = qw(

my %dns_servers = (
	Level_3	=> '',
	Google	=> '',
	OpenDNS	=> '',

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 = (

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

Deleting Old Files

| No Comments
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 # - 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: [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 }

About this Archive

This page is an archive of recent entries in the Script category.

Perl is the previous category.

Snippet is the next category.

Find recent content on the main index or look in the archives to find all content.


OpenID accepted here Learn more about OpenID
Powered by Movable Type 4.38