Peter’s Perl Examples

Contents

Introduction

Installing Modules

Make a PDF from GIF images

Make an animated GIF that rotates in the Z axis

Make Image Catalog

Base64 Encoding

Find a file in your path

Execute AppleScript commands

Compare two files in BBEdit

Clean Attachments Folder

Get DNS Info

Hex Dump

Server Example

Introduction

This section gives some example code for using Perl to perform various fuctions. Unless otherwise stated, this code is in the Public Domain, which means you can use it for any purpose without and restrictions. If you do use it, I'd ask you to attribute me as the source and to let me know, but you do not have to do this. I work on Mac OS X so that tends to be where the files have been tested. I often make small changes to make them more suitable for publication, so I have not necessarily tested the exact code shown here - please let me know if I add any bugs or typos.

Installing Modules

You can install modules using CPAN:

sudo perl -MCPAN -e 'install MIME::Base64'

or more generally:

sudo perl -MCPAN -e shell
install MIME::Base64

Make a PDF from GIF images

I wanted to scan in an old newsletter and make it in to a PDF to publish it on the web. After scanning it in, I used GraphicConverter's Convert command to resize all the images and save them all as GIFs. Then I used this script to change a folder of GIFs into a PDF. The images were named like 01.gif, 02.gif etc to ensure the sorted pages would be in the right order.

use Image::Magick;
use warnings;
use strict;
my $dir = '/Users/peter/images';
my $pdffile = '/Users/peter/newsletter.pdf';
chdir( $dir ) or die "Cant chdir to $dir $!";
while( <*.gif> ) {
push @files, $_;
}
my $pdf = Image::Magick->new();
foreach $file ( sort @files ) {
my $img = Image::Magick->new();
$rc = $img->Read( $file );
warn $rc if $rc;
push @$pdf, $img;
}
$pdf->[0]->Coalesce();
$pdf->Write( $pdffile );

Make an animated GIF that rotates in the Z axis

This script takes an image and rotates it in the Z axis to form a spinning logo. I used it to create a spinning logo for Carey baptist College.

use Image::Magick;
use warnings;
use strict;
chdir( '/Users/peter/Documents/Carey' ) or die "cant chdir $!";
our $sourcefile = 'carey-image.eps';
our $destfile = 'carey-animation.gif';
our $PI = atan2(1,1) * 4;
my $rc;
my $source = Image::Magick->new();
$rc = $source->Read( $sourcefile );
warn $rc if $rc;
our $xsize = 70;
our $ysize = 40;
my $background = Image::Magick->new(size => $xsize.'x'.$ysize);
$rc = $background->Read('xc:white');
warn $rc if $rc;
my $animation = Image::Magick->new();
for (my $degrees = 0; $degrees < 360; $degrees += 10) {
my $angle = $degrees/180*$PI;
my $x = int($xsize * cos($angle));
$x++ if $x > 0 && (($x & 1) == 1);
$x-- if $x < 0 && (($x & 1) == 1);
$x = 2 if $x == 0;
my $y = $ysize;
my $scaled = $source->Clone();
if ( $x < 0 ) {
$rc = $scaled->Flop();
warn $rc if $rc;
$rc = $scaled->Flip();
warn $rc if $rc;
$x = -$x;
}
$rc = $scaled->Scale( width => $x, height => $y );
warn $rc if $rc;
my $img = $background->Clone();
$rc = $img->Composite( image => $scaled, x => (($xsize - $x)/2) );
push @$animation, $img;
}
$animation->[0]->Coalesce();
$animation->Set(delay => 10);
$animation->Write( $destfile );

Make Image Catalog

Rather than keep a disorganised pile of business cards, I tend to scan in business cards I receive, name them so I can find the people and store them in a folder. I used to use a cataloging program to view them, but since it was not Mac OS X compatible I just replaced it with an html file generated from the folder of images. I cheat in that I allow the web browser to "shrink"the images to thumb nail size rather than creating real thumb nail images - since I only view the file locally, the image size/loading time is not too relevent.

#!/usr/bin/perl
use Image::Magick;
use warnings;
use strict;
chdir( '/Users/peter/Business Cards/' ) or die "cant chdir $!";
open( OUT, ">0Catalog.html" ) or die "cant open out $!";
our $query = Image::Magick->new();
our @files = ();
while( <*> ) {
push @files, $_ unless /^\./ || /^0Catalog/;
}
our $colspan = 7;
our $maxsize = 96;
print OUT <<EOM;
<!doctype html public "-//W3C//DTD HTML 3.2//EN">
<html>
<head>
<meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1">
<meta http-equiv="generator" content="BBEdit and Perl">
<meta http-equiv="author" content="Peter N Lewis">
<title>Business Cards</title>
</head>
<table border=2><colgroup span="$colspan" width="132" align="center"><tr>
EOM
our $col = 0;
foreach my $file ( sort alphabetically @files ) {
$col++;
$col = 1, print OUT "</tr><tr>
" if $col == $colspan;
my ($width, $height, $size, $format) = $query->Ping($file);
die "Bad file $file" unless $width && $height;
#  my $img = Image::Magick->new();
#  $rc = $img->Read( $file );
#  warn $rc if $rc;
if( $width > $maxsize || $height > $maxsize ) {
my $scale;
if ( $width > $height ) {
$scale = $maxsize/$width;
} else {
$scale = $maxsize/$height;
}
$width = int( $width * $scale );
$height = int( $height * $scale );
}
print OUT <<EOM;
<td width=132>
<a href="$file"><img src="$file" alt="$file" width=$width height=$height></a><br>
<a href="$file">                      $file                              </a>
</td>
EOM
}
print OUT <<'EOM';
</tr></table>
</body>
</html>
EOM
sub alphabetically {
my ($aa, $bb) = ($a, $b);
$aa =~ tr/A-Z/a-z/;
$bb =~ tr/A-Z/a-z/;
return $aa cmp $bb;
}

Base64 Encoding

This is easily done using the MIME::Base64 module:

#!/usr/bin/perl
use MIME::Base64;
printf ("%s", encode_base64(eval "\"$ARGV[0]\""));

Find a file in your path

This little script finds where a file in your path, listing them all.

#!/usr/bin/perl
use warnings;
use strict;
our $path = $ENV{'PATH'};
for my $request (shift) {
for my $dir ( split( /:/,$path ) ) {
my $file = "$dir/$request";
print "$file
" if -e $file;
}
}

Execute AppleScript commands

See do_osa_script in Compare two files in BBEdit .

Compare two files in BBEdit

#!/usr/bin/perl
use warnings;
use strict;
use File::Spec::Unix;
my $file1 = shift or Usage();
my $file2 = shift or Usage();
compare_in_bbedit( $file1, $file2 );
sub Usage {
print STDERR "Usage: bbedit-compare.pl file1 file2
";
exit( 1 );
}
sub compare_in_bbedit {
my( $file1, $file2 ) = @_;
$file1 = File::Spec::Unix->rel2abs( $file1 );
$file2 = File::Spec::Unix->rel2abs( $file2 );
do_osa_script( <<EOM );
tell app "BBEdit"
compare POSIX file "$file1" against POSIX file "$file2"
activate
end tell
EOM
}
sub do_osa_script {
my( $script ) = @_;
my $fh;
open( $fh, "| /usr/bin/osascript >/dev/null" ) or die "cant open osascript $!";
print $fh $script;
close( $fh );
}

Clean Attachments Folder

Mac OS X is relatively immune to visus infections, however that does not stop PC users from filling up your Attachments Folder with virus infected files. This script looks through your Attachments Folder and dumps a list of shell commands to remove all the files. You can peruse the list and/or execute it by piping it to/bin/sh.

#!/usr/bin/perl
use strict;
use warnings;
our $attachments_dir = $ENV{'HOME'}."/Documents/Eudora Folder/Attachments Folder";
print "#!/bin/sh
";
my $where = $attachments_dir;
$where =~ s! !\\ !g;
print "cd $where
";
our %del;
chdir( $attachments_dir ) or die "cant chdir $!";
while (<*>) {
$del{$_} = 1 if /\.vcf( \d+)?$/i;
$del{$_} = 1 if /\.pif( \d+)?$/i;
$del{$_} = 1 if /\.bat( \d+)?$/i;
$del{$_} = 1 if /\.exe( \d+)?$/i;
$del{$_} = 1 if /\.scr( \d+)?$/i;
$del{$_} = 1 if /^dilbert.*\.gif( \d+)?$/i;
$del{$_} = 1 if /^message\.txt( \d+)?$/i;
$del{$_} = 1 if /^InterScan_Disclaimer\.txt( \d+)?$/i;
}
our $trash = "
";
$trash .= `grep -la 'This program cannot be run in DOS mode' *`;
$trash .= "
";
$trash .= `grep -la 'This program must be run under Win32' *`;
$trash .= "
";
$trash .= `grep -la 'JFIF.*Ducky.*Adobe' *`;
$trash .= "
";
if ( -e 'Untitled' ) {
$trash .= `grep -la '[-]--BEGIN PGP MESSAGE---' Untitled*`;
$trash .= "
";
$trash .= `grep -la '[-]--BEGIN PGP SIGNATURE---' Untitled*`;
$trash .= "
";
}
foreach my $file (split (/
/,$trash)) {
next unless $file =~ /./;
$del{$file} = 1 if -e $file;
}
foreach my $file (sort keys %del) {
print "rm \"$file\"
";
}

Get DNS Info

This script displays the IP associated with a DNS name (or vice versa).

#!/usr/bin/perl
use strict;
use warnings;
use Socket qw(AF_INET);
usage() if $#ARGV == -1;
display_info( @ARGV );
sub display_info {
foreach (shift) {
my ($ip, $host, $aliases, $addrtype, $length, @addrs);
$ip = $_;
if ( /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/ ) {
print "IP is $ip
";
($host, $aliases, $addrtype, $length, @addrs) =
gethostbyaddr( pack( 'C4', $1, $2, $3, $4 ), AF_INET );
die "Reverse lookup failed to find name for $ip
" unless $host;
}
$host = $ip unless $host;
print "Hostname is $host
";
($host, $aliases, $addrtype, $length, @addrs) = gethostbyname( $host );
die "Lookup failed to find address for $host
" unless @addrs;
print "Maps to these IPs:
";
foreach (@addrs) {
print "IP: ".join( '.', unpack( 'C4', $_ ) )."
";
}
}
}
sub usage {
print STDERR <<EOM;
Usage: getdnsinfo.pl <IP|host>...
Example `getdnsinfo.pl www.interarchy.com'
EOM
exit( 0 );
}

Hex Dump

This script dumps its input files in hex format.

#!/usr/bin/perl
# Written by Peter N Lewis a long time ago
# Released in to the Public Domain
# modified by Rudif c/o Perlmonks.org, to handle CRLF conversion
use strict;
use warnings;
usage() if $ARGV[0] and $ARGV[0] =~ m!^-[^-]!;
our $filepos = 0;
our $linechars = '';
foreach (@ARGV) {
if ($_ eq "-") {
binmode STDIN;
*FILE = *STDIN;
}
else {
open FILE, '<:raw', $_ or die "no such file $_";
}
while (<FILE>) {
dump_char($_) foreach split(//);
}
dump_char( ' ', 1 ) while length($linechars) != 0;
close FILE;
}
sub dump_char {
my ( $char, $blank ) = @_;
if ( length( $linechars ) == 0 ) {
printf( "%06X: ", $filepos );
}
$linechars .= ( $char =~ m#[!-~ ]# ) ? $char : '.';
if ( $blank ) {
print '   ';
} else {
printf( "%02X ", ord($char) );
}
print ' ' if length( $linechars ) % 4 == 0;
if ( length( $linechars ) == 16 ) {
print( $linechars, "
" );
$linechars = '';
$filepos += 16;
}
}
sub usage {
print STDERR <<EOM;
Usage: hdump.pl [file]...
Example `hdump.pl .cshrc' or `ls -l | hdump.pl'
EOM
exit( 0 );
}

Server Example

This is an example of using Socket and IO::Socket to write a single threaded server.

#!/usr/bin/perl
use Socket;
use IO::Socket;
$filebits = '';
OpenServer();
my $rout;
while( 1 ) {
print STDERR "Loop
";
select( undef, undef, undef, 1 );
select( $rout = $filebits, undef, undef, undef );
my $routs = unpack("b*", $rout);
print STDERR "Select $routs
";
my $pos = index( $routs,'1');
while ( $pos >= 0 ) {
HandleFile( $pos );
$pos = index( $routs,'1', $pos+1);
}
}
sub SendMessage {
local( $message ) = @_;
print STDERR "SendMessage $message
";
$message .= "\r
";
foreach $fileno (keys %connections) {
if ( $connections{$fileno} ) {
my $client = $connections{$fileno}{client};
print $client $message;
}
}
}
sub HandleFile {
local( $fileno ) = @_;
print STDERR "HandleFile $fileno
";
if ( $fileno == $server_fileno ) {
HandleServer();
} elsif ( $connections{$fileno} ) {
HandleClient( $fileno );
} else {
print STDERR "Weird fileno $fileno
";
}
}
sub HandleServer {
my $client = $server->accept();
print STDERR "HandleServer
";
if ( $client ) {
my $fileno = fileno($client);
$client->blocking(0);
$connections{$fileno}{client} = $client;
$connections{$fileno}{loggedin} = 0;
vec($filebits,$fileno,1) = 1;
print $client "Welcome $fileno\r
";
SendMessage( "New Client" );
} else {
print STDERR "No accept for server, reopen
";
CloseServer();
OpenServer();
}
}
sub HandleClient {
local( $fileno ) = @_;
print STDERR "HandleClient $fileno
";
recv( $connections{$fileno}{client}, $receive, 200, 0 );
if ( $receive ) {
my $line = $connections{$fileno}{receive};
$line .= $receive;
while ( $line =~ s/(.*)
// ) {
my $temp = $1;
$temp =~ tr/\r
//d;
SendMessage( $temp );
}
$connections{$fileno}{receive} = $line;
} else {
print STDERR "Close client $fileno
";
vec($filebits,$fileno,1) = 0;
$connections{$fileno}{client}->close();
undef $connections{$fileno};
SendMessage( "Close Client" );
}
}
sub CloseServer {
vec($filebits,$server_fileno,1) = 0;
$server->close();
undef $server;
}
sub OpenServer {
$server = IO::Socket::INET->new(Listen    => 5,
LocalPort => 3234,
Reuse => 1,
ReuseAddr => 1,
Timeout   => 0,
Proto     => 'tcp');
die "Could not create socket $!" unless $server;
$server->blocking(0);
$server_fileno = fileno($server);
vec($filebits,$server_fileno,1) = 1;
print STDERR "Starting $server_fileno
";
}