├── test
├── log-ntl-cablemodem-stats
    ├── CableModemStats
    │   ├── bin
    │   │   └── app.pl
    │   ├── t
    │   │   ├── 001_base.t
    │   │   └── 002_index_route.t
    │   ├── public
    │   │   ├── favicon.ico
    │   │   ├── images
    │   │   │   ├── perldancer.jpg
    │   │   │   └── perldancer-bg.jpg
    │   │   ├── dispatch.cgi
    │   │   ├── dispatch.fcgi
    │   │   ├── 404.html
    │   │   ├── 500.html
    │   │   └── css
    │   │   │   ├── error.css
    │   │   │   └── style.css
    │   ├── MANIFEST.SKIP
    │   ├── views
    │   │   ├── index.tt
    │   │   ├── stat.tt
    │   │   └── layouts
    │   │   │   └── main.tt
    │   ├── environments
    │   │   ├── production.yml
    │   │   └── development.yml
    │   ├── MANIFEST
    │   ├── Makefile.PL
    │   ├── config.yml
    │   └── lib
    │   │   └── CableModemStats.pm
    ├── schema-sqlite3.sql
    ├── schema-mysql.sql
    ├── README.pod
    ├── cablemodemstats-munin
    └── log-ntl-cablemodem-stats
├── dnstiming
    ├── README
    └── dnstiming.pl
├── jobs-alert
    ├── README
    └── jobs-alert
├── mysqldump-backups
    ├── README
    └── mysqldump-backups
├── avoid-moo-reapage
    ├── README
    └── lambdamoo-auto
├── find-duplicate-files
    ├── README
    └── find-duplicate-files.pl
├── diffr
    ├── README
    └── diffr.pl
├── auto-name-incoming
    ├── README
    └── auto-name-incoming
├── minecraft-stats-reporting
    ├── README
    ├── player-stats
    ├── player-stats.pl
    ├── compare-player-stats
    └── MinecraftStatsParser.pm
├── mp3-rename
    ├── README
    └── mp3-rename
├── lottery-pick
    └── lottery-pick
├── nagios_network_errors
    ├── README
    └── nagios_network_errors
├── darts-scoring-practice
    ├── README
    └── dartscoringpractice
├── sh-planning-search
    └── README.md
├── log-vm-superhub-stats
    ├── schema-sqlite3.sql
    ├── schema-mysql.sql
    ├── README.pod
    └── cablemodemstats-munin
├── tagtrack
    ├── README
    └── tagtrack
├── html-table-dump
    ├── README.md
    └── html-table-dump
├── fetch-xdslstats
    ├── schema.sql
    ├── README.md
    └── fetch-xdslstats
├── irssi
    └── wincommandsfixer
    │   ├── README.pod
    │   └── wincommandsfixer.pl
├── countrykitchen-meals-export
    ├── README.md
    ├── meals-summary.tt
    └── test-data.json
├── dancer-init.d
    ├── README
    └── dancer
├── chart-strip-cli-grapher
    ├── README.pod
    └── graph
├── set-slack-status
    ├── README.md
    └── set-slack-status
├── nagios_sensors_check
    ├── README.pod
    └── nagios_sensors_check
├── bot-basicbot-modules
    ├── WelcomeMibbit.pm
    ├── SayFromQueue.pm
    ├── DancerLinks.pm
    ├── RateLimitUsers.pm
    └── GitHubPullRequests.pm
├── vine-queue-watcher
    ├── README.pod
    └── check-for-vine-items
├── backup-google-stuff
    ├── README
    └── backup-google-stuff.pl
├── education
    ├── sums.tmpl
    └── generate-maths-worksheet
├── rip-dvd-handbrake-cli
    └── README.pod
├── stevenage-rubbish-reminder
    ├── README
    └── rubbish-reminder
├── rsync-log-collate
    ├── README.pod
    └── rsync-log-collate
├── mpdutils
    └── mpd-now-playing
├── show-tags
    ├── show-tags
    └── README
├── luton-flight-monitor
    ├── README.pod
    └── flight-monitor
├── set-pyrus-hi3518-cam-datetime
    ├── README.md
    └── set-pyruscam-datetime
├── retag-by-filename
    ├── README
    └── retag-by-filename
├── xchat-plugins
    ├── README.pod
    ├── xchat-parse-netlink-msgs.pl
    └── xchat-parse-trivia-hints.pl
├── cpants-scores
    ├── cpants-scores
    └── README.pod
├── odyssey-bookings-to-gcal
    ├── README.pod
    └── odyssey-bookings-to-gcal
├── nagios_rdiffbackup_check
    ├── README.pod
    └── nagios_rdiffbackup_check
├── nagios_adaptec_raid_check
    ├── README.pod
    └── nagios_adaptec_raid_check
├── fortivpn-connect-scripts
    ├── connect-fortivpn
    └── get-vpn-password
├── wordle-solver
    ├── README.md
    └── wordle-hint
├── misc
    └── check-abbie-polo-shirt
├── photo-frame-populate
    └── photo-frame-populate
├── shdc-rubbish-scraper
    └── shdc-rubbish-scraper.js
├── minecraft-utils
    └── diamondratio.ts
├── nagios_smart_log
    ├── nagios_smart_log
    └── README.pod
├── munin_am2302_dht
    ├── am2302_dht
    └── README.pod
├── munin_db_query
    ├── munin_db_query
    └── README.pod
├── lagmeter-log-munin
    ├── lagmeter-log-munin
    └── check-lagmeter-log
├── tabulate
    ├── README
    └── tabulate
├── nagios_check_mysql_stats
    └── README.pod
├── get-rm-pro-temp-reading
    └── get-rm-pro-temp-reading
├── fse
    ├── fse-flight-to-flightplan
    └── monitor-fbo-availability
├── get-esp-temp-reading
    └── get-esp-temp-reading
├── nagios_check_process_stats
    └── README.pod
└── nagios_3ware_raid_check
    └── README.pod


/test:
--------------------------------------------------------------------------------
1 | Just testing GitHub hooks.
2 | 


--------------------------------------------------------------------------------
/log-ntl-cablemodem-stats/CableModemStats/bin/app.pl:
--------------------------------------------------------------------------------
1 | #!/usr/bin/env perl
2 | use Dancer;
3 | use CableModemStats;
4 | dance;
5 | 


--------------------------------------------------------------------------------
/dnstiming/README:
--------------------------------------------------------------------------------
1 | A simple script I created to compare DNS resolver performance between my local
2 | DNS servers and OpenDNS/Google.
3 | 


--------------------------------------------------------------------------------
/jobs-alert/README:
--------------------------------------------------------------------------------
1 | A quickly thrown together script to run from cron and nag me when
2 | there are job listings waiting to be approved.
3 | 


--------------------------------------------------------------------------------
/mysqldump-backups/README:
--------------------------------------------------------------------------------
1 | mysqldump-backups
2 | 
3 | Simple script to run from cron and back up all MySQL databases using mysqldump.
4 | 
5 | 
6 | 


--------------------------------------------------------------------------------
/log-ntl-cablemodem-stats/CableModemStats/t/001_base.t:
--------------------------------------------------------------------------------
1 | use Test::More tests => 1;
2 | use strict;
3 | use warnings;
4 | 
5 | use_ok 'CableModemStats';
6 | 


--------------------------------------------------------------------------------
/log-ntl-cablemodem-stats/CableModemStats/public/favicon.ico:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/bigpresh/misc-scripts/HEAD/log-ntl-cablemodem-stats/CableModemStats/public/favicon.ico


--------------------------------------------------------------------------------
/log-ntl-cablemodem-stats/CableModemStats/public/images/perldancer.jpg:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/bigpresh/misc-scripts/HEAD/log-ntl-cablemodem-stats/CableModemStats/public/images/perldancer.jpg


--------------------------------------------------------------------------------
/avoid-moo-reapage/README:
--------------------------------------------------------------------------------
1 | Log in to LambdaMOO, perform some actions, log out.
2 | 
3 | Run from cron periodically to ensure character doesn't get reaped if it hasn't
4 | been used for a while.
5 | 
6 | 


--------------------------------------------------------------------------------
/log-ntl-cablemodem-stats/CableModemStats/public/images/perldancer-bg.jpg:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/bigpresh/misc-scripts/HEAD/log-ntl-cablemodem-stats/CableModemStats/public/images/perldancer-bg.jpg


--------------------------------------------------------------------------------
/find-duplicate-files/README:
--------------------------------------------------------------------------------
1 | Loop through a directory and find duplicate
2 | files, based on the MD5 sum (therefore finding
3 | files with identical content even if their timestamp
4 | and attributes are different)
5 | 
6 | 


--------------------------------------------------------------------------------
/log-ntl-cablemodem-stats/CableModemStats/MANIFEST.SKIP:
--------------------------------------------------------------------------------
 1 | ^\.git\/
 2 | maint
 3 | ^tags$
 4 | .last_cover_stats
 5 | Makefile$
 6 | ^blib
 7 | ^pm_to_blib
 8 | ^.*.bak
 9 | ^.*.old
10 | ^t.*sessions
11 | ^cover_db
12 | ^.*\.log
13 | ^.*\.swp$
14 | 


--------------------------------------------------------------------------------
/log-ntl-cablemodem-stats/CableModemStats/views/index.tt:
--------------------------------------------------------------------------------
 1 | 
 2 | <h1>Select desired measurement to view</h1>
 3 | 
 4 | <ul>
 5 | [% FOREACH stat IN stat_types %]
 6 | <li><a href="/view/[% stat %]">[% stat %]</a></li>
 7 | [% END %]
 8 | 
 9 | 
10 | 
11 | 


--------------------------------------------------------------------------------
/diffr/README:
--------------------------------------------------------------------------------
1 | A recursive diff tool, with ability to filter files it looks at.
2 | 
3 | usage: diffr -s source -d dest [-p pattern]
4 | 
5 | if -p is given, we will only do the diff for filenames which match
6 | this pattern - this matches the full path, so a pattern of 'foo' will
7 | match 'foo.txt', '/home/foo/bar' etc. 
8 | 


--------------------------------------------------------------------------------
/auto-name-incoming/README:
--------------------------------------------------------------------------------
1 | Quick dirty script to watch a directory for new files and automagically
2 | move them to another directory, automatically naming them,
3 | 
4 | A useful trick for saving images from stock photo sites which are
5 | misconfigured so that the browser tries to save each image as download.php etc.
6 | 
7 | 
8 | 


--------------------------------------------------------------------------------
/minecraft-stats-reporting/README:
--------------------------------------------------------------------------------
 1 | Simple Perl scripts to parse the output of the Bukkit Stats plugin's web
 2 | interface
 3 | 
 4 | See http://dev.bukkit.org/bukkit-plugins/lolmewnstats/
 5 | 
 6 | Originally written to parse the stats from The-Wild at http://the-wild.tk/ but
 7 | should probably work elsewhere too.
 8 | 
 9 | 
10 | 


--------------------------------------------------------------------------------
/mp3-rename/README:
--------------------------------------------------------------------------------
 1 | 
 2 | mp3-rename
 3 | 
 4 | Rename MP3 files based on their tags.
 5 | 
 6 | Usage:
 7 | 
 8 |     mp3-rename [dir]
 9 | 
10 | If dir is not given, looks at files in current directory.
11 | 
12 | A list of proposed renames will be displayed, and you will be prompted whether
13 | to go ahead and perform them.
14 | 
15 | 
16 | 


--------------------------------------------------------------------------------
/minecraft-stats-reporting/player-stats:
--------------------------------------------------------------------------------
 1 | #!/usr/bin/env perl
 2 | 
 3 | use strict;
 4 | use 5.010;
 5 | 
 6 | use lib '.';
 7 | use MinecraftStatsParser;
 8 | 
 9 | use Data::Dump;
10 | 
11 | my $player_name = shift
12 |     or die "Usage: $0 playername";
13 | 
14 | say Data::Dump::dump(
15 |     MinecraftStatsParser::get_stats($player_name)
16 | );
17 | 
18 | 


--------------------------------------------------------------------------------
/log-ntl-cablemodem-stats/CableModemStats/t/002_index_route.t:
--------------------------------------------------------------------------------
 1 | use Test::More tests => 2;
 2 | use strict;
 3 | use warnings;
 4 | 
 5 | # the order is important
 6 | use CableModemStats;
 7 | use Dancer::Test;
 8 | 
 9 | route_exists [GET => '/'], 'a route handler is defined for /';
10 | response_status_is ['GET' => '/'], 200, 'response status is 200 for /';
11 | 


--------------------------------------------------------------------------------
/lottery-pick/lottery-pick:
--------------------------------------------------------------------------------
 1 | #!/usr/bin/perl
 2 | 
 3 | use strict;
 4 | 
 5 | my ($numbers, $max) = @ARGV;
 6 | $max     ||= 49;
 7 | $numbers ||= 6;
 8 | 
 9 | my %results;
10 | for (1..$numbers) {
11 |     my $pick = int(rand $max) + 1;
12 |     redo if $results{$pick}++;
13 | }
14 | 
15 | print "Your numbers: " . join(', ', sort { $a <=> $b } keys %results) . "\n";
16 | 
17 | 


--------------------------------------------------------------------------------
/nagios_network_errors/README:
--------------------------------------------------------------------------------
 1 | nagios_network_errors
 2 | 
 3 | A simple plugin for Nagios to monitor ifconfig's error counters and alert if the
 4 | error counters are increasing.
 5 | 
 6 | Usage: set it up in NRPE's config as per any other plugin.  Run the plugin
 7 | with --help for details on the options available.
 8 | 
 9 | 
10 | TODO: more documentation.
11 | 
12 | 
13 | 
14 | 


--------------------------------------------------------------------------------
/darts-scoring-practice/README:
--------------------------------------------------------------------------------
1 | A silly little script to practice quick mental arithmetic for darts scoring,
2 | which I rather suck at.
3 | 
4 | Unfortunately I've spent too much of my life with a computer in front of me to
5 | give me quick accurate answers, so when I chalk darts games, my mental
6 | arithmetic can be painfully slow.
7 | 
8 | This was a quick fun script knocked together to practice :)
9 | 


--------------------------------------------------------------------------------
/sh-planning-search/README.md:
--------------------------------------------------------------------------------
1 | # planning-search
2 | 
3 | Quick and dirty script to query my local council's planning search portal
4 | for recently-submitted planning applications in the local area, and email
5 | me if there are any new ones that the script hasn't emailed about before.
6 | 
7 | Could be improved and genericised, should take areas and recipients from config
8 | etc, but does the job for now!
9 | 


--------------------------------------------------------------------------------
/log-ntl-cablemodem-stats/CableModemStats/environments/production.yml:
--------------------------------------------------------------------------------
 1 | # configuration file for production environment
 2 | 
 3 | # only log warning and error messsages
 4 | log: "warning"
 5 | 
 6 | # log message to a file in logs/
 7 | logger: "file"
 8 | 
 9 | # don't consider warnings critical
10 | warnings: 0
11 | 
12 | # hide errors 
13 | show_errors: 0
14 | 
15 | # cache route resolution for maximum performance
16 | route_cache: 1
17 | 
18 | 


--------------------------------------------------------------------------------
/log-ntl-cablemodem-stats/CableModemStats/views/stat.tt:
--------------------------------------------------------------------------------
 1 | <h1>[% stat %]</h1>
 2 | 
 3 | 
 4 | <h2>Last hour</h2>
 5 | <img src="/graph/[% stat %]/hour/1">
 6 | 
 7 | <h2>Last 6 hours</h2>
 8 | <img src="/graph/[% stat %]/hour/6">
 9 | 
10 | <h2>Last 24 hours</h2>
11 | <img src="/graph/[% stat %]/hour/24">
12 | 
13 | <h2>Last week</h2>
14 | <img src="/graph/[% stat %]/week/1">
15 | 
16 | <h2>Last month</h2>
17 | <img src="/graph/[% stat %]/month/1">
18 | 
19 | 
20 | 
21 | 


--------------------------------------------------------------------------------
/log-vm-superhub-stats/schema-sqlite3.sql:
--------------------------------------------------------------------------------
 1 | CREATE TABLE stats (
 2 |     id INTEGER PRIMARY KEY,
 3 |     timestamp DATETIME DEFAULT CURRENT_TIMESTAMP,
 4 |     key VARCHAR,
 5 |     value VARCHAR
 6 | );
 7 | 
 8 | CREATE TABLE eventlog (
 9 |     id           INTEGER PRIMARY KEY,
10 |     timestamp    DATETIME DEFAULT CURRENT_TIMESTAMP,
11 |     first_time   VARCHAR,
12 |     last_time    VARCHAR,
13 |     priority     VARCHAR,
14 |     description  VARCHAR
15 | );
16 | 
17 | 


--------------------------------------------------------------------------------
/log-ntl-cablemodem-stats/schema-sqlite3.sql:
--------------------------------------------------------------------------------
 1 | CREATE TABLE stats (
 2 |     id INTEGER PRIMARY KEY,
 3 |     timestamp DATETIME DEFAULT CURRENT_TIMESTAMP,
 4 |     key VARCHAR,
 5 |     value VARCHAR
 6 | );
 7 | 
 8 | CREATE TABLE eventlog (
 9 |     id           INTEGER PRIMARY KEY,
10 |     timestamp    DATETIME DEFAULT CURRENT_TIMESTAMP,
11 |     first_time   VARCHAR,
12 |     last_time    VARCHAR,
13 |     priority     VARCHAR,
14 |     description  VARCHAR
15 | );
16 | 
17 | 


--------------------------------------------------------------------------------
/tagtrack/README:
--------------------------------------------------------------------------------
 1 | Set ID3 tags on MP3 files.
 2 | 
 3 | Options:
 4 | 
 5 | --track, --title, --artist, --album, --comment
 6 |     Set the specified IDv3 tags on each file.
 7 | 
 8 | --verbose / -v
 9 |     Be verbose.
10 | 
11 | --dry-run / --dryrun / -d
12 |     Just report what we would have done, don't do it.
13 | 
14 | 
15 | Examples:
16 | 
17 | To set the artist tag for all MP3s in the current directory:
18 | 
19 | tagtrack --artist 'Some Great Band' *.mp3
20 | 
21 | 
22 | 


--------------------------------------------------------------------------------
/html-table-dump/README.md:
--------------------------------------------------------------------------------
 1 | # html-table-dump
 2 | 
 3 | A quick Perl script to take either an URL to fetch or some HTML on STDIN, and
 4 | dump details of all tables found by
 5 | [HTML::TableExtract](https://metacpan.org/pod/HTML::TableExtract)
 6 | 
 7 | Useful when scraping data from tables, and you want a quick view of what's
 8 | there.
 9 | 
10 | Output is JSON, with details of each table, the "coordinates" (depth and count),
11 | and the rows of the table.
12 | 
13 | Leading and trailing whitespace is stripped from each cell.
14 | 


--------------------------------------------------------------------------------
/log-ntl-cablemodem-stats/CableModemStats/views/layouts/main.tt:
--------------------------------------------------------------------------------
 1 | <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
 2 |         "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
 3 | <html xmlns="http://www.w3.org/1999/xhtml">
 4 | <head>
 5 | <meta http-equiv="Content-type" content="text/html; charset=<% settings.charset %>" />
 6 | <title>CableModemStats</title>
 7 | <link rel="stylesheet" href="<% request.uri_base %>/css/style.css" />
 8 | 
 9 | </head>
10 | <body>
11 | [% content %]
12 | </body>
13 | </html>
14 | 


--------------------------------------------------------------------------------
/log-ntl-cablemodem-stats/CableModemStats/public/dispatch.cgi:
--------------------------------------------------------------------------------
 1 | #!/usr/bin/env perl
 2 | use Dancer ':syntax';
 3 | use FindBin '$RealBin';
 4 | use Plack::Runner;
 5 | 
 6 | # For some reason Apache SetEnv directives dont propagate
 7 | # correctly to the dispatchers, so forcing PSGI and env here 
 8 | # is safer.
 9 | set apphandler => 'PSGI';
10 | set environment => 'production';
11 | 
12 | my $psgi = path($RealBin, '..', 'bin', 'app.pl');
13 | die "Unable to read startup script: $psgi" unless -r $psgi;
14 | 
15 | Plack::Runner->run($psgi);
16 | 


--------------------------------------------------------------------------------
/fetch-xdslstats/schema.sql:
--------------------------------------------------------------------------------
 1 | CREATE TABLE xdslstats (
 2 |     timestamp TIMESTAMP DEFAULT NOW(),
 3 |     router     VARCHAR(255),
 4 |     status     VARCHAR(255),
 5 |     training   VARCHAR(255),
 6 |     rate_up    FLOAT,
 7 |     rate_down  FLOAT,
 8 |     snr_up     FLOAT,
 9 |     snr_down   FLOAT,
10 |     power_up   FLOAT,
11 |     power_down FLOAT,
12 |     attn_up    FLOAT,
13 |     attn_down  FLOAT,
14 |     crc_up_per_sec FLOAT,
15 |     crc_down_per_sec FLOAT,
16 |     fec_up_per_sec FLOAT,
17 |     fec_down_per_sec FLOAT
18 | );
19 | 
20 | 


--------------------------------------------------------------------------------
/irssi/wincommandsfixer/README.pod:
--------------------------------------------------------------------------------
 1 | =head1 wincommandsfixer.pl
 2 | 
 3 | A Perl script for Irssi, to catch typo'd C</win> commands and DTRT.
 4 | 
 5 | Too many times, I've accidentally sent e.g. C<win 22> to a channel, when I meant
 6 | to use the command C</win 22> to switch windows.
 7 | 
 8 | This script catches these typos, stops the signal so it doesn't get sent to the
 9 | channel, and executes the desired window switch command for you instead.
10 | 
11 | =head1 AUTHOR
12 | 
13 | David Precious (BIGPRESH) C<< <davidp@preshweb.co.uk> >>
14 |  
15 | 


--------------------------------------------------------------------------------
/log-vm-superhub-stats/schema-mysql.sql:
--------------------------------------------------------------------------------
 1 | CREATE TABLE stats (
 2 |     id int(11)    NOT NULL AUTO_INCREMENT PRIMARY KEY,
 3 |     `timestamp`   TIMESTAMP DEFAULT CURRENT_TIMESTAMP,
 4 |     `key`         VARCHAR(200),
 5 |     `value`       VARCHAR(200)
 6 | );
 7 | 
 8 | CREATE TABLE eventlog (
 9 |     id int(11)    NOT NULL AUTO_INCREMENT PRIMARY KEY,
10 |     `timestamp`   TIMESTAMP DEFAULT CURRENT_TIMESTAMP,
11 |     `first_time`  VARCHAR(200),
12 |     `last_time`   VARCHAR(200),
13 |     `priority`    VARCHAR(200),
14 |     `description` VARCHAR(250)
15 | );
16 | 


--------------------------------------------------------------------------------
/log-ntl-cablemodem-stats/schema-mysql.sql:
--------------------------------------------------------------------------------
 1 | CREATE TABLE stats (
 2 |     id int(11)    NOT NULL AUTO_INCREMENT PRIMARY KEY,
 3 |     `timestamp`   TIMESTAMP DEFAULT CURRENT_TIMESTAMP,
 4 |     `key`         VARCHAR(200),
 5 |     `value`       VARCHAR(200)
 6 | );
 7 | 
 8 | CREATE TABLE eventlog (
 9 |     id int(11)    NOT NULL AUTO_INCREMENT PRIMARY KEY,
10 |     `timestamp`   TIMESTAMP DEFAULT CURRENT_TIMESTAMP,
11 |     `first_time`  VARCHAR(200),
12 |     `last_time`   VARCHAR(200),
13 |     `priority`    VARCHAR(200),
14 |     `description` VARCHAR(250)
15 | );
16 | 


--------------------------------------------------------------------------------
/log-ntl-cablemodem-stats/CableModemStats/MANIFEST:
--------------------------------------------------------------------------------
 1 | MANIFEST
 2 | bin/app.pl
 3 | config.yml
 4 | environments/development.yml
 5 | environments/production.yml
 6 | views/index.tt
 7 | views/layouts/main.tt
 8 | MANIFEST.SKIP
 9 | lib/CableModemStats.pm
10 | public/css/style.css
11 | public/css/error.css
12 | public/images/perldancer-bg.jpg
13 | public/images/perldancer.jpg
14 | public/500.html
15 | public/404.html
16 | public/dispatch.fcgi
17 | public/favicon.ico
18 | public/dispatch.cgi
19 | public/javascripts/jquery.js
20 | t/002_index_route.t
21 | t/001_base.t
22 | Makefile.PL
23 | 


--------------------------------------------------------------------------------
/minecraft-stats-reporting/player-stats.pl:
--------------------------------------------------------------------------------
 1 | #!/usr/bin/env perl
 2 | 
 3 | use strict;
 4 | use 5.010;
 5 | use CGI;  # yeah, I know!
 6 | use JSON;
 7 | 
 8 | use lib '.';
 9 | use MinecraftStatsParser;
10 | 
11 | use Data::Dump;
12 | print "Content-Type: application/json\n\n";
13 | 
14 | my $cgi = CGI->new;
15 | if (my $player_name = $cgi->param('player')) {
16 |     say JSON::to_json(
17 |         MinecraftStatsParser::get_stats($player_name)
18 |     );
19 | } else {
20 |     say JSON::to_json(
21 |         { error => "Player name not supplied" }
22 |     );
23 | }
24 | 
25 | 
26 | 


--------------------------------------------------------------------------------
/log-ntl-cablemodem-stats/CableModemStats/public/dispatch.fcgi:
--------------------------------------------------------------------------------
 1 | #!/usr/bin/env perl
 2 | use Dancer ':syntax';
 3 | use FindBin '$RealBin';
 4 | use Plack::Handler::FCGI;
 5 | 
 6 | # For some reason Apache SetEnv directives dont propagate
 7 | # correctly to the dispatchers, so forcing PSGI and env here 
 8 | # is safer.
 9 | set apphandler => 'PSGI';
10 | set environment => 'production';
11 | 
12 | my $psgi = path($RealBin, '..', 'bin', 'app.pl');
13 | my $app = do($psgi);
14 | die "Unable to read startup script: $@" if $@;
15 | my $server = Plack::Handler::FCGI->new(nproc => 5, detach => 1);
16 | 
17 | $server->run($app);
18 | 


--------------------------------------------------------------------------------
/log-ntl-cablemodem-stats/CableModemStats/public/404.html:
--------------------------------------------------------------------------------
 1 | <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
 2 |         "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
 3 | <html>
 4 | <head>
 5 | <title>Error 404</title>
 6 | <link rel="stylesheet" href="/css/error.css" />
 7 | <meta http-equiv="Content-type" content="text/html; charset=UTF-8" />
 8 | </head>
 9 | <body>
10 | <h1>Error 404</h1>
11 | <div id="content">
12 | <h2>Page Not Found</h2><p>Sorry, this is the void.</p>
13 | </div>
14 | <div id="footer">
15 | Powered by <a href="http://perldancer.org/">Dancer</a> 1.3071
16 | </div>
17 | </body>
18 | </html>


--------------------------------------------------------------------------------
/log-ntl-cablemodem-stats/CableModemStats/public/500.html:
--------------------------------------------------------------------------------
 1 | <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
 2 |         "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
 3 | <html>
 4 | <head>
 5 | <title>Error 500</title>
 6 | <link rel="stylesheet" href="/css/error.css" />
 7 | <meta http-equiv="Content-type" content="text/html; charset=UTF-8" />
 8 | </head>
 9 | <body>
10 | <h1>Error 500</h1>
11 | <div id="content">
12 | <h2>Internal Server Error</h2><p>Wooops, something went wrong</p>
13 | </div>
14 | <div id="footer">
15 | Powered by <a href="http://perldancer.org/">Dancer</a> 1.3071
16 | </div>
17 | </body>
18 | </html>


--------------------------------------------------------------------------------
/countrykitchen-meals-export/README.md:
--------------------------------------------------------------------------------
 1 | # What?
 2 | 
 3 | Logs in to the parents section of the www.acountrykitchen.co.uk school meals
 4 | provider's website, and scrapes the list of ordered meals for each child for
 5 | each week.
 6 | 
 7 | # Why?
 8 | 
 9 | Their website lets you view the meals ordered for a specific child for a
10 | specific week, but doesn't let you get a higher-level view of the next few
11 | week's meals for each child at a glance - the kind of thing you might want to be
12 | able to view quickly to see what days packed lunches are required, or what to do
13 | for dinner that they won't have had at lunch, etc.
14 | 
15 | 
16 | 


--------------------------------------------------------------------------------
/countrykitchen-meals-export/meals-summary.tt:
--------------------------------------------------------------------------------
 1 | <table border="1" padding="2">
 2 | <tr>
 3 | <th>Date</th>
 4 | [% FOREACH child IN children %]
 5 | <th>[% child %]</th>
 6 | [% END %]
 7 | </tr>
 8 | 
 9 | 
10 | [% FOREACH date IN meals.keys.sort %]
11 | 
12 | [%
13 |   # if this is a Monday, and not the first entry, then add a separator
14 |   IF date_to_display.$date.match('Monday') AND !loop.first %]
15 | <tr><td colspan="3"> --- </td></tr>
16 | [% END %]
17 | <tr>
18 | <td>[% date_to_display.$date %]</td>
19 | [% FOREACH child IN children %]
20 | <td>[% meals.$date.$child || "PACKED LUNCH" %]</td>
21 | [% END %]
22 | </tr>
23 | [% END %]
24 | 
25 | </table>
26 | 
27 | 


--------------------------------------------------------------------------------
/dancer-init.d/README:
--------------------------------------------------------------------------------
 1 | A simple way to run Dancer applications  under Starman on Debian machines.
 2 | 
 3 | This was cobbled together for me own use, but I've put it here in case it's
 4 | useful to others.
 5 | 
 6 | Usage:
 7 | 
 8 |  - copy 'dancer'  to /etc/init.d and make it executable
 9 | 
10 |  - run update-rc.d dancer defaults
11 |    (This sets up symlinks to start/stop apps at boot/shutdown)
12 | 
13 |  - mkdir /etc/dancer
14 |    (This dir contains app config files)
15 | 
16 |  - in /etc/dancer, create a file for each app, one per line, containing:
17 | DIR=/path/to/myapp
18 | SCRIPT=bin/app.pl
19 | USER=davidp
20 | PORT=5000  
21 | PIDFILE=/var/run/site-$SITENAME.pid
22 | 
23 | 
24 | 


--------------------------------------------------------------------------------
/chart-strip-cli-grapher/README.pod:
--------------------------------------------------------------------------------
 1 | =head1 Chart::Strip CLI graphing tool
 2 | 
 3 | A quick Perl script using L<Chart::Strip> to chart time-based data piped in 
 4 | on STDIN.
 5 | 
 6 | Reads data from STDIN, one reading per line, timestamp and value separated by a
 7 | pipe, e.g.:
 8 | 
 9 |     1328054640|0.109
10 |     1328054880|0.13455
11 |     1328054940|0.1589
12 | 
13 | Can be given command line options to override the defaults to set the graph
14 | size, output file, title, etc.
15 | 
16 | See the script for full details.
17 | 
18 | =head1 AUTHOR
19 | 
20 | David Precious C<< <davidp@preshweb.co.uk> >>
21 | 
22 | =head1 LICENCE
23 | 
24 | Released under the terms of the WTFPL.
25 | 
26 | 
27 | 
28 | 
29 | 


--------------------------------------------------------------------------------
/set-slack-status/README.md:
--------------------------------------------------------------------------------
 1 | # set-slack-status
 2 | 
 3 | A simple Perl script to update status on Slack.
 4 | 
 5 | Takes a legacy Slack token:
 6 | https://api.slack.com/legacy/custom-integrations/legacy-tokens
 7 | 
 8 | Sadly the ability to generate those is going away soon, and you instead have to
 9 | create a Slack app and stuff.
10 | 
11 | Set an entry in `~/.netrc` for `machine slack.com` with the `account` set to
12 | your Slack legacy API token.
13 | 
14 | You can then run the script to set your status, optionally with an emoji as
15 | the first argument.
16 | 
17 | ## Examples
18 | 
19 | ./set-slack-status :beers: "It's time for beer!"
20 | ./set-slack-status :clown_face: "Talking to THG"
21 | ./set-slack-status "Just text, no silly emojis here"
22 | 
23 | 


--------------------------------------------------------------------------------
/nagios_sensors_check/README.pod:
--------------------------------------------------------------------------------
 1 | =head1 nagios_sensors_check
 2 | 
 3 | =head2 SYNOPSIS
 4 | 
 5 |     ./nagios_sensors_check --sensor 'CPU Temp:0:60' --sensor 'fan1:1000:8000'
 6 | 
 7 | =head2 DESCRIPTION
 8 | 
 9 | A simple Nagios plugin to monitor selected hardware sensors values
10 | (temperatures, fan speeds, voltages) from the output of the lm_sensors
11 | C<sensors> utility.
12 | 
13 | Allows you to select only the readings you want to monitor, and easily set
14 | acceptable thresholds.
15 | 
16 | Avoids the headache of configuring lm_sensors to use sensible thresholds and
17 | alarms.
18 | 
19 | Also, provides useful information so you can see what the values are, rather
20 | than just "ok" or "alarm", as the standard Nagios C<check_sensors> plugin seems
21 | to provide.
22 | 
23 | 
24 | 
25 | 


--------------------------------------------------------------------------------
/bot-basicbot-modules/WelcomeMibbit.pm:
--------------------------------------------------------------------------------
 1 | package Bot::BasicBot::Pluggable::Module::WelcomeMibbit;
 2 | use strict;
 3 | use base 'Bot::BasicBot::Pluggable::Module';
 4 | 
 5 | 
 6 | sub help {
 7 |     return <<HELPMSG
 8 | Customised welcome to Mibbit users.
 9 | 
10 | Invites them to change their nick and ask for any help they need.
11 | HELPMSG
12 | }
13 | 
14 | sub chanjoin {
15 |     my ($self, $mess, $pri) = @_;
16 |     
17 |     if ($mess->{who} =~ /^mib_/) {
18 |         $self->say(
19 |             channel => $mess->{channel},
20 |             body => "Welcome $mess->{who}!  Feel free to use /nick yournickhere"
21 |                 . " to select a nicer nick.  If you need any help, ask away"
22 |                 . " - there's usually someone around to help.");
23 |     }
24 | }
25 | 
26 | 1;
27 | 


--------------------------------------------------------------------------------
/vine-queue-watcher/README.pod:
--------------------------------------------------------------------------------
 1 | =head1 vine-queue-watcher
 2 | 
 3 | A simple script to fetch the list of reviewable products from Amazon's Vine, and
 4 | send an email when any new items are found.
 5 | 
 6 | Expects your Amazon account details to be in C<~/.netrc> under machine
 7 | C<www.amazon.co.uk>, and sends the email to the username given (which should be
 8 | your Amazon account's email address).
 9 | 
10 | =head1 DB Schema
11 | 
12 | To keep track of which items have already been seen, so it can email only when
13 | new items are found for the first time, it uses a database; it has been written
14 | to use MySQL and take your connection details from C<~/.my.cnf>.
15 | 
16 | There should be a table named C<vine_products_seen> with a schema containing, at
17 | a minimum, a column named C<asin>; a timestamp column could be added should you
18 | wish.
19 | 


--------------------------------------------------------------------------------
/mysqldump-backups/mysqldump-backups:
--------------------------------------------------------------------------------
 1 | #!/usr/bin/perl
 2 | 
 3 | # Basic MySQL backups - dumps all databases to text files with mysqldump.
 4 | # Intended to be run from root's crontab, with DB auth details in root's .my.cnf
 5 | # file.
 6 | 
 7 | use strict;
 8 | use DirHandle;
 9 | use DateTime;
10 | 
11 | my $mysql_data_dir = '/var/lib/mysql';
12 | my $backups_dir = '/var/backups/sql';
13 | 
14 | 
15 | my $dirh = new DirHandle $mysql_data_dir
16 |     or die "Failed to read mysql data directory $mysql_data_dir - $!";
17 | 
18 | while (my $dbname = $dirh->read) {
19 |     next if (! -d "$mysql_data_dir/$dbname");
20 |     next if ($dbname eq '.' || $dbname eq '..');
21 |     print "Need to back up $dbname\n";
22 |     my $dt = DateTime->now;
23 |     my $datetime = $dt->ymd . '_' . $dt->hms;
24 |     `mysqldump -icf  $dbname > $backups_dir/$dbname-$datetime.sql`;
25 | }
26 | 


--------------------------------------------------------------------------------
/log-ntl-cablemodem-stats/CableModemStats/Makefile.PL:
--------------------------------------------------------------------------------
 1 | use strict;
 2 | use warnings;
 3 | use ExtUtils::MakeMaker;
 4 | 
 5 | WriteMakefile(
 6 |     NAME                => 'CableModemStats',
 7 |     AUTHOR              => q{YOUR NAME <youremail@example.com>},
 8 |     VERSION_FROM        => 'lib/CableModemStats.pm',
 9 |     ABSTRACT            => 'YOUR APPLICATION ABSTRACT',
10 |     ($ExtUtils::MakeMaker::VERSION >= 6.3002
11 |       ? ('LICENSE'=> 'perl')
12 |       : ()),
13 |     PL_FILES            => {},
14 |     PREREQ_PM => {
15 |         'Test::More' => 0,
16 |         'YAML'       => 0,
17 |         'Dancer'     => 1.3071,
18 |         'Dancer::Plugin::Database' => 1.50,
19 |         'Chart::Strip' => 1.08,
20 |     },
21 |     dist                => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', },
22 |     clean               => { FILES => 'CableModemStats-*' },
23 | );
24 | 


--------------------------------------------------------------------------------
/backup-google-stuff/README:
--------------------------------------------------------------------------------
 1 | backup-google-stuff.pl
 2 | 
 3 | A quick and dirty script I use to back up stuff from my Google account
 4 | (contacts, calendar, Google Reader subscriptions).
 5 | 
 6 | I figured I should share this after discussions on Twitter about backing up
 7 | stuff stored with Google, in case it's of help to others.
 8 | 
 9 | It's a Perl script that logs in to Google and exports stuff via Google's export
10 | mechanisms.
11 | 
12 | It's fairly basic as I just rocked it up for my own use, but I may extend it in
13 | future, make it easier to configure and use, and perhaps add support for backing
14 | up other Google-hosted data (Google Plus, perhaps).
15 | 
16 | See also https://github.com/kript/GoogleStuff - a reworked version of this
17 | script with more flexibility by Kript - http://www.kript.net/wordpress/?p=667
18 | 
19 | David Precious <davidp@preshweb.co.uk>
20 | 
21 | 
22 | 


--------------------------------------------------------------------------------
/education/sums.tmpl:
--------------------------------------------------------------------------------
 1 | <html>
 2 | <head>
 3 | <title>Randomly-generated maths worksheet</title>
 4 | 
 5 | <style>
 6 | BODY {
 7 |     font-family: Verdana, Arial, sans-serif;
 8 |     size: 16px;
 9 | }
10 | 
11 | .sum {
12 |     padding: 10px 50px 50px 10px;
13 |     margin: 10px;
14 |     border: 1px solid blue;
15 |     width: 150px;
16 |     float: left;
17 |     text-align: right;
18 |     font-size: 24px;
19 |     font-weight: bold;
20 | }
21 | .operator {
22 |     font-size: 28px;
23 | }
24 | .sum HR {
25 |     width: 50%;
26 |     float: right;
27 | }
28 | </style>
29 | </head>
30 | <body>
31 | 
32 | [% FOREACH sum IN sums %]
33 | <div class="sum">
34 | <span class="operand">[% sum.operand1 %]</span><br />
35 | <span class="operator">[% sum.operator %]</span><br />
36 | <span class="operand">[% sum.operand2 %]</span><br />
37 | <hr>
38 | </div>
39 | [% END %]
40 | 
41 | </body>
42 | </html>
43 | 


--------------------------------------------------------------------------------
/rip-dvd-handbrake-cli/README.pod:
--------------------------------------------------------------------------------
 1 | =head1 rip-dvd-handbrakecli
 2 | 
 3 | My simple command-line DVD ripping script, designed for ripping TV box set
 4 | discs.
 5 | 
 6 | Uses HandBrakeCLI to parse the disc to get the list of titles and chapters,
 7 | works out whether it looks like the disc uses one title per episode, or one
 8 | title where each chapter is an episode, and then rips each episode to a separate
 9 | file, numbered e.g. C<S01E01.mp4>.
10 | 
11 | Needs a lot more polishing, and proper argument parsing via Getopt or similar.
12 | 
13 | For now, it takes only one argument, the season number:
14 | 
15 |   ./rip-dvd-handbrakecli 1
16 | 
17 | Files are written to the current working directory (so cd to the directory you
18 | want them in then run it; at some point I plan to polish it up so you can give
19 | it args to specify an output dir, control the quality etc.
20 | 
21 | =head1 AUTHOR
22 | 
23 | David Precious C<< <davidp@preshweb.co.uk> >>
24 | 


--------------------------------------------------------------------------------
/irssi/wincommandsfixer/wincommandsfixer.pl:
--------------------------------------------------------------------------------
 1 | #!/usr/bin/env perl
 2 | #
 3 | # A simple script to stop me accidentally saying e.g. "win 22" in channels, when
 4 | # I meant to use the command /win 22.
 5 | # Stops it being sent, and just switches window for you.
 6 | 
 7 | use strict;
 8 | use vars qw($VERSION %IRSSI);
 9 | 
10 | use Irssi;
11 | $VERSION = '1.00';
12 | %IRSSI = (
13 |     authors     => 'David Precious',
14 |     contact     => 'davidp@preshweb.co.uk',
15 |     name        => '/win commands typo fixer',
16 |     description => 'Catch typoed /win commands (e.g. "win 6") ',
17 |     license     => 'Public Domain',
18 | );
19 | 
20 | 
21 | sub sig_send_text {
22 |     my ($line, $server, $witem) = @_;
23 | 
24 |     return if $witem->{type} !~ /^(CHANNEL|QUERY)$/;
25 | 
26 |     if (my($win_num) = $line =~ /^win (\d+)/) {
27 |         $server->window_item_find($witem->{name})->command("win $win_num");
28 |         Irssi::signal_stop();
29 |     }
30 | }
31 | 
32 | Irssi::signal_add('send text', 'sig_send_text');
33 | 


--------------------------------------------------------------------------------
/log-ntl-cablemodem-stats/CableModemStats/environments/development.yml:
--------------------------------------------------------------------------------
 1 | # configuration file for development environment
 2 | 
 3 | # the logger engine to use
 4 | # console: log messages to STDOUT (your console where you started the
 5 | #          application server)
 6 | # file:    log message to a file in log/
 7 | logger: "console"
 8 | 
 9 | # the log level for this environement
10 | # core is the lowest, it shows Dancer's core log messages as well as yours
11 | # (debug, warning and error)
12 | log: "core"
13 | 
14 | # should Dancer consider warnings as critical errors?
15 | warnings: 1
16 | 
17 | # should Dancer show a stacktrace when an error is caught?
18 | show_errors: 1
19 | 
20 | # auto_reload is a development and experimental feature
21 | # you should enable it by yourself if you want it
22 | # Module::Refresh is needed 
23 | # 
24 | # Be aware it's unstable and may cause a memory leak.
25 | # DO NOT EVER USE THAT FEATURE IN PRODUCTION 
26 | # OR TINY KITTENS SHALL DIE WITH LOTS OF SUFFERING
27 | auto_reload: 0
28 | 


--------------------------------------------------------------------------------
/stevenage-rubbish-reminder/README:
--------------------------------------------------------------------------------
 1 | =head1 rubbish-reminder
 2 | 
 3 | This is likely only of use for Stevenage residents.
 4 | 
 5 | Consults the L<stevenage.gov.uk|http://www.stevenage.gov.uk> website, and checks
 6 | when the next rubbish/recycling collection is, and sends a notification to my
 7 | phone using NotifyMyAndroid L<https://www.notifymyandroid.com/>.
 8 | 
 9 | =head2 Configuration
10 | 
11 | Uses L<Config::Auto> to parse config.
12 | 
13 | Dump the following into C<~/.rubbish-reminderrc> or any of the other filenames
14 | that Config::Auto would look for:
15 | 
16 |     nma_key: ...your NMA API key...
17 |     house_num: 1
18 |     postcode: TE57 1NG
19 | 
20 | (Obviously replacing the fake details with real ones)
21 | 
22 | It will find out your next collection date and the type, and, if the next
23 | collection date is tomorrow, send a notification via NMA.  It's intended to be
24 | used as a cron job in the evenings.
25 | 
26 | *NOTE*: The stevenage.gov.uk webform is specific in it's postcode search. You
27 | /must/ include the space in the postcode or it won't find your address.
28 | 
29 | 


--------------------------------------------------------------------------------
/rsync-log-collate/README.pod:
--------------------------------------------------------------------------------
 1 | =head1 rsync-log-collate
 2 | 
 3 | A simple script to process an rsync log file on STDIN, collate the log entries
 4 | by connection (using a combination of PID and remote hostname), then output
 5 | each one, so all lines for a given connection are togther rather than all 
 6 | interspersed.
 7 | 
 8 | =head2 USAGE
 9 | 
10 | Simply pipe rsync logs into the script's STDIN:
11 | 
12 |     cat rsync.log | ./rsync-log-collate
13 | 
14 | If you only want log entries for a certain host, supply the hostname as the
15 | script's C<--only-host> argument:
16 | 
17 |     cat rsync.log | ./rsync-log-collate --only-host foo.example.com
18 | 
19 | 
20 | =head1 TODO
21 | 
22 | Refactor to ensure connections are output in time order; currently log lines are
23 | collated simply by using a hash with the hostname and PID as the key, so when
24 | iterating over them to output them, they'll be in indeterminate order (but all
25 | lines within the same collated connection will be in correct order, of course).
26 | 
27 | 
28 | =head1 AUTHOR
29 | 
30 | David Precious C<< <davidp@preshweb.co.uk> >>
31 | 
32 | 
33 | 
34 | 


--------------------------------------------------------------------------------
/mpdutils/mpd-now-playing:
--------------------------------------------------------------------------------
 1 | #!/usr/bin/perl
 2 | 
 3 | # Called with no arguments, outputs the path to the currently playing song.
 4 | #
 5 | # Called with arguments, performs an action on the currently playing song.
 6 | #
 7 | # Currently-supported commands:
 8 | # copy <new path> - copies the file to the path specified
 9 | # delete - deletes the file (TODO: tell MPD about the deletion)
10 | 
11 | use strict;
12 | use warnings;
13 | use Audio::MPD;
14 | use File::Copy;
15 | 
16 | my $mpd = Audio::MPD->new;
17 | 
18 | if (!$mpd) {
19 |     die "Failed to connect to MPD";
20 | }
21 | 
22 | my $song = $mpd->current();
23 | 
24 | if (!$song) {
25 |     die "No current song (not currently playing?";
26 | }
27 | 
28 | my $command = shift @ARGV || '';
29 | {
30 |     'copy' => \&copy_file,
31 |     'delete' => \&delete_file,
32 |     '' => \&display_file,
33 | }->{$command}($song);
34 | 
35 | 
36 | sub display_file { say shift->file };
37 | sub copy_file    {
38 |     File::Copy::copy(shift->file, shift @ARGV) or die "Copy failed - $!";
39 | };
40 | sub delete_file  { unlink(shift->file) or die "Delete failed - $!" };
41 | 
42 | 
43 | 
44 | 


--------------------------------------------------------------------------------
/show-tags/show-tags:
--------------------------------------------------------------------------------
 1 | #!/usr/bin/perl
 2 | 
 3 | 
 4 | # Display the tags of all the tracks in the given dir
 5 | # $Id: show-tags 581 2009-04-28 10:00:20Z davidp $
 6 | 
 7 | use strict;
 8 | use File::Find::Rule;
 9 | use Music::Tag;
10 | use Cwd;
11 | use Text::Tabulate;
12 | 
13 | my $startdir = $ARGV[0] || getcwd;
14 | 
15 | if (!-d $startdir) {
16 |     die "$startdir is not a directory";
17 | }
18 | 
19 | my @files = File::Find::Rule->file()->name(qr/\.mp3$/i)->in($startdir);
20 | 
21 | my @lines;
22 | file:
23 | for my $file (@files) {
24 |     my $info = Music::Tag->new($file);
25 |     ($info && $info->get_tag) or do {
26 |         print "Error reading ID3 tags for: $file\n";
27 |         next file;
28 |     };
29 |     push @lines, join "\t", (
30 |         $info->track()  || 'No track', 
31 |         $info->title()  || 'No title',
32 |         $info->artist() || 'No artist',
33 |         $info->album()  || 'No album',
34 |     );
35 | }
36 | 
37 | my $tabulate =  Text::Tabulate->new(
38 |     gutter  => '|', 
39 |     joint   => "\n",
40 | );
41 | 
42 | print $tabulate->format("Track\tTitle\tArtist\tAlbum", @lines) . "\n";
43 | 


--------------------------------------------------------------------------------
/log-ntl-cablemodem-stats/CableModemStats/config.yml:
--------------------------------------------------------------------------------
 1 | # This is the main configuration file of your Dancer app
 2 | # env-related settings should go to environments/$env.yml
 3 | # all the settings in this file will be loaded at Dancer's startup.
 4 | 
 5 | # Your application's name
 6 | appname: "CableModemStats"
 7 | 
 8 | port: 8050
 9 | 
10 | 
11 | # The default layout to use for your application (located in
12 | # views/layouts/main.tt)
13 | layout: "main"
14 | 
15 | # when the charset is set to UTF-8 Dancer will handle for you
16 | # all the magic of encoding and decoding. You should not care
17 | # about unicode within your app when this setting is set (recommended).
18 | charset: "UTF-8"
19 | 
20 | # template engine
21 | # simple: default and very basic template engine
22 | # template_toolkit: TT
23 | 
24 | 
25 | template: "template_toolkit"
26 | engines:
27 |   template_toolkit:
28 |     encoding:  'utf8'
29 |     start_tag: '[%'
30 |     end_tag:   '%]'
31 | 
32 | plugins:
33 |     Database:
34 |         driver: "mysql"
35 |         username: "davidp"
36 |         password: "davidp"
37 |         host: "localhost"
38 |         database: "modemstats"
39 | 


--------------------------------------------------------------------------------
/luton-flight-monitor/README.pod:
--------------------------------------------------------------------------------
 1 | =head1 flight-monitor
 2 | 
 3 | =head2 Description
 4 | 
 5 | A really simple and somewhat nasty script to watch for changes of the status of
 6 | a flight on Luton Airport's website and send me a text message using L<SMS::AQL>
 7 | every time it changes (TODO: use L<SMS::Send> so it's easier to change SMS
 8 | gateway provider for anyone who happens to use this).
 9 | 
10 | =head2 Configuration
11 | 
12 | Uses L<Config::Auto> to semi-magically find and parse the config file - see the
13 | docs for L<Config::Auto> for how this works.
14 | 
15 | Same config file:
16 | 
17 |     username: 'youraqlusername'
18 |     password: 'youraqlpassword'
19 |     sender: '+447.......'
20 |     destination: '+447.......'
21 | 
22 | 
23 | =head2 Usage
24 | 
25 |     # Run it with the flight number, e.g.:
26 |     perl flight-monitor EG-42
27 | 
28 | 
29 | =head2 Licence
30 | 
31 | This is just a quick dirty script I use for myself when I pick up my parents
32 | from Luton Airport; I dumped it here in case anyone else found it at all useful.
33 | If so, use it under the terms of the WTFPL.
34 | 
35 | 
36 | =head2 Author
37 | 
38 | David Precious C<< <davidp@preshweb.co.uk> >>
39 | 
40 | 
41 | 


--------------------------------------------------------------------------------
/bot-basicbot-modules/SayFromQueue.pm:
--------------------------------------------------------------------------------
 1 | package Bot::BasicBot::Pluggable::Module::SayFromQueue;
 2 | use strict;
 3 | use Bot::BasicBot::Pluggable::Module;
 4 | use base 'Bot::BasicBot::Pluggable::Module';
 5 | use File::Find::Rule;
 6 | use File::Slurp;
 7 | 
 8 | sub help {
 9 |     return <<HELPMSG
10 | Simple module to allow local processes to ask the bot to say something on IRC.
11 | 
12 | Dirt-simple; could be improved to allow configurable directory to watch.
13 | HELPMSG
14 | }
15 | 
16 | 
17 | sub tick {
18 |     my $self = shift;
19 | 
20 |     # Look in the queue dir for any files, and deal with them.
21 |     my $qdir = $ENV{HOME} . '/.botmsgqueues/' . $self->bot->username;
22 |     my @files = File::Find::Rule->file()->in($qdir);
23 |     for my $file (@files) {
24 |         warn "Found file $file";
25 |         my @messages = File::Slurp::read_file($file);
26 |         for my $message (@messages) {
27 |             my ($chan,$body) = split /:/, $message, 2;
28 |             for ($body) { s/^\s+//; s/\s+$//; }
29 |             $self->say({ channel => $chan, body => $body });
30 |         }
31 |         unlink $file;
32 |     }
33 |     return 5;
34 | }
35 | 
36 | 
37 | 
38 | 
39 | 
40 | 1;
41 |        
42 | 


--------------------------------------------------------------------------------
/education/generate-maths-worksheet:
--------------------------------------------------------------------------------
 1 | #!/usr/bin/env perl
 2 | 
 3 | # Generate a maths worksheet with random sums.
 4 | 
 5 | use strict;
 6 | use Template;
 7 | 
 8 | # TODO: support command-line option to pick only a given operator, or limit
 9 | # the set (e.g. add or minus only, no multiplication/division until old enough)
10 | my @operators = ('+', '-');
11 | 
12 | # TODO: support command-line option to set max operand value for difficulty
13 | my $max = 10;
14 | 
15 | # TODO: support command-line option to point us at a template to use
16 | my $template_file = 'sums.tmpl';
17 | 
18 | # Subtractions where the answer is negative are probably best avoided for now
19 | my $avoid_negative = 1;
20 | 
21 | my @sums;
22 | 
23 | my %had_sum;
24 | for (1..10) {
25 |     my ($op1, $op2) = map { int(rand($max)) } (0..1);
26 |     my $op = $operators[int(rand(@operators))];
27 |     redo if ($avoid_negative and $op eq '-' and $op1 - $op2 < 0);
28 |     redo if ($had_sum{join '', $op1, $op, $op2}++);
29 | 
30 |     push @sums, {
31 |         operand1 => $op1,
32 |         operand2 => $op2,
33 |         operator => $op,
34 |     };
35 | }
36 | 
37 | my $tt = Template->new;
38 | $tt->process($template_file, { sums => \@sums });
39 | 
40 | 


--------------------------------------------------------------------------------
/set-pyrus-hi3518-cam-datetime/README.md:
--------------------------------------------------------------------------------
 1 | # set-pyrus-hi3518-cam-datetime
 2 | 
 3 | I have a Pyrus-branded outdoor IP camera, marked with the model WST-8102-TD.
 4 | 
 5 | It's a bit crap, and its web UI is awful and plain doesn't work for me.
 6 | 
 7 | I can't set the date & time that it overlays on the video feed to be correct
 8 | via the broken web interface.
 9 | 
10 | I can, however, telnet to it using its default, hardcoded credentials -
11 | username `root`, password `xmhdipc`, and execute the date command.
12 | 
13 | So, in this dir is a shell script which uses `expect` to log in via telnet
14 | and set the camera's date & time to the current date & time, so I can run
15 | it regularly via cron to keep the camera's time correct.
16 | 
17 | ## RTSP URL
18 | 
19 | Whilst it's not directly related to this script, if you find this documentation
20 | by Googling for this camera, the RTSP URL which works for me for it is:
21 | 
22 | rtsp://pyruscam/user=admin&password=&channel=&stream=.sdp?real_stream--rtp-caching=100
23 | (yes, empty password; if you put the actual password in, it doesn't work!)
24 | 
25 | Gets me a reasonable 1920x1080 20fps stream in H264 - MPEG-4 AVC (part 10),
26 | bitrate arond 5000kbps.
27 | 
28 | 


--------------------------------------------------------------------------------
/retag-by-filename/README:
--------------------------------------------------------------------------------
 1 | Retag audio files based on their filenames.
 2 | 
 3 | Given a pattern with named captures, set the ID tags for each named file based
 4 | on that pattern.
 5 | 
 6 | Options:
 7 | 
 8 | --verbose / -v
 9 |     Be verbose.
10 | 
11 | --dry-run / --dryrun / -d
12 |     Just show what we would have done, don't do it
13 | 
14 | --pattern / -p
15 |     Specify a Perl regex with named captures
16 | 
17 | --setonly / -s
18 |     Limit which tags are set, e.g. "-s track" to only set the track tag,
19 |     leaving all others unchanged.  You should be able to repeat it for
20 |     multiple tags, e.g. -s track -s title
21 | 
22 | For an example:
23 | 
24 | [davidp@supernova:~]$ ./retag-by-filename.pl --dry-run \
25 |   --pattern="(?<track> \d+) \s - \s (?<title> .+ ) \s - \s (?<artist> .+ ) \.mp3" \
26 |   /shared/music/Complete\ Albums/Oasis\ -\ The\ Masterplan/*.mp3
27 | [01] Acquiesce by Oasis ()
28 | [02] Underneath The Sky by Oasis ()
29 | [03] Talk Tonight by Oasis ()
30 | ....
31 | 
32 | If I'd left out the --dry-run option, it would have retagged the files.
33 | 
34 | The tags which can be set, by including a named capture with the matching name,
35 | are: track, title, artist, comment.
36 | 
37 | 
38 | 
39 | 


--------------------------------------------------------------------------------
/xchat-plugins/README.pod:
--------------------------------------------------------------------------------
 1 | =head1 XChat plugins
 2 | 
 3 | In this directory are some old Perl plugins I wrote for
 4 | L<XChat|http://www.xchat.org/>.
 5 | 
 6 | I no longer actively use XChat, but these are here for anyone who may find them
 7 | useful.
 8 | 
 9 | These scripts are old, unsupported, and not illustrative of my current coding
10 | standards - they're nasty.
11 | 
12 | 
13 | =head2 xchat-filter-messages.pl
14 | 
15 | Allows you to filter out unwanted messages matching regular expressions.  Useful
16 | to ignore pointless things like "now playing" updates.
17 | 
18 | =head2 xchat-parse-netlink-messages.pl
19 | 
20 | Parses messages relayed from one IRC channel to another (typically on a
21 | different network) by the NetLink eggdrop script written by David Proper and
22 | turns them into “normal” channel messages.
23 | 
24 | =head2 xchat-parse-trivia-hints.pl
25 | 
26 | I used to use this in a trivia quiz channel; it parses messages containing the
27 | hints, e.g. "Hint: @@@ @@@@", and replaces them with a message showing the
28 | number of letters at a glance - e.g. "Hint letters: 3, 4".  Also, more
29 | unsportingly, remembers the answers to questions, and if it sees that question
30 | again, reports the answer :)
31 | 
32 | 


--------------------------------------------------------------------------------
/set-pyrus-hi3518-cam-datetime/set-pyruscam-datetime:
--------------------------------------------------------------------------------
 1 | #!/bin/bash
 2 | 
 3 | # Script to correct datetime on my Pyrus hi3518-based IP camera.
 4 | #
 5 | # Its web interface is dire and doesn't even work for me, so I can't set
 6 | # the date & time via it.
 7 | # However, it exposes telnet with a factory username & password(!), so
 8 | # I can just telnet in and set the datetime correctly periodically.
 9 | #
10 | # Yes, this is the kind of device that gets put on its own subnet where it
11 | # cannot talk outbound at all, because I do not trust it.
12 | 
13 | camera_hostname=$1
14 | curdate=`date +'%F %T'`
15 | echo "Setting Pyrus camera $camera_hostname's datetime to $curdate"
16 | expect << EOF
17 | exp_internal 0 # set to 1 for debug
18 | spawn telnet $camera_hostname
19 | expect -re ".+login: "
20 | send "root\r"
21 | expect -re "Password: "
22 | send "xmhdipc\r"
23 | expect "# "
24 | send "cat /proc/loadavg\r"
25 | expect "# "
26 | send_user "Request current datetime..."
27 | send "date\r"
28 | expect "# "
29 | #send_user "Attempt to set datetime to $curdate\n"
30 | send -- "date -s '$curdate'\r"
31 | expect "# "
32 | send_user "Re-request date to check it was updated\n"
33 | send "date\n"
34 | send "exit\n"
35 | send_user "All done\n"
36 | EOF
37 | 


--------------------------------------------------------------------------------
/cpants-scores/cpants-scores:
--------------------------------------------------------------------------------
 1 | #!/usr/bin/perl
 2 | 
 3 | use strict;
 4 | use LWP::Simple ();
 5 | use HTML::TableExtract;
 6 | use List::Util;
 7 | 
 8 | my $author = uc shift;
 9 | my $url = "http://cpants.cpanauthors.org/author/$author";
10 | my $author_page_html = LWP::Simple::get($url)
11 |     or die "Failed to fetch $url";
12 | 
13 | my ($game_kwalitee) = $author_page_html
14 |     =~ m{<th>CPANTS Game Kwalitee</th><td>(.+?)</td>};
15 | 
16 | print "Game score for $author: $game_kwalitee\n";
17 | 
18 | my $te = HTML::TableExtract->new(
19 |     headers => [ qw(name released kwalitee metrics) ]
20 | );
21 | $te->parse($author_page_html)
22 |     or die "Failed to page author page HTML";
23 | 
24 | my @scores;
25 | for my $row ($te->rows) {
26 |     my $dist = $row->[0];
27 |     $dist =~ s/\n//g;
28 |     my $url = "http://cpants.cpanauthors.org/dist/$dist";
29 |     my $dist_page_html = LWP::Simple::get($url)
30 |         or die "Failed to fetch $url";
31 | 
32 |     my ($core_kwalitee) = $dist_page_html
33 |         =~ m{<th>Core Kwalitee</th><td>(.+?)</td>};
34 | 
35 |     print "$dist kwalitee: $core_kwalitee\n";
36 |     push @scores, $core_kwalitee;
37 | }
38 | 
39 | my $avg = List::Util::sum(@scores) / @scores;
40 | 
41 | print "Calculated average: $avg\n";
42 | 
43 | 


--------------------------------------------------------------------------------
/darts-scoring-practice/dartscoringpractice:
--------------------------------------------------------------------------------
 1 | #!/usr/bin/perl
 2 | 
 3 | use strict;
 4 | use 5.010;
 5 | 
 6 | # $Id: dartscoringpractice 738 2009-10-01 22:51:27Z davidp $
 7 | 
 8 | my $remaining = 501;
 9 | 
10 | throw:
11 | while ($remaining >= 2) {
12 |     my $scored = int rand(180) + 1;
13 |     if ($remaining - $scored < 2) {
14 |         say "Bust";
15 |         next throw;
16 |     }
17 |     say "$remaining remained";
18 |     print "$scored scored - enter new remaining: ?> ";
19 |     my $answer;
20 |     guess:
21 |     while ($answer != $remaining - $scored) {
22 |         if ($answer) { print "Try again ?> "; }
23 |         chomp($answer = <>);
24 | 
25 |         # if the answer starts with "r", reverse the digits; this is to make it
26 |         # easier to work backwards.
27 |         if (my($digits) = $answer =~ m{r(\d+)}) {
28 |             $answer = join '', reverse split //, $digits;
29 |         }
30 | 
31 |         # If the answer is '?', tell them the correct answer.
32 |         if ($answer eq '?') {
33 |             $answer = $remaining - $scored;
34 |             say "Fool.  It was $answer";
35 |             last guess;
36 |         }
37 |     }
38 |     say "** OK, $scored scored, $remaining left";
39 |     $remaining -= $scored;
40 | }
41 | 
42 | 
43 | 
44 | 


--------------------------------------------------------------------------------
/odyssey-bookings-to-gcal/README.pod:
--------------------------------------------------------------------------------
 1 | =head1 odyssey-bookings-to-gcal
 2 | 
 3 | I'm a member of Odyssey Health & Racquet Club
 4 | (http://www.odysseyhealthclubs.com/).
 5 | 
 6 | This script logs in to the Odyssey members area, scrapes the list of bookings
 7 | (e.g. squash courts), and adds them to my Google Calendar for me, so I don't
 8 | have to.
 9 | 
10 | One drawback - Odyssey don't tell you which court the booking is for on their
11 | site.  Bah.
12 | 
13 | =head2 USAGE
14 | 
15 | The script uses L<Config::Auto>, so you'll need to set up a config file it will
16 | find, for e.g. C<~/.odyssey-bookings-to-gcalrc>, containing for e.g.:
17 | 
18 |     username: davidp@preshweb.co.uk
19 |     password: supersecretpassword
20 |     calendarname: Squash
21 | 
22 | The calendar name is the name of a calendar within your Google Calendar account
23 | that bookings should be added to.
24 | 
25 | You'll also need to add your Google Calendar login details to C<~/.netrc> -
26 | they're separate as I use various scripts that interact with my Google Calendar,
27 | and that's where I put the details.
28 | 
29 | Hmm - now I think about it, it would probably make sense to pull the Odyssey
30 | account details from there, too, and let the calendar name just be an option
31 | passed on the command line.  TODO.
32 | 
33 | 
34 | 


--------------------------------------------------------------------------------
/show-tags/README:
--------------------------------------------------------------------------------
 1 | Simple Perl script to display ID3 tags from given files.
 2 | 
 3 | Usage:
 4 | 
 5 |     show-tags [dir]
 6 | 
 7 | Given a directory name, will show the ID3 tags for all files in that dir.
 8 | 
 9 | If no dir is given, all files in the current directory will be shown instead.
10 | 
11 | Example:
12 | 
13 |     [davidp@supernova:~]$ show-tags
14 |     /shared/music/Complete\ Albums/Oasis\ -\ The\ Masterplan
15 |     Track|Title                 |Artist|Album
16 |     1    |Acquiesce             |Oasis |The Masterplan
17 |     2    |Underneath The Sky    |Oasis |The Masterplan
18 |     3    |Talk Tonight          |Oasis |The Masterplan
19 |     4    |Going Nowhere         |Oasis |The Masterplan
20 |     5    |Fade Away             |Oasis |The Masterplan
21 |     6    |The Swamp Song        |Oasis |The Masterplan
22 |     7    |I Am The Walrus (Live)|Oasis |The Masterplan
23 |     8    |Listen Up             |Oasis |The Masterplan
24 |     9    |Rockin' Chair         |Oasis |The Masterplan
25 |     10   |Half The World Away   |Oasis |The Masterplan
26 |     11   |(It's Good) To Be Free|Oasis |The Masterplan
27 |     12   |Stay Young            |Oasis |The Masterplan
28 |     13   |Headshrinker          |Oasis |The Masterplan
29 |     14   |The Masterplan        |Oasis |The Masterplan
30 | 
31 | 
32 | 


--------------------------------------------------------------------------------
/chart-strip-cli-grapher/graph:
--------------------------------------------------------------------------------
 1 | #!/usr/bin/perl
 2 | 
 3 | # Read a series of timestamp|value pairs on STDIN, and graph them using
 4 | # Chart::Strip.
 5 | # David Precious <davidp@preshweb.co.uk>, 2012
 6 | 
 7 | use strict;
 8 | use Chart::Strip;
 9 | use Getopt::Long;
10 | 
11 | # Defaults, then read any options we got
12 | my $output_file = 'chart.png';
13 | my $label  = 'Value';
14 | my $title  = '';
15 | my $style  = 'line';
16 | my $height = 300;
17 | my $width  = 800;
18 | 
19 | GetOptions(
20 |     "file|output-file|f=s" => \$output_file,
21 |     "label|l=s"  => \$label,
22 |     "title|t=s"  => \$title,
23 |     "style|s=s"  => \$style,
24 |     "height|h=s" => \$height,
25 |     "width|w=s"  => \$width,
26 | );
27 | 
28 | my @dataset;
29 | while (my $line = <>) {
30 |         chomp;
31 |         my ($timestamp, $value) = split /\|/, $line;
32 |         push @dataset, { time => $timestamp, value => $value };
33 | }
34 |  
35 | my $chart = Chart::Strip->new( 
36 |     title  => $title, 
37 |     height => $height,
38 |     width  => $width,
39 | );
40 | $chart->add_data(\@dataset, { style => $style });
41 | 
42 | open my $fh, '>', $output_file
43 |     or die "Failed to open $output_file to write - $!";
44 | binmode $fh;
45 | print $fh $chart->png;
46 | close $fh;
47 | print "PNG chart written to $output_file\n";
48 | 


--------------------------------------------------------------------------------
/log-ntl-cablemodem-stats/README.pod:
--------------------------------------------------------------------------------
 1 | =head1 NAME
 2 | 
 3 | log-ntl-cablemodem-stats
 4 | 
 5 | =head1 DESCRIPTION
 6 | 
 7 | A quick script to gather statistics from my Virgin Media (ex-NTL) Ambit cable
 8 | modem and record them to a database for later analysis/graphing etc.
 9 | 
10 | Parses the information via the web interface, as SNMP appears to be disabled
11 | (and also SNMP is a hateful ball of pain I'd rather not deal with anyway).
12 | 
13 | Written for my own use, but shared here in case it's of use to anyone else.
14 | 
15 | If you find it useful, feel free to drop me a mail; if I find other people are
16 | interested in it, I may well make it better, easier to configure, and be more
17 | likely to write a fancy data graphing interface too.
18 | 
19 | =head1 USAGE
20 | 
21 | As it was written for my own use, it's perhaps not as friendly as it could be.
22 | 
23 | There's SQL schemass provided for MySQL and SQLite; use the appropriate one to
24 | set up a database table (or convert to be compatible with your favourite RDBMS).
25 | 
26 | Then, edit the script and change the C<DBI> connect call to suit where your
27 | database is, and amend the modem connection details if required.
28 | 
29 | Then, run the script from cron, and each time it runs, it will insert a new set
30 | of measurements in the database.
31 | 
32 | 
33 | =head1 AUTHOR
34 | 
35 | David Precious <davidp@preshweb.co.uk>
36 | 


--------------------------------------------------------------------------------
/find-duplicate-files/find-duplicate-files.pl:
--------------------------------------------------------------------------------
 1 | #!/usr/bin/perl -w
 2 | 
 3 | 
 4 | # Loop through a directory and find duplicate
 5 | # files, based on the MD5 sum (therefore finding
 6 | # files with identical content even if their timestamp
 7 | # and attributes are different)
 8 | # 
 9 | # David Precious, 26/07/2006
10 | 
11 | # TODO : some code to offer to resolve dupes (i.e. pick
12 | # the filename you want to keep, I'll delete the others)
13 | 
14 | use Cwd;
15 | use Digest::MD5::File qw(file_md5_hex);
16 | use strict;
17 | use Data::Dumper;
18 | 
19 | my $start_dir = '';
20 | 
21 | if ($ARGV[0]) {
22 |     print "dir:$ARGV[0]\n";
23 |     $start_dir = $ARGV[0];
24 |     chdir($start_dir) || die "Can't chdir() to $start_dir\n";
25 | } else {
26 |     $start_dir = getcwd;
27 | }
28 | 
29 | my %hashes;
30 | 
31 | opendir(DIR, $start_dir);
32 | my @files = readdir(DIR);
33 | closedir(DIR);
34 | 
35 | FILE:
36 | foreach my $file (@files) {
37 | 
38 | 	next FILE if ($file =~ /^\.\.?$/);	
39 | 	next FILE unless (-f $file);
40 | 	
41 | 	unless (-r $file) {
42 | 	    print STDERR "Can't read $file\n";
43 | 	    next FILE;
44 | 	}
45 | 	my $hash = file_md5_hex($file);
46 | 	
47 | 	push @{$hashes{$hash}}, $file;
48 | 			
49 | }
50 | 		
51 | 
52 | 
53 | foreach my $hash (keys %hashes) {
54 | 
55 |     if (scalar @{$hashes{$hash}} > 1) {
56 | 	print "Dupes: " . join(' ', @{$hashes{$hash}}) . "\n";
57 |     }
58 | }
59 | 
60 | 


--------------------------------------------------------------------------------
/nagios_rdiffbackup_check/README.pod:
--------------------------------------------------------------------------------
 1 | =head1 nagios_rdiffbackup_check
 2 | 
 3 | =head2 SYNOPSIS
 4 | 
 5 |     ./nagios_rdiffbackup_check -w 6h -c 12h -d /path/to/destination
 6 | 
 7 | =head2 DESCRIPTION
 8 | 
 9 | A simple Nagios plugin to check how recent the current mirror increment of an
10 | L<http://www.rdiff-backup.org/|rdiff-backup> destination is.
11 | 
12 | The C<-w / --warning> and C<-c / --critical> options set the warning and
13 | critical threshold values for the maximum time since last mirror increment.
14 | 
15 | They can be given in seconds, or with logical suffixes - C<m> for minutes, C<h>
16 | for hours, C<d> for days.
17 | 
18 | The C<-d / --dest> option specifies the directory to which rdiff-backup has been
19 | backing up.
20 | 
21 | The optional C<--rdiff-backup> option sets the path to the C<rdiff-backup>
22 | script; by default, just C<rdiff-backup> will be used, which will work assuming
23 | that C<rdiff-backup> is found in C<$PATH>.
24 | 
25 | If the ownership on the backups is such that the user Nagios runs as wouldn't
26 | normally be able to read them, you can use the C<--sudo> option to have
27 | C<rdiff-backup> run using sudo - of course, you'll have to arrange for the
28 | Nagios user to do that - something like this in your sudoers file:
29 | 
30 |   nagios  ALL=   NOPASSWD: /usr/bin/rdiff-backup
31 | 
32 | 
33 | =head1 AUTHOR
34 | 
35 | David Precious C<< <davidp@preshweb.co.uk> >>
36 | 
37 | 


--------------------------------------------------------------------------------
/nagios_adaptec_raid_check/README.pod:
--------------------------------------------------------------------------------
 1 | =head1 nagios_adaptec_raid_check/
 2 | 
 3 | =head2 DESCRIPTION
 4 | 
 5 | This is a simple Nagios plugin to monitor the state of RAID arrays on Adaptec
 6 | RAID cards, using Adaptec's C<arcconf> utility from their StorMan (Storage
 7 | Manager) software, which you can download for Linux, FreeBSD and Windows from
 8 | their website: L<http://www.adaptec.com/en-us/downloads/>
 9 | 
10 | 
11 | 
12 | =head3 sudo setup
13 | 
14 | You probably don't want to be running your Nagios plugins as root.  However,
15 | C<arcconf> needs to run as root.  So, this script uses sudo to execute
16 | C<arcconf> as root.
17 | 
18 | You'll need to allow this to happen with no password.  For security, I'd only
19 | allow the nagios user to run the C<arcconf> command - add something like this to
20 | the C<sudoers> file:
21 | 
22 |   nagios  ALL=  NOPASSWD: /usr/StorMan/arcconf
23 | 
24 | By default, this plugin expects to find the C<arcconf> binary at
25 | C</usr/StorMan/arcconf>.  
26 | 
27 | However, if you need to, you can provide the path to the C<arcconf> binary using 
28 | the C<--arcconf> option, e.g.:
29 | 
30 |     ./nagios_adaptec_raid_check --arcconf_cli=/path/to/arcconf
31 | 
32 | 
33 | 
34 | =head1 CONTRIBUTING / NEW VERSIONS
35 | 
36 | This plugin is developed on GitHub at:
37 | 
38 | L<https://github.com/bigpresh/misc-scripts/tree/master/nagios_adaptec_raid_check>
39 | 
40 | Patches / bug reports / feedback welcome.
41 | 
42 | =head1 AUTHOR
43 | 
44 | David Precious <davidp@preshweb.co.uk>
45 | 
46 | 
47 | 


--------------------------------------------------------------------------------
/avoid-moo-reapage/lambdamoo-auto:
--------------------------------------------------------------------------------
 1 | #!/usr/bin/perl
 2 | 
 3 | use strict;
 4 | use Net::Telnet;
 5 | use YAML;
 6 | use Config::Auto;
 7 | 
 8 | # $Id: lambdamoo-auto.pl 590 2009-05-06 22:24:26Z davidp $
 9 | # Log in to LambdaMOO, perform some actions, log out.
10 | # Run from cron periodically to ensure character doesn't
11 | # get reaped.
12 | # Config::Auto will be used to read config; you can pass the name of the
13 | # config file if you need to.
14 | 
15 | my $config = Config::Auto::parse($ARGV[0] || '') or die "No config found";
16 | 
17 | for my $param (qw(host port character password email)) {
18 |     if (!$config->{$param}) {
19 |         die "Config does not contain $param";
20 |     }
21 | }
22 | $config->{timeout} ||= 10;
23 | 
24 | my $telnet = new Net::Telnet;
25 | $telnet->open(Host => $config->{host}, Port => $config->{port})
26 |     or die "Failed to connect to MOO";
27 | 
28 | $telnet->waitfor(
29 |     '/The lag is (.+); there are (\d+) connected/');
30 | $telnet->print("CONNECT $config->{character} $config->{password}");
31 | $telnet->waitfor('/\*{3} Connected \*{3}/');
32 | print "OK, connected..\n";
33 | my @actions = (
34 |     ':is automatically avoiding reaping with a quick login',
35 |     '"if you want to get hold of me, email ' . $config->{email},
36 |     ':does a little dance',
37 |     ':is done.',
38 |     '@quit',
39 | );
40 | for my $action (@actions) {
41 |     print "Performing action - $action\n";
42 |     $telnet->print($action);
43 |     sleep 5;
44 | }
45 | $telnet->close;
46 | print "Done.\n";
47 | 
48 | 


--------------------------------------------------------------------------------
/fortivpn-connect-scripts/connect-fortivpn:
--------------------------------------------------------------------------------
 1 | #!/usr/bin/env perl
 2 | 
 3 | use strict;
 4 | use Expect;
 5 | 
 6 | # The script and lib path to call over SSH to get password
 7 | my $host = 'supernova-vm.preshweb.co.uk';
 8 | my $remote_script = './get-thg-vpn-password';
 9 | my $lib_dir = '/home/davidp/perl5/lib/perl5';
10 | my $vpn_server = "...";
11 | 
12 | my $user_pass = `ssh $host 'perl -I$lib_dir $remote_script'`;
13 | 
14 | if (!$user_pass) {
15 |     die "Failed to fetch password over SSH from $host";
16 | }
17 | 
18 | my ($user, $pass) = split ':', $user_pass, 2;
19 | 
20 | say "OK, connect to VPN as $user with $pass";
21 | 
22 | my $vpn_command = "/opt/forticlient-sslvpn/64bit/forticlientsslvpn_cli";
23 | my $expect = Expect->new;
24 | $expect->debug(2);
25 | $expect->raw_pty(1);
26 | say "Spawning $vpn_command via sudo";
27 | $expect->spawn(
28 |     "/usr/bin/sudo",
29 |     $vpn_command,
30 |     "--vpnuser" =>  $user,
31 |     "--server"  => $vpn_server,
32 | ) or die "Failed to spawn $vpn_command - $!";
33 | 
34 | 
35 | $expect->expect(10, "Password for VPN:");
36 | say "Sending password";
37 | $expect->send($pass . "\n");
38 | 
39 | 
40 | # Hopefully we'll get connected now...
41 | $expect->expect(20, "STATUS::Tunnel running");
42 | say "Tunnel is running, now wait until client closes";
43 | # Now, let it run (wait until the process sends an EOF itself)
44 | $expect->expect(undef);
45 | 
46 | 
47 | # Do I need to do something here to say "alright, now just wait"?
48 | #
49 | say "VPN comand exit status: " . $expect->exitstatus();
50 | 
51 | 
52 | 


--------------------------------------------------------------------------------
/log-ntl-cablemodem-stats/CableModemStats/public/css/error.css:
--------------------------------------------------------------------------------
 1 | body {
 2 |     font-family: Lucida,sans-serif;
 3 | }
 4 | 
 5 | h1 {
 6 |     color: #AA0000;
 7 |     border-bottom: 1px solid #444;
 8 | }
 9 | 
10 | h2 { color: #444; }
11 | 
12 | pre {
13 |     font-family: "lucida console","monaco","andale mono","bitstream vera sans mono","consolas",monospace;
14 |     font-size: 12px;
15 |     border-left: 2px solid #777;
16 |     padding-left: 1em;
17 | }
18 | 
19 | footer {
20 |     font-size: 10px;
21 | }
22 | 
23 | span.key {
24 |     color: #449;
25 |     font-weight: bold;
26 |     width: 120px;
27 |     display: inline;
28 | }
29 | 
30 | span.value {
31 |     color: #494;
32 | }
33 | 
34 | /* these are for the message boxes */
35 | 
36 | pre.content {
37 |     background-color: #eee;
38 |     color: #000;
39 |     padding: 1em;
40 |     margin: 0;
41 |     border: 1px solid #aaa;
42 |     border-top: 0;
43 |     margin-bottom: 1em;
44 | }
45 | 
46 | div.title {
47 |     font-family: "lucida console","monaco","andale mono","bitstream vera sans mono","consolas",monospace;
48 |     font-size: 12px;
49 |     background-color: #aaa;
50 |     color: #444;
51 |     font-weight: bold;
52 |     padding: 3px;
53 |     padding-left: 10px;
54 | }
55 | 
56 | pre.content span.nu {
57 |     color: #889;
58 |     margin-right: 10px;
59 | }
60 | 
61 | pre.error {
62 |     background: #334;
63 |     color: #ccd;
64 |     padding: 1em;
65 |     border-top: 1px solid #000;
66 |     border-left: 1px solid #000;
67 |     border-right: 1px solid #eee;
68 |     border-bottom: 1px solid #eee;
69 | }
70 | 
71 | 


--------------------------------------------------------------------------------
/wordle-solver/README.md:
--------------------------------------------------------------------------------
 1 | # wordle-hint
 2 | 
 3 | A quick, dirty script to find potential words for [Wordle](https://www.powerlanguage.co.uk/wordle/)
 4 | 
 5 | ## Usage:
 6 | 
 7 | `./wordle-hint <hint> <include_letters> <exclude_letters>`
 8 | 
 9 | Where:
10 | 
11 | * `<hint>` is e.g. `..i..` if you know the 3rd char is an "i" (so a dot for
12 |   each position you don't yet know what letter should be there (green squares),
13 |   and any letters you do know are in their right place)
14 | * `<include_letters>` is a list of letters you know are in the word (yellow
15 |   squares) but don't know the position of - so possible solutions must include
16 |   these
17 | * `<exclude_letters>` are letters you know from previous guesses are *not* in
18 |   the word (grey squares)
19 | 
20 | For instance,
21 | 
22 | `./wordle-hint ..i.. r asewng` - we know the 3rd letter is an "i", we know
23 | there is a "r" somewhere but don't yet know where, and we know the letters
24 | a, s, e, w, n and g are *not* in the word.
25 | 
26 | It will then spew out words which could match.
27 | 
28 | So far, the word list it uses is just from `/usr/share/dict/words`.
29 | 
30 | I could rip the list of words from the Wordle JS source instead... but if I
31 | wanted to do that, I could just rip the solutions from there too and not worry
32 | about a solver, and where's the fun in that?
33 | 
34 | Some would consider even this approach cheating.  I suppose it sort-of is, but
35 | I saw it as a fun challenge to write a little code to do it for me.  I like
36 | making computers solve problems for me, it's What I Do.
37 | 
38 | 
39 | 
40 | 


--------------------------------------------------------------------------------
/rsync-log-collate/rsync-log-collate:
--------------------------------------------------------------------------------
 1 | #!/usr/bin/perl
 2 | 
 3 | # Quick script to process an rsync log file on STDIN, collate the log entries
 4 | # by connection (using a combination of PID and remote hostname), then output
 5 | # each one, so all lines for a given connection are togther rather than all 
 6 | # interspersed.
 7 | # David Precious <davidp@preshweb.co.uk> 2011
 8 | 
 9 | use strict;
10 | use Getopt::Long;
11 | 
12 | my $only_host;
13 | GetOptions("only-host|h=s" => \$only_host );
14 | 
15 | my %connection;
16 | my %hostname_for_pid;
17 | while (my $line = <>) {
18 |     $line =~ m{ 
19 |         (?<date> \S+)
20 |         \s+
21 |         (?<time> \S+)
22 |         \s+
23 |         \[ (?<pid> \d+ ) \]
24 |         \s+
25 |         (?<message> .+)
26 |     }x or next;
27 |     my %matches = %+;
28 | 
29 |     # If this is a new connection, remember the hostname being served by this
30 |     # PID so we can collate the rest of the lines
31 |     if (my ($hostname) = $matches{message} =~ m{connect from (\S+)\s+}) {
32 |         $hostname_for_pid{ $matches{pid} } = $hostname;
33 |     }
34 | 
35 |     # If we've been asked for only a given hostname, skip unless this matches
36 |     next if ($only_host and $hostname_for_pid{ $matches{pid} } ne $only_host);
37 | 
38 |     # Collate log lines based on the hostname and PID
39 |     my $key = join '_', $hostname_for_pid{ $matches{pid} }, $matches{pid};
40 |     push @{ $connection{$key} }, $line;
41 | }
42 | 
43 | for my $conn_key (keys %connection) {
44 |     print " *** Connection $conn_key ***\n";
45 |     print @{ $connection{$conn_key} };
46 |     print "\nConnection $conn_key ends \n\n";
47 | }
48 | 
49 | 


--------------------------------------------------------------------------------
/misc/check-abbie-polo-shirt:
--------------------------------------------------------------------------------
 1 | #!/usr/bin/env perl
 2 | 
 3 | # Quick, dirty script to monitor for a Sainsburys product becoming available in
 4 | # the desired size.
 5 | # It should be made much more generic, controllable via command line options
 6 | # etc.
 7 | # For now, though, I just want to watch for the school polo shirts we got Abbie
 8 | # coming available in the tiny size we need for her and struggled to get many
 9 | # of, so this'll do!
10 | #
11 | use strict;
12 | 
13 | use Mail::Sendmail;
14 | use WWW::Mechanize;
15 | 
16 | my $mech = WWW::Mechanize->new;
17 | 
18 | $mech->get(
19 | 'https://tuclothing.sainsburys.co.uk/p/White-Embroidered-Pocket-Polo-Shirts-3-Pack-(3-12-years)/128118016-White'
20 | ) or die "Failed to fetch page";
21 | 
22 | #my $form = $mech->form_with_fields('productVariantSize')
23 | my $form = $mech->form_number(2)
24 |     or die "failed to find form";
25 | 
26 | my $size_input = $form->find_input('#productVariantSize')
27 |     or die "No size input found in form $form";
28 | 
29 | my %year_state;
30 | for my $label ($size_input->value_names) {
31 |     my ($year, $status) = $label =~ /^(\d+) years\s*(.+)?/;
32 |     $year_state{$year} = $status || 'In stock';
33 | }
34 | 
35 | my $want_year = 2;
36 | if ($year_state{$want_year} ne 'Out of Stock') {
37 |     Mail::Sendmail::sendmail(
38 |         To      => 'davidp@preshweb.co.uk',
39 |         From    => 'supernova@preshweb.co.uk',
40 |         Subject => 'Abbie polo shirts back in stock at Sainsburys',
41 |         message => "QUICK - go order Abbie more polos\n\n"
42 |             . "Status on Sainsburys site: " . $year_state{$want_year},
43 |     ) and say "Email sent!";
44 | }
45 | 
46 | 


--------------------------------------------------------------------------------
/photo-frame-populate/photo-frame-populate:
--------------------------------------------------------------------------------
 1 | #!/usr/bin/perl
 2 | 
 3 | # Walk through all the files (well, symlinks) in the input dir, and if a file of
 4 | # that name doesn't exist in the output dir, use imagemagick's convert tool to
 5 | # resize and auto-rotate the input file and write the result to the output dir.
 6 | 
 7 | use strict;
 8 | use File::Find;
 9 | use File::Spec;
10 | use File::Which;
11 | 
12 | my $desired_res = '1024x768';
13 | 
14 | if (!File::Which::which('convert')) {
15 |     die "'convert' util not in \$PATH - ImageMagick not installed?\n";
16 | }
17 | 
18 | my ($in_dir, $out_dir) = @ARGV;
19 | if (!$in_dir || !$out_dir) {
20 |     die "Usage: $0 input-dir output-dir\n";
21 | }
22 | for ($in_dir, $out_dir) {
23 |     if (!-d $_) {
24 |         die "No such directory $_\n";
25 |     }
26 | }
27 | if (!-w $out_dir) {
28 |     die "Cannot write to $out_dir\n";
29 | }
30 | 
31 | File::Find::find(\&process_image, $in_dir);
32 | 
33 | sub process_image {
34 |     my ($file, $file_path) = ( $_, $File::Find::name );
35 |     say "Considering $file";
36 | 
37 |     if (my $link_dest = readlink($file_path)) {
38 |         $file_path = $link_dest;
39 |     }
40 | 
41 |     my $out_path = File::Spec->catfile($out_dir, $file);
42 |     if (-e $out_path) {
43 |         warn "$out_path already exists, skip";
44 |         return;
45 |     }
46 | 
47 |     say "Processing $file...";
48 |     my @convert_args = (
49 |         "$file_path", 
50 |         "-auto-orient",
51 |         "-resize",
52 |         $desired_res,
53 |         $out_path,
54 |     );
55 |     system("convert", @convert_args) == 0
56 |         or warn "convert execution failed - $?";
57 | 
58 | }
59 | 
60 | 


--------------------------------------------------------------------------------
/html-table-dump/html-table-dump:
--------------------------------------------------------------------------------
 1 | #!/usr/bin/env perl
 2 | 
 3 | # Quick script to fetch a page and dump details of all HTML tables which
 4 | # HTML::TableExtract finds.  Useful as a starting-point for table scraping.
 5 | #
 6 | # If given an URL as the first param, fetches it, otherwise reads HTML from
 7 | # STDIN.
 8 | #
 9 | # Outputs JSON containing details of each table and its rows and columns
10 | 
11 | use strict;
12 | use LWP::UserAgent;
13 | use HTML::TableExtract;
14 | use JSON;
15 | 
16 | my $html;
17 | my %output;
18 | my $url = shift;
19 | if ($url) {
20 |     my $response = LWP::UserAgent->new->get($url);
21 | 
22 |     if (!$response->is_success) {
23 |         die "Failed to fetch $url - " . $response->status_line . "\n";
24 |     }
25 |     $html = $response->decoded_content;
26 |     $output{source} = $url;
27 | } else {
28 |     $html = join "", <STDIN>;
29 |     $output{source} = 'STDIN';
30 | }
31 | 
32 | use HTML::TableExtract;
33 | my $te = HTML::TableExtract->new( );
34 | $te->parse($html);
35 | 
36 | # Examine all matching tables
37 | my $tablenum=0;
38 | foreach my $ts ($te->tables) {
39 |     my $table = {
40 |         num => $tablenum++,
41 |         coords => {
42 |             depth => $ts->depth,
43 |             count => $ts->count,
44 |         },
45 |     };
46 |     my $rownum=0;
47 |     foreach my $row ($ts->rows) {
48 |         # Strip leading/trailing whitespace from each value
49 |         my @values = map { s/^\s+//; s/\s+$//; $_ } @$row;
50 |         push @{ $table->{rows} }, \@values;
51 |         $rownum++;
52 |     }
53 |     $table->{total_rows} = $rownum;
54 |     push @{$output{tables}}, $table;
55 | }
56 | 
57 | print JSON::to_json(\%output);
58 | 
59 | 


--------------------------------------------------------------------------------
/shdc-rubbish-scraper/shdc-rubbish-scraper.js:
--------------------------------------------------------------------------------
 1 | const puppeteer = require('puppeteer');
 2 | const fs = require('node:fs');
 3 | 
 4 | async function getBinCollectionDates(houseNumber, postcode) {
 5 |   const browser = await puppeteer.launch({
 6 |       headless: true,
 7 |       // args: ['--single-process', '--no-zygote', '--no-sandbox']
 8 |   });
 9 |   const page = await browser.newPage();
10 | 
11 |   await page.goto('https://www.sholland.gov.uk/mycollections', {
12 |     waitUntil: 'networkidle0',
13 |   });
14 | 
15 |   // Fill in the address details
16 |   await page.type('input[name="SHDCWASTECOLLECTIONS_PAGE1_BUILDING"]', houseNumber);
17 |   await page.type('input[name="SHDCWASTECOLLECTIONS_PAGE1_POSTCODENEW"]', postcode);
18 | 
19 |   // Click the Find Address button
20 |   await Promise.all([
21 |     page.click('input[value="Find Address"]'),
22 |         page.waitForNavigation({ waitUntil: 'networkidle0' })
23 |   ]);
24 | 
25 | 
26 |   // find the content of the two divs...
27 |   const rubbish   = await page.$eval('.general', el => el.innerText);
28 |   const recycling = await page.$eval('.mixed', el => el.innerText);
29 |   await browser.close();
30 | 
31 |   return { rubbish: rubbish, recycling: recycling };
32 | }
33 | 
34 | async function saveResult(resp, outputfile) {
35 |     console.log(resp);
36 |     fs.writeFileSync(outputfile, JSON.stringify(resp));
37 | }
38 | 
39 | const [ house, postcode, outputfile ] = process.argv.slice(2);
40 | console.log(`Write rubbish collection dates for '${house}', '${postcode}' into ${outputfile}`);
41 | getBinCollectionDates(house, postcode)
42 |   .then(resp => saveResult(resp, outputfile))
43 |   .catch(err => console.error('Error:', err));
44 | 
45 | 


--------------------------------------------------------------------------------
/log-vm-superhub-stats/README.pod:
--------------------------------------------------------------------------------
 1 | =head1 NAME
 2 | 
 3 | log-vm-superhub-stats
 4 | 
 5 | =head1 DESCRIPTION
 6 | 
 7 | A quick script to gather statistics from my Virgin Media "SuperHub" (a
 8 | VM-branded Netgear cable modem with wifi and routing abilities)
 9 | and record them to a database for later analysis/graphing etc.
10 | 
11 | Parses the information via the web interface, as SNMP appears to be disabled
12 | (and also SNMP is a hateful ball of pain I'd rather not deal with anyway).
13 | 
14 | Written for my own use, but shared here in case it's of use to anyone else.
15 | 
16 | If you find it useful, feel free to drop me a mail; if I find other people are
17 | interested in it, I may well make it better, easier to configure, and be more
18 | likely to write a fancy data graphing interface too.
19 | 
20 | This is based on my previous log-ntl-cablemodem-stats, found in this same
21 | repository, which was intended for the old NTL Ambit 120 cable modem (which
22 | served me bloody well, but has been replaced with the SuperHub in order to
23 | obtain faster broadband).
24 | 
25 | =head1 USAGE
26 | 
27 | As it was written for my own use, it's perhaps not as friendly as it could be.
28 | 
29 | There's SQL schemass provided for MySQL and SQLite; use the appropriate one to
30 | set up a database table (or convert to be compatible with your favourite RDBMS).
31 | 
32 | Then, edit the script and change the C<DBI> connect call to suit where your
33 | database is, and amend the modem connection details if required.
34 | 
35 | Then, run the script from cron, and each time it runs, it will insert a new set
36 | of measurements in the database.
37 | 
38 | 
39 | =head1 AUTHOR
40 | 
41 | David Precious <davidp@preshweb.co.uk>
42 | 


--------------------------------------------------------------------------------
/minecraft-utils/diamondratio.ts:
--------------------------------------------------------------------------------
 1 | // Given a player's name, look up their UUID, open their player stats, and
 2 | // calculate the ratio of diamonds to stone mined.
 3 | 
 4 | const stats_dir : string = 'The-Wild/world/stats';
 5 | 
 6 | const fs      = require('fs');
 7 | const sprintf = require('sprintf-js').sprintf;
 8 | const request = require('request');
 9 | 
10 | const username : string = process.argv[2];
11 | if (username == null) {
12 |     console.log("You must supply a username");
13 |     process.exit(1);
14 | }
15 | 
16 | request('https://api.mojang.com/users/profiles/minecraft/' + username, 
17 |     function (error, response, body) {
18 |         if (error) {
19 |             console.log("ERROR: " + error);
20 |             process.exit(1);
21 |         }
22 |         let account = JSON.parse(body);
23 | 
24 |         check_ratio(account);
25 | });
26 | 
27 | function check_ratio (player) {
28 |     let padded_uuid : string = require("add-dashes-to-uuid")(player.id);
29 |     let stats_file : string  = stats_dir + '/' + padded_uuid + '.json';
30 | 
31 |     let stats_data = JSON.parse( fs.readFileSync(stats_file) );
32 |     let stats = stats_data.stats;
33 |     //console.log("Got stats:", stats_data);
34 | 
35 |     let diamond_mined : number = stats["minecraft:mined"]["minecraft:diamond_ore"];
36 | 
37 |     if (diamond_mined == 0) {
38 |         console.log(player.name + " has not mined any diamond yet");
39 |         process.exit;
40 |     }
41 | 
42 |     let stone_mined : number = stats["minecraft:mined"]["minecraft:stone"];
43 | 
44 |     let ratio : number = sprintf('%.4f', diamond_mined / stone_mined);
45 | 
46 |     console.log(
47 |         `${player.name} mined ${diamond_mined} dia of ${stone_mined} stone = ${ratio}`
48 |     );
49 | }
50 | 
51 | 


--------------------------------------------------------------------------------
/log-vm-superhub-stats/cablemodemstats-munin:
--------------------------------------------------------------------------------
 1 | #!/usr/bin/perl
 2 | 
 3 | # A simple Munin plugin to fetch the latest value for a given stat from the
 4 | # database for Munin to graph it.
 5 | #
 6 | # Usage: drop this script somewhere (say, /usr/share/munin/plugins)
 7 | # Then, for each reading you want graphed, symlink it with -readingname
 8 | # appended, e.g.:
 9 | # cd /etc/munin/plugins
10 | # ln -sf /usr/share/munin/plugins/cablemodem-munin \
11 | #       "cablemodem-munin-Downstream Receive Power Level"
12 | # 
13 | # David Precious <davidp@preshweb.co.uk>
14 | 
15 | use strict;
16 | use DBI;
17 | 
18 | # Configure your DB connection here
19 | my $dbh = DBI->connect(
20 |     'dbi:mysql:database=modemstats', 
21 |     'davidp', 'davidp',
22 |     { RaiseError => 1 }
23 | );
24 | 
25 | 
26 | my ($statname) = $0 =~ /cablemodemstats-munin-(.+)/
27 |     or die "Symlink this script as cablemodem-munin-statname";
28 | $statname =~ s/_/ /g;
29 | 
30 | # OK, find the most recent reading for the stat we're after
31 | my $row = $dbh->selectrow_hashref(
32 |     'select * from stats where `key` = ? order by id desc limit 1', 
33 |     {}, $statname
34 | );
35 | my ($value, $unit) = split /\s+/, $row->{value};
36 | 
37 | my $confname = lc $statname;
38 | $confname =~ s/[^a-z]//g;
39 | 
40 | # If munin is calling us to get details of what we return, tell it:
41 | if ($ARGV[0] eq 'config') {
42 |     print <<CONFIG;
43 | graph_title $statname ($unit)
44 | graph_vlabel $statname
45 | $confname.label $statname ($unit)
46 | graph_category network
47 | graph_info $statname reading from the cable modem
48 | $confname.info $statname value
49 | CONFIG
50 |     exit;
51 | } else {
52 |     # Provide the actual reading
53 |     print "$confname.value $value\n";
54 | }
55 | 
56 | exit;
57 | 
58 | 


--------------------------------------------------------------------------------
/log-ntl-cablemodem-stats/cablemodemstats-munin:
--------------------------------------------------------------------------------
 1 | #!/usr/bin/perl
 2 | 
 3 | # A simple Munin plugin to fetch the latest value for a given stat from the
 4 | # database for Munin to graph it.
 5 | #
 6 | # Usage: drop this script somewhere (say, /usr/share/munin/plugins)
 7 | # Then, for each reading you want graphed, symlink it with -readingname
 8 | # appended, e.g.:
 9 | # cd /etc/munin/plugins
10 | # ln -sf /usr/share/munin/plugins/cablemodem-munin \
11 | #       "cablemodem-munin-Downstream Receive Power Level"
12 | # 
13 | # David Precious <davidp@preshweb.co.uk>
14 | 
15 | use strict;
16 | use DBI;
17 | 
18 | # Configure your DB connection here
19 | my $dbh = DBI->connect(
20 |     'dbi:mysql:database=modemstats', 
21 |     'davidp', 'davidp',
22 |     { RaiseError => 1 }
23 | );
24 | 
25 | 
26 | my ($statname) = $0 =~ /cablemodemstats-munin-(.+)/
27 |     or die "Symlink this script as cablemodem-munin-statname";
28 | $statname =~ s/_/ /g;
29 | 
30 | # OK, find the most recent reading for the stat we're after
31 | my $row = $dbh->selectrow_hashref(
32 |     'select * from stats where `key` = ? order by id desc limit 1', 
33 |     {}, $statname
34 | );
35 | my ($value, $unit) = split /\s+/, $row->{value};
36 | 
37 | my $confname = lc $statname;
38 | $confname =~ s/[^a-z]//g;
39 | 
40 | # If munin is calling us to get details of what we return, tell it:
41 | if ($ARGV[0] eq 'config') {
42 |     print <<CONFIG;
43 | graph_title $statname ($unit)
44 | graph_vlabel $statname
45 | $confname.label $statname ($unit)
46 | graph_category network
47 | graph_info $statname reading from the cable modem
48 | $confname.info $statname value
49 | CONFIG
50 |     exit;
51 | } else {
52 |     # Provide the actual reading
53 |     print "$confname.value $value\n";
54 | }
55 | 
56 | exit;
57 | 
58 | 


--------------------------------------------------------------------------------
/nagios_smart_log/nagios_smart_log:
--------------------------------------------------------------------------------
 1 | #!/usr/bin/perl
 2 | 
 3 | # Nagios plugin to monitor for logged S.M.A.R.T. errors
 4 | #
 5 | # I've been using the Nagios check_ide_smart plugin, but it has given a clean
 6 | # bill of health to clearly failing drives.  Drives which show errors logged in
 7 | # the SMART error logs.  I will not trust any drive which has logged errors.
 8 | #
 9 | # David Precious <davidp@preshweb.co.uk>
10 | 
11 | use strict;
12 | use FileHandle;
13 | use Monitoring::Plugin;
14 | 
15 | 
16 | my $np = Monitoring::Plugin->new(
17 |     shortname => 'CHECKSMARTLOG',
18 |     'usage' => "%s -d sda",
19 | );
20 | 
21 | $np->add_arg(
22 |     spec    => "drive|d=s",
23 |     help    => "Drive to monitor",
24 |     default => "sda",
25 | );
26 | $np->add_arg(
27 |     spec    => "smartctl|s=s",
28 |     help    => "Path to smartctl",
29 |     default => "/usr/sbin/smartctl",
30 | );
31 | $np->add_arg(
32 |     spec    => "sudo|S",
33 |     help    => "Use sudo to run smartctl",
34 |     default => 1,
35 | );
36 | 
37 | $np->getopts;
38 | 
39 | 
40 | 
41 | ## Fetch the data we need:
42 | my $smartctl_fh = FileHandle->new(
43 |     ($np->opts->sudo ? 'sudo ' : '') . $np->opts->smartctl 
44 |     . " -l error " . $np->opts->drive . " |"
45 | ) or $np->nagios_die("Can't execute " . $np->opts->smartctl . " - $!");
46 | 
47 | my $error_log = join '',  $smartctl_fh->getlines;
48 | $smartctl_fh->close;
49 | 
50 | my @errors = $error_log =~ /(Error \d+ occurred at.+$)/mg;
51 | if (@errors) {
52 |     $np->nagios_exit(CRITICAL,
53 |         scalar(@errors) . " SMART errors, latest: " . $errors[0]
54 |     );
55 | } elsif ($error_log =~ /No Errors Logged/m) {
56 |     $np->nagios_exit(OK, "No SMART errors logged");
57 | } else {
58 |     $np->nagios_exit(UNKNOWN, "Failed to read/parse SMART error log");
59 | }
60 | 
61 | 
62 | 


--------------------------------------------------------------------------------
/xchat-plugins/xchat-parse-netlink-msgs.pl:
--------------------------------------------------------------------------------
 1 | #!/usr/bin/perl -w
 2 | 
 3 | 
 4 | # Simple XChat script to filter out unwanted
 5 | # messages matching one of the expressions
 6 | # given.
 7 | #
 8 | # David Precious, davidp@preshweb.co.uk
 9 | # bigpresh on EFNet, DALnet and undernet
10 | # 20th March 2006
11 | #
12 | # updated 23/03/2006 to handle messages containing
13 | # colons which were breaking the regexp parsing.
14 | 
15 | my $script = 'xchat-parse-netlink-msgs.pl';
16 | my $ver = '0.0.2';
17 | 
18 | # rules file - each line is a regexp to match
19 | # against incoming messages - if it matches, it'll
20 | # be dropped.
21 | 
22 | IRC::register ($script, $ver, "", "");
23 | IRC::add_message_handler('PRIVMSG', 'parse_line');
24 | IRC::add_message_handler('NOTICE', 'parse_line');
25 | IRC::print("*** \0038,2$script v$ver loaded \003");
26 | 
27 | 
28 | 
29 | sub parse_line {
30 | # received a PRIVMSG or a NOTICE, so 
31 | # try matching it:
32 | #Line::bigpresh!~bigpresh@supernova.preshweb.co.uk PRIVMSG #irish-buzzerz :test
33 | 
34 | my ( $sender, $type, $channel, $message ) = split( ' ', $_[0], 4 );
35 | my ( $nick, $user ) = parse_sender( $sender );
36 | 
37 | # clean up the message
38 | $message =~ s/^://;
39 | $message =~ s/\cc[0-9]{2}//g;
40 | #if ($line =~ /^:(.+)!(.+)@(.+)\s([A-Z]+)\s(.+)\s?:(.+)$/g)
41 | 	
42 | if ($message =~ /\((.+)@([A-Z]{2})\)\s(.+)/)
43 | 	{
44 | 	my ($relaynick, $relaynet, $relaymsg) = ($1,$2,$3);
45 | 	# a message being relayed from the "other side"
46 | 	Xchat::emit_print('Channel Message', ("$relaynick\[$relaynet\]", $relaymsg, undef));
47 | 
48 | 	return 1;
49 | 	}
50 | 
51 | } # end of sub parse_line
52 | 
53 | #>> :badgerbot!bigpresh@drink.b.udweiser.com PRIVMSG #irish-buzzerz :(bigpresh@DA) msg txt
54 | 
55 | sub parse_sender {
56 | # split sender into nick / user@host
57 | my $sender = shift;
58 | $sender =~ m/^:(.*?)!(.*)$/;
59 | }


--------------------------------------------------------------------------------
/munin_am2302_dht/am2302_dht:
--------------------------------------------------------------------------------
 1 | #!/usr/bin/env perl
 2 | 
 3 | use strict;
 4 | use 5.010;
 5 | 
 6 | # the Adafruit DHT driver util thing:
 7 | # see 
 8 | my $sensor_type = '2302';
 9 | my $gpio_pin = 2;
10 | my $cmd = "/usr/local/bin/Adafruit_DHT $sensor_type $gpio_pin";
11 | 
12 | my $mode = shift;
13 | my ($location,$type) = $0 =~ /(\w+)_(\w+)$/;
14 | 
15 | my %types = (
16 |     temperature => {
17 |         unit => 'degC',
18 |         range_min => -25,
19 |         range_max => 40,
20 |     },
21 |     humidity => {
22 |         unit => '%',
23 |         range_min => 0,
24 |         range_max => 100,
25 |     },
26 | );
27 | 
28 | my $reading_specs = $types{$type}
29 |     or die "Invalid type '$type', must be one of: "
30 |         . join(",", keys %types);
31 | 
32 | if ($mode eq "autoconf") {
33 |     say "yes";
34 |     exit;
35 | } elsif ($mode eq "config") {
36 |     my $label = ucfirst $type;
37 |     $location = ucfirst $location;
38 |     my $unit = $reading_specs->{unit};
39 |     my $lower = $reading_specs->{range_min};
40 |     my $upper = $reading_specs->{range_max};
41 |     print <<CONFIG;
42 | graph_title $location $label
43 | graph_vlabel $unit
44 | graph_info $location  $label in $unit
45 | graph_category Sensors
46 | graph_args --rigid --lower-limit $lower --upper-limit $upper
47 | $type.label $label
48 | $type.min $lower
49 | $type.max $upper
50 | CONFIG
51 |     exit;
52 | } else {
53 |     my $tries;
54 |     while ($tries++ < 10) {
55 |         my $result = `$cmd 2>/dev/null`;
56 |         if ($result =~ m{
57 |             Temp \s =\s+ (?<temperature>\S+)
58 |             .+
59 |             Hum \s = \s+ (?<humidity>\S+)
60 |         }x) {
61 |             print "$type.value " . $+{$type};
62 |             exit;
63 |         } else {
64 |             warn "No $type result found!  Returnval $?, result [$result]";
65 |         }
66 |     }
67 | }
68 | 
69 | 
70 | 


--------------------------------------------------------------------------------
/set-slack-status/set-slack-status:
--------------------------------------------------------------------------------
 1 | #!/usr/bin/env perl
 2 | 
 3 | use strict;
 4 | use LWP::UserAgent::JSON;
 5 | use Net::Netrc;
 6 | 
 7 | # Lookup credentials from .netrc; set the token as the 'account', not
 8 | # 'password' (in case you also store your account password).
 9 | # Token needs to have users.profile:write privs.
10 | my $mach = Net::Netrc->lookup('slack.com')
11 |     or die "Set up a .netrc entry with your token as the account";
12 | my ($user, undef, $token) = $mach->lpa;
13 | 
14 | my $ua = LWP::UserAgent::JSON->new;
15 | my %status_set;
16 | if ($ARGV[0] =~ /^:.+:/) {
17 |     $status_set{status_emoji} = shift @ARGV;
18 | }
19 | $status_set{status_text}  = join " ", @ARGV;
20 | 
21 | # If we're setting the status to empty to clear it, we must do the same with
22 | # the status emoji (this doesn't appear to be documented, I got the totally
23 | # undocumented error profile_status_clear_failed_text_but_no_emoji and had
24 | # to guess at the fix)
25 | if ($status_set{status_text} eq '') {
26 |     $status_set{status_emoji} = '';
27 | }
28 | 
29 | # TODO: maybe add a command-line option to set this.  When I use this script,
30 | # it'll typically be as a cron job to set my status at night / in the morning,
31 | # so I won't need it - just clear it in case I'd previously set an auto-expire
32 | # status via the Slack client
33 | $status_set{status_expiration} = '';
34 | 
35 | my $res = $ua->post_json(
36 |     "https://slack.com/api/users.profile.set",
37 |     {
38 |         token => $token,
39 |         profile => \%status_set,
40 |     },
41 |     Authorization => "Bearer $token",
42 | );
43 | if ($res->is_success) {
44 |     if (my $error = $res->json_content->{error}) {
45 |         die "Failed: $error\n";
46 |     } else {
47 |         say "OK, updated status";
48 |     }
49 | } else {
50 |     die "Failed to set status - " . $res->status_line . "\n";
51 | }
52 | 
53 | 


--------------------------------------------------------------------------------
/nagios_adaptec_raid_check/nagios_adaptec_raid_check:
--------------------------------------------------------------------------------
 1 | #!/usr/bin/perl
 2 | 
 3 | # A simple Nagios plugin to monitor the status of a RAID array on an Adaptec RAID
 4 | # card, using the Adaptec StorMan utility
 5 | #
 6 | # For new versions, check GitHub:
 7 | # https://github.com/bigpresh/misc-scripts/tree/master/nagios_adaptec_raid_check
 8 | #
 9 | # David Precious <davidp@preshweb.co.uk>
10 | 
11 | 
12 | use strict;
13 | use Monitoring::Plugin;
14 | use FileHandle;
15 | 
16 | my $np = Monitoring::Plugin->new(
17 |     shortname => 'RAIDCHECK',
18 |     usage => '%s [--verbose]',
19 | );
20 | 
21 | $np->add_arg(
22 |     spec => 'verbose|v',
23 |     help => 'Verbose debug output',
24 | );
25 | $np->add_arg(
26 |     spec => 'controller|c=i',
27 |     help => 'RAID controller number',
28 |     default => 1,
29 | );
30 | $np->add_arg(
31 |     spec => 'arcconf|a=s',
32 |     help => 'Path to arcconf utility',
33 |     default => '/usr/StorMan/arcconf',
34 | );
35 | 
36 | $np->getopts;
37 | 
38 | # Quick and braindead approach; this wouldn't be of any use if there were
39 | # multiple logical devices (arrays), but, well, meh.  The two boxes we'll use
40 | # this on only have one array.  If we ever want to use this on a box with
41 | # additional arrays, we'll need to refactor it.
42 | 
43 | my $cmd = 'sudo ' . $np->opts->arcconf . ' getconfig ' 
44 |     . $np->opts->controller . ' LD';
45 | 
46 | print "Executing '$cmd'\n" if $np->opts->verbose;
47 | 
48 | my $fh = FileHandle->new("$cmd |")
49 |     or $np->nagios_die("Failed to get controller config info - $!");
50 | 
51 | my ($status_line) = grep { /Status of logical device/ } $fh->getlines;
52 | $fh->close;
53 | 
54 | if (!$status_line) {
55 |     $np->nagios_die("Failed to match adaptor status!");
56 | }
57 | 
58 | my ($status) = $status_line =~ /:\s+(.+)$/;
59 | 
60 | if ($status ne 'Optimal') {
61 |     $np->nagios_exit(CRITICAL, "RAID status $status");
62 | } else {
63 |     $np->nagios_exit(OK, "RAID status $status");
64 | }
65 | 
66 | 


--------------------------------------------------------------------------------
/bot-basicbot-modules/DancerLinks.pm:
--------------------------------------------------------------------------------
 1 | # A quick Bot::BasicBot::Pluggable module to provide easy links when someone
 2 | # mentions Dancer::* modules or keywords on our channel
 3 | # David Precious <davidp@preshweb.co.uk>
 4 | 
 5 | package Bot::BasicBot::Pluggable::Module::DancerLinks;
 6 | use strict;
 7 | use base 'Bot::BasicBot::Pluggable::Module';
 8 | use Dancer;
 9 | use URI::Title;
10 | use 5.010;
11 | 
12 | sub help {
13 |     return <<HELPMSG;
14 | A quick module for use on Dancer IRC channels to provide links to module /
15 | keyword documentation.
16 | HELPMSG
17 | }
18 | 
19 | my %link_said;
20 | sub said {
21 |     my ($self, $mess, $pri) = @_;
22 |     
23 |     return unless $pri == 2;
24 |     my $link;
25 |     if (my ($module) = $mess->{body} =~ /(Dancer::\S+)/) {
26 |         my $url = "http://p3rl.org/$module";
27 |         my $title = URI::Title::title($url);
28 |         if ($title) {
29 |             $title =~ s/^$module - //;
30 |             $title =~ s/- metacpan.+//;
31 |             $link = "$module is at http://p3rl.org/$module ($title)";
32 |         }
33 | 
34 |     } elsif ($mess->{body} =~ m{
35 |         (
36 |         # match"the keyword forward", "the keyword 'forward", etc
37 |         the \s keyword \s ['"]? (?<keyword> [a-z_-]+) ['"]?
38 |         |
39 |         # or "forward keyword, "'forward' keyword, "forward() keyword" etc
40 |         \b['"]? (?<keyword> [a-z_-]+) ['"]? (?:\(\))? \s keyword
41 |         )
42 |     }xm
43 |     ) {
44 |         my $keyword = $+{keyword};
45 | 
46 |         if (Dancer->can($keyword)) {
47 |             $link = "The $keyword keyword is documented at "
48 |                 . "http://p3rl.org/Dancer#$keyword";
49 |         }
50 |     }
51 | 
52 |     # Announce the link we found, unless we already did that recently
53 |     if ($link && time - $link_said{$link} > 30) {
54 |         $link_said{$link} = time;
55 |         return $link;
56 |     }
57 | 
58 |     return 0; # This message didn't interest us
59 | }
60 | 
61 | 
62 | 1;
63 | 
64 | 


--------------------------------------------------------------------------------
/munin_db_query/munin_db_query:
--------------------------------------------------------------------------------
 1 | #!/usr/bin/env perl
 2 | 
 3 | # A dirty Munin plugin to produce graphs based on database queries.
 4 | #
 5 | # Symlink it into /etc/nagios/plugins, and add env vars in
 6 | # /etc/munin/plugin-conf.d/munin-node in a section named after the name you
 7 | # symlinked it as, containing the env vars as per the README.
 8 | 
 9 | use strict;
10 | use 5.010;
11 | 
12 | use DBI;
13 | 
14 | my $mode = shift;
15 | 
16 | # Make sure the required env vars are present:
17 | unless ($ENV{title} && $ENV{vlabel} && $ENV{dsn}
18 |     && ($ENV{query} || $ENV{query1})) {
19 |     die "Must set all env vars: title,vlabel,query (or query1,query2,..),dsn";
20 | }
21 | 
22 | # If we got only query and maybe label, turn that into query1 and label1, to
23 | # simplify things later on
24 | if ($ENV{query}) {
25 |     $ENV{query1} = delete $ENV{query};
26 |     $ENV{label1} = delete $ENV{label} || $ENV{vlabel};
27 | }
28 | 
29 | 
30 | my $dbh = DBI->connect($ENV{dsn}, $ENV{db_user}, $ENV{db_pass})
31 |     or die "Failed to connect with DSN '$ENV{dsn}'";
32 | 
33 | 
34 | if ($mode eq "autoconf") {
35 |     say "yes";
36 |     exit;
37 | } elsif ($mode eq "config") {
38 |     my $category = $ENV{category} || 'Database queries';
39 |     my $info     = $ENV{info} || "$ENV{title} ($ENV{label})";
40 |     print <<CONFIG;
41 | graph_title $ENV{title}
42 | graph_vlabel $ENV{vlabel}
43 | graph_info $info
44 | graph_category $category
45 | CONFIG
46 | 
47 |     for my $i (1..100) {
48 |         last unless exists $ENV{"label$i"};
49 |         print qq{value$i.label $ENV{"label$i"}\n};
50 |     }
51 |     exit;
52 | 
53 | } else {
54 |     for my $i (1..100) {
55 |         last unless $ENV{"query$i"};
56 | 
57 |         my @cols = $dbh->selectrow_array($ENV{"query$i"})
58 |             or die "SQL query $i failed: " . $dbh->errstr;
59 | 
60 |         if (@cols != 1) {
61 |             die "Expected exactly one column";
62 |         }
63 | 
64 |         print "value$i.value $cols[0]\n";
65 |     }
66 |     exit;
67 | }
68 | 
69 | 


--------------------------------------------------------------------------------
/countrykitchen-meals-export/test-data.json:
--------------------------------------------------------------------------------
1 | {"date_to_display":{"2022-09-22":"Thursday 22 September","2022-09-15":"Thursday 15 September","2022-09-23":"Friday 23 September","2022-09-12":"Monday 12 September","2022-09-16":"Friday 16 September","2022-09-21":"Wednesday 21 September","2022-09-08":"Thursday 08 September","2022-09-20":"Tuesday 20 September","2022-09-07":"Wednesday 07 September","2022-09-19":"Monday 19 September","2022-09-09":"Friday 09 September","2022-09-14":"Wednesday 14 September"},"meals_data":{"2022-09-16":{"Scott":"Main: LOADED MEATBALL SUB WITH SIDE SALAD"},"2022-09-12":{"Scott":"Main: SMOKEY BACON & TOMATO PASTA WITH PEAS","Abbie":"Main: SMOKEY BACON & TOMATO PASTA WITH PEAS"},"2022-09-21":{"Abbie":"Main: STIR FRIED VEGETABLE NOODLES\nSweet: VICTORIA SPONGE","Scott":"Main: JACKET POTATO WITH CHEESE & SALAD\nSweet: VICTORIA SPONGE"},"2022-09-08":{"Scott":"Main: JACKET POTATO WITH CHEESE & SALAD","Abbie":"Main: CHEESE & CRACKERS WITH VEG STICKS, YOGHURT & FRUIT"},"2022-09-22":{"Scott":"Main: LOADED POTATO WEDGES WITH CHEESE & BACON & BAKED BEANS\nSweet: FLAPJACK","Abbie":"Main: LOADED POTATO WEDGES WITH CHEESE & BACON & BAKED BEANS\nSweet: FLAPJACK"},"2022-09-15":{"Abbie":"Main: CHEESE & BACON POTATO SKINS & BAKED BEANS","Scott":"Main: CHEESE & BACON POTATO SKINS & BAKED BEANS"},"2022-09-23":{"Abbie":"Main: ROASTED VEGETABLE PASTA BAKE\nSweet: BANANA & ICE CREAM"},"2022-09-19":{"Abbie":"Main: HAM ROLL, YOGHURT, FRUIT, BISCUIT & VEG STICKS","Scott":"Main: JACKET POTATO WITH CHEESE & SALAD\nSweet: YOGHURT"},"2022-09-09":{"Scott":"Main: BACON ROLL HASH BROWN & BAKED BEANS","Abbie":"Main: BACON ROLL HASH BROWN & BAKED BEANS"},"2022-09-14":{"Abbie":"Main: PLOUGHMANS WITH HAM CHEESE CRUSTY BREAD & VEGETABLE STICKS"},"2022-09-20":{"Scott":"Main: CHEESE PIZZA WITH A BOWL OF TOMATO SOUP\nSweet: FRESH FRUIT SELECTION","Abbie":"Main: CHEESE PIZZA WITH A BOWL OF TOMATO SOUP\nSweet: FRESH FRUIT SELECTION"},"2022-09-07":{"Abbie":"Main: HAM ROLL, YOGHURT, FRUIT, BISCUIT & VEG STICKS","Scott":"Main: FISH PIE WITH VEGETABLES"}}}
2 | 


--------------------------------------------------------------------------------
/lagmeter-log-munin/lagmeter-log-munin:
--------------------------------------------------------------------------------
 1 | #!/usr/bin/perl
 2 | 
 3 | # A simple Munin plugin to graph stats from the log file written by the LagMeter
 4 | # server plugin:
 5 | # http://dev.bukkit.org/bukkit-plugins/lagmeter/
 6 | #
 7 | # A simple and fast way for Munin to obtain and graph stats without messing
 8 | # about with RCON and spamming the server logs with RCON connections, etc.
 9 | #
10 | # Author: David Precious (BIGPRESH) <davidp@preshweb.co.uk>
11 | # Released under the Perl Artistic Licence:
12 | # http://dev.perl.org/licenses/artistic.html
13 | # Original version 10th February 2016.
14 | #
15 | # Usage: symlink it in your Munin plugins dir with a suffix denoting which stat
16 | # to monitor (players,chunks,entities,tps)
17 | # Edit /etc/munin/plugin-conf.d/munin-node and add:
18 | # [lagmeter-log-munin_*]
19 | # env.LAGMETER_LOGFILE /path/to/plugins/LagMeter/lag.log
20 | 
21 | use strict;
22 | use File::ReadBackwards;
23 | 
24 | my ($stat) = $0 =~ /_(\w+)$/;
25 | my $filename = $ENV{LAGMETER_LOGFILE}
26 |     or die "Set env.LAGMETER_LOGFILE in your munin config";
27 | 
28 | my %stat_re = (
29 |     players => qr{Players online: (\d+)/\d+},
30 |     chunks  => qr{Total chunks loaded: (\d+)},
31 |     entities => qr{Total entities: (\d+)},
32 |     tps      => qr{TPS: (\d+)},
33 | );
34 | 
35 | 
36 | if (!$stat_re{$stat}) {
37 |    die "End of symlink should be _statname, one of: "
38 |         . join ',', sort keys %stat_re;
39 | }
40 | 
41 | if ($ARGV[0] eq 'config') {
42 |     print <<CONFIG;
43 | graph_title Minecraft $stat
44 | graph_vlabel $stat
45 | graph_category minecraft
46 | CONFIG
47 |     exit;
48 | }
49 | 
50 | my $bw = File::ReadBackwards->new($filename)
51 |     or die "Failed to open $filename - $!";
52 | 
53 | my $last_entry;
54 | 
55 | while( defined( my $log_line = $bw->readline ) ) {
56 |     last if $log_line =~ /^$/ && length $last_entry;
57 |     $last_entry .= $log_line;
58 | }
59 | 
60 | my ($stat_value) = $last_entry =~ $stat_re{$stat};
61 | 
62 | print "$stat.value=$stat_value\n";
63 | 
64 | 


--------------------------------------------------------------------------------
/fortivpn-connect-scripts/get-vpn-password:
--------------------------------------------------------------------------------
 1 | #!/usr/bin/env perl
 2 | 
 3 | # Return the password to use to connect to our FortiSSLVPN.
 4 | # Gets the password from .netrc, and the 2FA token from my mailbox.
 5 | 
 6 | use strict;
 7 | use warnings;
 8 | use DateTime;
 9 | use Net::IMAP::Simple;
10 | use Email::Simple;
11 | use Net::Netrc;
12 | use MIME::Base64;
13 | 
14 | my $o365_creds = Net::Netrc->lookup('office365.com')
15 |     or die "No office.com credentials in ~/.netrc";
16 | 
17 | my $dc_creds   = Net::Netrc->lookup('thg-dc')
18 |     or die "No DC credentials in ~/.netrc";
19 | 
20 | my $imap = Net::IMAP::Simple->new(
21 |     'outlook.office365.com', use_ssl => 1, port => 993,
22 | ) or die "Unable to connect by IMAP: $Net::IMAP::Simple::errstr\n";
23 | my ($user, $pass) = $o365_creds->lpa;
24 | if(!$imap->login($user, $pass)){
25 |     print STDERR "Login as $user failed: " . $imap->errstr . "\n";
26 |     exit(64);
27 | }
28 | 
29 | # Get the most recent message in the folder
30 | my $messages_count = $imap->select('INBOX/automails/2FA')
31 |     or die "Failed to select 2FA mailbox";
32 | my $message = $imap->get($messages_count);
33 | my $es = Email::Simple->new(join '', @$message);
34 | 
35 | # Paranoia - make sure the email we found is what we're after, and
36 | # not some other rubbish (this should never happen, otherwise I'd
37 | # iterate over the most recent messages until we find one)
38 | if ($es->header('Subject') ne 'Two Factor Authentication Passcode') {
39 |     die "Unknown email found, subject: " . $es->header('Subject');
40 | }
41 | 
42 | # Make sure the token is for today
43 | #Wed, 14 Nov 2018 07:00:08 +0000
44 | 
45 | my ($date) = $es->header('Date') =~ /\b(\d+ \w+ \d{4})\b/;
46 | my $today = DateTime->now->strftime('%d %b %Y');
47 | $today =~ s/^0//;
48 | if ($date ne $today) {
49 |     die "Token was for $date, expected $today";
50 | }
51 | 
52 | my ($token) = MIME::Base64::decode_base64($es->body) =~ /^(\d+)/;
53 | 
54 | if (!$token) {
55 |     die "No token found in mail";
56 | }
57 | 
58 | my ($vpn_user, $vpn_pass) = $dc_creds->lpa;
59 | 
60 | say $vpn_user . ':' . $vpn_pass . $token;
61 | 
62 | 
63 | 
64 | 


--------------------------------------------------------------------------------
/luton-flight-monitor/flight-monitor:
--------------------------------------------------------------------------------
 1 | #!/usr/bin/perl
 2 | 
 3 | # Crude script to monitor for flight status changes on Luton Airport's website.
 4 | #
 5 | # Written for my own use, a bit nasty, but shared here under the terms of the
 6 | # WTFPL in case it's useful to anyone.
 7 | #
 8 | # David Precious <davidp@preshweb.co.uk>
 9 | 
10 | use strict;
11 | use Config::Auto;
12 | use LWP::Simple;
13 | use HTML::TableExtract;
14 | use SMS::AQL;
15 | 
16 | my $flight = shift or die "Usage: $0 flightnum";
17 | my $url ="http://www.london-luton.co.uk/FlightData.ashx"
18 |     . "?dir=arr&lang=en&id=1&r=20016807";
19 | 
20 | $Config::Auto::DisablePerl = 1;
21 | my $config = Config::Auto::parse()
22 |     or die "No config found";
23 | 
24 | # check we have all expected config settings
25 | if (my @missing = grep { !$config->{$_} }
26 |     qw(username password sender destination)
27 | ) {
28 |     die "Config file missing settings: " . join ',', @missing;
29 | }
30 | 
31 | my $sms = SMS::AQL->new({
32 |     username => $config->{username},
33 |     password => $config->{password},
34 |     options => { sender => $config->{sender} },
35 | });
36 | 
37 | my $last_status;
38 | check:
39 | while (1) {
40 |     sleep 30 if $last_status;
41 |     my $html = LWP::Simple::get($url) or warn "Failed to fetch HTML" and next;
42 |     my $te = HTML::TableExtract->new(
43 |         headers => [ 'Flight No', 'Airport', 'Scheduled', 'Flight Status' ]
44 |     );
45 |     $te->parse($html) or warn "Failed to parse HTML" and next;
46 | 
47 |     for my $row ($te->rows) {
48 |         if ($row->[0] eq $flight) {
49 |             say "Status: $row->[3]";
50 |             if ($row->[3] ne $last_status) {
51 |                 say "That's a change!";
52 |                 my ($ok, $err) = $sms->send_sms(
53 |                     $config->{destination}, 
54 |                     "Flight $flight now $row->[3]"
55 |                 );
56 |                 if (!$ok) {
57 |                     warn "Failed to send SMS - $err";
58 |                 }
59 |             }
60 |             $last_status = $row->[3];
61 | 
62 |             next check;
63 |         }
64 |     }
65 | }
66 |     
67 | 


--------------------------------------------------------------------------------
/tabulate/README:
--------------------------------------------------------------------------------
 1 | A simple script to tabulate data within a Unix pipeline into an ASCII-art table,
 2 | optionally filtering the data, taking only certain columns, etc.
 3 | 
 4 | A rather contrived example - let's tabulate process info:
 5 | 
 6 | [davidp@supernova:~]$ ps auxw
 7 | USER       PID %CPU %MEM    VSZ   RSS TTY      STAT START   TIME COMMAND
 8 | root         1  0.0  0.0   2052   716 ?        Ss   Jan21   0:16 init [2]  
 9 | root         2  0.0  0.0      0     0 ?        S    Jan21   0:00 [kthreadd]
10 | root         3  0.0  0.0      0     0 ?        S    Jan21   0:00 [migration/0]
11 | 
12 | 
13 | Let's say I want that in a table, only want the first and last column, and only 
14 | want processes with 'getty' in the name:
15 | 
16 | [davidp@supernova:~]$ ps auxw | dev/git/misc-scripts/tabulate/tabulate \
17 |   -f 0,10,8 --filter getty --split-on '\s+'  -K 1
18 | |USER|COMMAND    |START|
19 | |root|/sbin/getty|Jan21|
20 | |root|/sbin/getty|Jan21|
21 | |root|/sbin/getty|Jan21|
22 | |root|/sbin/getty|Jan21|
23 | |root|/sbin/getty|Jan21|
24 | |root|/sbin/getty|Jan21|
25 | |root|/sbin/getty|Jan21|
26 | 
27 | I've asked for fields 0, 10 and 8, filtering to rows which contain 'getty',
28 | splitting by sequences of one or more space, and keeping the first row
29 | (since that contains the headings).
30 | 
31 | TODO: document properly :)
32 | 
33 | Options taken:
34 | 
35 | --fieldspec / -f
36 |     List the columns you want.  Note - indexing starts at 0.
37 |     Examples: 0,3 - first and third.  0..3 - first four columns.  
38 | 
39 | --headers / -h
40 |     Specify column heading names
41 | 
42 | --filter / -m
43 |     Include only rows which match the given pattern
44 | 
45 | --skip-first / --skipfirst / -s
46 |     Skip the first X rows.  Example: --skip-first=1
47 | 
48 | --keep-first / --keepfirst / -K
49 |     Do not discard the first X rows.  Only useful when using --filter.
50 | 
51 | --separator / --seperator / --sep
52 |     Character to use to separate columns in output.  Defaults to '|'.
53 | 
54 | --split-on / --spliton
55 |     Pattern to use to split input into columns.  Default: '\s+' (whitespace)
56 | 
57 | 
58 | 
59 | 
60 | 
61 | 


--------------------------------------------------------------------------------
/jobs-alert/jobs-alert:
--------------------------------------------------------------------------------
 1 | #!/usr/bin/env perl
 2 | 
 3 | use 5.012;
 4 | use Encode;
 5 | use HTML::TableExtract;
 6 | use Mail::Sendmail;
 7 | use Net::Netrc;
 8 | use WWW::Mechanize;
 9 | 
10 | my $machine = Net::Netrc->lookup('jobs.perl.org')
11 |     or die "No entry for jobs.perl.org in .netrc";
12 | my ($login, $password) = $machine->lpa;
13 | 
14 | 
15 | my $mech = WWW::Mechanize->new;
16 | $mech->get('https://jobs.perl.org/login?redir=%2Findex');
17 | 
18 | $mech->submit_form(
19 |     with_fields => {
20 |         login    => $login,
21 |         password => $password,
22 |     },
23 |     button => 'Submit',
24 | );
25 | 
26 | if ($mech->content !~ /Logout/) {
27 |     die "Looks like the login failed\n" . $mech->content;
28 | }
29 | 
30 | $mech->follow_link(text => 'Admin');
31 | 
32 | if ($mech->content =~ /No jobs needing review/) {
33 |     exit;
34 | }
35 | 
36 | # OK, parse out the jobs listed and send an email to nag me to review them.
37 | my @cols = ('Id', 'Title', 'Date posted', 'Status');
38 | my $te = HTML::TableExtract->new(
39 |     headers => \@cols,
40 | );
41 | 
42 | $te->parse($mech->content)
43 |     or die "Failed to parse out HTML table";
44 | 
45 | 
46 | my @jobs;
47 | for my $row ($te->rows) {
48 |     my %job;
49 |     for (@$row) {
50 |         s{^\s+}{};
51 |         s{\s+$}{};
52 |     }
53 |     @job{@cols} = @$row;
54 |     say "Job $job{Id} - $job{Title}";
55 |     push @jobs, \%job;
56 | }
57 | 
58 | if (@jobs) {
59 |     my $msg = "There are new jobs to review on jobs.perl.org\n\n";
60 | 
61 |     for my $job (@jobs) {
62 |         $msg .= sprintf "%s (posted %s)\n\thttps://jobs.perl.org/preview/%d\n\n",
63 |             @$job{'Title', 'Date posted', 'Id'};
64 |     }
65 | 
66 |     $msg .= "\n\n\nSee them all at https://jobs.perl.org/admin/\n";
67 |     my $bytes = encode('utf8', $msg);
68 | 
69 |     Mail::Sendmail::sendmail(
70 |         To => 'davidp@preshweb.co.uk',
71 |         From => 'davidp@preshweb.co.uk',
72 |         Subject => scalar(@jobs) . " jobs to approve on jobs.perl.org",
73 |         charset => 'utf8',
74 |         _text => $bytes,
75 |     ) or die "Failed to send notification email";
76 | }
77 | 
78 | 
79 | 
80 | 


--------------------------------------------------------------------------------
/minecraft-stats-reporting/compare-player-stats:
--------------------------------------------------------------------------------
 1 | #!/usr/bin/env perl
 2 | 
 3 | use strict;
 4 | use 5.010;
 5 | use List::Util;
 6 | 
 7 | use lib '.';
 8 | use MinecraftStatsParser;
 9 | 
10 | use Data::Dump;
11 | 
12 | # Get a list of all players sorted by playtime, by default) and for each, get 
13 | # their stats; then we can walk through and calculate averages and player's
14 | # ratios from that average
15 | my @players = @ARGV ? @ARGV : @{ MinecraftStatsParser::get_players(500) };
16 | 
17 | my %stats;
18 | 
19 | for my $player (@players) {
20 |     say "Fetching stats for $player...";
21 |     
22 |     $stats{$player} = MinecraftStatsParser::get_stats($player);
23 | }
24 | 
25 | # Now, first pass, walk through remembering all ratio values we saw:
26 | my %ratios;
27 | for my $player (keys %stats) {
28 |     for my $ratio (keys %{ $stats{$player}{ratio} }) {
29 |         my $value = $stats{$player}{ratio}{$ratio};
30 |         push @{ $ratios{$ratio} }, $value;
31 |     }
32 | }
33 | # Now we can calculate the average ratios:
34 | my %avg_ratio;
35 | for my $ratio (keys %ratios) {
36 |     my @values = @{ $ratios{$ratio} };
37 |     $avg_ratio{$ratio} = List::Util::sum(@values) / scalar @values;
38 |     say "Average ratio for $ratio is " . $avg_ratio{$ratio};
39 | }
40 | 
41 | # Second pass, for each player, work out what ratio each of their ratios is to
42 | # the average ratio:
43 | for my $player (keys %stats) {
44 |     for my $ratio (keys %{ $stats{$player}{ratio} }) {
45 |         my $value = $stats{$player}{ratio}{$ratio};
46 |         my $ratio_of_avg = $value / $avg_ratio{$ratio};
47 |         $stats{$player}{ratio_of_avg}{$ratio} = $ratio_of_avg;
48 |     }
49 | }
50 | 
51 | # Dump the results, sorted by diamond ratio to look for xrayers
52 | # TODO: make sort criteria customisable
53 | # TODO: move most of the average ratio calculation & comparison logic in to
54 | # MinecraftStatsParser.pm
55 | say Data::Dump::dump(
56 |     (
57 |         map { { $_ => $stats{$_} } }
58 |         sort {
59 |             $stats{$b}{ratio_of_avg}{diamond} 
60 |             <=>
61 |             $stats{$a}{ratio_of_avg}{diamond}
62 |         } keys %stats
63 |     )
64 | );
65 | 
66 | 


--------------------------------------------------------------------------------
/nagios_check_mysql_stats/README.pod:
--------------------------------------------------------------------------------
 1 | =head1 NAME
 2 | 
 3 | check_mysql_stats - Nagios plugin for MySQL status monitoring
 4 | 
 5 | =head1 FEATURES
 6 | 
 7 | Why this, instead of the basic check_mysql?
 8 | 
 9 | =over
10 | 
11 | =item Check specific stats against thresholds
12 | 
13 | Want to just check the number of open tables is in a range you expect?
14 | 
15 | Sure, just C<-s 'Open tables:10:200' -t 20> - if the number of tables is less
16 | than 10 or more than 200, you'll get an alarm - a WARNING if it's just outside,
17 | a CRITICAL if it's outside by more than 20%.  You can repeat C<-s> parameters to
18 | check as many different stats (as returned by C<mysqladmin status> as you wish.
19 | 
20 | =item Returns perfdata
21 | 
22 | Using nagiosgraph or Graphios to get metrics graphing from Nagios?  This plugin
23 | will return perfdata, either for all stats if no specific stats were named to
24 | check, or for the stat(s) named otherwise.
25 | 
26 | =item Useful C<Queries per second> metric
27 | 
28 | C<mysqladmin status> gives you a C<Queries per second avg> metric, which would
29 | at first glance seem useful to you if you want to graph the number of queries
30 | your database servers are seeing.  It's not, though, as it's the average QPS
31 | since the server started, not for the last short period, so it won't reflect
32 | changes in the query load the DB is seeing usefully.
33 | 
34 | If you use the C<--saved_state> parameter, then the status we get on each run
35 | will be written to the named file; when we next run, we read the last run's
36 | stats from the file - then, given we can work out how many new queries we've
37 | seen since that file was updated, and how many seconds have passed since it was
38 | updated, we can add a new C<Queries per second> metric which is actually useful.
39 | 
40 | (That metric can be used for threshold-checking just like any other one, and
41 | will be returned in perfdata so you can graph it.)
42 | 
43 | 
44 | =head1 AUTHOR
45 | 
46 | David Precious C<< <davidp@preshweb.co.uk> >>
47 | 
48 | 
49 | =head1 FEEDBACK
50 | 
51 | Feedback very much welcomed.  Do feel free to drop me an email and let me know
52 | if this is useful to you!
53 | 
54 | 


--------------------------------------------------------------------------------
/minecraft-stats-reporting/MinecraftStatsParser.pm:
--------------------------------------------------------------------------------
 1 | package MinecraftStatsParser;
 2 | 
 3 | use strict;
 4 | use 5.010;
 5 | use LWP::UserAgent;
 6 | use HTML::TableExtract;
 7 | 
 8 | # Mapping of interesting block IDs to names
 9 | my %block_name_by_id = (
10 |     56 => 'diamond',
11 |     14 => 'gold',
12 |     15 => 'iron',
13 |     16 => 'coal',
14 |     4  => 'cobble',
15 |     1  => 'stone',
16 |     27 => 'powered_rail',
17 |     49 => 'obsidian',
18 |     129 => 'emerald',
19 |     21 => 'lapis',
20 |     73 => 'redstone', # unlit
21 |     74 => 'redstone', # lit-up
22 | );
23 | 
24 | 
25 | my $ua = LWP::UserAgent->new;
26 | 
27 | sub get_stats {
28 |     my $player = shift;
29 |     my %player_stats;
30 | 
31 |     my $response = $ua->get(
32 |         sprintf "http://the-wild.tk/stats/single_player.php?p=%s",
33 |         $player
34 |     );
35 |     
36 |     my $te = HTML::TableExtract->new(
37 |         headers => [ qw(Block BlockID Placed Broken) ],
38 |     );
39 |     $te->parse($response->content);
40 |     my ($table) = $te->tables
41 |         or die "Failed to find blocks table in stats HTML";
42 | 
43 |     for my $row ($table->rows) {
44 |         my ($block, $block_id, $placed, $broken) = @$row;
45 | 
46 |         if (my $block_name = $block_name_by_id{$block_id}) {
47 |             $player_stats{broken}{$block_name} += $broken;
48 |             $player_stats{placed}{$block_name} += $placed if $placed;
49 |         }
50 |     }
51 | 
52 |     for (qw(diamond gold iron coal emerald redstone lapis)) {
53 |         if ($player_stats{broken}{$_}) {
54 |         $player_stats{ratio}{$_} = sprintf '%.4f', 
55 |             $player_stats{broken}{$_} / $player_stats{broken}{stone};
56 |         }
57 |     }
58 |     return \%player_stats;
59 | }
60 | 
61 | sub get_players {
62 |     my ($player_count) = shift || 50;
63 |     my $response = $ua->get(
64 |         "http://the-wild.tk/stats/ajax_player_table.php?"
65 |         . "iDisplayStart=0&iDisplayLength=$player_count"
66 |         . "&iColumns=7"
67 |         . "&iSortCol_0=1&iSortingCols=1&sSortDir_0=desc"
68 |     );
69 |     my @players;
70 |     @players = ($response->content =~ /p=(.+?)\\?"/xmg);
71 |     return \@players;
72 | }
73 | 
74 | 
75 | 


--------------------------------------------------------------------------------
/backup-google-stuff/backup-google-stuff.pl:
--------------------------------------------------------------------------------
 1 | #!/usr/bin/perl
 2 | 
 3 | # $Id: backup-google-stuff.pl 837 2010-02-24 11:58:23Z davidp $
 4 | 
 5 | use common::sense;
 6 | use DateTime;
 7 | use File::Copy;
 8 | use WWW::Contact;
 9 | use WWW::Mechanize;
10 | use YAML;
11 | 
12 | # Sure, Google "do no evil", but I don't trust them to hold my data without me
13 | # having a backup.
14 | 
15 | my $account = YAML::LoadFile($ENV{HOME} . "/.google_login")
16 |     or die "Failed to read $ENV{HOME}/.google_login - $!";
17 | my $backup_dir = '/mnt/backup/google';
18 | 
19 | # First, log in:
20 | my $mech = WWW::Mechanize->new;
21 | $mech->get('https://calendar.google.com/');
22 | $mech->form_with_fields(qw(Email Passwd))
23 |     or die "Failed to locate login form";
24 | $mech->set_fields(
25 |     Email => $account->{username}, Passwd => $account->{password}
26 | );
27 | $mech->submit or die "Failed to submit login form";
28 | 
29 | # Now, fetch the ical export ZIP file:
30 | my $dt = DateTime->now;
31 | my $ymd = $dt->ymd;
32 | 
33 | $mech->get(
34 |     'http://www.google.com/calendar/exporticalzip',
35 |     ':content_file' => "$backup_dir/calendar_$ymd.ical.zip"
36 | ) or warn "Failed to fetch ical export ZIP file";
37 | 
38 | 
39 | # For contacts, we used to be able to get Google's CSV format and standard vCard
40 | # format, but they changed how their export system works.  Now, we need to use
41 | # WWW::Contact to get contact data.  It might not be in a format we can
42 | # immediately import with other stuff, but at least we have the data.
43 | my @contacts = WWW::Contact->new->get_contacts(
44 |     $account->{username}, $account->{password}
45 | ) or die "Failed to fetch contacts!";
46 | 
47 | YAML::DumpFile("$backup_dir/contacts_$ymd.yml", \@contacts);;
48 | 
49 | 
50 | 
51 | # Finally, Google Reader subscriptions:
52 | $mech->get('http://www.google.com/reader/subscriptions/export',
53 |     ':content_file' => "$backup_dir/reader_subscriptions_$ymd.xml"
54 | ) or warn "Failed to fetch Reader subscriptions";
55 | 
56 | # Finally, copy the contacts to /shared/backups so my laptop can access them:
57 | File::Copy::copy(
58 |     "$backup_dir/contacts_VCARD_$ymd",
59 |     "/shared/backups/google-contacts.vcard"
60 | );
61 | 


--------------------------------------------------------------------------------
/munin_db_query/README.pod:
--------------------------------------------------------------------------------
 1 | =head1 munin_db_query
 2 | 
 3 | A simple Munin plugin which can be fed an SQL query (which should return one row
 4 | with one column), which just executes it and returns the result.
 5 | 
 6 | A trivial way to e.g. graph the latest reading from a table of values.
 7 | 
 8 | =head1 USAGE
 9 | 
10 | Symlink it under C</etc/munin/plugins> with the desired name.
11 | 
12 | In C</etc/munin/plugin-conf.d/munin-node>, add a section with the name of the
13 | symlink you created, with the following env vars - this is a live working
14 | example from my home server:
15 | 
16 |     [garden_temp]
17 |     env.title Outdoor temperature
18 |     env.label Temperature
19 |     env.vlabel Temperature (C)
20 |     env.category Environment
21 |     env.query select temp_c from temperature_records order by timestamp desc limit 1
22 |     env.dsn DBI:mysql:davidp
23 |     env.db_user munin
24 | 
25 | If you wish to graph multiple values on the same graph, then instead of
26 | C<env.query> and C<env.label>, use pairs of e.g. C<env.query1> and C<env.label1>,
27 | C<env.query2> and C<env.label2>, etc.
28 | 
29 | =head1 Env vars
30 | 
31 | The environment vars used to control the plugin (see above for how to set them
32 | in the munin-node config) are:
33 | 
34 | =over
35 | 
36 | =item title
37 | 
38 | The title for the graph - shown across the top of the graph
39 | 
40 | =item vlabel
41 | 
42 | The label for the data being plotted (labels the Y axis)
43 | 
44 | =item label
45 | 
46 | The label for the value - i.e. shown in the graph legend.  Defaults to
47 | the same as C<vlabel>.  If you are graphing multiple values, then instead use
48 | C<label1>, C<label2> etc.
49 | 
50 | =item category
51 | 
52 | The category for this graph.  If not specified, defaults to "Database queries".
53 | 
54 | =item query
55 | 
56 | The SQL query to run.  If you are graphing multiple values, instead use
57 | C<query1>, C<query2> etc, and be sure to also supply C<label1>, C<label2> etc
58 | to label what each reading is.
59 | 
60 | =item dsn
61 | 
62 | The DSN to pass to L<DBI>.
63 | 
64 | =item db_user
65 | 
66 | Optional, the username to connect as
67 | 
68 | =item db_pass
69 | 
70 | Optional, the password to use
71 | 
72 | =back
73 | 
74 | 


--------------------------------------------------------------------------------
/dnstiming/dnstiming.pl:
--------------------------------------------------------------------------------
 1 | #!/usr/bin/perl
 2 | 
 3 | # $Id: dnstiming.pl 789 2009-12-03 19:06:51Z davidp $
 4 | 
 5 | use common::sense;
 6 | use HTML::Table;
 7 | use Time::HiRes;
 8 | use Net::DNS::Resolver;
 9 | use List::Util;
10 | 
11 | my @hostnames = qw(
12 |     www.google.com
13 |     www.facebook.com
14 |     www.bbc.co.uk
15 |     www.myspace.com
16 |     www.yahoo.com
17 |     www.wikipedia.org
18 |     www.debian.org
19 |     www.youtube.com
20 |     www.twitter.com
21 |     www.imdb.com
22 |     www.apple.com
23 | );
24 | 
25 | my %providers = (
26 |     Google =>  [ '8.8.8.8',        '8.8.4.4'        ],
27 |     OpenDNS => [ '208.67.220.220', '208.67.222.222' ],
28 |     Virgin  => [ '194.168.4.100',  '194.168.8.100'  ],
29 |     Local   => [ '127.0.0.1'                        ],
30 | );
31 | 
32 | # Build up a hash of arrayrefs of durations, to average at the end
33 | my %times;
34 | 
35 | 
36 | # Now, for each provider, we'll try each hostname against each of their
37 | # resolvers several times, to get more accurate figures.
38 | for (1..50) {
39 |     for my $provider (keys %providers) {
40 |         for my $server (@{ $providers{$provider} }) {
41 |             my $dns = Net::DNS::Resolver->new( nameservers => [ $server ] );
42 |             for my $hostname (@hostnames) {
43 |                 my $start = [ Time::HiRes::gettimeofday ];
44 |                 my $result = $dns->query($hostname);
45 |                 push @{ $times{$provider} }, Time::HiRes::tv_interval($start);
46 |             }
47 |         }
48 |     }
49 | }
50 | 
51 | 
52 | # Go through each provider and calculate best/worst/avg times:
53 | my @rows;
54 | for my $provider (keys %providers) {
55 |     my @times = @{ $times{$provider} };
56 |     my $best  = sprintf '%.4f', List::Util::min(@times);
57 |     my $worst = sprintf '%.4f', List::Util::max(@times);
58 |     my $avg   = sprintf '%.4f', List::Util::sum(@times) / @times;
59 |     push @rows, [ $provider, $avg, $best, $worst ];
60 | }
61 | 
62 | my $table = HTML::Table->new;
63 | $table->addRow(qw( Provider Average Best Worst ));
64 | $table->setRowHead(1);
65 | 
66 | for my $row (sort { $a->[1] <=> $b->[1] } @rows) {
67 |     $table->addRow(@$row);
68 | }
69 | $table->print;
70 | 
71 | 
72 | 


--------------------------------------------------------------------------------
/cpants-scores/README.pod:
--------------------------------------------------------------------------------
 1 | =head1 cpants-scores
 2 | 
 3 | A quick script to parse the overall "CPANTS Game Kwalitee" score from
 4 | cpants.cpanauthors.org for a named author, and then fetch the core kwalitee
 5 | for each of their dists.
 6 | 
 7 | =head1 USAGE
 8 | 
 9 |     cpants-scores BIGPRESH
10 | 
11 | =head1 OUTPUT
12 | 
13 | Example output:
14 | 
15 |     Game score for BIGPRESH: 98.6519607843137
16 |     Bot-BasicBot-Pluggable-Module-Abuse-YourMomma kwalitee: 100.00
17 |     Bot-BasicBot-Pluggable-Module-GitHub kwalitee: 100.00
18 |     Bot-BasicBot-Pluggable-Module-Nagios kwalitee: 100.00
19 |     Bot-BasicBot-Pluggable-Module-TwitterFriendsStatus kwalitee: 100.00
20 |     Bot-BasicBot-Pluggable-Module-TwitterWatch kwalitee: 100.00
21 |     Color-Spectrum-Multi kwalitee: 100.00
22 |     Dancer-Plugin-Auth-Extensible kwalitee: 100.00
23 |     Dancer-Plugin-Database kwalitee: 100.00
24 |     Dancer-Plugin-DebugDump kwalitee: 100.00
25 |     Dancer-Plugin-EscapeHTML kwalitee: 100.00
26 |     Dancer-Plugin-MPD kwalitee: 100.00
27 |     Dancer-Plugin-NYTProf kwalitee: 100.00
28 |     Dancer-Plugin-SMS kwalitee: 100.00
29 |     Dancer-Plugin-SimpleCRUD kwalitee: 100.00
30 |     Dancer-Plugin-TimeRequests kwalitee: 100.00
31 |     Dancer-Session-Storable kwalitee: 100.00
32 |     Dancer-Template-HtmlTemplate kwalitee: 100.00
33 |     Finance-PremiumBonds kwalitee: 100.00
34 |     HTML-Table-FromDatabase kwalitee: 100.00
35 |     Lyrics-Fetcher kwalitee: 100.00
36 |     Lyrics-Fetcher-AZLyrics kwalitee: 100.00
37 |     Lyrics-Fetcher-AstraWeb kwalitee: 100.00
38 |     Lyrics-Fetcher-LyricWiki kwalitee: 100.00
39 |     MP3-CreateInlayCard kwalitee: 100.00
40 |     Net-Shoutcast-Admin kwalitee: 100.00
41 |     Pod-Readme kwalitee: 100.00
42 |     SMS-AQL kwalitee: 100.00
43 |     SMS-Send-AQL kwalitee: 100.00
44 |     WWW-Comic-Plugin-CyanideAndHappiness kwalitee: 100.00
45 |     WWW-Comic-Plugin-LeastICouldDo kwalitee: 100.00
46 |     WWW-Comic-Plugin-Wulffmorgenthaler kwalitee: 100.00
47 |     WWW-Comic-Plugin-XKCD kwalitee: 100.00
48 |     WWW-Comic-Plugin-f8d kwalitee: 100.00
49 |     WebService-Bluga-Webthumb kwalitee: 100.00
50 |     Calculated average: 100
51 | 
52 | 
53 | =head1 AUTHOR
54 | 
55 | David Precious (bigpresh) C<< <davidp@preshweb.co.uk> >>
56 | 
57 | 


--------------------------------------------------------------------------------
/tabulate/tabulate:
--------------------------------------------------------------------------------
 1 | #!/usr/bin/perl
 2 | 
 3 | # $Id: tabulate 822 2010-01-28 13:27:09Z davidp $
 4 | 
 5 | use strict;
 6 | use Text::Tabulate;
 7 | use Getopt::Lucid;
 8 | 
 9 | my @option_specs = (
10 |     Getopt::Lucid::Param('fieldspec|f'),
11 |     Getopt::Lucid::Param('headers|h'),
12 |     Getopt::Lucid::Param('skipfirst|skip-first|s')->default(0),
13 |     Getopt::Lucid::Param('filter|m'),
14 |     Getopt::Lucid::Param('keepfirst|keep-first|keep-first-rows|K', qr/\d+/),
15 |     Getopt::Lucid::Param('separator|seperator|sep')->default('|'),
16 |     Getopt::Lucid::Param('spliton|split-on')->default('\s+'),
17 | );
18 | 
19 | my $opt = Getopt::Lucid->getopt(\@option_specs);
20 | 
21 | my @rows;
22 | my $fieldspec = $opt->get_fieldspec;
23 | my $split_on = $opt->get_spliton;
24 | $split_on = qr/$split_on/;
25 | for (<>) {
26 |     my @fields = split $split_on;
27 |     if ($fieldspec) {
28 |         push @rows, join "\t",  eval "\@fields[$fieldspec]";
29 |     } else {
30 |         push @rows, join "\t", @fields;
31 |     }
32 | }
33 | 
34 | # If we were asked to skip some initial rows, do so:
35 | if (my $skip = $opt->get_skipfirst) {
36 |     shift @rows for 1..$skip;
37 | }
38 | 
39 | 
40 | # If we're filtering the rows we output to rows which match a given pattern,
41 | # do that now.
42 | my @output;
43 | if (my $match = $opt->get_filter) {
44 |     # If we were told to preserve the first X rows, do so:
45 |     if (my $keep = $opt->get_keepfirst) {
46 |         push @output, shift @rows for 1..$keep;
47 |     }
48 | 
49 |     # Now, go through and add rows if they match the pattern
50 |     # TODO: Maybe make it possible to match only on a given column
51 |     push @output, grep { /$match/ } @rows;
52 | 
53 | } else {
54 |     # We're outputting everything, so it's easy
55 |     @output = @rows;
56 | }
57 | 
58 | # If we got column names, add them as the first row of the table:
59 | my @headings;
60 | if (my $heading_opt = $opt->get_headers) {
61 |     unshift @output, join "\t", @headings;
62 | }
63 | 
64 | my $tabulate = Text::Tabulate->new(
65 |     gutter => $opt->get_separator,
66 |     left   => $opt->get_separator,
67 |     right  => $opt->get_separator,
68 |     joint => "\n",
69 | );
70 | print scalar $tabulate->format(@output). "\n";
71 | 
72 | 
73 | 
74 | 


--------------------------------------------------------------------------------
/wordle-solver/wordle-hint:
--------------------------------------------------------------------------------
 1 | #!/usr/bin/env perl
 2 | 
 3 | # Quick Wordle helper
 4 | # Usage: wordle-hint <hint> <includes> <exclude>
 5 | # where:
 6 | # hint is e.g. "...er" using dots for "don't know" and letters in their
 7 | #     known to be correct places
 8 | # includes is a list of letters known to be in the word, but their position
 9 | #     is unknown yet
10 | # exclude is a list of letters known not to be in the word
11 | # e.g. wordle-hint .o... r sweganhyjku
12 | 
13 | use 5.012;
14 | 
15 | my $dict = '/usr/share/dict/words';
16 | 
17 | my ($hint, $includes, $excludes) = @ARGV;
18 | 
19 | if (length($hint) != 5) {
20 |     die "Hint must be 5 characters long\n";
21 | }
22 | 
23 | if (!$includes || !$excludes) {
24 |     die "Usage: $0 hint includeletters excludeletters\n\n"
25 |         . "For e.g. '$0 .o... r sweganhyjk'\n"
26 |         . " - know 2nd letter is 'o', know there's an 'r' somewhere,\n"
27 |         . "and know there's no s, w, e, g, a, n  etc";
28 | }
29 | 
30 | # Sure I could do these better with a hairy lookaround regex, but KISS for now
31 | my $hint_re = qr/$hint/ or die "Invalid hint regex '$hint'!";
32 | my $exclude_class = "[$excludes]";
33 | say "exclude_class: $exclude_class";
34 | my $exclude_re = qr{$exclude_class};
35 | my @known_present_letters = split //, $includes;
36 | my @known_missing_letters = split //, $excludes;
37 | 
38 | say "look for matches for $hint_re, excluding $exclude_re";
39 | open my $fh, "<", $dict
40 |     or die "Failed to open dictionary $dict - $!";
41 | 
42 | word:
43 | while (chomp(my $word = <$fh>)) {
44 |     # All Wordle words are 5 letters:
45 |     next word if length($word) != 5;
46 |     # Exclude any contractions, accented chars etc
47 |     next word if $word =~ /[^a-z]/;
48 |     # Must match our hint pattern (e.g. known-right letters in known-right
49 |     # places)
50 |     next word unless $word =~ $hint_re;
51 | 
52 |     # Must contain all of the letters that we know are present but don't yet
53 |     # know their position
54 |     for (@known_present_letters) {
55 |         next word unless $word =~ /$_/;
56 |     }
57 |     # and must not contain any of the letters we know are not present:
58 |     next word if $word =~ $exclude_re;  # must not contain known-not-to-be-present
59 |     say "Consider '$word'";
60 | }
61 |     
62 | 
63 | 


--------------------------------------------------------------------------------
/retag-by-filename/retag-by-filename:
--------------------------------------------------------------------------------
 1 | #!/usr/bin/perl
 2 | 
 3 | # $Id: retag-by-filename.pl 587 2009-05-06 22:01:45Z davidp $
 4 | 
 5 | use strict;
 6 | use 5.010;
 7 | use Music::Tag;
 8 | use Getopt::Lucid;
 9 | use File::Basename;
10 | 
11 | # Given a regex (with named captures) and a list of files, retag the files
12 | # based on the pattern.
13 | # Example:
14 | # --pattern='(?<track> \d+ ) \s (?<title> .+) - (?<artist> .+ ) \.mp3' *
15 | # Note: patterns have /xmsi modifier applied to them
16 | 
17 | my @option_specs = (
18 |     Getopt::Lucid::Switch('verbose|v'),
19 |     Getopt::Lucid::Switch('dry-run|dryrun|d'),
20 |     Getopt::Lucid::List('set-only|setonly|s'),
21 |     Getopt::Lucid::Param('pattern|p'),
22 | );
23 | my $opt = Getopt::Lucid->getopt(\@option_specs);
24 | $opt->validate( { requires => ['pattern'] } );
25 | 
26 | my $pattern_val = $opt->get_pattern;
27 | my $pattern = qr/$pattern_val/xmsi       # lack of \Q..\E here is intentional.
28 |     or die "Failed to parse pattern";
29 | 
30 | # Getopt::Lucid will have removed recognised options from @ARGV, leaving behind
31 | # the files we need to work on:
32 | my @files = @ARGV;
33 | # Now, look for files in the directory, and see what to retag them to:
34 | for my $file (@files) {
35 |     my $filename = File::Basename::basename($file);
36 |     
37 |     if ($filename =~ $pattern) {
38 |         say qq{[$+{track}] "$+{title}" by "$+{artist}" ($+{comment})};
39 | 
40 |         next if ($opt->get_dry_run);
41 | 
42 |         my $tags = Music::Tag->new($file,
43 |             { quiet => ! $opt->get_verbose });
44 |         $tags->get_tag or warn "Failed to read tags for $filename" && next;
45 |         for my $tag(qw(track title artist comment)) {
46 |             if (!$opt->get_set_only || grep { $_ eq $tag } $opt->get_set_only) {
47 |                 my $tag_val = $+{$tag} || '';
48 |                 if ($tag eq 'track') {
49 |                     $tag_val = sprintf '%02d', $tag_val;
50 |                 }
51 |                 say "Setting $tag to '$tag_val'" if $opt->get_verbose;
52 |                 $tags->$tag($tag_val);
53 |             }
54 |         }
55 |         $tags->set_tag or warn "Failed to set tags for $filename" && next;
56 |         $tags->close;
57 | 
58 |     } else {
59 |         warn "$file does not match $pattern";
60 |     }
61 | }
62 | 


--------------------------------------------------------------------------------
/get-rm-pro-temp-reading/get-rm-pro-temp-reading:
--------------------------------------------------------------------------------
 1 | #!/usr/bin/env perl
 2 | 
 3 | # Fetch a temperature reading from an RM Pro, via broadlink-http-rest,
 4 | # and store it in the readings database.
 5 | #
 6 | # Takes a few readings and averages them, to avoid silly readings.
 7 | #
 8 | # Expects MySQL connection details in ~/.my.cnf
 9 | #
10 | # Call it with the sensor name and the hostname & port that broadlink-http-rest
11 | # is running on, e.g. ... lounge supernova:9898
12 | 
13 | use strict;
14 | 
15 | use DBI;
16 | use LWP::UserAgent;
17 | use List::Util;
18 | use JSON;
19 | 
20 | 
21 | $SIG{ALRM}  = sub { die "timeout\n" };
22 | 
23 | alarm 15;
24 | 
25 | my ($sensor_name, $hostname) = @ARGV
26 |     or die "Usage: $0 readingname host:port";
27 | 
28 | my $ua = LWP::UserAgent->new( timeout => 5 );
29 | 
30 | 
31 | # Poll 5 times for readings to help smooth out random bullshit readings
32 | # TODO: should we discard obvious outliers?
33 | my @temperatures;
34 | my $discard_count;
35 | for (1..3) {
36 |     my $response = $ua->get("http://$hostname/getStatus/temperature");
37 |     if (!$response->is_success) {
38 |         warn "Failed request to $hostname - " . $response->status_line;
39 |         sleep 10;
40 |         redo;
41 |     }
42 | 
43 |     my $data = JSON::decode_json($response->content);
44 | 
45 |     # Discard obvious sillyness - I've seen times when it randomly
46 |     # returns 249C, and I'm sure my lounge wasn't *that* warm :)
47 |     if ($data->{temperature} > 60 || $data->{temperature} < -20) {
48 |         if ($discard_count++ > 5) {
49 |             die "Retried too many times, still getting implausible readings";
50 |         }
51 |         warn "Discarding implausible reading $data->{temperature}";
52 |         sleep 2;
53 |         redo;
54 |     }
55 | 
56 | 
57 | 
58 |     push @temperatures, $data->{temperature};
59 |     sleep 1;
60 | }
61 | 
62 | my $avg_temp = List::Util::sum(@temperatures) / scalar @temperatures;
63 | 
64 | 
65 | my $dbh = DBI->connect(
66 |     "DBI:mysql:davidp;mysql_read_default_file=$ENV{HOME}/.my.cnf"
67 | ) or die "Failed to connect to DB! $DBI::errstr";
68 | 
69 | 
70 | $dbh->do(qq{
71 |     INSERT INTO temperature_records (
72 |         timestamp, sensor, temp_c
73 |     ) VALUES (
74 |         NOW(), ?, ?
75 |     )
76 | }, {}, $sensor_name, $avg_temp
77 | ) or die "DB insert failed - " . $dbh->errstr;
78 | 
79 | 


--------------------------------------------------------------------------------
/log-ntl-cablemodem-stats/CableModemStats/lib/CableModemStats.pm:
--------------------------------------------------------------------------------
 1 | package CableModemStats;
 2 | use Dancer ':syntax';
 3 | use Dancer::Plugin::Database;
 4 | 
 5 | use Chart::Strip;
 6 | 
 7 | our $VERSION = '0.1';
 8 | 
 9 | get '/' => sub {
10 |     my $stats = database->selectcol_arrayref(
11 |         'select distinct(`key`) from `stats`'
12 |     ) or die "Failed to fetch available stat types";
13 |     template 'index', {
14 |         stat_types => $stats,
15 |     };
16 | };
17 | 
18 | get '/view/:statname' => sub {
19 |     template 'stat', { stat => params->{statname} };
20 | };
21 | 
22 | 
23 | get '/graph/:statname' => sub {
24 |     redirect '/graph/' . params->{statname} . '/hour/1';
25 | };
26 | 
27 | get '/graph/:statname/:unit/:unitcount' => sub {
28 |     my $periodunit = params->{unit};
29 |     my $periodunitcount = params->{unitcount};
30 |     $periodunit =~ s/s$//;
31 |     if ($periodunit !~ /^ (hour|day|week|month|year) $/x) {
32 |         return send_error "Invalid unit $periodunit";
33 |     }
34 |     if ($periodunitcount !~ /^ \d+ $/x) {
35 |         return send_error "Invalid unitcount $periodunitcount";
36 |     };
37 | 
38 |     my $query = <<QUERY;
39 | SELECT 
40 |     UNIX_TIMESTAMP(`timestamp`) AS time_t, 
41 |     `value` 
42 | FROM `stats` 
43 | WHERE 
44 |     `key` = ?
45 | AND timestamp >= DATE_SUB(now(), interval $periodunitcount $periodunit)
46 | QUERY
47 |     my $sth = database->prepare($query);
48 |     $sth->execute(
49 |         params->{statname}, 
50 |     );
51 |     my @dataset;
52 |     my $unit;
53 |     while (my $row = $sth->fetchrow_hashref) {
54 |         ($unit) = $row->{value} =~ /\d+\s+(.+)$/ unless $unit;
55 |         my $value = $row->{value};
56 |         $value =~ s/\s+.+$//g;
57 |         push @dataset, { time => $row->{time_t}, value => $value };
58 |     }
59 |     
60 |     my $title = params->{statname};
61 |     $title .= " ($unit)" if $unit;
62 |     my $period = "$periodunitcount $periodunit";
63 |     $period .= 's' if $periodunitcount > 1;
64 |     $title .= "($period)";
65 |     my $chart = Chart::Strip->new(
66 |         title  => $title, 
67 |         width  => 500, 
68 |         height => 100,
69 |         transparent => 0,
70 |     );
71 |     $chart->add_data(\@dataset, { style => 'line' });
72 | 
73 | 
74 |     content_type 'image/png';
75 |     return $chart->png;
76 |     
77 | };
78 | 
79 | dance;
80 | 


--------------------------------------------------------------------------------
/bot-basicbot-modules/RateLimitUsers.pm:
--------------------------------------------------------------------------------
 1 | package Bot::BasicBot::Pluggable::Module::RateLimitUsers;
 2 | use strict;
 3 | use base 'Bot::BasicBot::Pluggable::Module';
 4 | 
 5 | 
 6 | sub help {
 7 |     return <<HELPMSG
 8 | Stops a user from spamming the bot (e.g. repeated karma scoring, etc).
 9 | 
10 | Keeps track of how many times each nick has addressed the bot, and
11 | begins to ignore them if they've done it too often in a configurable
12 | period.
13 | 
14 | Configure with max_messages (how many times a user can address the bot)
15 | and rate_limit_window - (the number of seconds to look back).  For example,
16 | max_messages = 5 and rate_limit_window = 60 would start ignoring a user after
17 | they address the bot 5 times in a minute.
18 | HELPMSG
19 | }
20 | 
21 | my %messages_from_nick;
22 | sub said {
23 |     my ($self, $mess, $pri) = @_;
24 | 
25 |     # If the user wasn't talking to us, no further checks:
26 |     return unless $mess->{address};
27 | 
28 |     my $max_messages = $self->get('max_messages') || 5;
29 |     my $rate_limit_window = $self->get('rate_limit_window') || 60;
30 | 
31 |     # Want to get first interception of everything
32 |     return unless $pri == 0;
33 | 
34 |     # First, remove any expired timestamps:
35 |     $messages_from_nick{$mess->{who}} = [
36 |         grep {
37 |             $_ > time - $rate_limit_window
38 |         } @{ $messages_from_nick{$mess->{who}} || [] }
39 |     ];
40 |     
41 |     # Record this one... 
42 |     push @{ $messages_from_nick{$mess->{who}} }, scalar time;
43 | 
44 |     # and now, if they're being too chatty - if they've just hit the limit, tell
45 |     # them and ignore them, if they've over the limit already just ignore.
46 |     my $messages_in_window = scalar @{ $messages_from_nick{$mess->{who}} };
47 |     if ($messages_in_window == $max_messages) {
48 |         warn sprintf "Beginning to ignore %s - %d messages in %d seconds",
49 |             $mess->{who},
50 |             $messages_in_window,
51 |             $rate_limit_window;
52 |         return "Slow down please $mess->{who} - ignoring you for a while";
53 |     } elsif ($messages_in_window > $max_messages) {
54 |         warn sprintf "Still ignoring %s (%d messages in %d second window"
55 |             . " exceeds limit of %d)",
56 |             $mess->{who},
57 |             $messages_in_window,
58 |             $rate_limit_window,
59 |             $max_messages;
60 |         return 1;
61 |     }
62 | }
63 | 
64 | 
65 | 1;
66 | 


--------------------------------------------------------------------------------
/fse/fse-flight-to-flightplan:
--------------------------------------------------------------------------------
 1 | #!/usr/bin/env perl
 2 | 
 3 | use strict;
 4 | use LWP::UserAgent;
 5 | use Net::Netrc;
 6 | use XML::Twig;
 7 | 
 8 | # Enter your API key - get it from http://server.fseconomy.net/datafeeds.jsp
 9 | # Or, leave empty, and we'll read it from .netrc using Net::Netrc - see below.
10 | my $api_key = "";
11 | # Enter the filename to write the flight plan to:
12 | my $filename = "/mnt/data/SteamLibrary/steamapps/common/X-Plane 10/Output/FMS plans/FSE.fms";
13 | 
14 | 
15 | # First - if we don't have an API key provided, then look in .netrc
16 | # You should define an entry for server.fseconomy.net with the "account" 
17 | # set to the API key, e.g.:
18 | #     machine server.fseconomy.net
19 | #     account XXXXXXX
20 | if (!$api_key) {
21 |     my $mach = Net::Netrc->lookup('server.fseconomy.net');
22 |     if (!$mach) {
23 |         die "No API key in script and none found in .netrc!";
24 |     }
25 |     $api_key = $mach->account;
26 | }
27 | 
28 | 
29 | my $url = "http://server.fseconomy.net/data?userkey=$api_key&format=xml&query=assignments&search=key&readaccesskey=$api_key";
30 | my $ua = LWP::UserAgent->new;
31 | my $response = $ua->get($url);
32 | 
33 | if (!$response->is_success) {
34 |     die "Request failed - " . $response->status_line;
35 | }
36 | 
37 | my $twig = XML::Twig->new;
38 | $twig->parse($response->decoded_content);
39 | my $root = $twig->root;
40 | my %destinations;
41 | for my $assignment ($root->children) {
42 |     my $destination = $assignment->first_child_text('Destination');
43 |     my $status = $assignment->first_child_text('Status');
44 |     if ($status =~ /Departing|Enroute/) {
45 |         $destinations{$destination}++;
46 |     }
47 | }
48 | 
49 | 
50 | # For now, dead simple - just dump each ICAO code to a flight plan in no
51 | # particular order, I can just pick the one I want and hit direct-to, still
52 | # avoids having to scroll through entering letter-by-letter.
53 | # Except for complex flights with multiple stops enroute, it'll be fine
54 | # anyway.
55 | # TODO: find a good way to fetch the distance for each assignment, as it's
56 | # unhelpfully not present in the data feed - then we could sort by distance,
57 | # shortest hop first.
58 | open my $fh, ">", $filename
59 |     or die "Failed to open $filename - $!";
60 | 
61 | print {$fh} <<PREAMBLE;
62 | I
63 | 3 version
64 | 0
65 | 4
66 | PREAMBLE
67 | 
68 | for my $icao (sort keys %destinations) {
69 |     say "Adding $icao to flight plan";
70 |     say {$fh} "1 $icao 0";
71 | }
72 | 
73 | 
74 | 
75 | 


--------------------------------------------------------------------------------
/tagtrack/tagtrack:
--------------------------------------------------------------------------------
 1 | #!/usr/bin/perl
 2 | 
 3 | # $Id: tagtrack 586 2009-05-06 21:56:37Z davidp $
 4 | 
 5 | use strict;
 6 | use 5.010;
 7 | use Music::Tag;
 8 | use Getopt::Lucid;
 9 | use Data::Dumper;
10 | 
11 | # Set ID3 tags on a file.
12 | 
13 | # The options we can take - these correspond to the name of the tag that
14 | # they'll set:
15 | my @options = qw(track title artist album comment);
16 | 
17 | my @option_specs = (
18 |     Getopt::Lucid::Switch('verbose|v'),
19 |     Getopt::Lucid::Switch('dry-run|dryrun|d'),
20 |     map { Getopt::Lucid::Param($_) } @options,
21 | );
22 | my $opt = Getopt::Lucid->getopt(\@option_specs);
23 | 
24 | my @tags_to_set = grep { $opt->{seen}{$_} } @options;
25 | # Getopt::Lucid will have taken all the recognised params from @ARGV, and
26 | # left behind the filenames we need to operate on:
27 | my @files = @ARGV;
28 | 
29 | say "Files we'll work on: " . join ',', @files  if $opt->get_verbose;
30 | 
31 | if (!@tags_to_set) {
32 |     say "Nothing to do.  Use one or more of the options:\n" .
33 |         join ', ', map {'--'.$_} @options;
34 |     exit;
35 | }
36 | 
37 | say "Setting tag(s) " . human_friendly_list(@tags_to_set) .
38 |     " on " . scalar @files . " files";
39 | 
40 | file:
41 | my $filenum = 0;
42 | for my $file (@files) {
43 |     if (!-f $file) {
44 |         warn "$file is not a file";
45 |         next file;
46 |     }
47 |     if (!-r _ || !-w _) {
48 |         warn "$file is not readable/writable";
49 |         next file;
50 |     }
51 | 
52 |     $filenum++;
53 | 
54 |     # OK, read the current tags:
55 |     my $tags = Music::Tag->new($file, { quiet => !$opt->get_verbose });
56 |     if (!$tags) {
57 |         die "Music::Tag failed to read $file";
58 |     }
59 |     $tags->get_tag || die "Failed to parse tags in $file";
60 | 
61 |     # For each tag we might have been asked to set, set it:
62 |     for my $tag (@tags_to_set) {
63 |         my $param_method = "get_$tag";
64 |         my $newval = $opt->$param_method();
65 |         if ($tag eq 'track' && $newval eq 'auto') { $newval = $filenum; }
66 |         say "Setting $tag for $file to $newval" if $opt->get_verbose;
67 |         $tags->$tag($newval) unless $opt->get_dry_run;
68 |     }
69 | 
70 |     $tags->set_tag unless $opt->get_dry_run;
71 |     $tags->close;
72 | }
73 | 
74 | 
75 | # Turn a list into a human friendly string, e.g. "foo, bar and baz"
76 | sub human_friendly_list {
77 |     return '' unless @_;
78 |     return @_ > 1? join(', ', @_[0..@_-2]) . ' and ' . $_[-1] : @_[0];
79 | }
80 | 
81 | 


--------------------------------------------------------------------------------
/munin_am2302_dht/README.pod:
--------------------------------------------------------------------------------
 1 | =head1 am2302_dht humidity/temperature monitoring
 2 | 
 3 | This is a simple Munin plugin to monitor and graph temperature and humidity
 4 | readings from an AM2302 temperature and humidity sensor.
 5 | 
 6 | The AM2302 is a simple, cheap and effective device for monitoring temperature
 7 | and humidity from a single device.
 8 | 
 9 | The plugin uses the Adafruit drives which you can check out from:
10 | 
11 | L<git://github.com/adafruit/Adafruit-Raspberry-Pi-Python-Code.git>
12 | 
13 | For more info on this Adafruit repo, see its GitHub page with a README:
14 | 
15 | L<https://github.com/adafruit/Adafruit-Raspberry-Pi-Python-Code>
16 | 
17 | In particular it executes the C<Adafruit_DHT> driver from the above repo to read
18 | the values - a direct link to the driver itself is:
19 | 
20 | L<https://github.com/adafruit/Adafruit-Raspberry-Pi-Python-Code/tree/master/Adafruit_DHT_Driver>
21 | 
22 | 
23 | At the moment the path to C<Adafruit_DHT>, sensor type and GPIO PIN are
24 | hardcoded in vars at the top of the script, which is a bit lazy, but  I wrote
25 | this for my own use and then decided to shove it here in case it's useful to
26 | anyone else.  If I get feedback from others using it, I may refactor it to take
27 | these parameters properly etc.
28 | 
29 | =head2 Configuring
30 | 
31 | To use it from Munin, copy it somewhere (your Munin plugins dir, e.g.
32 | C</usr/share/munin/plugins> or elsewhere) then, in your Munin Node config
33 | plugins dir, e.g. C</etc/munin/plugins>, place symlinks to it with the name as 
34 | location_readingtype - for instance, I have two symlinks, C<shed_temperature> 
35 | and C<shed_humidity>.  The script uses the name it was called as to find out 
36 | the location name and which reading is required. (This way you don't need to 
37 | do anything clever in your Munin config.)
38 | 
39 | =head2 Help / Support
40 | 
41 | I wrote this hastily for my own purposes, for a Raspberry Pi I have in my shed,
42 | monitoring the temperature and humidity using an AM2302, and also external
43 | temperatures using 1-wire sensors.  So, it's not as good as code I'd have
44 | written initially planning to release.  That said, it works for me, and may be
45 | useful to you.  If it is, I'd be very grateful to know, if you have a moment to
46 | drop me a quick "hey, I'm using this and it works" email, that would be awesome.
47 | If it's not working for you and you want help, I'll see what I can do.
48 | 
49 | =head2 AUTHOR
50 | 
51 | David Precious C<davidp@preshweb.co.uk>
52 | 
53 | 
54 | 


--------------------------------------------------------------------------------
/nagios_smart_log/README.pod:
--------------------------------------------------------------------------------
 1 | =head1 nagios_smart_logs
 2 | 
 3 | A Nagios plugin to monitor for errors reported by
 4 | L<SMART|http://en.wikipedia.org/wiki/S.M.A.R.T.> to alert on failing hard
 5 | drives.
 6 | 
 7 | I'd long used the good old C<check_ide_smart> plugin from Nagios itself, but 
 8 | it relies upon SMART detecting and reporting problems well and doesn't
 9 | monitor the SMART logs for failed self-tests etc.
10 | 
11 | I've seen a few drives failing and throwing IO errors, all the while SMART
12 | happily proclaims:
13 | 
14 |   SMART overall-health self-assessment test result: PASSED
15 | 
16 | Similarly, C<check_ide_smart> reported no problems:
17 | 
18 |   [dave@devvps:~]$ sudo /usr/lib/nagios/plugins/check_ide_smart -n /dev/sdb
19 |   OK - Operational (18/18 tests passed)
20 | 
21 | I can no longer trust it alone.
22 | 
23 | So, this plugin requests the error log (using C<smartctl -l errors> and alarms
24 | if errors are found:
25 | 
26 |   [dave@devvps:~]$ ./nagios_smart_log -d /dev/sdb
27 |   CHECKSMARTLOG CRITICAL - 5 SMART errors, latest: Error 13 occurred at disk
28 |   power-on lifetime: 29769 hours (1240 days + 9 hours)
29 | 
30 | Far more useful.
31 | 
32 | =head2 Consider check_scsi_smart instead
33 | 
34 | Update Feb 2024: I was having problems with C<check_ide_smart> on a drive
35 | in an external enclosure, where running it directly would work fine, but
36 | when run via Nagios it would fail with C<CRITICAL - SMART_CMD_ENABLE>.
37 | 
38 | I couldn't see what was going on easily, and a Google turned up several
39 | people with the same problem, including:
40 | 
41 | =over
42 | 
43 | =item L<Icinga #2725|https://community.icinga.com/t/unable-to-perform-check-ide-smart-on-agent/2725>
44 | 
45 | =item L<monitoring-plugins#1104|https://github.com/monitoring-plugins/monitoring-plugins/issues/1104>
46 | 
47 | =item L<Debian #690760|https://bugs.debian.org/cgi-bin/bugreport.cgi?bug=690760>
48 | 
49 | =back
50 | 
51 | The Debian report suggested the problem was fixed in Wheezy and Jessie packages,
52 | but I was still seeing it on my Debian 12 (Buster) box with monitoring-plugins 
53 | package version C<2.3.3-5+deb12u2>.
54 | 
55 | I saw L<check_scsi_smart|https://github.com/spjmurray/nagios-plugin-check-scsi-smart>
56 | recommended as a more modern alternative to C<check_ide_smart>; it works a treat
57 | for me, and also can monitor the SMART logs as well, replacing the need for
58 | this plugin.
59 | 
60 | So, I'd recommend you give it a go first, and props to L<@spjmurray|https://github.com/spjmurray> for it.
61 | 
62 | 
63 | 


--------------------------------------------------------------------------------
/fse/monitor-fbo-availability:
--------------------------------------------------------------------------------
 1 | #!/usr/bin/env perl
 2 | 
 3 | 
 4 | # Watch for FBO availability at the given airports.
 5 | # If the page doesn't contain "no room for FBO construction", there's a gap, so
 6 | # pounce
 7 | 
 8 | use strict;
 9 | use List::Util;
10 | use LWP::UserAgent;
11 | use Mail::Sendmail;
12 | use Net::Netrc;
13 | 
14 | 
15 | my $fse_server = 'server.fseconomy.net';
16 | my $recipient = 'davidp@preshweb.co.uk';
17 | 
18 | my $machine = Net::Netrc->lookup($fse_server)
19 |     or die "No login details for $fse_server in ~/.netrc";
20 | my ($user, $pass) = $machine->lpa;
21 | 
22 | my $ua = LWP::UserAgent->new(
23 |     agent => "Mozilla/5.0 (X11; Ubuntu; Linux x86_64; rv:56.0) Gecko/20100101 Firefox/56.0",
24 |     cookie_jar => {},
25 | );
26 | push @{ $ua->requests_redirectable }, 'POST';
27 | 
28 | 
29 | sleep 8 + int rand 25;
30 | 
31 | my $resp = $ua->post("http://$fse_server/userctl",
32 |     {
33 |         offset => 1, # TODO: calculate time offset
34 |         user => $user,
35 |         password => $pass,
36 |         event => 'Agree & Log in',
37 |     },
38 | );
39 | 
40 | if (!$resp->is_success) {
41 |     die "Login request failed - " . $resp->status_line;
42 | }
43 | 
44 | 
45 | sleep 2;
46 | 
47 | for my $icao (List::Util::shuffle(split /,/, $ARGV[0])) {
48 | 
49 |     print "Looking up $icao\n";
50 | 
51 |     my $resp = $ua->get("http://$fse_server/airport.jsp?icao=$icao");
52 |     if (!$resp->is_success) {
53 |         die "Failed to ask about $icao - " . $resp->status_line;
54 |     }
55 |     if ($resp->content !~ /$icao/) {
56 |         die "Didn't recognise airport page";
57 |     }
58 | 
59 |     if ($resp->content =~ /no room for FBO construction/) {
60 |         print "No room for FBOs at $icao right now\n";
61 |         # FIXME: should recognise the "Closed" status of an FBO by parsing the
62 |         # HTML table, in case of false positives on just "Closed"
63 |         if ($resp->content =~ /(closed FBO|Closed)/) {
64 |             print "Closed FBO at $icao may go away soon?\n";
65 |         }
66 |     } else {
67 |         print "Ooh - $icao has FBO space";
68 |         notify($icao);
69 |     }
70 | 
71 |     # go easy on the FSE servers, don't be a dick.
72 |     sleep int rand(10) + 5;
73 | 
74 | }
75 | 
76 | 
77 | sub notify {
78 |     my $icao = shift;
79 |     Mail::Sendmail::sendmail(
80 |         To => $recipient,
81 |         From => $recipient,
82 |         Subject => "FBO opening at $icao!",
83 |         message => "Check out $icao, it has space for an FBO!",
84 |     ) or die "failed to send mail - " . $Mail::Sendmail::error;
85 | }
86 | 
87 | 
88 | 
89 | 


--------------------------------------------------------------------------------
/get-esp-temp-reading/get-esp-temp-reading:
--------------------------------------------------------------------------------
 1 | #!/usr/bin/env perl
 2 | 
 3 | # Fetch a temperature/humidity reading from an ESP8266 running my code and store
 4 | # it in the readings database.
 5 | #
 6 | # Takes a few readings and averages them, to avoid silly readings.
 7 | #
 8 | # Expects MySQL connection details in ~/.my.cnf
 9 | 
10 | use strict;
11 | 
12 | use DBI;
13 | use LWP::UserAgent;
14 | use List::Util;
15 | use JSON;
16 | 
17 | 
18 | $SIG{ALRM}  = sub { die "timeout\n" };
19 | 
20 | alarm 15;
21 | 
22 | my $hostname = shift
23 |     or die "Usage: $0 esp-hostname";
24 | 
25 | my $ua = LWP::UserAgent->new( timeout => 5 );
26 | 
27 | 
28 | # Poll 5 times for readings to help smooth out random bullshit readings
29 | # TODO: should we discard obvious outliers?
30 | my @temperatures;
31 | my @humidities;
32 | 
33 | for (1..5) {
34 |     my $response = $ua->get("http://$hostname/");
35 |     my $retries = 0;
36 |     if (!$response->is_success) {
37 |         warn "Failed request to $hostname - " . $response->status_line;
38 | 
39 |         if ($retries++ < 10) {
40 |             sleep 10;
41 |             redo;
42 |         } else {
43 |             die "Request to $hostname failed after $retries retries"
44 |                 . " - " . $response->status_line;
45 |         }
46 |     }
47 |     if ($response->content =~ /timeout/) {
48 |         warn "DHT reading timeout";
49 |         sleep 2;
50 |         redo;
51 |     }
52 | 
53 |     #my $data = JSON::decode_json($response->content);
54 | 
55 |     # FIXME: use JSON::decode_json() once I've fixed my Lua firmware to output
56 |     # real JSON
57 |     my $data = {};
58 |     @$data{qw(temp humidity)} = $response->content =~ /temp:(.+),humidity:(.+)/;
59 | 
60 |     if ($data->{humdity} > 100 || $data->{temp} > 50) {
61 |         redo;
62 |     }
63 | 
64 |     push @temperatures, $data->{temp};
65 |     push @humidities,   $data->{humidity};
66 |     sleep 1;
67 | }
68 | 
69 | my $avg_temp = List::Util::sum(@temperatures) / scalar @temperatures;
70 | my $avg_hum  = List::Util::sum(@humidities)   / scalar @humidities;
71 | 
72 | if ($avg_hum > 100) {
73 |     die "Silly humidity reading $avg_hum, bailing out";
74 | }
75 | 
76 | my $dbh = DBI->connect(
77 |     "DBI:mysql:davidp;mysql_read_default_file=$ENV{HOME}/.my.cnf"
78 | ) or die "Failed to connect to DB! $DBI::errstr";
79 | 
80 | 
81 | $dbh->do(qq{
82 |     INSERT INTO temperature_records (
83 |         timestamp, sensor, temp_c, humidity_pc
84 |     ) VALUES (
85 |         NOW(), ?, ?, ?
86 |     )
87 | }, {},$hostname, $avg_temp, $avg_hum
88 | ) or die "DB insert failed - " . $dbh->errstr;
89 | print "OK, stored reading $avg_temp C, $avg_hum %\n" if $ENV{DEBUG};
90 | 


--------------------------------------------------------------------------------
/nagios_check_process_stats/README.pod:
--------------------------------------------------------------------------------
 1 | =head1 NAME
 2 | 
 3 | check_process_stats - Nagios plugin for monitoring CPU/memory use by processes
 4 | 
 5 | =head1 FEATURES
 6 | 
 7 | Allows you to monitor which processes (grouped by name) use the most CPU time /
 8 | memory on your box, with configurable thresholds, perfdata reporting etc.
 9 | 
10 | =over
11 | 
12 | =item Returns perfdata
13 | 
14 | Returns perfdata stats of memory and CPU usage and process count grouped by
15 | process name, so you can feed that to your metrics graphing system via Graphios
16 | etc and get pretty graphs so you can see at a glance what is using up lots of
17 | memory or CPU time, as well as monitoring in case any particular type of
18 | process gets greedier than it should.
19 | 
20 | =over
21 | 
22 | =item Monitor only processes with a specific name
23 | 
24 | By default, looks at all processes, groups them by their process name, returns
25 | that grouped perfdata for all of them, and checks each group against the
26 | thresholds (see below).
27 | 
28 | If you only want to check processes with a specific name, then use the C<-p> /
29 | C<--process_name> option to only look at processes with the name provided, e.g.:
30 | 
31 |   [davidp@supernova:~]$ perl check_process_stats -p perl
32 |   PROCESSES OK - 3 procs matching perl | perl.procs=3;; perl.total_rss=97632kB;;
33 |   perl.total_cpu=20.5;;
34 | 
35 | 
36 | =item Check CPU usage / memory usage against thresholds
37 | 
38 | If you want to check the CPU usage / memory usage/ number of processes against
39 | thresholds, then you can, using the C<--max_ram|m>, C<--max_cpu|c> and
40 | C<--max_procs|p> options, and the C<--threshold|t> option to provide a
41 | percentage leeway above the threshold where the return will be WARNING,
42 | after which it will be CRITICAL.
43 | 
44 | =item Returns perfdata
45 | 
46 | Using nagiosgraph or Graphios to get metrics graphing from Nagios?  This plugin
47 | will return perfdata, either for all process name groups if no specific name
48 | was given to filter by, or just the processes whose name matched that group
49 | otherwise.  Perfdata values returned are:
50 | 
51 | =over
52 | 
53 | =item I<procname>.procs
54 | 
55 | The number of processes with this name
56 | 
57 | =item I<procname>.total_cpu
58 | 
59 | The total CPU usage (%) of all processes with this name
60 | 
61 | =item I<procname>.total_rss
62 | 
63 | The total memory usage (RSS - Resident Set Size) of all processes with this
64 | name.
65 | 
66 | =back
67 | 
68 | 
69 | =head1 AUTHOR
70 | 
71 | David Precious C<< <davidp@preshweb.co.uk> >>
72 | 
73 | 
74 | =head1 FEEDBACK
75 | 
76 | Feedback very much welcomed.  Do feel free to drop me an email and let me know
77 | if this is useful to you!
78 | 
79 | 


--------------------------------------------------------------------------------
/bot-basicbot-modules/GitHubPullRequests.pm:
--------------------------------------------------------------------------------
 1 | # A quick Bot::BasicBot::Pluggable module to fetch a count of open pull requests
 2 | # for a GitHub project.
 3 | #
 4 | # David Precious <davidp@preshweb.co.uk>
 5 | 
 6 | package Bot::BasicBot::Pluggable::Module::GitHubPullRequests;
 7 | use strict;
 8 | use base 'Bot::BasicBot::Pluggable::Module';
 9 | use LWP::Simple ();
10 | use JSON;
11 | 
12 | sub help {
13 |     return <<HELPMSG;
14 | Monitors outstanding pull requests on a GitHub project.
15 | 
16 | Allows use of a !pr command to fetch the current count of open pull requests
17 | including a tally by user.
18 | 
19 | Usage: !pr user/project, or just !pr for the default project, configured by
20 | setting the 'github_project' setting using the Vars module (or by directly
21 | setting the user_github_project setting in the bot's store).
22 | HELPMSG
23 | }
24 | 
25 | 
26 | sub said {
27 |     my ($self, $mess, $pri) = @_;
28 |     
29 |     return unless $pri == 2;
30 | 
31 |     if ($mess->{body} =~ /^!pr (?: \s+ (\S+))?/xi) {
32 |         my $check_projects = $1;
33 |         $check_projects ||=  $self->get('user_github_project');
34 |         if (!$check_projects) {
35 |             $self->reply(
36 |                 $mess, 
37 |                 "No project(s) to check; either specify"
38 |                 . " a project, e.g. '!pr username/project', or use the Vars"
39 |                 . " module to configure the github_project setting for this"
40 |                 . " module to set the default project to check."
41 |             );
42 |             return 1;
43 |         }
44 |         for my $project (split /,/, $check_projects) {
45 |             my $prs = $self->_get_pull_request_count($project);
46 |             $self->say(
47 |                 channel => $mess->{channel},
48 |                 body => "Open pull requests for $project : $prs",
49 |             );
50 |         }
51 |         return 1; # "swallow" this message
52 |     }
53 |     return 0; # This message didn't interest us
54 | }
55 | 
56 | 
57 | sub _get_pull_request_count {
58 |     my ($self, $project) = @_;
59 |     my $url = "http://github.com/api/v2/json/pulls/" . $project;
60 |     my $json = LWP::Simple::get($url)
61 |         or return "Unknown - error fetching $url";
62 |     my $pulls = JSON::from_json($json)
63 |         or return "Unknown - error parsing API response";
64 | 
65 |     my %pulls_by_author;
66 |     $pulls_by_author{$_}++
67 |         for map { $_->{issue_user}{login} } @{ $pulls->{pulls} };
68 |     my $msg = scalar @{ $pulls->{pulls} } . " pull requests open (";
69 |     $msg .= join(", ", 
70 |         map  { "$_:$pulls_by_author{$_}" }
71 |         sort { $pulls_by_author{$b} <=> $pulls_by_author{$a} }
72 |         keys  %pulls_by_author 
73 |     );
74 |     $msg .= ")";
75 |     return $msg;
76 | }
77 | 
78 | 1;
79 | 
80 | 


--------------------------------------------------------------------------------
/dancer-init.d/dancer:
--------------------------------------------------------------------------------
  1 | #!/bin/bash
  2 | 
  3 | # Simple init.d script to start/stop Dancer appliactions on Debian boxes.
  4 | # Originally written by David Precious <davidp@preshweb.co.uk>
  5 | # Tweaked to use starman by way of Plackup, by James Ronan <jim@dev.uk2.net>
  6 | 
  7 | ### BEGIN INIT INFO
  8 | # Provides:          dancer
  9 | # Required-Start:    $network $local_fs
 10 | # Required-Stop:     $network $local_fs
 11 | # Default-Start:     2 3 4 5
 12 | # Default-Stop:      0 1 6                                                                                                        
 13 | # Short-Description: Dancer web framework sites
 14 | ### END INIT INFO
 15 | 
 16 | # Path to a directory containing per-app config files.
 17 | APPCFGDIR=/etc/dancer
 18 | PLACKUPBIN=/opt/perlbrew/perls/perl-5.14.2/bin/plackup
 19 | 
 20 | # Each Dancer application should have a config file in the directory named
 21 | # above, containing the following settings:
 22 | #DIR=/path/to/myappdir
 23 | #SCRIPT=bin/app.pl
 24 | #PORT=5000  
 25 | #USER=davidp
 26 | #PIDFILE=/var/run/myapp.pid
 27 | 
 28 | 
 29 | start() {
 30 |     if test -z "$1"; then
 31 |         echo "Starting all Dancer applications...";
 32 |         start_all_apps;
 33 |     else
 34 |         start_app $1;
 35 |     fi
 36 | }
 37 | 
 38 | stop() {
 39 |     if test -z "$1"; then
 40 |         echo "Stopping all Dancer applications..."
 41 |         stop_all_apps;
 42 |     else
 43 |         stop_app $1;
 44 |     fi
 45 | }
 46 | 
 47 | start_app() {
 48 |     APP_NAME=$1;
 49 |     echo "Starting Dancer application '$APP_NAME'";
 50 |     # Read the vars we're going to use from the app config:
 51 |     source $APPCFGDIR/$APP_NAME;
 52 |     # if we we weren't told to listen on a specific host/IP, default to "*"
 53 |     if [ "$HOST" == "" ]; then
 54 |         HOST="*"
 55 |     fi
 56 |     start-stop-daemon --start --chuid $USER --chdir $DIR --pidfile=$PIDFILE \
 57 |         --exec $PLACKUPBIN -- --server Starman --listen $HOST:$PORT \
 58 | 	--daemonize --pid $PIDFILE $STARMAN_OPTS --app $SCRIPT 
 59 | }
 60 | 
 61 | stop_app() {
 62 |     APP_NAME=$1
 63 |     echo "Stopping Dancer application '$APP_NAME'";
 64 |     source $APPCFGDIR/$APP_NAME;
 65 |     start-stop-daemon --stop --pidfile $PIDFILE
 66 | }
 67 | 
 68 | start_all_apps() {
 69 |     for APP in `ls -1 $APPCFGDIR`; do
 70 |         start_app $APP;
 71 |     done
 72 | }
 73 | stop_all_apps() {
 74 |     for APP in `ls -1 $APPCFGDIR`; do
 75 |         stop_app $APP;
 76 |     done
 77 | }
 78 | 
 79 | 
 80 | 
 81 | case "$1" in
 82 |     start)
 83 |         start $2;
 84 |     ;;
 85 | 
 86 |     stop)
 87 |         stop $2;
 88 |     ;;
 89 |     restart)
 90 |         stop $2;
 91 |         start $2;
 92 |     ;;
 93 |     *)
 94 | 	echo "Usage: $SCRIPTNAME {start|stop|restart} [appname]" >&2
 95 | 	exit 3
 96 | 	;;
 97 | esac
 98 | 
 99 | 
100 | 
101 | 


--------------------------------------------------------------------------------
/nagios_3ware_raid_check/README.pod:
--------------------------------------------------------------------------------
 1 | =head1 nagios_3ware_raid_check
 2 | 
 3 | =head2 DESCRIPTION
 4 | 
 5 | This is a simple Nagios plugin to monitor the state of RAID arrays on 3ware/LSI
 6 | RAID cards, using 3ware's C<tw_cli> utility, which you can download from the 
 7 | 3ware/LSI site (see below).
 8 | 
 9 | The plugin automatically determines which 3ware/LSI RAID controller cards are
10 | present, and which RAID arrays are configured, and checks the status of each.
11 | 
12 | This means it can happily support monitoring of multiple controller cards and
13 | RAID arrays, and does not need to be told which card number / unit number to
14 | monitor - it will just Do The Right Thing.
15 | 
16 | 
17 | =head2 REQUIREMENTS
18 | 
19 | Besides the obvious (Nagios/NRPE, Perl, and and the C<Monitoring::Plugin> module
20 | from CPAN), you'll also need 3ware's C<tw_cli> utility.
21 | 
22 | =head3 tw_cli utility from 3ware/LSI
23 | 
24 | You can download tw_cli from the 3ware (now LSI) website, for instance:
25 | 
26 | L<http://www.lsi.com/channel/products/raid_controllers/sata_sas/3ware_9690sa4i/index.html>
27 | 
28 | As that URL didn't work for me, at least with Javascript disabled, I've also
29 | mirrored the files for easy download:
30 | 
31 | Linux (32 bit): L<http://www.preshweb.co.uk/downloads/tw_cli-linux-x86-9.5.3.tgz>
32 | 
33 | Linux (64 bit): L<http://www.preshweb.co.uk/downloads/tw_cli-linux-x86_64-9.5.3.tgz>
34 | 
35 | It appears to be compatible with most cards, so you don't have to pick the
36 | specific card you have from the list.
37 | 
38 | Extract the tarball, and you'll find the C<tw_cli> util and man pages.  Make
39 | C<tw_cli> executable (C<chmod +x tw_cli>) then move it to C</usr/local/sbin/>.
40 | 
41 | 
42 | =head3 sudo setup
43 | 
44 | You probably don't want to be running your Nagios plugins as root.  However,
45 | tw_cli needs to run as root.  So, this script uses sudo to execute tw_cli as
46 | root.
47 | 
48 | You'll need to allow this to happen with no password.  For security, I'd only
49 | allow the nagios user to run the tw_cli command - add something like this to
50 | the C<sudoers> file:
51 | 
52 |   nagios  ALL=  NOPASSWD: /usr/local/sbin/tw_cli
53 | 
54 | By default, this plugin expects to find the C<tw_cli> binary in your $PATH.  
55 | If you can run C<sudo tw_cli> yourself and get output, it should work.  
56 | However, if you need to, you can provide the path to the tw_cli binary using 
57 | the C<--tw_cli> option, e.g.:
58 | 
59 |     ./nagios-3ware-raid-check --tw_cli=/path/to/tw_cli
60 | 
61 | This may be a good idea anyway, to ensure that the binary that the plugin
62 | executes (as root, remember!) is the one you expect, and not some other
63 | binary/script named C<tw_cli> which appeared in some other directory earlier 
64 | in your $PATH.
65 | 
66 | 
67 | =head1 CONTRIBUTING / NEW VERSIONS
68 | 
69 | This plugin is developed on GitHub at:
70 | 
71 | L<https://github.com/bigpresh/misc-scripts/tree/master/nagios_3ware_raid_check>
72 | 
73 | Patches / bug reports / feedback welcome.
74 | 
75 | =head1 AUTHOR
76 | 
77 | David Precious <davidp@preshweb.co.uk>
78 | 
79 | 
80 | 


--------------------------------------------------------------------------------
/nagios_rdiffbackup_check/nagios_rdiffbackup_check:
--------------------------------------------------------------------------------
  1 | #!/usr/bin/perl
  2 | 
  3 | # Nagios plugin to monitor the time since the current mirror increment on an
  4 | # rdiff-backup destination.
  5 | #
  6 | # David Precious <davidp@preshweb.co.uk>
  7 | 
  8 | use strict;
  9 | use Monitoring::Plugin;
 10 | use FileHandle;
 11 | use Time::Duration;
 12 | 
 13 | my $np = Monitoring::Plugin->new(
 14 |     shortname => "CHECKRDIFFBACKUP",
 15 |     usage => "%s -w 4h -c 12h -d /path/to/backup",
 16 | );
 17 | 
 18 | $np->add_arg(
 19 |     spec => "warning|w=s",
 20 |     help => "Warning threshold (e.g. 3h)",
 21 |     default => '6h',
 22 | );
 23 | $np->add_arg(
 24 |     spec => "critical|c=s",
 25 |     help => "Critical threshold (e.g. 6h)",
 26 |     default => '24h',
 27 | );
 28 | $np->add_arg(
 29 |     spec => "dest|d=s",
 30 |     help => "Path to backup destination",
 31 |     required => 1,
 32 | );
 33 | $np->add_arg(
 34 |     spec => 'rdiff_backup|diff-backup|r=s',
 35 |     help => "Path to rdiff-backup",
 36 |     default => 'rdiff-backup',
 37 | );
 38 | $np->add_arg(
 39 |     spec => 'sudo|s',
 40 |     help => "Use sudo to run rdiff-backup",
 41 |     default => 0,
 42 | );
 43 | 
 44 | $np->getopts;
 45 | 
 46 | my $rdfh = FileHandle->new(
 47 |     ($np->opts->sudo ? '/usr/bin/sudo ' : '') .
 48 |     $np->opts->rdiff_backup . ' -l --parsable-output ' . $np->opts->dest 
 49 |         . ' 2>&1 |'
 50 | ) or $np->nagios_die(
 51 |     "Can't execute " . $np->opts->rdiff_backup . " - $!"
 52 | );
 53 | my $last_mirror;
 54 | my $backup_running;
 55 | while (my $line = $rdfh->getline) {
 56 |     if (my ($pid) = $line =~ /(\d+) is still running/) {
 57 |         # TODO: perhaps verify that this PID is still running - although I
 58 |         # believe rdiff-backup does that already
 59 |         $backup_running = $pid;
 60 |         $last_mirror    = undef;
 61 |         last;
 62 |     }
 63 |     $line =~ /^(\d{10})/ and $last_mirror = $1;
 64 | }
 65 | $rdfh->close;
 66 | 
 67 | if (!$last_mirror) {
 68 |     if ($backup_running) {
 69 |         # TODO: Check time since last log update
 70 |         $np->nagios_exit(OK, "Backup in progress (PID $backup_running)");
 71 |     } else {
 72 |         $np->nagios_die("Failed to determine time since last mirror");
 73 |     }
 74 | }
 75 | 
 76 | 
 77 | # Turn our thresholds into seconds:
 78 | my $warning_secs  = $np->opts->warning;
 79 | my $critical_secs = $np->opts->critical;
 80 | my %suffixes = ( m => 60, h => 60 * 60, d => 60 * 60 * 24);
 81 | for my $suffix (keys %suffixes) {
 82 |     for ($warning_secs, $critical_secs) {
 83 |         $_ *= $suffixes{$suffix} if $_ =~ s/$suffix$//;
 84 |     }
 85 | }
 86 | 
 87 | my $secs_since_mirror = time - $last_mirror;
 88 | 
 89 | # And finally, check against them:
 90 | $np->nagios_exit(
 91 |     return_code => $np->check_threshold(
 92 |         check    => $secs_since_mirror,
 93 |         warning  => "$warning_secs",
 94 |         critical => "$critical_secs",
 95 |     ),
 96 |     message => sprintf "Last backup completed %s ago",
 97 |         Time::Duration::duration($secs_since_mirror),
 98 | );
 99 | 
100 | 
101 | 


--------------------------------------------------------------------------------
/stevenage-rubbish-reminder/rubbish-reminder:
--------------------------------------------------------------------------------
 1 | #!/usr/bin/perl
 2 | 
 3 | use strict;
 4 | use Config::Auto;
 5 | use DateTime::Format::DateParse;
 6 | use Net::Google::Calendar;
 7 | use Net::Netrc;
 8 | use WebService::NotifyMyAndroid;
 9 | use WWW::Mechanize;
10 | 
11 | my $conf = Config::Auto::parse;
12 | 
13 | my @required_conf_options = qw(nma_key house_num postcode);
14 | if (!$conf || grep { !exists $conf->{$_} } @required_conf_options) {
15 |     die "Must provide a conf file (see Config::Auto) with options: "
16 |         . join ', ', @required_conf_options;
17 | }
18 | 
19 | my $mach = Net::Netrc->lookup('calendar.google.com')
20 |     or die "No login details for calendar.google.com in ~/.netrc";
21 | my ($user, $pass) = $mach->lpa;
22 | 
23 | my $gcal = Net::Google::Calendar->new;
24 | say "Logging in to Google Calendar as $user";
25 | $gcal->login($user, $pass)
26 |     or die "Google Calendar login failed";
27 | 
28 | # Find the calendar we wnt
29 | my ($desired_calendar) = grep {
30 |     $_->title eq 'Rubbish collections'
31 | } $gcal->get_calendars;
32 | if ($desired_calendar) {
33 |     $gcal->set_calendar($desired_calendar);
34 | } else {
35 |     die "Desired calendar not found";
36 | }
37 | 
38 | my $mech = WWW::Mechanize->new;
39 | 
40 | $mech->get('http://www.stevenage.gov.uk/find/');
41 | 
42 | $mech->submit_form(
43 |     with_fields => {
44 |         # What the fuck kind of field names are these?  Fucking ASP.net
45 |         # bollocks.
46 |         'ctl00$ctl00$ContentPlaceHolder1$ContentPlaceHolder1$txtNumber' => 5,
47 |         'ctl00$ctl00$ContentPlaceHolder1$ContentPlaceHolder1$txtPostcode' => 'SG2 7DP',
48 |     },
49 |     button => 'ctl00$ctl00$ContentPlaceHolder1$ContentPlaceHolder1$BtnLookup',
50 | );
51 | 
52 | if (my ($date, $type) = $mech->content =~ 
53 |     m{Your next rubbish collection is on <strong>(.+) \((.+)\)</strong>}m)
54 | {
55 |     say "Next $type collection $date - looking for calendar reminder";
56 | 
57 |     # Look for an existing calendar event; if not found, create one.
58 |     # Note: start-min is inclusive, start-max exclusive - hence 
59 |     # adding a second
60 |     my $collection_dt = DateTime::Format::DateParse->parse_datetime($date);
61 |     my $reminder_start_dt = $collection_dt->clone->subtract(days => 1);
62 |     $reminder_start_dt->set(hour =>20, minute => 0, second => 0);
63 |     my $reminder_end_dt = $reminder_start_dt->clone->add( minutes => 10 );
64 |     say "Event reminder DT $reminder_start_dt";
65 |     my ($event) = $gcal->get_events(
66 |         'q' => 'collection tomorrow',
67 |         'start-min' => $reminder_start_dt,
68 |         'start-max' => $reminder_end_dt->clone->add(seconds => 1),
69 |     );
70 |     if (!$event) {
71 |         say "Creating reminder";
72 |         my $entry = Net::Google::Calendar::Entry->new;
73 |         $entry->title("$type out for collection tomorrow");
74 |         $entry->when($reminder_start_dt, $reminder_end_dt);
75 |         #$event->content("$type collection on $date");
76 |         $entry->reminder('alert', 'hours', 1);
77 |         $entry->reminder('alert', 'minutes', 10);
78 |         $gcal->add_entry($entry)
79 |             or die "Failed to add calendar entry";
80 |     } else {
81 |         say "Event already on calendar";
82 |     }
83 | } else {
84 |     die "Failed to identify next collection in response";
85 | }
86 | 


--------------------------------------------------------------------------------
/nagios_network_errors/nagios_network_errors:
--------------------------------------------------------------------------------
  1 | #!/usr/bin/perl
  2 | 
  3 | # Nagios plugin to monitor for increasing network error stats via ifconfig.
  4 | #
  5 | # David Precious <davidp@preshweb.co.uk>
  6 | use strict;
  7 | use FileHandle;
  8 | use Monitoring::Plugin;
  9 | use JSON;
 10 | 
 11 | 
 12 | my $np = Monitoring::Plugin->new(
 13 |     shortname => 'CHECKNETERRORS',
 14 |     'usage' => "%s -i eth0",
 15 | );
 16 | 
 17 | $np->add_arg(
 18 |     spec    => "interface|i=s",
 19 |     help    => "Network interface to monitor",
 20 |     default => "eth0",
 21 | );
 22 | $np->add_arg(
 23 |     spec    => "statefile|f=s",
 24 |     help    => "File to record stats in",
 25 |     default => "/var/state/nagios_network_errors",
 26 | );
 27 | $np->add_arg(
 28 |     spec    => "critical|c=s",
 29 |     help    => "More than this many errors since last run is critical",
 30 |     default => 10,
 31 | );
 32 | $np->add_arg(
 33 |     spec    => "warning|w=s",
 34 |     help    => "More than this many errors since last run is warning",
 35 |     default => 2,
 36 | );
 37 | 
 38 | $np->getopts;
 39 | 
 40 | 
 41 | 
 42 | ## Fetch the data we need:
 43 | my $ifconfig_fh = FileHandle->new(
 44 |     "/sbin/ifconfig " . $np->opts->interface . " |"
 45 | ) or $np->nagios_die("Can't execute ifconfig! - $!");
 46 | 
 47 | my $ifconfig_output = join '',  $ifconfig_fh->getlines;
 48 | my %stats;
 49 | for my $dir (qw(RX TX)) {
 50 |     my ($line) = $ifconfig_output =~ /^\s+($dir .+)/m;
 51 |     $stats{$dir . '_' . $1} = $2      
 52 |         while $line =~ m{(\w+):(\d+)}g;
 53 | }
 54 | $ifconfig_output =~ m{(collisions):(\d+)}g and $stats{$1} = $2;
 55 | 
 56 | delete $stats{$_} for qw(RX_packets TX_packets);
 57 | 
 58 | 
 59 | ## If the state file doesn't exist, try to create it, bail if we can't:
 60 | if (!-f $np->opts->statefile) {
 61 |     open my $fh, '>', $np->opts->statefile
 62 |         or $np->nagios_die(
 63 |             "Can't create state file " . $np->opts->statefile . " - $!"
 64 |         );
 65 | }
 66 | 
 67 | # Read in previous stats, then rewind the filehandle
 68 | # ready to write updated stats to
 69 | open my $state_fh, '+<', $np->opts->statefile
 70 |     or $np->nagios_die("Failed to open " . $np->opts->statefile . " - $!");
 71 | 
 72 | my $json = join '', <$state_fh>;
 73 | 
 74 | my $previous_stats = $json ? JSON::from_json($json) : {};
 75 | 
 76 | 
 77 | # Write the new data to the state file
 78 | seek $state_fh, 0, 0;
 79 | print {$state_fh} JSON::to_json(\%stats);
 80 | close $state_fh;
 81 | 
 82 | 
 83 | 
 84 | 
 85 | ## For each counter, see if it's increased since the last time we checked:
 86 | my %problems;
 87 | for my $stat (keys %stats) {
 88 |     if (exists $previous_stats->{$stat}) {
 89 |         my $diff = $stats{$stat} - $previous_stats->{$stat};
 90 |         my $error_type = $np->check_threshold(check => $diff);
 91 |         if ($error_type) {
 92 |             push @{ $problems{$error_type} }, "$stat increased by $diff";
 93 |         }
 94 |     }
 95 | }
 96 | 
 97 | ## Finally, exit with appropriate return code and message
 98 | for my $state (CRITICAL,WARNING) {
 99 |     if (my $problems = $problems{$state}) {
100 |         $np->nagios_exit($state, join ", ", @$problems);
101 |     }
102 | }
103 | $np->nagios_exit(OK, "Error counters not increasing");
104 | 
105 | 
106 | 
107 | 
108 | 
109 | 


--------------------------------------------------------------------------------
/nagios_sensors_check/nagios_sensors_check:
--------------------------------------------------------------------------------
  1 | #!/usr/bin/perl
  2 | 
  3 | # Dirt-simple plugin to monitor values of system sensors using lm-sensors
  4 | # easily.
  5 | #
  6 | # I wrote this because, on several boxes I was monitoring, the thresholds for
  7 | # various sensors were silly, and the lm-sensors configuration is hairy!
  8 | #
  9 | # Also, the Nagios check_sensors plugin simply reports e.g. "Sensor alarm
 10 | # detected" rather than useful information, like which sensor(s) are playing up.
 11 | #
 12 | # David Precious <davidp@preshweb.co.uk>
 13 | 
 14 | use strict;
 15 | use Monitoring::Plugin;
 16 | use FileHandle;
 17 | 
 18 | my $np = Monitoring::Plugin->new(
 19 |     shortname => "CHECKSENSOR",
 20 |     usage => "%s -s/--sensor -w threshold -c threshold",
 21 | );
 22 | 
 23 | $np->add_arg(
 24 |     spec => "sensor|s=s@",
 25 |     help => "sensor name:min:max - e.g. 'CPU Temp:15:65'.  Repeat as needed",
 26 |     required => 1,
 27 | );
 28 | $np->add_arg(
 29 |     spec => "warning|w=f",
 30 |     help => "Warning threshold in percent; values that exceed a threshold"
 31 |         . " by this amount or less result in a warning",
 32 |     default => 10,
 33 | );
 34 | $np->add_arg(
 35 |     spec => "sensorscmd|c=s",
 36 |     help => "Path to sensors command (optional, defaults to 'sensors')",
 37 |     default => "sensors",
 38 | );
 39 | 
 40 | $np->getopts;
 41 | my $warning = $np->opts->warning / 100;
 42 | 
 43 | my %sensorvalue;
 44 | my $sensorsfh = FileHandle->new($np->opts->sensorscmd . ' |')
 45 |     or $np->nagios_die(
 46 |         "Can't execute " . $np->opts->sensorscmd . " - $!"
 47 |     );
 48 | while (my $line = $sensorsfh->getline) {
 49 |     if (my ($sensor,$value) = $line =~ m{(.+) : \s+ (\S+)}x) {
 50 |         $sensorvalue{$sensor} = $value;
 51 |     }
 52 | }
 53 | $sensorsfh->close;
 54 | 
 55 | 
 56 | # Remember any values which exceed the thresholds, so we can exit with the worst
 57 | # status seen at the end,
 58 | my (@critical, @warning, @ok);
 59 | sensor:
 60 | for my $sensorspec (@{ $np->opts->sensor }) {
 61 |     my ($sensor, $min_thres, $max_thres) = split /:/, $sensorspec;
 62 |     if (!defined $sensorvalue{$sensor}) {
 63 |         push @critical, "No value for $sensor";
 64 |         next sensor;
 65 |     }
 66 |     my $value = $sensorvalue{$sensor};
 67 |     (my $rawvalue = $value) =~ s/[^0-9.]//g;
 68 | 
 69 |     # First, see if it's outside the warning tolerance either side of the
 70 |     # thresholds - if so, it's a critical problem:
 71 |     if (($rawvalue < $min_thres - ($min_thres * $warning))
 72 |         ||
 73 |         ($rawvalue > $max_thres + ($max_thres * $warning)))
 74 |     {
 75 |         push @critical, "$sensor $value";
 76 |         next sensor;
 77 |     }
 78 | 
 79 |     # OK, if it's outside the thresholds, but we didn't catch it above, then
 80 |     # it's within the warning tolerances, so only a warning:
 81 |     if ($rawvalue < $min_thres || $rawvalue > $max_thres) {
 82 |         push @warning, "$sensor $value";
 83 |         next sensor;
 84 |     }
 85 | 
 86 |     # OK, it must be fine.
 87 |     push @ok, "$sensor $value";
 88 | }
 89 | 
 90 | # Assemble all problematic readings, critical ones first:
 91 | # TODO: refactor, DRY
 92 | my @problems = (@critical, @warning);
 93 | if (@critical) {
 94 |     $np->nagios_exit(CRITICAL, join ', ', @problems);
 95 | } elsif (@warning) {
 96 |     $np->nagios_exit(WARNING, join ', ', @problems);
 97 | } else {
 98 |     $np->nagios_exit(OK, join ', ', @ok);
 99 | }
100 | 
101 | 


--------------------------------------------------------------------------------
/vine-queue-watcher/check-for-vine-items:
--------------------------------------------------------------------------------
  1 | #!/usr/bin/perl
  2 | 
  3 | use strict;
  4 | use 5.010;
  5 | 
  6 | use DBI;
  7 | use Mail::Sendmail;
  8 | use Net::Netrc;
  9 | use WWW::Mechanize;
 10 | 
 11 | # Expects username, password and database params in my.cnf
 12 | my $dbh = DBI->connect(
 13 |     "DBI:mysql:davidp;mysql_read_default_file=$ENV{HOME}/.my.cnf",
 14 |     undef, undef, {RaiseError => 1} 
 15 | ) or die "Failed to connect to database";
 16 | 
 17 | 
 18 | my $mach = Net::Netrc->lookup('www.amazon.co.uk')
 19 |     or die "No login details for www.amazon.co.uk in ~/.netrc";
 20 | my ($user, $pass) = $mach->lpa;
 21 | 
 22 | # Have to lie - if we tell the truth with the default WWW::Mech agent, they
 23 | # return a cookies disabled error, even though they're not.
 24 | my $mech = WWW::Mechanize->new(
 25 |     agent => 'Mozilla/ish',
 26 | );
 27 | 
 28 | $mech->get('http://vine.amazon.co.uk/');
 29 | 
 30 | $mech->submit_form(
 31 |     with_fields => {
 32 |         email => $user,
 33 |         password => $pass,
 34 |     },
 35 | );
 36 | 
 37 | $mech->follow_link(text => 'Your Queue')
 38 |     or die "Failed to follow 'Your Queue' link!";
 39 | 
 40 | if (!$mech->content =~ /Welcome to your Vine Targeted Queue/) {
 41 |     die "At " . $mech->uri . " - but this doesn't look like the queue page";
 42 | }
 43 | 
 44 | #warn "queue  content: " . $mech->content;
 45 | 
 46 | # Find all the items.  Using a regex to parse HTML is all kinds of wrong, but
 47 | # this HTML is pretty ugly, and this works, in a lightweight fashion.  May
 48 | # re-write to use Web::Scraper or similar, though.
 49 | my (@new_products, @new_asins);
 50 | my $queue_html = $mech->content;
 51 | while ($queue_html =~ m{
 52 |         <td \s class="product_description".*?>
 53 |         <a \s href="(?<url>.+?)".*?>
 54 |         <b>(?<name> .+?)</b></a><br/>
 55 |         (?<description> .+? )
 56 |         </td>
 57 |     }xgms)
 58 | {
 59 |     my %product = %+;
 60 |     my ($asin) = $product{url} =~ m{asin=([A-Z0-9]+)};
 61 | 
 62 |     if (!seen_product($asin)) {
 63 |         my $url = "https://www.amazon.co.uk" . $product{url};
 64 |         $url =~ s/&amp;/&/g;
 65 |         push @new_products, "$product{name}: $url\n";
 66 |         push @new_asins, $asin;
 67 |     }
 68 | }
 69 | 
 70 | if (@new_products) {
 71 |     # send email
 72 |     Mail::Sendmail::sendmail(
 73 |         To => $user,
 74 |         From => $user,
 75 |         Subject => scalar(@new_products) . " new Vine products available",
 76 |         message => "New products available for review on Amazon Vine:\n"
 77 |             . join("\n", @new_products),
 78 |     ) or die "Failed to send mail - " . $Mail::Sendmail::error;
 79 | 
 80 |     remember_product(\@new_asins);
 81 | }
 82 | 
 83 | 
 84 | 
 85 | # Returns the DB row if we've seen this product before
 86 | sub seen_product {
 87 |     my $asin = shift;
 88 |     my $sth = $dbh->prepare("SELECT * FROM vine_products_seen WHERE asin = ?");
 89 |     $sth->execute($asin);
 90 |     return $sth->fetchrow_hashref;
 91 | }
 92 | 
 93 | # Given a product ASIN, remember that we've seen it so we don't report it again
 94 | # on the next run
 95 | sub remember_product {
 96 |     my ($asin) = shift;
 97 |     my $sth = $dbh->prepare(
 98 |         "INSERT INTO vine_products_seen (asin) VALUES (?)"
 99 |     );
100 | 
101 |     # DWIMmery: if we got an arrayref of ASINs, add them all
102 |     my @asins = ref $asin ? @$asin : ($asin);
103 |     for my $asin (@asins) {
104 |         $sth->execute($asin);
105 |     }
106 | }
107 | 
108 | 


--------------------------------------------------------------------------------
/odyssey-bookings-to-gcal/odyssey-bookings-to-gcal:
--------------------------------------------------------------------------------
  1 | #!/usr/bin/perl
  2 | 
  3 | # Log in to Odyssey's members area, go to upcoming bookings, and for each
  4 | # booking found, make sure it's on my calendar.
  5 | 
  6 | use 5.010;
  7 | use strict;
  8 | use Config::Auto;
  9 | use HTML::TableExtract;
 10 | use Net::Google::Calendar;
 11 | use Net::Netrc;
 12 | use DateTime::Format::Strptime;
 13 | use WWW::Mechanize;
 14 | use YAML;
 15 | 
 16 | # Our config file should contain 'username' and 'password' for our Odyssey
 17 | # members account, and 'calendarname' for the name of the calendar within GCal
 18 | # we want to add events to.  Google Calendar credentials should be in .netrc for
 19 | # calendar.google.com
 20 | my $conf = Config::Auto::parse;
 21 | 
 22 | my @conf_params = qw(username password calendarname);
 23 | if (grep { !exists $conf->{$_} } @conf_params) { 
 24 |     die "Config must contain all of @conf_params";
 25 | }
 26 | 
 27 | # Get our login details, and find the Google calendar in question:
 28 | my $mach = Net::Netrc->lookup('calendar.google.com')
 29 |     or die "No login details for calendar.google.com in ~/.netrc";
 30 | my ($user, $pass) = $mach->lpa;
 31 | 
 32 | 
 33 | my $gcal = Net::Google::Calendar->new;
 34 | $gcal->login($user, $pass)
 35 |     or die "Google Calendar login failed";
 36 | 
 37 | my ($desired_calendar) = grep { 
 38 |     $_->title eq $conf->{calendarname}
 39 | } $gcal->get_calendars;
 40 | 
 41 | if (!$desired_calendar) {
 42 |     die "No calendar named $conf->{calendarname} found!";
 43 | }
 44 | $gcal->set_calendar($desired_calendar);
 45 | 
 46 | 
 47 | # Right, we have our calendar ready to interact with - now log in to Odyssey
 48 | # and find out what bookings we have...
 49 | my $mech = WWW::Mechanize->new;
 50 | $mech->get('http://members.odysseyhealthclubs.com/Odyssey/login.aspx');
 51 | 
 52 | my $stupid_prefix = 'ctl00$mainContent$Login1$';
 53 | $mech->submit_form(
 54 |     with_fields => {
 55 |         $stupid_prefix . 'UserName' => $conf->{username},
 56 |         $stupid_prefix . 'Password' => $conf->{password},
 57 |     },
 58 |     button => $stupid_prefix . 'LoginImageButton',
 59 | );
 60 | $mech->follow_link(text_regex => qr/My Bookings/);
 61 | 
 62 | if ($mech->content =~ /No bookings in this period/) {
 63 |     say "No bookings to process.";
 64 |     exit;
 65 | }
 66 | 
 67 | my $te = HTML::TableExtract->new(
 68 |     headers => [qw(Start End Description) ]
 69 | );
 70 | $te->parse($mech->content);
 71 | my ($table) = $te->tables
 72 |     or die "Failed to find expected bookings table";
 73 | 
 74 | for my $row ($table->rows) {
 75 |     my ($start, $end, $description) = @$row;
 76 |     my $dtparser = DateTime::Format::Strptime->new(
 77 |         pattern   => '%d/%m/%Y %H:%M',
 78 |     );
 79 |     my $start_dt = $dtparser->parse_datetime($start);
 80 |     my $end_dt   = $dtparser->parse_datetime($end);
 81 | 
 82 |     # Look for an event for this booking already.
 83 |     # Note: start-min is inclusive, start-max exclusive, hence the clone and
 84 |     # adding a second
 85 |     my ($event) = $gcal->get_events(
 86 |         q => qq{"$description"},
 87 |         'start-min' => $start_dt,
 88 |         'start-max' => $end_dt->clone->add(seconds => 1),
 89 |     );
 90 | 
 91 |     if (!$event) {
 92 |         my $entry = Net::Google::Calendar::Entry->new;
 93 |         $entry->title("$description at Odyssey");
 94 |         $entry->location("Odyssey, Knebworth, SG2 8DU");
 95 |         $entry->when($start_dt, $end_dt);
 96 |         $entry->reminder('alert', 'hours', 3);
 97 |         $entry->reminder('alert', 'minutes', 10);
 98 |         $gcal->add_entry($entry) and say "Added event $description at $start";
 99 |     } else {
100 |         say "Event $description at $start already on calendar";
101 |     }
102 | }
103 | 
104 | 


--------------------------------------------------------------------------------
/fetch-xdslstats/README.md:
--------------------------------------------------------------------------------
 1 | # Fetch DSL/VDSL line stats from xdslctl info
 2 | 
 3 | A quick script I threw together to SSH to my Zyxel VMG3925-B10C ADSL
 4 | modem/router (supplied by my ISP, Andrews & Arnold), and parse out
 5 | line performance statistics from the output of `xdslctl info --stats`.
 6 | 
 7 | A bit ugly, but works for me.
 8 | 
 9 | TODO: document more.
10 | 
11 | If you find this before I have documented it, and it would be helpful to you,
12 | poke me at davidp@preshweb.co.uk and I'll be happy to hurry up with documenting
13 | it properly!
14 | 
15 | 
16 | ## Graphing via Munin
17 | 
18 | I have the data collected here graphed by Munin for easy visualisation, using 
19 | [munin_db_query](https://github.com/bigpresh/misc-scripts/tree/master/munin_db_query)
20 | 
21 | I set up the config in `/etc/munin/plugin-conf.d/munin-node` along the lines
22 | of:
23 | 
24 | ```
25 | [xdslstats_signal]
26 | env.title DSL signal stats
27 | env.vlabel dB
28 | env.category Network
29 | env.query1 select snr_up from xdslstats where router = '192.168.1.1' and timestamp > date_sub(now(), interval 2 minute) order by timestamp desc limit 1
30 | env.label1 Upstream SNR
31 | env.query2 select snr_down from xdslstats where router = '192.168.1.1' and timestamp > date_sub(now(), interval 2 minute) order by timestamp desc limit 1
32 | env.label2 Downstream SNR
33 | env.query3 select attn_up from xdslstats where router = '192.168.1.1' and timestamp > date_sub(now(), interval 2 minute) order by timestamp desc limit 1
34 | env.label3 Upstream Attenuation
35 | env.query4 select attn_down from xdslstats where router = '192.168.1.1' and timestamp > date_sub(now(), interval 2 minute) order by timestamp desc limit 1
36 | env.label4 Downstream Attenuation
37 | env.query5 select power_up from xdslstats where router = '192.168.1.1' and timestamp > date_sub(now(), interval 2 minute) order by timestamp desc limit 1
38 | env.label5 Upstream Power
39 | env.query6 select power_down from xdslstats where router = '192.168.1.1' and timestamp > date_sub(now(), interval 2 minute) order by timestamp desc limit 1
40 | env.label6 Downstream Power
41 | env.dsn DBI:mysql:davidp
42 | env.db_user munin
43 | 
44 | 
45 | [xdslstats_errors]
46 | env.title DSL errors
47 | env.vlabel errors per second
48 | env.category Network
49 | env.query1 select fec_up_per_sec from xdslstats where router = '192.168.1.1' and timestamp > date_sub(now(), interval 2 minute) order by timestamp desc limit 1
50 | env.label1 Upstream FEC/sec
51 | env.query2 select fec_down_per_sec from xdslstats where router = '192.168.1.1' and timestamp > date_sub(now(), interval 2 minute) order by timestamp desc limit 1
52 | env.label2 Downstream FEC/sec
53 | env.query3 select crc_up_per_sec from xdslstats where router = '192.168.1.1' and timestamp > date_sub(now(), interval 2 minute) order by timestamp desc limit 1
54 | env.label3 Upstream CRC/sec
55 | env.query4 select crc_down_per_sec from xdslstats where router = '192.168.1.1' and timestamp > date_sub(now(), interval 2 minute) order by timestamp desc limit 1
56 | env.label4 Downstream CRC/sec
57 | env.dsn DBI:mysql:davidp
58 | env.db_user munin
59 | 
60 | [xdslstats_linerate]
61 | env.title DSL Line rate
62 | env.vlabel Kbps
63 | env.category Network
64 | env.query1 select rate_up from xdslstats where router = '192.168.1.1' and timestamp > date_sub(now(), interval 2 minute) order by timestamp desc limit 1
65 | env.label1 Upstream Kbps
66 | env.query2 select rate_down from xdslstats where router = '192.168.1.1' and timestamp > date_sub(now(), interval 2 minute) order by timestamp desc limit 1
67 | env.label2 Downstream Kbps
68 | env.dsn DBI:mysql:davidp
69 | env.db_user munin
70 | ```
71 | 
72 | Then create symlinks with those names - `xdslstats_signal`, `xdslstats_errors`,
73 | `xdslstats_linerate` in `/etc/munin/plugins` all pointing at `munin_db_query`.
74 | 
75 | 
76 | 


--------------------------------------------------------------------------------
/mp3-rename/mp3-rename:
--------------------------------------------------------------------------------
  1 | #!/usr/bin/perl
  2 | 
  3 | 
  4 | # Rename MP3s in a given directory based on their ID3
  5 | # tags.
  6 | # If a second arg is given, it's a format string to use instead of
  7 | # the default - for e.g.
  8 | #   mp3-rename /path/to/dir "%{track} - %{title} - %{artist}.mp3"
  9 | # 
 10 | # David Precious, originally 10/04/2006
 11 | #
 12 | # TODO: if ID3 'track' tags not given, auto-number tracks
 13 | #       based on the order we saw them in
 14 | # TODO: extend to support Ogg Vorbis (.ogg) and MP4 files
 15 | 
 16 | use strict;
 17 | use File::Find::Rule;
 18 | use File::Basename;
 19 | use File::Spec;
 20 | use Music::Tag;
 21 | use Cwd;
 22 | use Term::ReadKey;
 23 | 
 24 | my $startdir = $ARGV[0] || getcwd;
 25 | 
 26 | if (!-d $startdir) {
 27 |     die "$startdir is not a directory";
 28 | }
 29 | 
 30 | my @files = File::Find::Rule->file()->name(qr{\.mp3$}i)->in($startdir);
 31 | my %renames;
 32 | 
 33 | file:
 34 | for my $file (@files) {
 35 |     my $info = Music::Tag->new($file);
 36 |     ($info && $info->get_tag) or do {
 37 |         print "Error reading ID3 tags for: $file\n";
 38 |         $renames{$file} = $file;
 39 |         next file;
 40 |     };
 41 | 
 42 |     # Available tags to use in the format string
 43 |     my %tag_value = (
 44 |         track => sprintf('%02d', $info->track()),
 45 |         title => clean($info->title()),
 46 |         artist => clean($info->artist()),
 47 |     );
 48 |     my $new_filename = $ARGV[1] || "%{track} - %{title} - %{artist}.mp3";
 49 |     $new_filename .= ".mp3" unless $new_filename =~ /\.mp3$/;
 50 |     warn "before filling in: $new_filename";
 51 | 
 52 |     $new_filename =~ s{%\{(.+?)\}}{$tag_value{$1}}eg;
 53 |     warn "After: $new_filename";
 54 | 
 55 |     $renames{$file} = File::Spec->catfile($startdir, $new_filename);
 56 | }
 57 | 
 58 | # get the current screen width so we can work out column sizes:
 59 | my $screen_width = (Term::ReadKey::GetTerminalSize)[0];
 60 | my $col_width = int( ($screen_width - 5) / 2 );
 61 | 
 62 | # see what the maximum filename length for the left side is - no point in
 63 | # using half the screen for it if the longest entry is 15 chars.
 64 | my $longest_title = (reverse sort { $a <=> $b } 
 65 |                          map { length($_) }
 66 |                          map { File::Basename::fileparse($_) } keys %renames)[0];
 67 | 
 68 | # and now decide what to make the col widths:
 69 | my ($left_col, $right_col);
 70 | 
 71 | if ($longest_title < $col_width) {
 72 |     $left_col = $longest_title;
 73 |     $right_col = $col_width + ($col_width - $longest_title);
 74 | } else {
 75 |     $left_col = $right_col = $col_width;
 76 | }
 77 | 
 78 | 
 79 | print "The following renames will be performed:\n";
 80 | 
 81 | for my $ren (sort keys %renames) {
 82 |         # We only want to show the filenames
 83 |         # TODO: do this in a more cross-platform way
 84 |         my $from = File::Basename::fileparse($ren);
 85 |         my $to   = File::Basename::fileparse($renames{$ren});;
 86 | 	printf "%- ${left_col}s -> %- ${right_col}s\n", 
 87 | 	    substr($from, 0, $left_col), substr($to, 0, $right_col);
 88 | }
 89 | 
 90 | print qq[
 91 | Review the above renames to check the info is correct.
 92 | 
 93 | Type 'yes' to go ahead: ?> ];
 94 | 
 95 | my $foo = <STDIN>;
 96 | 
 97 | if ($foo =~ /yes/i) {
 98 |     for my $ren (keys %renames) {
 99 | 	rename($ren, $renames{$ren});
100 |     }
101 | 
102 | } else {
103 |     print "No renames performed.\n";
104 | }
105 | 
106 | 
107 | 
108 | sub clean {
109 |     # remove anything that's not good for a filename, and trim any leading or
110 |     # trailing whitespace
111 | 
112 |     my $in = shift;
113 |     $in =~ s/[^a-z0-9_&+ -]//gi;
114 |     $in =~ s/(^\s+|\s+$)//g;
115 | 
116 |     $in =~ s/\s*PMEDIA\s*//g;
117 |     return $in;
118 | } # end of sub clean
119 | 


--------------------------------------------------------------------------------
/log-ntl-cablemodem-stats/CableModemStats/public/css/style.css:
--------------------------------------------------------------------------------
  1 | 
  2 | body {
  3 | margin: 0;
  4 | margin-bottom: 25px;
  5 | padding: 0;
  6 | background-color: #ddd;
  7 | background-image: url("/images/perldancer-bg.jpg");
  8 | background-repeat: no-repeat;
  9 | background-position: top left;
 10 | 
 11 | font-family: "Lucida Grande", "Bitstream Vera Sans", "Verdana";
 12 | font-size: 13px;
 13 | color: #333;
 14 | }
 15 | 
 16 | h1 {
 17 | font-size: 28px;
 18 | color: #000;
 19 | }
 20 | 
 21 | a  {color: #03c}
 22 | a:hover {
 23 | background-color: #03c;
 24 | color: white;
 25 | text-decoration: none;
 26 | }
 27 | 
 28 | #page {
 29 | background-color: #ddd;
 30 | width: 750px;
 31 | margin: auto;
 32 | margin-left: auto;
 33 | padding-left: 0px;
 34 | margin-right: auto;
 35 | }
 36 | 
 37 | #content {
 38 | background-color: white;
 39 | border: 3px solid #aaa;
 40 | border-top: none;
 41 | padding: 25px;
 42 | width: 500px;
 43 | }
 44 | 
 45 | #sidebar {
 46 | float: right;
 47 | width: 175px;
 48 | }
 49 | 
 50 | #header, #about, #getting-started {
 51 | padding-left: 75px;
 52 | padding-right: 30px;
 53 | }
 54 | 
 55 | 
 56 | #header {
 57 | background-image: url("/images/perldancer.jpg");
 58 | background-repeat: no-repeat;
 59 | background-position: top left;
 60 | height: 64px;
 61 | }
 62 | #header h1, #header h2 {margin: 0}
 63 | #header h2 {
 64 | color: #888;
 65 | font-weight: normal;
 66 | font-size: 16px;
 67 | }
 68 | 
 69 | #about h3 {
 70 | margin: 0;
 71 | margin-bottom: 10px;
 72 | font-size: 14px;
 73 | }
 74 | 
 75 | #about-content {
 76 | background-color: #ffd;
 77 | border: 1px solid #fc0;
 78 | margin-left: -11px;
 79 | }
 80 | #about-content table {
 81 | margin-top: 10px;
 82 | margin-bottom: 10px;
 83 | font-size: 11px;
 84 | border-collapse: collapse;
 85 | }
 86 | #about-content td {
 87 | padding: 10px;
 88 | padding-top: 3px;
 89 | padding-bottom: 3px;
 90 | }
 91 | #about-content td.name  {color: #555}
 92 | #about-content td.value {color: #000}
 93 | 
 94 | #about-content.failure {
 95 | background-color: #fcc;
 96 | border: 1px solid #f00;
 97 | }
 98 | #about-content.failure p {
 99 | margin: 0;
100 | padding: 10px;
101 | }
102 | 
103 | #getting-started {
104 | border-top: 1px solid #ccc;
105 | margin-top: 25px;
106 | padding-top: 15px;
107 | }
108 | #getting-started h1 {
109 | margin: 0;
110 | font-size: 20px;
111 | }
112 | #getting-started h2 {
113 | margin: 0;
114 | font-size: 14px;
115 | font-weight: normal;
116 | color: #333;
117 | margin-bottom: 25px;
118 | }
119 | #getting-started ol {
120 | margin-left: 0;
121 | padding-left: 0;
122 | }
123 | #getting-started li {
124 | font-size: 18px;
125 | color: #888;
126 | margin-bottom: 25px;
127 | }
128 | #getting-started li h2 {
129 | margin: 0;
130 | font-weight: normal;
131 | font-size: 18px;
132 | color: #333;
133 | }
134 | #getting-started li p {
135 | color: #555;
136 | font-size: 13px;
137 | }
138 | 
139 | #search {
140 | margin: 0;
141 | padding-top: 10px;
142 | padding-bottom: 10px;
143 | font-size: 11px;
144 | }
145 | #search input {
146 | font-size: 11px;
147 | margin: 2px;
148 | }
149 | #search-text {width: 170px}
150 | 
151 | #sidebar ul {
152 | margin-left: 0;
153 | padding-left: 0;
154 | }
155 | #sidebar ul h3 {
156 | margin-top: 25px;
157 | font-size: 16px;
158 | padding-bottom: 10px;
159 | border-bottom: 1px solid #ccc;
160 | }
161 | #sidebar li {
162 | list-style-type: none;
163 | }
164 | #sidebar ul.links li {
165 | margin-bottom: 5px;
166 | }
167 | 
168 | h1, h2, h3, h4, h5 {
169 | font-family: sans-serif;
170 | margin: 1.2em 0 0.6em 0;
171 | }
172 | 
173 | p {
174 | line-height: 1.5em;
175 | margin: 1.6em 0;
176 | }
177 | 
178 | code, tt {
179 |     font-family: 'Andale Mono', Monaco, 'Liberation Mono', 'Bitstream Vera Sans Mono', 'DejaVu Sans Mono', monospace;
180 | }
181 | 
182 | #footer {
183 | clear: both;
184 | padding-top: 2em;
185 | text-align: center;
186 | padding-right: 160px;
187 | font-family: sans-serif;
188 | font-size: 10px;
189 | }
190 | 


--------------------------------------------------------------------------------
/fetch-xdslstats/fetch-xdslstats:
--------------------------------------------------------------------------------
  1 | #!/usr/bin/env perl
  2 | 
  3 | use strict;
  4 | use 5.012;
  5 | use DBI;
  6 | use Expect;
  7 | use Net::Netrc;
  8 | use SQL::Abstract;
  9 | 
 10 | 
 11 | my $dbh = DBI->connect(
 12 |     "DBI:mysql:davidp;mysql_read_default_file=$ENV{HOME}/.my.cnf"
 13 | ) or die "Failed to connect to DB! $DBI::errstr";
 14 | my $sqla = SQL::Abstract->new;
 15 | 
 16 | my $router = shift || "192.168.1.1";
 17 | 
 18 | my $mach = Net::Netrc->lookup($router)
 19 |     or die "No entry for $router in .netrc";
 20 | my ($user, $pass) = $mach->lpa;
 21 | 
 22 | my $expect = Expect->spawn("ssh $user\@$router")
 23 |     or die "Failed to spawn ssh $user\@$router - $!";
 24 | 
 25 | $expect->expect(2,
 26 |     [ qr/password:/ => sub {
 27 |         shift->send("$pass\n");
 28 |         exp_continue;
 29 |     }
 30 |     ],
 31 |     [ qr/ZySH>*?/ => sub {
 32 |             shift->send("xdslctl info --stats\n");
 33 |         },
 34 |     ],
 35 | );
 36 | 
 37 | # Read until EOF, or timeout
 38 | $expect->expect(2);
 39 | 
 40 | process_result($expect->before);
 41 | 
 42 | sub process_result {
 43 |     my $result = shift;
 44 | 
 45 |     my %stats;
 46 |     # A list of patterns to match against the `xdslctl info --stats` output.
 47 |     # Each named capture gets added to %stats.
 48 |     
 49 |     my @patterns = (
 50 |         qr{Status: \s (?<status>   .+ ) $}xm,
 51 |         qr{Training \s Status: \s+ (?<training> .+ ) $}xm,
 52 |         qr{
 53 |             Bearer:\s0, \s
 54 |             Upstream \s rate \s   = \s (?<rate_up>\d+) \s Kbps, \s 
 55 |             Downstream \s rate \s = \s (?<rate_down> \d+) \s Kbps
 56 |         }xm,
 57 |         qr{
 58 |             SNR \s \(dB\): \s+ 
 59 |             (?<snr_down> [0-9.]+ ) \s+
 60 |             (?<snr_up>   [0-9.]+ )
 61 |         }xm,
 62 |        qr{
 63 |             Attn\(dB\): \s+
 64 |             (?<attn_down> [0-9.]+ ) \s+
 65 |             (?<attn_up>   [0-9.]+ )
 66 |         }xm,
 67 |         qr{
 68 |             Pwr\(dBm\): \s+
 69 |             (?<power_down> [0-9.]+ ) \s+
 70 |             (?<power_up>   [0-9.]+ )
 71 |         }xm,
 72 |     );
 73 |     for my $patt (@patterns) {
 74 |         $result =~ $patt
 75 |             or die "Failed to match pattern $patt";
 76 |         $stats{$_} = $+{$_} for keys %+;
 77 |     }
 78 | 
 79 |     # Now, find the FEC (forward-error-corrections) counts for the
 80 |     # "Latest 15 minutes time" section (i.e. the most recent values)
 81 |     # ... that 15 minutes period will actually be however long it's been
 82 |     # since the last 15 minute mark; work out how many seconds the period
 83 |     # lasted, and divide the FEC counters by the time to get a rate, which
 84 |     # is what we're interested in.
 85 |     $result =~ m{
 86 |         Latest \s 15 \s minutes \s time \s = \s 
 87 |         (?<mins> \d+) \s min \s (?<secs> \d+ ) \s sec
 88 |         \r?\n
 89 |         FEC: \s+ (?<fec_down> \d+ ) \s+ (?<fec_up> \d+ )
 90 |         \r?\n
 91 |         CRC: \s+ (?<crc_down> \d+ ) \s+ (?<crc_up> \d+ )
 92 |     }xm or die "Feck!  No FEC stats.";
 93 |     my $secs = ($+{mins} * 60) + $+{secs};
 94 |     # For each stat (fec_up/fec_down, crc_up/crc_down), calculate a rate per
 95 |     # second
 96 |     for my $stat (qw(fec_down fec_up crc_down crc_up)) {
 97 |         $stats{$stat."_per_sec"} = sprintf '%.3f', $+{$stat} == 0 
 98 |             ? 0 
 99 |             : $+{$stat} / $secs;
100 |     }
101 |     $stats{$_} = $+{$_} for keys %+;
102 | 
103 |     # A few of the fields we captured along the way don't actually go in
104 |     # the DB
105 |     delete $stats{$_} for qw(secs mins fec_up fec_down crc_up crc_down);
106 | 
107 |     # And we want to record which router this is for, in case you're monitoring
108 |     # multiple ones
109 |     $stats{router} = $router;
110 | 
111 |     my ($sql, @bind) = $sqla->insert('xdslstats', \%stats);
112 |     $dbh->do($sql, {}, @bind);
113 | 
114 | 
115 | }
116 | 
117 | 


--------------------------------------------------------------------------------
/lagmeter-log-munin/check-lagmeter-log:
--------------------------------------------------------------------------------
  1 | #!/usr/bin/perl
  2 | 
  3 | # A simple Nagios plugin to monitor stats from the log file written by the
  4 | # LagMeter Minecraft server plugin:
  5 | # http://dev.bukkit.org/bukkit-plugins/lagmeter/
  6 | #
  7 | # A simple and fast way to have Nagios monitor the number of players connected,
  8 | # chunks loaded, entity count, and TPS (ticks per second) without messing
  9 | # about with RCON and spamming the server logs with RCON connections, etc.
 10 | # Outputs perfdata for nagiosgraph too, so you can have pretty graphs.
 11 | #
 12 | # Author: David Precious (BIGPRESH) <davidp@preshweb.co.uk>
 13 | # Released under the Perl Artistic Licence:
 14 | # http://dev.perl.org/licenses/artistic.html
 15 | #
 16 | # Original version 27th March 2018.
 17 | # Based on my previous  lagmeter-log-munin which was from Feb 2016. 
 18 | 
 19 | use strict;
 20 | use Monitoring::Plugin;
 21 | use File::ReadBackwards;
 22 | 
 23 | my $np = Monitoring::Plugin->new(
 24 |     shortname => 'MINECRAFT',
 25 |     usage => '%s -s|--stat',
 26 | );
 27 | 
 28 | $np->add_arg(
 29 |     spec => "stat|s=s\@",
 30 |     help => "stat:min:max - e.g. 'TPS:18:20' - repeat as needed",
 31 |     required => 1,
 32 | );
 33 | 
 34 | $np->add_arg(
 35 |     spec => "logfile|f=s",
 36 |     help => "LagMeter log file location",
 37 |     required => 1,
 38 | );
 39 | 
 40 | $np->add_arg(
 41 |     spec => "warning|w=f",
 42 |     help => "Warning threshold in percent; values that exceed a threshold"
 43 |         . " by this amount or less result in a warning, not critical",
 44 |     default => 10,
 45 | );
 46 | 
 47 | $np->getopts;
 48 | my $warning = $np->opts->warning / 100;
 49 | 
 50 | my %stat_re = (
 51 |     players => qr{Players online: (\d+)/\d+},
 52 |     chunks  => qr{Total chunks loaded: (\d+)},
 53 |     entities => qr{Total entities: (\d+)},
 54 |     TPS      => qr{TPS: (\d+)},
 55 | );
 56 | 
 57 | 
 58 | my $bw = File::ReadBackwards->new($np->opts->logfile)
 59 |     or die "Failed to open " . $np->opts->logfile ." - $!";
 60 | 
 61 | my $last_entry;
 62 | 
 63 | while( defined( my $log_line = $bw->readline ) ) {
 64 |     last if $log_line =~ /^$/ && length $last_entry;
 65 |     $last_entry .= $log_line;
 66 | }
 67 | 
 68 | # For each stat we've been asked to check, parse it out of the last
 69 | # entry, add perfdata, and check it against the thresholds.
 70 | my (@critical, @warning, @ok);
 71 | statspec:
 72 | for my $statspec (@{ $np->opts->stat }) {
 73 |     my ($stat, $min_thres, $max_thres) = split /:/, $statspec;
 74 |     if (!exists $stat_re{$stat}) {
 75 |         die "Unknown stat '$stat' - valid values: " . join ',', keys %stat_re;
 76 |     }
 77 |     my ($stat_value) = $last_entry =~ $stat_re{$stat}
 78 |         or do {
 79 |             push @critical, "No value found for $stat";
 80 |             next statspec;
 81 |         };
 82 | 
 83 |     $np->add_perfdata(
 84 |         label => $stat,
 85 |         value => $stat_value,
 86 |     );
 87 | 
 88 |     # First, if it's outside the thresholds plus/minus our warning leeway,
 89 |     # it's critical
 90 |     if (($stat_value < $min_thres - ($min_thres * $warning))
 91 |         ||
 92 |         ($stat_value > $max_thres + ($max_thres * $warning)))
 93 |     {
 94 |         push @critical, "$stat $stat_value";
 95 |         next statspec;
 96 |     }
 97 | 
 98 |     # OK, if it's outside the thresholds but we didn't catch it above,
 99 |     # then it's only a warning
100 |     if ($stat_value < $min_thres || $stat_value > $max_thres) {
101 |         push @warning, "$stat $stat_value";
102 |         next statspec;
103 |     }
104 | 
105 |     # And if neither of the above caught it, then it's fine.
106 |     push @ok, "$stat $stat_value";
107 | }
108 | 
109 |         
110 | # Assemble all problematic readings, critical ones first:
111 | # TODO: refactor, DRY
112 | my @problems = (@critical, @warning);
113 | if (@critical) {
114 |     $np->nagios_exit(CRITICAL, join ', ', @problems);
115 | } elsif (@warning) {
116 |     $np->nagios_exit(WARNING, join ', ', @problems);
117 | } else {
118 |     $np->nagios_exit(OK, join ', ', @ok);
119 | }
120 | 


--------------------------------------------------------------------------------
/xchat-plugins/xchat-parse-trivia-hints.pl:
--------------------------------------------------------------------------------
  1 | #!/usr/bin/perl -w
  2 | 
  3 | 
  4 | # Simple XChat script to parse trivia hints and
  5 | # display the number of letters in each word.
  6 | #
  7 | # Looks for lines in the format:
  8 | # Hint: @@@ @@@@ @@
  9 | # and writes back lines in the format:
 10 | # (Hint letters: 3, 4, 2)
 11 | #
 12 | # David Precious, davidp@preshweb.co.uk
 13 | # 20th December 2005  (Happy Christmas!!!)
 14 | #
 15 | # updated some time after then to add ability to remember
 16 | # previously seen answers + display them next time
 17 | #
 18 | # Updated 18th Feb 2006 to remember current Q for each
 19 | # channel seperately to avoid q's + a's in different
 20 | # channels getting mixed up
 21 | 
 22 | 
 23 | $script = 'xchat-parse-trivia-hints.pl';
 24 | $ver = '0.0.4';
 25 | $qdb = '/home/davidp/trivia-questions-db';
 26 | 
 27 | open(PTL, ">>/tmp/parse_trivia_log");
 28 | 
 29 | 
 30 | IRC::register ($script, $ver, "", "");
 31 | IRC::add_message_handler("PRIVMSG", "parse_line");
 32 | IRC::add_message_handler("NOTICE", "parse_line");
 33 | IRC::print("*** \0038,2$script v$ver loaded \003");
 34 | 
 35 | %qstate = ();
 36 | 
 37 | 
 38 | 
 39 | sub parse_line {
 40 | #Line::misspresh!~michelle@80.68.82.38 PRIVMSG #sharosmadhouse :rabbit
 41 | 
 42 | my $line = shift;
 43 | 
 44 | 
 45 | # replace the funky colour stuff:
 46 | $line =~ s/\cc[0-9]{2}//g;
 47 | 
 48 | print PTL "Line:$line\n";
 49 | 
 50 | if ($line =~ /:(.+)!(.+)@(.+)\s([A-Z]+)\s(.+)\s?:(.+)/)
 51 | 	{
 52 | 	($nick, $user, $host, $msgtype, $to, $msgtxt) = ($1, $2, $3, $4, $5, $6);
 53 | 	print PTL "Nick:$nick User:$user Host:$host Type:$msgtype To:$to Msg:$msgtxt\n";
 54 | 	}
 55 | 
 56 | if ($line =~ /Hint: (.+)/)
 57 | 	{
 58 | 	my @letters;
 59 | 
 60 | 	#foreach $bit (split '/ /', $1)
 61 | 	my @words = split / /, $1;
 62 | 	foreach $bit (@words)
 63 | 		{
 64 | 		#$out .= length($bit) . ' ';
 65 | 		push @letters, length($bit);
 66 | 		}
 67 | 
 68 | 	IRC::print( "Hint is: $1 (Letters: " . &output_list(@letters) . ')' );
 69 | 	return 1;
 70 | 
 71 | 	}
 72 | 
 73 | if ($msgtxt =~ /Question ([0-9]+)\/[0-9]+/)
 74 | 	{
 75 | 	$qstate{$nick}{'q'} = $1;
 76 | 	$qstate{$nick}{'a'} = '';
 77 | 
 78 | 	# see if we've seen it before:
 79 | 	if ((($ans, $line, $qbot) = &find_answer($nick, $qstate{$nick}{'q'}))
 80 | 		&& $ans)
 81 | 		{
 82 | 		$ans = lc($ans); # make it nicer to copy + paste <g>
 83 | 		IRC::print("\0031,11ANSWER: $ans\003 (line:$line, bot:$qbot)\n");
 84 | 		}
 85 | 	
 86 | 	}
 87 | 
 88 | if ($msgtxt =~ /The answer was ([^.]+)\./)
 89 | 	{
 90 | 	$qstate{$nick}{'a'} = $1;
 91 | 	#IRC::print("setting current answer to: '$1'\n");
 92 | 	}
 93 | 
 94 | if ($qstate{$nick}{'q'} && $qstate{$nick}{'a'})
 95 | 	{
 96 | 	unless (&find_answer($nick, $qstate{$nick}{'q'}))
 97 | 		{
 98 | 		&save_answer($nick, $qstate{$nick}{'q'}, $qstate{$nick}{'a'});
 99 | 		IRC::print("Q:" . $qstate{$nick}{'q'} . ", a:" . $qstate{$nick}{'a'} . " for bot " . $nick . " saved.\n");
100 | 		$qstate{$nick} = '';
101 | 		}
102 | 	}
103 | return 0;		
104 | }
105 | 	
106 | 
107 | sub find_answer {
108 | 
109 | my ($botname, $findqnum) = @_;
110 | 
111 | open QDB, "$qdb";
112 | my $line = 0;
113 | while (my ($bot,$qnum, $a, $foo) = split /\|/, <QDB>)
114 | 	{
115 | 	$line++;
116 | 	if (($bot eq $botname) && ($qnum == $findqnum))
117 | 		{
118 | 		close QDB;
119 | 		my @ret = ($a, $line, $bot);
120 | 		return @ret;
121 | 		}
122 | 	}
123 | 
124 | close QDB;
125 | my @ret = (0, 0, 0);
126 | return @ret;
127 | 
128 | } # end of sub find_by_id
129 | 
130 | 
131 | 
132 | sub save_answer {
133 | 
134 | my ($botname, $qnum, $a) = @_;
135 | 
136 | open QDB, ">>$qdb";
137 | print QDB "$botname|$qnum|$a|\n";
138 | close QDB;
139 | 
140 | 
141 | } # end of sub save_answer
142 | 
143 | 
144 | 
145 | 
146 | 
147 | sub output_list {
148 | # takes an array of items, and write a friendly list, for example:
149 | # output_list(@(1,2,3,4)) returns "one, two, three and four".
150 | # David Precious, Aug 2003
151 | my @items = @_;
152 | my $items_done = 0;
153 | my $out_string = '';
154 | foreach $item (@items)
155 | 	{
156 | 	$out_string .= $item;
157 | 	$items_done++;
158 | 	if ($items_done == @items-1)
159 | 		{
160 | 		$out_string .= ' and ';
161 | 		} elsif ($items_done < @items) {
162 | 		$out_string .= ', ';
163 | 		}
164 | 	}
165 | return $out_string;
166 | }
167 | 


--------------------------------------------------------------------------------
/diffr/diffr.pl:
--------------------------------------------------------------------------------
  1 | #!/usr/bin/perl
  2 | 
  3 | 
  4 | # recursive diff tool, with ability to filter files it looks at.
  5 | 
  6 | # $Id: diffr.pl 353 2008-05-16 22:05:00Z davidp $
  7 | 
  8 | use Getopt::Std;
  9 | use File::Find;
 10 | use strict;
 11 | use warnings;
 12 | 
 13 | # mainly for Getopt::Std to produce --help / --version output:
 14 | our $VERSION = '0.0.1';
 15 | 
 16 | my $usage = qq[
 17 | usage: diffr -s source -d dest [-p pattern] [-l]
 18 | 
 19 | if -p is given, we will only do the diff for filenames which match
 20 | this pattern - this matches the full path, so a pattern of 'foo' will
 21 | match 'foo.txt', '/home/foo/bar' etc. 
 22 | 
 23 | If -l is given, we will simply list files which differ, rather than outputting
 24 | the diff.
 25 | ];
 26 | 
 27 | 
 28 | my %opts;
 29 | getopt('sdplh', \%opts);
 30 | 
 31 | if (!$opts{'s'} || !$opts{'d'} || $opts{'h'}) {
 32 |     print $usage; exit;
 33 | }
 34 | 
 35 | my ($source, $dest) = @opts{qw(s d)};
 36 | 
 37 |  
 38 | unless (-d $opts{'s'} && -d $opts{'d'}) {
 39 |     print "source and dest directories must be given!\n"; exit;
 40 | }
 41 |  
 42 | # if we're given a pattern, we'll pre-compile the regexp for speed (we might
 43 | # be using it many,many times)
 44 | # TODO: we should probably catch any errors in case the pattern supplied isn't
 45 | # valid
 46 | my $regexp;
 47 | if ($opts{p}) {
 48 |     $regexp = qr/$opts{p}/xms;
 49 | }
 50 | 
 51 | # Loop one: we need to loop through the source dir, and diff any files which
 52 | # match the pattern, or report if they don't exist in the target dir.
 53 | process_dir($opts{'s'});
 54 | 
 55 | 
 56 | # Loop two: no diffs this time, but loop through the target dir and report any
 57 | # files which don't exist in the source dir.
 58 |  
 59 | # FIXME:
 60 | # actually, a better approach to looping through the source dir, then looping
 61 | # through the dest dir, might be to read both first and, for each file found,
 62 | # add the path to a hash (eg $paths{$thisfile}++), then do the work by walking
 63 | # through the keys of that hash, and:
 64 | #  - if it exists in both source + dest, do the diff
 65 | #  - if it exists in one but not the other, print the appropriate message
 66 | 
 67 | 
 68 | # search a directory, and call do_diff for all files (or, all files which
 69 | # match pattern if we've been given one), and for all dirs, calls itself
 70 | # recursively.
 71 | sub process_dir {
 72 | 
 73 |     my $dir = shift;
 74 |     
 75 |     $dir .= '/' unless $dir =~ /\/$/;
 76 |     
 77 |     opendir(DIR, $dir) || die "Failed to open dir $dir:$!\n";
 78 |     
 79 |     my @entries = readdir(DIR);
 80 |     close DIR;
 81 |     
 82 |     for my $entry (@entries) {
 83 |     
 84 |         next if ($entry =~ /^ \. \.? $/xms);
 85 |     
 86 |         my $fullentry = $dir . $entry;
 87 |         
 88 |         if (-d $fullentry) {
 89 |             # got a dir... process it
 90 |             process_dir($fullentry);
 91 |         } elsif (-f $fullentry) {
 92 |             # got a file:
 93 |             if (!$regexp || $fullentry =~ /$regexp/) {
 94 |                 
 95 |                 # now we need to know if this exists in the target dir:
 96 |                 my ($rel) = ($fullentry =~ /$opts{'s'}(.+)$/);
 97 |                 # $rel should now be something we can stick on the end of
 98 |                 # the dest dir to get a full path:
 99 |                 if (!-e $opts{'d'} . $rel) {
100 |                     print "$rel exists in source but not destination\n";
101 |                 } else {
102 |                     # it exists in both, diff it
103 |                     do_diff($rel);
104 |                 }
105 |                 
106 |             }
107 |         }
108 |     
109 |     } # end of for my $entry loop (nobody's looping through my entry!)
110 |             
111 | 
112 | } # end of sub process_dir
113 | 
114 | 
115 | 
116 | 
117 | # perform the diff
118 | sub do_diff {
119 | 
120 |     my $file = shift;
121 |     
122 |     my $diff = `diff -u '$opts{s}$file' '$opts{d}$file'`;
123 |     
124 |     if ($diff) {
125 |         if ($opts{l}) {
126 |             # -l option means only print list of files which differ
127 |             print "$file\n";
128 |         } else {
129 |             print "$diff\n";
130 |         }
131 |     }
132 |      
133 | }
134 | 
135 | 
136 | 


--------------------------------------------------------------------------------
/auto-name-incoming/auto-name-incoming:
--------------------------------------------------------------------------------
  1 | #!/usr/bin/perl
  2 | 
  3 | # auto-name-incoming
  4 | #
  5 | # Quick dirty script to watch a directory for new files and automagically
  6 | # move them to another directory, automatically naming them,
  7 | #
  8 | # A useful trick for saving images from stock photo sites which are misconfigured
  9 | # so that the browser tries to save each image as download.php etc.
 10 | #
 11 | # A little rough, but not too bad for something knocked up in about 30 minutes
 12 | # at night.  God bless Perl :-)
 13 | #
 14 | # David Precious <davidp@preshweb.co.uk>
 15 | 
 16 | 
 17 | use strict;
 18 | use File::Copy;
 19 | 
 20 | my %params = &get_cli_params;
 21 | 
 22 | 
 23 | if (!$params{'watch'}) {
 24 | 	print "Must specify directory to watch for new files with --watch\n\n"
 25 | 	     ."Use --help for all options.\n";
 26 | 	exit 1;
 27 | }
 28 | if (!$params{'target'}) {
 29 | 	print "Must specify target directory with --target\n\n"
 30 | 	     ."Use --help for all options.\n";
 31 | 	exit 2;
 32 | }
 33 | 	
 34 | if ($params{'help'}) { &print_help; }
 35 | 
 36 | $params{'watch'}  .= '/' unless (substr($params{'watch'},  -1, 1) eq '/');
 37 | $params{'target'} .= '/' unless (substr($params{'target'}, -1, 1) eq '/');
 38 | 
 39 | 
 40 | # right, get to it
 41 | 
 42 | while (1) {
 43 |     opendir(my $dirh, $params{watch})
 44 |         or die "Cannot open directory $params{watch} - $!";
 45 |     my @files = readdir($dirh);
 46 |     closedir($dirh);
 47 |     
 48 |     for my $file (@files) {
 49 |         next if ($file eq "." || $file eq "..");
 50 | 
 51 |         next if ($file =~ /\.part$/); # skip partial files...
 52 | 
 53 |         $file = $params{watch} . $file;
 54 | 
 55 |         my $ext = ($file =~ /\.(.+)$/)? $1 : '';
 56 |         $ext = ($params{'force-ext'})? $params{'force-ext'} : $ext;
 57 |         if ($ext && substr($ext, 0, 1) ne '.') { $ext = '.' . $ext; }
 58 | 
 59 |         my $prefix = ($params{prefix})? $params{prefix} : '';
 60 | 
 61 |         $params{start} = 0 unless $params{start};
 62 | 
 63 |         my $targetfile;
 64 |         my $digits = $params{digits} || 4;
 65 |         for (my $x = $params{'start'}; $x <= 9 x $digits; $x++) {
 66 |             $targetfile = $params{target} . $prefix
 67 |                 . sprintf("%0${digits}d", $x) . $ext;
 68 |             last unless (-e $targetfile);
 69 |         }
 70 |                 
 71 |         print "$file -> $targetfile\n";
 72 | 
 73 |         copy($file, $targetfile) or die "File cannot be copied.";
 74 |         unlink($file) || die "Failed to unlink $file ($!)!";
 75 | 
 76 |     } # end of foreach loop through incoming files
 77 |             
 78 |     sleep 1; # no need to continuously poll for files, so be nice
 79 | 
 80 |     
 81 | } # end of inifinite while() loop
 82 | 
 83 | 
 84 | 
 85 | sub print_help {
 86 | 
 87 | print qq[
 88 | 
 89 | auto-name-incoming takes the following parameters:
 90 | 
 91 |  --watch=... specifies the directory to watch for incoming files
 92 | 
 93 |  --target=... specifies the directory renamed files should go in
 94 | 
 95 | The following optional parameters customise its behaviour:
 96 | 
 97 |  --digits=  specifies the number of digits to use (default 4)
 98 | 
 99 |  --prefix=  specifies text to prefix the renamed file with
100 | 
101 |  --force-ext= forces the file extension to this (default is to keep existing)
102 | 
103 |  --start=  forces digit numbering to start at given value
104 | 
105 | ];
106 | exit;
107 |  
108 | } # end of sub print_help
109 | 
110 | 
111 | # TODO: Why did I re-invent this wheel?  Use one of the many much more circular
112 | # ones already on CPAN....
113 | sub get_cli_params {
114 |     # returns a hash of all the parameters passed to us on the command
115 |     # line as --param[=value].
116 |     
117 |     # let's get the params given to us on the command line:
118 |     my %myargs = ();
119 |     for my $arg (@ARGV) {
120 |         if ($arg =~ /\-\-([a-z0-9_-]+)=?(.+)?$/ig) {
121 |             $myargs{$1} = $2;
122 |             if (!$myargs{$1}) { $myargs{$1} = ''; }
123 |             # make sure it that got set, since if the arg
124 |             # has no value, it won't get set otherwise.
125 |         }
126 |     }
127 |     
128 |     return %myargs;
129 | 
130 | } # end of sub get_cli_params
131 | 
132 | 
133 | 
134 | 
135 | 
136 | 


--------------------------------------------------------------------------------
/log-ntl-cablemodem-stats/log-ntl-cablemodem-stats:
--------------------------------------------------------------------------------
  1 | #!/usr/bin/perl
  2 | 
  3 | # A quick script to extract connection details (signal/noise ratio, etc) from 
  4 | # a Virgin Media (ex NTL) cable modem and insert them in an SQLite DB for later
  5 | # analysis.
  6 | #
  7 | # Written for myself to monitor my connection, but may perhaps be useful to
  8 | # others (feel free to let me know if it's useful to you!)
  9 | #
 10 | # David Precious <davidp@preshweb.co.uk>, 2011
 11 | 
 12 | use strict;
 13 | use DBI;
 14 | use LWP::UserAgent;
 15 | use HTML::TableExtract;
 16 | 
 17 | # Amend this to suit your database
 18 | my $dbh = DBI->connect(
 19 |     'dbi:mysql:database=modemstats;',  # tweak to suit your DB
 20 |     'davidp', 'davidp',                # and put real credentials here
 21 |     {'RaiseError' => 1 }, 
 22 | ) or die "Failed to connect to database - $DBI::errstr"; 
 23 | 
 24 | # Cable modem config details:
 25 | my $user = "root";
 26 | my $pass = "root";
 27 | my $modem = "192.168.100.1";
 28 | 
 29 | 
 30 | ###############################################################################
 31 | # The following patch, subclassing LWP::UserAgent to provide basic auth only,
 32 | # was contributed by Jeff Fern, who noted that the original version (which had
 33 | # worked for my Ambit 120 CM) didn't work for him; this change made it work for
 34 | # him.  I no longer use my CM (I got upgraded to the "Super"Hub), so I haven't
 35 | # been able to test this; if you have authentication problems, you may wish to
 36 | # try the previous version (use GitHub to find the commit this change was added
 37 | # in, and use the one before :) ).
 38 | {
 39 |     package RequestAgent;
 40 |     our @ISA = qw(LWP::UserAgent);
 41 |     sub get_basic_credentials {
 42 |         return ($user, $pass);
 43 |     }
 44 | }
 45 | 
 46 | 
 47 | my $verbose = 0;
 48 | 
 49 | my $sth = $dbh->prepare('INSERT INTO stats (`key`,`value`) VALUES(?,?)')
 50 |     or die "Failed to prepare INSERT query - " . $dbh->errstr;
 51 | 
 52 | my $ua = RequestAgent->new;
 53 | 
 54 | # Fetch upstream/downstream stats
 55 | for my $page (qw(CmDnstream.asp CmUpstream.asp)) {
 56 |     my $res = $ua->get("http://$modem/$page");
 57 |     if (!$res->is_success) {
 58 |         die "Failed to fetch $page from CM - " . $res->status_line;
 59 |     }
 60 | 
 61 |     my $te = HTML::TableExtract->new(attribs => { width => 510, height => 300 });
 62 |     $te->parse($res->content)
 63 |         or die "Failed to parse HTML for table";
 64 | 
 65 |     my $table = $te->first_table_found
 66 |         or die "No table matched";
 67 |     for my $row ($table->rows) {
 68 |         my ($key,$value) = @$row;
 69 |         $key =~ s/\s+:\s+//;
 70 |         next unless $key =~ /\S+/;
 71 |         print "'$key' => '$value'\n" if $verbose;
 72 |         $sth->execute($key, $value);
 73 |     }
 74 | 
 75 | }
 76 | 
 77 | # Now, fetch any event log entries:
 78 | my $res = $ua->get("http://$modem/CmEventLog.asp");
 79 | if (!$res->is_success) {
 80 |     die "Failed to fetch event log page";
 81 | }
 82 | 
 83 | my $te = HTML::TableExtract->new(attribs => { id => 'LogTable' });
 84 | $te->parse($res->content)
 85 |     or die "Failed to parse HTML for table";
 86 | my $table = $te->first_table_found
 87 |     or die "Failed to find table";
 88 | 
 89 | my $log_sth = $dbh->prepare(
 90 |     "INSERT INTO eventlog (first_time, last_time, priority, description)"
 91 |     ." VALUES(?, ?, ?, ?)"
 92 | );
 93 | my $seen_headers;
 94 | for my $row ($table->rows) {
 95 |     next unless $seen_headers++;
 96 |     my ($first, $last, $priority, $description) = @$row;
 97 |     print "[$first][$last][$priority][$description]\n" if $verbose;
 98 |     $log_sth->execute($first, $last, $priority, $description);
 99 | }
100 | 
101 | # Now we've inserted any log entries into the DB, clear the log so we don't see
102 | # them again next time.
103 | # Yes, there is a potential race condition here, where an event could be logged
104 | # between us fetching the page and then clearing the log, in which case that
105 | # event would be lost.  That's not the end of the world.  In an ideal world, I
106 | # wouldn't be using this nasty approach, I'd just be telling the modem to syslog
107 | # to a real box.
108 | 
109 | # We'll get a redirect as the result of this POST:
110 | push @{ $ua->requests_redirectable }, 'POST';
111 | $res = $ua->post("http://$modem/goform/CmEventLog",
112 |     { submit => 'Clear Log', SnmpClearEventLog => 2 });
113 | if (!$res->is_success) {
114 |     die "Failed to clear event log - " . $res->status_line;
115 | }
116 | 
117 | 


--------------------------------------------------------------------------------