Bill Ruppert

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.

# Create QR code with Perl

use strict;
use warnings;
use GD::Barcode::QRcode;

open my $OUT, '>', 'test.png';
binmode($OUT);

my $gd = GD::Barcode::QRcode->new(
	'http://m.cindyruppert.com',  
	{ Ecc => 'L', Version=>2, ModuleSize => 16},
);

print $OUT $gd->plot->png;
close $OUT;

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;

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

#!/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;

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