Kill All Octopuses

A blogging framework for hackers.

Testing a UNIX System With Perl the Cucumber Way

I’ve found that using systems like cucumber to be quite handy when testing software, and I was hoping for a lightweight Perl solution that I could run on my UNIX systems without having to install a bunch of dependancies.

Enter testadmin.pl.

The files are stored in this github gist with a couple of simple examples. One tests if a user is logged in:

1
2
3
As a silly system administrator
When I run who
Then user pblair must be logged in

In order to satisfy this test, we look in w.step

Example step file - w.step
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
our @output;

When qr{I run (\S.*)} => sub {
        my ($regex, $capture) = @_;
        @output = `$capture->[0]`;
        chomp for @output;
};

Then qr{user (\S+) must be logged in} => sub {
    my ($regex, $capture) = @_;
    my $user = $capture->[0];

    my @l = grep { /^$user/ } @output;

    die if scalar @l == 0;
    scalar @l;
};

We see that it captures the name of a user (supplied by the feature file) and checks the @output array for the given username. It returns the number of found users. The calling function will return a warning if we return 0, so as long as there’s 1 user, then this function will cause the hilighting of the definition file to be displayed as green.

Create Debian Package From Latest Perl Module

When writing Perl modules, it makes sense to pass the heavy lifting of the admin work off to established tools, namely MakeMaker, dh-make-perl and debuild.

I’ve written a couple of handler scripts that facilitate the auto building of packages from upstream HTTP source.

The first is the install latest script:

Create debian package from latest upstream
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
#/bin/bash

function die
{
        echo "$1"
        exit 1
}

get_latest.pl $1 |
while read PACKAGE
do
        cd /tmp
        wget $PACKAGE || die 'Could not get package'
        FN=$(echo $PACKAGE | awk -F\/ '{print $NF}')
        tar zxpvf $FN
        D=$(echo $FN | awk -F '.tar.gz' '{print $1}')
        cd $D || die "Could not cd to $D"
        perl Makefile.PL && make dist && make distclean
        ls -1 *.tar.gz  \
        | while read SOURCE
        do
          ORIG=$(echo $SOURCE | perl -lane 's/:/-/g; if( /((?:\S+?-)*(?:[A-Za-z]+))-(\d+.*?)\.tar\.gz/ ){ print "lib" . lc($1) . "-perl_" . "$2.orig.tar.gz";}')
          if [ ! -e ../$ORIG ]; then
            ln -s $SOURCE ../$ORIG
          fi
        done
        dh-make-perl && debuild -i -us -uc -b
done

# libpackage-from-git-perl_0.0003.orig.tar.gz,

This requires that the script get_latest.pl be present in the path.

Get the latest upstream
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
#!/usr/bin/perl
use strict;

#my $regex = 'http://slowpoke.internal.tucows.com/~pblair/perl/Tucows-OPS-Cloud-(\d+(?:\.\d+)).tar.gz';

my $WGET = `which wget` || die 'Must install either wget for this to work';
chomp $WGET;

die 'wget must be installed and in the PATH' if $WGET =~ /^\s*$/;

$WGET .= ' -O - 2>/dev/null';

@ARGV = map { /^http/ ? "$WGET $_ |" : $_ } @ARGV;

while ( <> ){
        chomp;

        s/#.*//g;

        next if /^\s*$/;

        next unless /^(\S+?):\/\//;

        my $regex = $_;

        my $versions = {};

        my @a = reverse( split( /\//, $regex ) );
        my $r = shift( @a );
        my $url = join( "/", reverse( @a ) );

        open( FD, "$WGET -O - $url 2>/dev/null |" );
        while( <FD> ){
                chomp;
                if( /a href="(.*?)"/ ){
                        my $link = $1;
                        if( $1 =~ /$r/ ){
                                $versions->{$1} = $link;
                        }
                }
        }

        my @latest = sort keys %$versions;

        print $url . "/" . $versions->{$latest[-1]} . "\n";
}

Which in turn requires that a regex file, or string be presented to it that looks like:

1
http://slowpoke.internal.tucows.com/~pblair/perl/Package-From-Git-(\d+(?:\.\d+)).tar.gz

Running:

1
package_latest.sh http://slowpoke.internal.tucows.com/~pblair/perl/bin/versions.regex

results in:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
Package-From-Git-0.0003/
Package-From-Git-0.0003/MANIFEST
Package-From-Git-0.0003/lib/
Package-From-Git-0.0003/lib/Package/
Package-From-Git-0.0003/lib/Package/From/
Package-From-Git-0.0003/lib/Package/From/Git.pm
Package-From-Git-0.0003/Makefile.PL
Package-From-Git-0.0003/META.yml
Checking if your kit is complete...
Looks good
Writing Makefile for Package::From::Git
Writing MYMETA.yml
rm -rf Package-From-Git-0.0003
/usr/bin/perl "-MExtUtils::Manifest=manicopy,maniread" \
      -e "manicopy(maniread(),'Package-From-Git-0.0003', 'best');"
mkdir Package-From-Git-0.0003
mkdir Package-From-Git-0.0003/lib
mkdir Package-From-Git-0.0003/lib/Package
mkdir Package-From-Git-0.0003/lib/Package/From
Generating META.yml
tar cvf Package-From-Git-0.0003.tar Package-From-Git-0.0003
Package-From-Git-0.0003/
Package-From-Git-0.0003/MANIFEST
Package-From-Git-0.0003/lib/
Package-From-Git-0.0003/lib/Package/
Package-From-Git-0.0003/lib/Package/From/
Package-From-Git-0.0003/lib/Package/From/Git.pm
Package-From-Git-0.0003/Makefile.PL
Package-From-Git-0.0003/META.yml
rm -rf Package-From-Git-0.0003
gzip --best Package-From-Git-0.0003.tar
rm -f \
    *.a core \
    core.[0-9] blib/arch/auto/Package/From/Git/extralibs.all \
    core.[0-9][0-9] Git.bso \
    pm_to_blib.ts core.[0-9][0-9][0-9][0-9] \
    MYMETA.yml Git.x \
     perl \
    tmon.out *.o \
    pm_to_blib blib/arch/auto/Package/From/Git/extralibs.ld \
    blibdirs.ts core.[0-9][0-9][0-9][0-9][0-9] \
    *perl.core core.*perl.*.? \
    Makefile.aperl perl \
    Git.def core.[0-9][0-9][0-9] \
    mon.out libGit.def \
    perlmain.c perl.exe \
    so_locations Git.exp
rm -rf \
    blib
mv Makefile Makefile.old > /dev/null 2>&1
rm -f \
    Makefile.old Makefile
rm -rf \
    Package-From-Git-0.0003
/usr/bin/perl "-MExtUtils::Manifest=fullcheck" -e fullcheck
Using META.yml
Found: Package-From-Git 0.0003 (libpackage-from-git-perl arch=all)
Using maintainer: Peter Blair <pblair@tucows.com>
Found docs:
Using rules: /usr/share/dh-make-perl/rules.dh7.tiny
**********
Copyright information incomplete!

Upstream copyright information could not be automatically determined.

If you are building this package for your personal use, you might disregard
this information; however, if you intend to upload this package to Debian
(or in general, if you plan on distributing it), you must look into the
complete copyright information.

The causes for this warning are:
Licensing information is present, but cannot be parsed
--- Done

Reading package lists... 0%

Reading package lists... 100%

Reading package lists... Done


Building dependency tree... 0%

Building dependency tree... 0%

Building dependency tree... 50%

Building dependency tree... 50%

Building dependency tree


Reading state information... 0%

Reading state information... 0%

Reading state information... Done

 dpkg-buildpackage -rfakeroot -D -us -uc -i -b
dpkg-buildpackage: export CFLAGS from dpkg-buildflags (origin: vendor): -g -O2 -fstack-protector --param=ssp-buffer-size=4 -Wformat -Wformat-security
dpkg-buildpackage: export CPPFLAGS from dpkg-buildflags (origin: vendor): -D_FORTIFY_SOURCE=2
dpkg-buildpackage: export CXXFLAGS from dpkg-buildflags (origin: vendor): -g -O2 -fstack-protector --param=ssp-buffer-size=4 -Wformat -Wformat-security
dpkg-buildpackage: export FFLAGS from dpkg-buildflags (origin: vendor): -g -O2
dpkg-buildpackage: export LDFLAGS from dpkg-buildflags (origin: vendor): -Wl,-Bsymbolic-functions -Wl,-z,relro
dpkg-buildpackage: source package libpackage-from-git-perl
dpkg-buildpackage: source version 0.0003-1
dpkg-buildpackage: source changed by Peter Blair <pblair@tucows.com>
 dpkg-source -i --before-build Package-From-Git-0.0003
dpkg-buildpackage: host architecture amd64
 fakeroot debian/rules clean
dh clean
   dh_testdir
   dh_auto_clean
   dh_clean
 debian/rules build
dh build
   dh_testdir
   dh_auto_configure
Checking if your kit is complete...
Looks good
Writing Makefile for Package::From::Git
Writing MYMETA.yml
   dh_auto_build
make[1]: Entering directory `/tmp/Package-From-Git-0.0003'
cp lib/Package/From/Git.pm blib/lib/Package/From/Git.pm
Manifying blib/man3/Package::From::Git.3pm
make[1]: Leaving directory `/tmp/Package-From-Git-0.0003'
   dh_auto_test
make[1]: Entering directory `/tmp/Package-From-Git-0.0003'
No tests defined for Package::From::Git extension.
make[1]: Leaving directory `/tmp/Package-From-Git-0.0003'
 fakeroot debian/rules binary
dh binary
   dh_testroot
   dh_prep
   dh_installdirs
   dh_auto_install
make[1]: Entering directory `/tmp/Package-From-Git-0.0003'
Manifying blib/man3/Package::From::Git.3pm
Installing /tmp/Package-From-Git-0.0003/debian/libpackage-from-git-perl/usr/share/perl5/Package/From/Git.pm
Installing /tmp/Package-From-Git-0.0003/debian/libpackage-from-git-perl/usr/share/man/man3/Package::From::Git.3pm
make[1]: Leaving directory `/tmp/Package-From-Git-0.0003'
   dh_install
   dh_installdocs
   dh_installchangelogs
   dh_installexamples
   dh_installman
   dh_installcatalogs
   dh_installcron
   dh_installdebconf
   dh_installemacsen
   dh_installifupdown
   dh_installinfo
   dh_pysupport
dh_pysupport: This program is deprecated, you should use dh_python2 instead. Migration guide: http://deb.li/dhs2p
   dh_installinit
   dh_installmenu
   dh_installmime
   dh_installmodules
   dh_installlogcheck
   dh_installlogrotate
   dh_installpam
   dh_installppp
   dh_installudev
   dh_installwm
   dh_installxfonts
   dh_installgsettings
   dh_bugfiles
   dh_ucf
   dh_lintian
   dh_gconf
   dh_icons
   dh_perl
   dh_usrlocal
   dh_link
   dh_compress
   dh_fixperms
   dh_installdeb
   dh_gencontrol
   dh_md5sums
   dh_builddeb
dpkg-deb: building package `libpackage-from-git-perl' in `../libpackage-from-git-perl_0.0003-1_all.deb'.
 dpkg-genchanges -b >../libpackage-from-git-perl_0.0003-1_amd64.changes
dpkg-genchanges: binary-only upload - not including any source code
 dpkg-source -i --after-build Package-From-Git-0.0003
dpkg-buildpackage: binary only upload (no source included)
Now running lintian...
W: libpackage-from-git-perl: new-package-should-close-itp-bug
W: libpackage-from-git-perl: copyright-contains-dh-make-perl-boilerplate
W: libpackage-from-git-perl: description-contains-dh-make-perl-template
Finished running lintian.

And now we have a new little debian package:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
$ ls -lart *.deb
-rw-r--r-- 1 pblair pblair 6456 Feb  6 11:11 libpackage-from-git-perl_0.0003-1_all.deb

$ dpkg -c libpackage-from-git-perl_0.0003-1_all.deb
drwxr-xr-x root/root         0 2013-02-06 11:11 ./
drwxr-xr-x root/root         0 2013-02-06 11:11 ./usr/
drwxr-xr-x root/root         0 2013-02-06 11:11 ./usr/share/
drwxr-xr-x root/root         0 2013-02-06 11:11 ./usr/share/perl5/
drwxr-xr-x root/root         0 2013-02-06 11:11 ./usr/share/perl5/Package/
drwxr-xr-x root/root         0 2013-02-06 11:11 ./usr/share/perl5/Package/From/
-rw-r--r-- root/root      3254 2013-02-05 10:57 ./usr/share/perl5/Package/From/Git.pm
drwxr-xr-x root/root         0 2013-02-06 11:11 ./usr/share/doc/
drwxr-xr-x root/root         0 2013-02-06 11:11 ./usr/share/doc/libpackage-from-git-perl/
-rw-r--r-- root/root      1738 2013-02-06 11:11 ./usr/share/doc/libpackage-from-git-perl/copyright
-rw-r--r-- root/root       151 2013-02-06 11:11 ./usr/share/doc/libpackage-from-git-perl/changelog.Debian.gz
drwxr-xr-x root/root         0 2013-02-06 11:11 ./usr/share/man/
drwxr-xr-x root/root         0 2013-02-06 11:11 ./usr/share/man/man3/
-rw-r--r-- root/root      2556 2013-02-06 11:11 ./usr/share/man/man3/Package::From::Git.3pm.gz

Parsing Domain Names Out of Emails

I’ve just written a Perl CPAN module called Net::Domain::Regex that can be used to parse free form text and extract a series of domain name matches that are broken down into their components.

Parse an email to discover all domains within the headers and body
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
#!/usr/bin/perl -w
use strict;
use Net::Domain::Regex;
use Data::Dumper;

my $r = Net::Domain::Regex->new;

my $email = do {
        local $/;
        open FD, "</tmp/google.email";
        <FD>;
};

# Filter out some of the domains from the headers etc.
my @results = grep { !($_->{tld} eq 'com' and $_->{domain} =~ /google|tucows|hostedemail/) } $r->match( $email );

# Map it so that we get the FQDN and the Domain name
my $r = {};
for( @results ){
        print $_->{match},"\n";
        $r->{$_->{domain} . "." . $_->{tld}}->{$_->{match}}++;
}

print "Parsed Domains:",Dumper( $r ),"\n";

This will result in the following:

Parse an email to discover all domains within the headers and body
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
pblair@T500:~$ perl bin/extract_domains.pl
"my" variable $r masks earlier declaration in same scope at bin/extract_domains.pl line 18.
google.trakken.com
google.trakken.com
webcindario.com
febf653bd95.webcindario.com
webcindario.com
febf653bd95.webcindario.com
Parsed Domains:$VAR1 = {
          'trakken.com' => {
                             'google.trakken.com' => 2
                           },
          'webcindario.com' => {
                                 'webcindario.com' => 2,
                                 'febf653bd95.webcindario.com' => 2
                               }
        };

killallhumans.ca - New Programming Blog

I’ve maintained a blog at petermblair.com which has grown to include a lot of programming examples, snippets, etc., but I felt that I wanted to have a place dedicated to programming without having to trim out all of the non programming stuff from my personal site (which I believe should remain to service my personal ‘brand’). As such, I’m starting a new blog here which will attempt to be strictly programming: Perl, Python, C++, etc.