Category Archives: perl

Perl script to get video details

This is a command line Perl script I made a while back to simply show details about a specified video. It is tested on Ubuntu.

You can modify it for your specific requirements or grab some code for another use.

#!/usr/bin/perl -w
use strict;
use warnings;
 
use IPC::Open3;
 
# example
my $filename  = $ARGV[0];
my %videoInfo = videoInfo($filename);
print "duration: " . $videoInfo{'duration'} . "\n";
print "durationsecs: " . $videoInfo{'durationsecs'} . "\n";
print "bitrate: " . $videoInfo{'bitrate'} . "\n";
print "vcodec: " . $videoInfo{'vcodec'} . "\n";
print "vformat: " . $videoInfo{'vformat'} . "\n";
print "acodec: " . $videoInfo{'acodec'} . "\n";
print "asamplerate: " . $videoInfo{'asamplerate'} . "\n";
print "achannels: " . $videoInfo{'achannels'} . "\n";
 
#
# returns media information in a hash
sub videoInfo {
	# ffmpeg command
	my $ffmpeg = '/usr/local/bin/ffmpeg';
 
	my %finfo = (
				  'duration'     => "00:00:00.00",
				  'durationsecs' => "0",
				  'bitrate'      => "0",
				  'vcodec'       => "",
				  'vformat'      => "",
				  'acodec'       => "",
				  'asamplerate'   => "0",
				  'achannels'       => "0", 
	);
 
	my $file = shift;
 
	# escaping characters
	$file =~ s/(\W)/\\$1/g;
 
	open3( "/dev/null", \*ERPH, "$ffmpeg -i $file" ) or die "can't run $ffmpeg\n";
	my @res = ;
 
	# parse ffmpeg output
	foreach (@res) {
        print;
 
		# duration
		if (m!Duration: ([0-9][0-9]:[0-9][0-9]:[0-9][0-9].[0-9][0-9])!) {
			$finfo{'duration'} = $1;
		}
 
		# bitrate
		if (m!bitrate: (\d*) kb/s!) {
			$finfo{'bitrate'} = $1;
		}
 
		# vcodec and vformat
		if (/Video: (\w*), (\w*),/) {
			$finfo{'vcodec'}  = $1;
			$finfo{'vformat'} = $2;
		}
 
        # Stream #0.1(und): Audio: aac, 48000 Hz, 1 channels, s16, 64 kb/s
 
		# acodec, samplerate, stereo and audiorate
		if (m!Audio: (\w*), (\d*) Hz, (\d*)!) {
			$finfo{'acodec'}     = $1;
			$finfo{'asamplerate'} = $2;
			$finfo{'achannels'}     = $3;
		}
	}
 
	my $tenths  = substr( $finfo{'duration'}, 9, 2 );
	my $seconds = substr( $finfo{'duration'}, 6, 2 );
	my $minutes = substr( $finfo{'duration'}, 3, 2 );
	my $hours   = substr( $finfo{'duration'}, 0, 2 );
	$finfo{'durationsecs'} = ( $tenths * .01 ) + $seconds + ( $minutes * 60 ) + ( $hours * 360 );
 
	return %finfo;
}

Linux command line language translator

I wanted a command language translator that can be used in bash shell scripts. There are a couple of options available, but none that were versatile enough. A little research resulted in finding that Google Translate offered what I wanted and that there was a JSON interface, which I could use with Perl’s JSON module.

I added a few niceties such as help, multiple source options and a listing of available languages.

Entering:

tranny -t de ‘I am a citizen of Berlin’

gets this result:

Ich bin ein Bürger von Berlin

and entering:

tranny ‘Ich bin ein Bürger von Berlin’

results:

I am a citizen of Berlin

I created a Google Code project for tranny at: http://code.google.com/p/tranny/

If you need a scriptable translator, give it a try. If you run into trouble or would like to suggest changes, leave comments here or at the project.

#!/usr/bin/perl
#
# what:      tranny, a language translator
# project:   https://code.google.com/p/tranny/
# copyright: Copyright 2010, Andrew Ault
# license:   This content is released under the  http://code.google.com/p/tranny/wiki/license MIT License.
#
# Uses the JSON module from CPAN. To install: "sudo cpan JSON"
#

use strict;
use warnings;
use POSIX;
use Getopt::Std;
use JSON;
use LWP;

require 'sys/ioctl.ph';
die "no TIOCGWINSZ " unless defined &TIOCGWINSZ;

my $original;
my $winsize;
my $has_tty = 1;
my ( $screen_rows, $screen_cols, $screen_xpixels, $screen_ypixels );

my %languages = (
				  'afrikaans'      => 'af',
				  'albanian'       => 'sq',
				  'amharic'        => 'am',
				  'arabic'         => 'ar',
				  'armenian'       => 'hy',
				  'azerbaijani'    => 'az',
				  'basque'         => 'eu',
				  'belarusian'     => 'be',
				  'bengali'        => 'bn',
				  'bihari'         => 'bh',
				  'breton'         => 'br',
				  'bulgarian'      => 'bg',
				  'burmese'        => 'my',
				  'catalan'        => 'ca',
				  'cherokee'       => 'chr',
				  'chinese'        => 'zh',
				  'chinese simp'   => 'zh-cn',
				  'chinese trad'   => 'zh-tw',
				  'corsican'       => 'co',
				  'croatian'       => 'hr',
				  'czech'          => 'cs',
				  'danish'         => 'da',
				  'dhivehi'        => 'dv',
				  'dutch'          => 'nl',
				  'english'        => 'en',
				  'esperanto'      => 'eo',
				  'estonian'       => 'et',
				  'faroese'        => 'fo',
				  'filipino'       => 'tl',
				  'finnish'        => 'fi',
				  'french'         => 'fr',
				  'frisian'        => 'fy',
				  'galician'       => 'gl',
				  'georgian'       => 'ka',
				  'german'         => 'de',
				  'greek'          => 'el',
				  'gujarati'       => 'gu',
				  'haitian creole' => 'ht',
				  'hebrew'         => 'iw',
				  'hindi'          => 'hi',
				  'hungarian'      => 'hu',
				  'icelandic'      => 'is',
				  'indonesian'     => 'id',
				  'inuktitut'      => 'iu',
				  'irish'          => 'ga',
				  'italian'        => 'it',
				  'japanese'       => 'ja',
				  'javanese'       => 'jw',
				  'kannada'        => 'kn',
				  'kazakh'         => 'kk',
				  'khmer'          => 'km',
				  'korean'         => 'ko',
				  'kurdish'        => 'ku',
				  'kyrgyz'         => 'ky',
				  'lao'            => 'lo',
				  'latin'          => 'la',
				  'latvian'        => 'lv',
				  'lithuanian'     => 'lt',
				  'luxembourgish'  => 'lb',
				  'macedonian'     => 'mk',
				  'malay'          => 'ms',
				  'malayalam'      => 'ml',
				  'maltese'        => 'mt',
				  'maori'          => 'mi',
				  'marathi'        => 'mr',
				  'mongolian'      => 'mn',
				  'nepali'         => 'ne',
				  'norwegian'      => 'no',
				  'occitan'        => 'oc',
				  'oriya'          => 'or',
				  'pashto'         => 'ps',
				  'persian'        => 'fa',
				  'polish'         => 'pl',
				  'portuguese'     => 'pt',
				  'punjabi'        => 'pa',
				  'quechua'        => 'qu',
				  'romanian'       => 'ro',
				  'russian'        => 'ru',
				  'sanskrit'       => 'sa',
				  'scots_gaelic'   => 'gd',
				  'serbian'        => 'sr',
				  'sindhi'         => 'sd',
				  'sinhalese'      => 'si',
				  'slovak'         => 'sk',
				  'slovenian'      => 'sl',
				  'spanish'        => 'es',
				  'sundanese'      => 'su',
				  'swahili'        => 'sw',
				  'swedish'        => 'sv',
				  'syriac'         => 'syr',
				  'tajik'          => 'tg',
				  'tamil'          => 'ta',
				  'tatar'          => 'tt',
				  'telugu'         => 'te',
				  'thai'           => 'th',
				  'tibetan'        => 'bo',
				  'tonga'          => 'to',
				  'turkish'        => 'tr',
				  'ukrainian'      => 'uk',
				  'urdu'           => 'ur',
				  'uzbek'          => 'uz',
				  'uighur'         => 'ug',
				  'vietnamese'     => 'vi',
				  'welsh'          => 'cy',
				  'yiddish'        => 'yi',
				  'yoruba'         => 'yo',
);

# get window size for country listing
open( TTY, "+;
	close FILE;
# text is from STDIN
} else {
	# slurp STDIN
	local $/ = undef;
	$original = ;
}

my $ua = LWP::UserAgent->new;
$ua->agent("PGDict/1.0");
my $request =
  HTTP::Request->new( GET => "http://ajax.googleapis.com/ajax/services/language/translate?v=1.0&langpair=$from|$to&q=$original" );
my $response = $ua->request($request);

if ( $response->is_success ) {
	my $perl_res = from_json( $response->content );
	if ( $perl_res->{'responseStatus'} eq '200' ) {
		print $perl_res->{'responseData'}->{'translatedText'} . "\n";
	} else {
		warn "error " . $perl_res->{'responseDetails'} . "\n";
	}
} else {
	print $response->status_line . "\n";
}

sub usage {
	print "usage: ";
	print "\ttranny -f language_code -t language_code [original text]\n\n";
	print "-f language_code (optional)\n\n";
	print "-t language_code (optional)\n\n";
	print "-o original_file (optional)\n\n";
	print "-h this help\n\n";
	print "-l language list\n\n";
	print "Tranny uses Google Translate and requires an Internet connection to work.\n";
	print "Text is translated from STDIN, from the command line or a file with -o.\n\n";
	print "By default,the 'from' language is automatically detected and translated to English (en).\n\n";
	if ( defined $opts{l} && $opts{l} == 1 ) { list_languages() }
	exit;
}

sub list_languages {
	my $num_columns = ceil( $screen_cols / 23 );
	my $num_rows = ceil ( keys(%languages) /$num_columns );
	my $row = 0;
	my $col = 0;
	my @formatted_languages = ( );
	foreach my $key ( sort ( keys(%languages) ) ) {
		$row++;
		$formatted_languages[$col][$row] =  sprintf( "%-14s %-6s", $key, $languages{$key} );
		if ( $row == $num_rows ){
			$row = 0;
			$col++;
		}
	}
	for ($row = 0; $row <= $num_rows; $row++) {
		for ($col = 0; $col <= $num_columns; $col++) {
			if ( defined $formatted_languages[$col][$row] ){
				print $formatted_languages[$col][$row];
			}
		}
		print "\n";
	}
}

My remote Subversion dump/tar/rotating file Perl script

This is the script I use to SSH remotely dump Subversion repositories on various servers for which I am responsible.

Before you can use this script, you need to set up SSH so your local cron can access the remote servers without a password.

One thing to note about this script is that it automatically rotates the archived dump files; keeping a fie for the 1st of the week on a month, 1st of the month and 1st of the year.

see: Using Public/Private Key Pairs with SSH

Then, just modify the script for your database/servers (the block @ about line 22).

This will create a series of files over time with daily/weekly/monthly Subversion dump backup tar files. The point is not so much to have every state of every repository, but to grab the daily changes without clobbering the last know good one. More is better, no?

#!/usr/bin/perl -w
#
# rtar_svn.pl
#
# by Andrew Ault www.andrewault.net
#
# No arguments. The program is to be modified to include each Subversion repository to be archived.
#
# Saves a tar of a remote Subversion dump in a rotating file.
#
# Of course you have to have SSH authentication already set up.
#
# This get cron'd daily on my local workstation.
#
use strict;
use warnings;

use DateTime;

my $fileError;
my $jobError  = 0;
my $jobErrors = "";
my $result;

# Specify a data block for each remote repository to be archived.
my %dumpJobs = (
				 'servername-repositoryname' => {
							'remoteServer' => 'servername',
							'repository'     => 'repositoryname',
							'dumpFilename' => 'servername-repositoryname.dump.svn',
							'svnDumpCmd' => '/usr/bin/svnadmin dump', # find svnadmin on your server
							'tarCmd'       => '/bin/tar', # find tar on your server
				 },
				 'servername-repositoryname2' => {
							'remoteServer' => 'servername',
							'repository'     => 'repositoryname2',
							'dumpFilename' => 'servername-repositoryname2.dump.svn',
							'svnDumpCmd' => '/usr/bin/svnadmin dump',
							'tarCmd'       => '/bin/tar',
				 },
);

# Process each specified repository dump/archive job.
for my $dumpJob ( sort keys %dumpJobs ) {
	$fileError = 0;
	my $tarballFilename = "$dumpJobs{$dumpJob}{'dumpFilename'}-" . tarDateSegment() . ".tgz";
	my $svnDumpCmd    = $dumpJobs{$dumpJob}{'svnDumpCmd'};
	my $tarCmd          = $dumpJobs{$dumpJob}{'tarCmd'};
	print "$dumpJob\n";

	my $dumpCommand = "ssh $dumpJobs{$dumpJob}{'remoteServer'} '$svnDumpCmd ";
	$dumpCommand .= "/var/lib/svn/$dumpJobs{$dumpJob}{'repository'} > $dumpJobs{$dumpJob}{'dumpFilename'}'";
	print $dumpCommand . "\n";
	$result = system($dumpCommand );
	if ($result) { $fileError = 1; }

	if ( !$fileError ) {
		my $remoteMakeTarball = "ssh $dumpJobs{$dumpJob}{'remoteServer'} '$tarCmd ";
		$remoteMakeTarball .= "cvfz $tarballFilename $dumpJobs{$dumpJob}{'dumpFilename'}'";
		print $remoteMakeTarball . "\n";
		$result = system($remoteMakeTarball );
		if ($result) { $fileError = 1; }
	}

	if ( !$fileError ) {
		my $downloadCommand = "scp $dumpJobs{$dumpJob}{'remoteServer'}:$tarballFilename .";
		print $downloadCommand . "\n";
		$result = system($downloadCommand );
		if ($result) { $fileError = 1; }
	}

	if ($fileError) {
		$jobError = 1;
		$jobErrors .= "$dumpJob ";
	}
}
if ($jobError) {
	warn "Errors were encountered: $jobErrors\n";
	exit(1);
}

sub tarDateSegment {
	my $dt = DateTime->now();

	my ( $sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst ) = localtime(time);
	$year += 1900;
	my $dateTime = sprintf "%4d-%02d-%02d %02d:%02d:%02d", $year, $mon + 1, $mday, $hour, $min, $sec;
	my $date     = sprintf "%4d-%02d-%02d",                $year, $mon + 1, $mday;
	my @weekdays = qw( sun mon tue wed thu fri sat );
	my $weekday  = $weekdays[$wday];
	my @months   = qw( jan feb mar apr may jun jul aug sep oct nov dec );
	my $month    = $months[$mon];

	my $weekOfMonth = $dt->week_of_month;

	my $dateTar = "";

	# if the first day of the year, set $dateTar like: 2009-1st
	if ( $yday == 1 ) {
		$dateTar = "$year-1st";
	}

	# if the first day of the month, set $dateTar like: feb-1st
	elsif ( $mday == 1 ) {
		$dateTar = "$month-1st";
	}

	# if the first day of the week, set $dateTar like: mon-1
	# where the number is the week of the month number
	elsif ( $wday == 1 ) {
		$dateTar = "$weekday-$weekOfMonth";
	}

	# otherwise, set the $dateTar like: mon
	else {
		$dateTar = "$weekday";
	}

	# $sec      seconds          54
	# $min      monutes          37
	# $hour     hour             11
	# $mon      month            4
	# $year     year             2009
	# $wday     weekday          3
	# $yday     day of the year  146
	# $isdst    is DST           1
	# $weekday  day of the week  wed
	# $month    month            may
	# $dateTime date and time    2009-05-27 11:37:54
	# $date     date             2009-05-27
	return $dateTar;
}

=head1 NAME

rtar_svn.pl - Andrew's remote Subversion repository archive program.

=head1 SYNOPSIS

    use: rtar_svn.pl

=head1 DESCRIPTION

This is a program I wrote to SSH/dump/tar/download/rotate archives of Subversion repositories.

=over

=back

=head1 LICENSE

Use this as you will.

=head1 AUTHOR

Andrew Ault 

=cut

Installing Net::Amazon::S3 Perl module on an Ubuntu server

The following is the same on recent Ubuntu releases, including Karmic, Lucid and Maverick.

What will not work

There seems to be a problem if you install Net::Amazon::S3 from CPAN. This will not work:

sudo cpan Net::Amazon::S3

Just about every dependency in the world installs, but fails in the home stretch when XML::LibXML::XPathContext and XML::LibXML fail to install.

What will work

sudo aptitude install libnet-amazon-s3-perl
sudo cpan Net::Amazon::S3::Client

Test your install with this

After throwing some data into S3 with S3Fox, test your installation. You will need to set values for aws_access_key_id and aws_secret_access_key, of course.

#!/usr/bin/perl
use warnings;
use strict;
use Net::Amazon::S3;
use Net::Amazon::S3::Client;

my %s3_hash = (
				aws_access_key_id     => "XXXXXXXXXXXXXXXXX",
				aws_secret_access_key => "YYYYYYYYYYYYYYYYYYYYYYYYYY",
				retry                 => 1,
);

my $s3 = Net::Amazon::S3->new( \%s3_hash );
my $client = Net::Amazon::S3::Client->new( s3 => $s3 );

my @buckets = $client->buckets;
foreach my $bucket (@buckets) {
	print $bucket->name . "\n";
}

Perl function that returns info about a video (uses FFMPEG)

This program contains a Perl function I wrote to extract data about a given video.

It also shows how to parse information from program output and organize it usefully.

This has been used a few times in production systems.

If you use this, please drop a comment! It would be fun to know.

Share and enjoy!

#!/usr/bin/perl -w
# get_video_info.pl
# by Andrew Ault, www.andrewault.net
# Please drop me a note it you use this.

use strict;
use warnings;

use IPC::Open3;

# example
my $filename  = "yourvideoFilenameHere.mp4";
my %videoInfo = videoInfo($filename);
print "duration: " . $videoInfo{'duration'} . "\n";
print "durationsecs: " . $videoInfo{'durationsecs'} . "\n";
print "bitrate: " . $videoInfo{'bitrate'} . "\n";
print "vcodec: " . $videoInfo{'vcodec'} . "\n";
print "vformat: " . $videoInfo{'vformat'} . "\n";
print "acodec: " . $videoInfo{'acodec'} . "\n";
print "asamplerate: " . $videoInfo{'asamplerate'} . "\n";
print "achannels: " . $videoInfo{'achannels'} . "\n";

#
# returns media information in a hash
sub videoInfo {
	# ffmpeg command
	my $ffmpeg = '/usr/local/bin/ffmpeg';

	my %finfo = (
				  'duration'     => "00:00:00.00",
				  'durationsecs' => "0",
				  'bitrate'      => "0",
				  'vcodec'       => "",
				  'vformat'      => "",
				  'acodec'       => "",
				  'asamplerate'   => "0",
				  'achannels'       => "0", 
	);

	my $file = shift;

	# escaping characters
	$file =~ s/(\W)/\\$1/g;

	open3( "/dev/null", \*ERPH, "$ffmpeg -i $file" ) or die "can't run $ffmpeg\n";
	my @res = ;

	# parse ffmpeg output
	foreach (@res) {

		# duration
		if (m!Duration: ([0-9][0-9]:[0-9][0-9]:[0-9][0-9].[0-9][0-9])!) {
			$finfo{'duration'} = $1;
		}

		# bitrate
		if (m!bitrate: (\d*) kb/s!) {
			$finfo{'bitrate'} = $1;
		}

		# vcodec and vformat
		if (/Video: (\w*), (\w*),/) {
			$finfo{'vcodec'}  = $1;
			$finfo{'vformat'} = $2;
		}

        # Stream #0.1(und): Audio: aac, 48000 Hz, 1 channels, s16, 64 kb/s

		# acodec, samplerate, stereo and audiorate
		if (m!Audio: (\w*), (\d*) Hz, (\d*)!) {
			$finfo{'acodec'}     = $1;
			$finfo{'asamplerate'} = $2;
			$finfo{'achannels'}     = $3;
		}
	}

	my $tenths  = substr( $finfo{'duration'}, 9, 2 );
	my $seconds = substr( $finfo{'duration'}, 6, 2 );
	my $minutes = substr( $finfo{'duration'}, 3, 2 );
	my $hours   = substr( $finfo{'duration'}, 0, 2 );
	$finfo{'durationsecs'} = ( $tenths * .01 ) + $seconds + ( $minutes * 60 ) + ( $hours * 360 );

	return %finfo;
}

Create a test pattern video with Perl

I wanted a test pattern video to test a transcoding daemon I wrote for an iPhone application. I wanted to use the classic RCA test pattern image and a tone.

Simply edit the program header with the path to an image you want to use and the name of the output file you’d like to create.

You’ll need FFMPEG installed, of course.

You can change the audio tone if you’d like to.

If you use this script, please let me know.

Share and enjoy.

#!/usr/bin/perl -w
# create_test_pattern_video.pl
# by Andrew Ault, www.andrewault.net
#
# This produces a test pattern video from an image you supply with a tone that you specify.
#
use strict;
use warnings;

use File::Temp qw/ :mktemp tempdir /;
use File::Path;
use File::Spec;
use Audio::Wav;

# still image to create video from
my $fileImage = "/path/imageInputFilename.jpeg";

# output file - name of the file to output to
my $fileOutput = "/path/videoOutputFilename.mp4";

# video parameters
my $vFrameRate      = 25;
my $vBitRate        = "200k";
my $durationSeconds = 10;

# audio parameters - set up the tone to produce and use in the resulting video
my $hertz      = 400;
my $sampleRate = 44100;
my $sampleBits = 16;

#
my $dirTemp = tempdir("tmp-hax-XXXXXXXX");
$dirTemp = File::Spec->rel2abs($dirTemp) . "/";
my $numFrames = $vFrameRate * $durationSeconds;
my $cmd;
my $fileTmpAnimationVideo = $dirTemp . "animation.mp4";
my $fileTmpAudio          = $dirTemp . "sound.wav";

chdir $dirTemp;

# create a sequence of image files
print "creating image sequence\n";
for ( my $i = 1 ; $i <= $numFrames ; $i++ ) {
	my $seq = sprintf( "%08d", $i );
	$cmd = "cp $fileImage " . $seq . ".jpeg";
	print "$cmd\n";
	`$cmd`;
}

# create .mp4 from the image sequence
print "creating animation video\n";
$cmd = "ffmpeg -r $vFrameRate -b $vBitRate -i " . $dirTemp . "%08d.jpeg $fileTmpAnimationVideo";
print "$cmd\n";
`$cmd`;

# create the audio tone .wav
my $wav = Audio::Wav->new;
my $details = {
	'bits_sample' => $sampleBits,
	'sample_rate' => $sampleRate,
	'channels'    => 1,
};
my $write = $wav->write( $fileTmpAudio, $details );
&add_sine( $hertz, $durationSeconds );
$write->finish();

# combine the video and audio files to output
print "creating final output video file\n";
$cmd = "ffmpeg -y -i $fileTmpAnimationVideo -i $fileTmpAudio -acodec libfaac -ab 128k -ar 48000 $fileOutput";
print "$cmd\n";
`$cmd`;

# wrap it up
print "done\n";
rmtree($dirTemp);
exit(0);

sub add_sine {
	my $hz     = shift;
	my $length = shift;
	my $pi     = ( 22 / 7 ) * 2;
	$length *= $sampleRate;
	my $max_no = ( 2**$sampleBits ) / 2;
	for my $pos ( 0 .. $length ) {
		my $time = $pos / $sampleRate;
		$time *= $hz;
		my $val  = sin $pi * $time;
		my $samp = $val * $max_no;
		$write->write($samp);
	}
	return;
}

Top 10 Perl Sites

As is typical of my posts, this is another reference for my own use. When I can’t immediately remember something, I look here or on my private wiki. I hope you find this list useful.

perl.org

http://www.perl.org/

The mothership. Includes: Planet Perl : Perl History : Learn Perl : Online Perl Documentation

Home of the baddest Swiss Army Chainsaw there is.

CPAN

http://www.cpan.org/

The Comprehensive Perl Network. The reason I use Perl. Don not leave the womb with it.

Perl Monks

http://www.perlmonks.com/

Wide-ranging discussions of every possible Perl permutation.

Planet Perl

http://planet.perl.org/

Planet Perl is a regularly updated Perl blog with news from around the ‘net about Perl and Perl people. Definitely worth adding the RSS feed to Google Reader.

Perl.com

http://www.perl.com/

Infrequently updated, but still an interesting aggregate of Perl @ O’Reilly – the source of Perl paper artifacts.

Wiki Books Perl

http://en.wikibooks.org/wiki/Perl

A nice concentration of easily accessible Perl know how.

Perl 6

http://www.perl6.org/

The future of Perl…beyond 5.x

http://perl.net.au

http://perl.net.au

Great Perl resource.

The Perl Foundation

http://www.perlfoundation.org/

The Perl Foundation is dedicated to the advancement of the Perl programming language through open discussion, collaboration, design, and code.

Perl Design Patterns

http://perldesignpatterns.com/

Cargill’s quandary: “any design problem can be solved by adding an additional level of indirection, except for too many levels of indirection.”

My remote MySQL backup script in Perl – rtar_mysql.pl

Before you can use this script, you need to set up SSH so your local cron can access the remote servers without a password.

One thing to note about this script is that it automatically rotates the archived dump files; keeping a fie for the 1st of the week on a month, 1st of the month and 1st of the year.

see: Using Public/Private Key Pairs with SSH

Then, just modify the script for your database/servers (the block @ line 22).

This will create a series of files over time with daily/weekly/monthly MySQL dump backups.

#!/usr/bin/perl -w
# rtar_mysql.pl
#
# No arguments. The program is to be modified to include each database to be archived.
#
# Saves a tar of a remote mysql dump in a rotating file.
#
# This is used on Andrew's workstation to automatically grab a sql dump tar of each database daily.
#
use strict;
use warnings;

use DateTime;

my $fileError;
my $jobError  = 0;
my $jobErrors = "";
my $result;

# Specify a data block for each remote database to be archived.
my %dumpJobs = (
				 'db1' => {
							'remoteServer' => 'server_1',
							'database'     => 'database_name_1',
							'dbUser'       => 'database_username_1',
							'dbPassword'   => 'database_password_1',
							'dumpFilename' => 'server_1-database_name_1.dump.sql',
							'mysqlDumpCmd' => '/usr/bin/mysqldump',
							'tarCmd'       => '/bin/tar',
				 },
				 'db2' => {
							'remoteServer' => 'server_2',
							'database'     => 'database_name_2',
							'dbUser'       => 'database_username_1',
							'dbPassword'   => 'database_password_2',
							'dumpFilename' => 'server_2-database_name_2.dump.sql',
							'mysqlDumpCmd' => '/usr/bin/mysqldump',
							'tarCmd'       => '/bin/tar',
				 },
);

# Process each specified database dump/archive job.
for my $dumpJob ( sort keys %dumpJobs ) {
	$fileError = 0;
	my $tarballFilename = "$dumpJobs{$dumpJob}{'dumpFilename'}-" . tarDateSegment() . ".tgz";
	my $mysqlDumpCmd    = $dumpJobs{$dumpJob}{'mysqlDumpCmd'};
	my $tarCmd          = $dumpJobs{$dumpJob}{'tarCmd'};
	print "$dumpJob\n";

	my $dumpCommand = "ssh $dumpJobs{$dumpJob}{'remoteServer'} '$mysqlDumpCmd ";
	$dumpCommand .= "--user=$dumpJobs{$dumpJob}{'dbUser'} --password=$dumpJobs{$dumpJob}{'dbPassword'} ";
	$dumpCommand .= "$dumpJobs{$dumpJob}{'database'} > $dumpJobs{$dumpJob}{'dumpFilename'}'";
	print $dumpCommand . "\n";
	$result = system($dumpCommand );
	if ($result) { $fileError = 1; }

	if ( !$fileError ) {
		my $remoteMakeTarball = "ssh $dumpJobs{$dumpJob}{'remoteServer'} '$tarCmd ";
		$remoteMakeTarball .= "cvfz $tarballFilename $dumpJobs{$dumpJob}{'dumpFilename'}'";
		print $remoteMakeTarball . "\n";
		$result = system($remoteMakeTarball );
		if ($result) { $fileError = 1; }
	}

	if ( !$fileError ) {

		# using a more flexible naming scheme now
		my $downloadCommand = "scp $dumpJobs{$dumpJob}{'remoteServer'}:$tarballFilename .";
		print $downloadCommand . "\n";
		$result = system($downloadCommand );
		if ($result) { $fileError = 1; }
	}

	if ($fileError) {
		$jobError = 1;
		$jobErrors .= "$dumpJob ";
	}
}
if ($jobError) {
	warn "Errors were encountered: $jobErrors\n";
	exit(1);
}


sub tarDateSegment {
	my $dt = DateTime->now();

	my ( $sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst ) = localtime(time);
	$year += 1900;
	my $dateTime = sprintf "%4d-%02d-%02d %02d:%02d:%02d", $year, $mon + 1, $mday, $hour, $min, $sec;
	my $date     = sprintf "%4d-%02d-%02d",                $year, $mon + 1, $mday;
	my @weekdays = qw( sun mon tue wed thu fri sat );
	my $weekday  = $weekdays[$wday];
	my @months   = qw( jan feb mar apr may jun jul aug sep oct nov dec );
	my $month    = $months[$mon];

	my $weekOfMonth = $dt->week_of_month;

	my $dateTar = "";

	# if the first day of the year, set $dateTar like: 2009-1st
	if ( $yday == 1 ) {
		$dateTar = "$year-1st";
	}

	# if the first day of the month, set $dateTar like: feb-1st
	elsif ( $mday == 1 ) {
		$dateTar = "$month-1st";
	}

	# if the first day of the week, set $dateTar like: mon-1
	# where the number is the week of the month number
	elsif ( $wday == 1 ) {
		$dateTar = "$weekday-$weekOfMonth";
	}

	# otherwise, set the $dateTar like: mon
	else {
		$dateTar = "$weekday";
	}

	# $sec      seconds          54
	# $min      monutes          37
	# $hour     hour             11
	# $mon      month            4
	# $year     year             2009
	# $wday     weekday          3
	# $yday     day of the year  146
	# $isdst    is DST           1
	# $weekday  day of the week  wed
	# $month    month            may
	# $dateTime date and time    2009-05-27 11:37:54
	# $date     date             2009-05-27
	return $dateTar;
}

=head1 NAME

rtar_mysql.pl - Andrew's remote MySQL archive program.

=head1 SYNOPSIS

    use: rtar_mysql.pl

=head1 DESCRIPTION

This is a program I wrote to SSH/dump/tar/download/rotate archives of MySQL databases.

=over

=back

=head1 LICENSE

None.

=head1 AUTHOR

Andrew Ault 

=cut

Perl program for makeiPhoneRefMovie

This creates the small .mov (or whatnot) redirect files that Apple’s makeiPhoneRefMovie generates. This is simply a driver to creat those files with makeiPhoneRefMovie.

#!/usr/bin/perl -w
#
# gen_mwn_iphone_mov_redirect_files.pl
#
# This makes the special iPhone .mov rediect files (~ 300 bytes) that the iPhone
# uses to redirect to the appropriate actual movie file.
#
# To use this utility:
#
# Make sure that the program makeiPhoneRefMovie is in your $PATH with:
#
#  which makeiPhoneRefMovie
#
# Then, let fly!
#
# ./gen_mwn_iphone_mov_redirect_files.pl
#
# Then, FTP the .mov files that are created up to the CDN.
#

use strict;
use File::Basename;
use Net::FTP;
use DBI;
use Cwd;

# Where to output files
my $dirOutput = "./iphone-ref-movs/";

my $dirBase = getcwd;

# Working directories
my %workingDirs = ( dirOutput => $dirBase . "/iphone-ref-movs/", );

# Prepend url strings
my $url3gp = "http://low_bandbidth_url_goes_here/";
my $urlM4v = "http://high_bandbidth_url_goes_here/";

# MySQL connection data
my $dbHost     = "db_hostname_here";
my $dbDatabase = "db_databasename_here";
my $mysqlDsn   = "DBI:mysql:$dbDatabase;host=$dbHost";
my $dbUsername = "db_username_here";
my $dbPassword = "db_password_here";

# Create working directories, if they do not already exist.
while ( my ( $key, $value ) = each(%workingDirs) ) {
	if ( !-d $value ) { mkdir $value or die $!; }
	print $key . ": " . $value . "\n";
}

# Connect to MySQL database
my $dbh = DBI->connect( $mysqlDsn, $dbUsername, $dbPassword )
  or die "Cannot connect to database $dbHost: $@";

# Get a list of @songFilenames from the database
my $sqlQuery = "SELECT filename FROM videos WHERE filename != ''";
my $sth      = $dbh->prepare($sqlQuery);
$sth->execute();
my @songFilenames;
while ( my ($songFilename) = $sth->fetchrow_array() ) {
	push( @songFilenames, $songFilename );
}
$dbh->disconnect();
my $numSongIds = @songFilenames;

# Create the mov redirect files
foreach my $songFilename (@songFilenames) {
	my $dirOutput = $workingDirs{dirOutput};

	my $url3gp = $url3gp . $songFilename . ".3gp";
	my $urlM4v = $urlM4v . $songFilename . ".m4v";
	my $filenameMov = $dirOutput . $songFilename . ".mov";

	my $cmd       = "makeiPhoneRefMovie $url3gp $urlM4v $urlM4v $filenameMov";
	system($cmd);
}