Hi monks,

I've been growing an interest for computer graphics lately, and most especially for proceduraly generated landscapes (the kind of stuff we can see in open-world or sandbox games). So while educating myself on this subject I learnt a few things about noise, and I learnt about the so-called Perlin noise, which was invented in the eighties or something. In 2002, Perlin improved his algorithm by using a better tesselation of space. It's called the Simplex noise and it's discussed and explained by Stefan Gustavson in this document, while providing a java implementation in public domain.

Well, I don't like java so I wanted to translate it into Perl. I've done it for the 2D dimension, and I thought it was worth sharing with you monks. I'll certainly translate the rest (3D and 4D) later. I will almost certainly write a Perl 6 version as well.

I also added a few lines to create a noise image in PGM format. Here is the result:

And here is the code (the original java code is in the __END__)

Once one of your modules on CPAN is used/required by another module on CPAN not under your own control, it might be a good idea to test all those modules with your new code to verify you didn't break anything.

The first thing you want to check is the fact that your module actually is used by something else. We are in luck here, as that is already done for us. For this example, I'll continue with a short and simple module (Data::Peek) as the logs are much shorter, but the process is exactly the same as for a module that is used widely, as DBI or Text::CSV_XS, for which I wrote this to begin with.

Before you want to check other modules, of course you check your own suite:

$ perl Makefile.PL
$ make test
:
All tests successful.
:
Result: PASS
$ make distcheck
[download]

So the module passes, but does it still pass in the modules that require it? To test that, we first need to see what that lists consists of. CPANTS has that list readily available for each module on CPAN. We can use the internals of CPAN to fetch and test that list.

That fetches the list of modules that require Data::Peek, check if any of those is recognized by CPAN, for each makes a call to CPAN's test function/method, catches all the output with Capture::Tiny (and ignores all output for now) and use the return code available in $? to decide FAIL or success:

$ prove -vwb sandbox/used-by.pl
sandbox/used-by.pl ..
Reading '/home/merijn/.cpan/Metadata'
  Database was generated on Mon, 03 Mar 2014 14:17:02 GMT
CPAN: YAML loaded ok (v0.90)
Reading 3 yaml files from /home/merijn/.cpan/build/
..........................DONE
Restored the state of 1 (in 0.0431 secs)
ok 1 - App::tkiv
ok 2 - Geo::KML
ok 3 - Spreadsheet::Read
1..3
ok
All tests successful.
Files=1, Tests=3, 13 wallclock secs ( 0.02 usr  0.00 sys + 10.29 cusr 
+ 0.60 csys = 10.91 CPU)
Result: PASS
$
[download]

Running this for Text::CSV_XS resulted in 4 RT tickets with patches on other modules that failed depending on Text::CSV_XS where they did either something wrong or were not yet up to date with new(er) code.

If I find myself not forgetting to run this before I release a new module, I think I will prevent a lot of complaints later :)

I created a single user Mojolicious based RSS aggregator. It uses PostgreSQL for its database. I had attempted to use SQLite when I first started but I ran into some problems with reliability and I have not had much of a need to go back.

It is pretty minimal for Mojolicious use as well a JavaScript to get the work done.

I have been using it everyday for several months and it has been quite stable. At the moment it is a single file script.

I wrote it to be usable from a desktop web browser but also from a mobile browser as well. I only have access to an Android Galaxy S3 so I cannot say how well it will work on iPhones or other devices.

Here are some features

• Mobile friendly
• Can favorite items
• Can delete news items that are older than X amount of days you choose
• Fairly light weight when it comes to the web client with respect to JavaScript
• You mark all current news items as read
• You will only see items that have current news
• If you are on a long list of news items you can jump back to the top of the page quite easily

You can find it here on GitHub

First the programs, python:

#!/usr/bin/python
import operator
import hashlib
from threading import Thread

def ticks_all():
  with open('/proc/stat') as f:
    cpu = f.readline().split()
    return (int(cpu[1]), int(cpu[3]))

def ticks_process():
  with open('/proc/self/stat') as f:
    cpu = f.readline().split()
    return (int(cpu[13]), int(cpu[14]))

def do_work():
  d = hashlib.md5()
  d.update('nobody inspects')
  for i in xrange(0, 10000000):
    d.update(' the spammish repetition')

before_all_user, before_all_sys = ticks_all()
before_process_user, before_process_sys = ticks_process()

threads = []
for i in xrange(0, 8):
  t = Thread(target=do_work)
  threads.append(t)
  t.start()
for t in threads:
  t.join()

after_process_user, after_process_sys = ticks_process()
after_all_user, after_all_sys = ticks_all()

print 'delta process: user:', after_process_user - before_process_user
+, 'sys:', after_process_sys - before_process_sys
print 'delta all: user:', after_all_user - before_all_user, 'sys:', af
+ter_all_sys - before_all_sys
[download]

#!/usr/bin/perl
use 5.16.0;
use threads;

sub open_for_read($) {
  open(my $handle, "<$_[0]") or die "opening $_[0]: $!";
  $handle }

sub ticks_all {
  my $f = open_for_read("/proc/stat");
  return (split ' ', <$f>)[1,3] }

sub ticks_process() {
  my $f = open_for_read("/proc/self/stat");
  return (split ' ', <$f>)[13,14] }

sub dowork () {
  use Digest::MD5;
  my $d = Digest::MD5->new;
  $d->add('nobody inspects');
  $d->add(' the spammish repetition') for (0 .. 10_000_000)} 

my ($before_all_user, $before_all_sys) = ticks_all();
my ($before_process_user, $before_process_sys) = ticks_process();

my @threads; 
for my $i (0 .. 8) {
  my $t = threads->create(\&dowork);
  push @threads,$t }
$_->join() foreach @threads;

my ($after_all_user, $after_all_sys) = ticks_all();
my ($after_process_user, $after_process_sys) = ticks_process();

#(note: changing perl defaults for print)
$, = " ";   #put spaces between output fields
$\ = "\n";  #add LF to end of lines by default

print 'delta process: user:', $after_process_user - $before_process_us
+er, 
      ' sys:', $after_process_sys - $before_process_sys;
print 'delta all: user:', $after_all_user - $before_all_user, 
      ' sys: ', $after_all_sys - $before_all_sys;
[download]

> export TIMEFORMAT="%2Rsec %2Uusr %2Ssys (%P%% cpu)"

> time python ticks.py
delta process: user: 9263 sys: 2987
delta all: user: 6034 sys: 2178
67.35sec 92.64usr 29.89sys (181.94% cpu)

> time perl /tmp/pticks
delta process: user: 2917  sys: 3
delta all: user: 2926  sys:  25
3.36sec 29.20usr 0.03sys (870.05% cpu)
---

For 9 threads:

lang    #thrds  #coresuse  %efficency
python    9          1.82       20.2%
perl      9          8.70       96.7%

[download]

In a recent blog post I put together, I added a code sample I am expecting to release in LedgerSMB 1.5 (code under the GPL v2+, etc). The sample shows what I think is really cool about Perl 5 as a language, namely the ability to change the semantics enough to build dialects for specific things in the code.

This example extends some of the things that Moose or Moo does to show declaratively defined object methods (in this case wrapping a service locator for PostgreSQL stored procedures.

package LedgerSMB::Currency;
use Moose;
with 'LedgerSMB::PGOSimple::Role', 'LedgerSMB::MooseTypes';

use PGObject::Util::DBMethod;
   
sub _set_prefix { 'currency__' }

has id                => (is => 'rw', isa => 'Int', required => '0');
has symbol            => (is => 'ro', isa => 'Str', required => '1');
has allowed_variance  => (is => 'rw', 
                          isa => 'LedgerSMB::Moose::Number',
                          coerce => 1, required => 1);
has display_precision => (is => 'rw', isa => 'Int', required => '0');
has is_default => (is => 'ro', isa => 'Bool', required => '0');

dbmethod list      => (funcname => 'list', returns_objects => 1 );
dbmethod save      => (funcname => 'save', merge_back => 1);
dbmethod get       => (funcname => 'get', returns_objects => 1,
                          arg_list => ['symbol']);
dbmethod get_by_id =>  (funcname => 'get_by_id', returns_objects => 1,
                        arg_list => ['id']);
__PACKAGE__->meta->make_immutable;
[download]

This code allows me to do something like:

my $usd = LedgerSMB::Currency->get('USD');

my @currencies = LedgerSMB::Currency->list;

$usd->{allowed_variance} = 0.2;

$usd->save;
[download]

It also gives useful information that the simple form of ipconfig lacks (eg. the adapter's MAC address -- to get it you have to use "ipconfig/all" which spews out even more information to wade through). Plus, you can easily spot from the "Connected" line in the header the indices of connected interfaces (when -a or -v is supplied).

Here's an output comparison, where less lines is arguably better when you're trying to get device information quickly:

    ipconfig .........  57 lines
    ipconfig/all ..... 121 lines (!)
    ifconfig.pl ......  19 lines
[download]

Now that I'm using the script all the time I've added a feature to disable/reenable the network device by adding the argument ~N, where N is the index of the device displayed. This saves the hassle of having to open several dialog boxes to get to the network adapter settings, just to be able to cycle an interface that's down for some reason.

#!/usr/bin/perl -w
#
#  Displays currently connected network interfaces.
#  Lets you DISABLE/REENABLE an interface (eg. if it's not responding)
#
#  2014-02-26  golux -- created.
##


###############
## Libraries ##
###############
use strict;
use warnings;
use File::Basename;
use Data::Dumper;
use Getopt::Long;


##################
## User-defined ##
##################
my $ipconfig   = 'C:\Windows\System32\ipconfig.exe';
my $netsh      = 'C:\Windows\System32\netsh.exe';
my $maxwidth   = 12;
my $re_addr    = qr/^(\d+)[.](\d+)[.](\d+)[.](\d+)(?:)?$/;
my $re_vm      = qr/VMware Network Adapter/i;
my $re_dots    = qr/[\s.]*:\s*/;
my $re_if      = qr/^\s*([\sa-z0-9]+):\s*$/i;
my $re_ip_addr = qr/IP Address:\s*(\d+[.]\d+[.]\d+[.]\d+)/i;

# Order of tags presented
my $a_items = [qw[ desc dhcp state mac addr addr6 mask gate dns ]];

# Label used for each tag
my $h_label = {
    'desc'  => 'Desc',
    'state' => 'State',
    'dhcp'  => 'DHCP',
    'mac'   => 'MAC',
    'addr'  => 'IP Addr',
    'addr6' => 'IPv6 Addr',
    'mask'  => 'Mask',
    'gate'  => 'Gateway',
    'dns'   => 'DNS Suffix',
};

# Regex used to capture the value for each tag
my $h_regex   = {
    'desc'   => qr/^\s*Description${re_dots}(.+)/i,
    'state'  => qr/^\s*Media State${re_dots}(.+)/i,
    'dhcp'   => qr/^\s*Dhcp Enabled${re_dots}(\S+)/i,
    'mac'    => qr/^\s*Physical Address${re_dots}(\S+)/i,
    'addr'   => qr/^\s*IP(?:v4)? Address${re_dots}(\S+)/i,
    'addr6'  => qr/^\s*IPv6 Address${re_dots}(\S+)/i,
    'mask'   => qr/^\s*Subnet Mask${re_dots}(\S+)/i,
    'gate'   => qr/^\s*Default Gateway${re_dots}(\S+)/i,
    'dns'    => qr/^\s*Connection-specific DNS Suffix${re_dots}(\S+)/i
+,
};


#############
## Globals ##
#############
my $b_all  = 0;
my $b_vms  = 0;
my $b_help = 0;


##################
## Command-line ##
##################
Getopt::Long::Configure("bundling");
my $go = GetOptions(
    "a"  => \$b_all,
    "v"  => \$b_vms,
    "h"  => \$b_help,
);


##################
## Main Program ##
##################
$| = 1;
my $iam = basename $0;

$b_help and give_help();

my $a_args  = [ @ARGV ];
my $a_info  = get_config_info();

if (@$a_args > 0) {
    change_inteface_states($a_info, $a_args);
    $a_info = get_config_info();
}

show_basic_info();
show_interface_info($a_info);


#################
## Subroutines ##
#################
sub fatal {
    my ($msg) = @_;

    my $lnum = (caller)[2];
    my $text = "($iam)  FATAL[$lnum]:  $msg";
    die "$text\n";
}


sub give_help {
    my $syntax = qq{
        :  Syntax:  $iam  [switches]  [command ...]
        :
        :  This program shows the currently connected network interfac
+es.
        :
        :  To cycle a network interface #N  (disable, then enable it a
+gain),
        :  use the command '$iam ~N'.
        :
        :  Switches
        :      -a ... display all interfaces (even disconnected ones)
        :      -v ... display virtual (ie. VMware) interfaces
        :      -h ... display help message and exit
    };

    $syntax =~ s/(^\s+:)|((?<=\n)\s+:)|(\s+$)//g;
    die "$syntax\n";
}


sub get_config_info {
    chomp(my @lines = `$ipconfig /all`);

    my $a_info = [ ];
    my $h_if   = { };

    HANDLE_LINE: 
    foreach my $line (@lines) {
        $line =~ /^\s*$/ and next;
        if ($line =~ /$re_if/) {
            my $if = $1;
            (my $name = $if) =~ s/^Ethernet adapter\s*//i;
            $h_if = { 'if' => $if, 'name' => $name };
            push @$a_info, $h_if;
            next;
        }

        foreach my $item (@$a_items) {
            if ($line =~ /$h_regex->{$item}/) {
                $h_if->{$item} = $1;
                next HANDLE_LINE;
            }
        }
    }

    return prune_results($a_info);
}


sub prune_results {
    my ($a_info) = @_;

    my $a_pruned = [ ];

    for (my $i = 0; $i < @$a_info; $i++) {
        my $idx     = $i + 1;
        my $h_if    = $a_info->[$i];
        my $addr    = $h_if->{'addr'} || "";
        my $name    = $h_if->{'name'} || "";
        my $b_is_vm = ($name =~ /$re_vm/)? 1: 0;
        my $b_conn  = 0;

        $addr =~ s/\(Preferred\)//;
        if ($addr =~ /$re_addr/) {
            ($1 or $2 or $3 or $4) and $b_conn = 1;
        }

        $h_if->{'conn'} = $b_conn;

        if ($b_all or ($b_conn and ($b_vms or !$b_is_vm))) {
            push @$a_pruned, $h_if;
        }
    }

    return $a_pruned;
}


sub show_basic_info {
    my $a_conn = [ ];

    for (my $i = 0; $i < @$a_info; $i++) {
        my $idx    = $i + 1;
        my $h_if   = $a_info->[$i];
        my $b_conn = $h_if->{'conn'} || 0;
        $b_conn and push @$a_conn, $idx;
    }

    my $conn = (0 == @$a_conn)? "(none)": join(", ", @$a_conn);

    print "\n";
    my $cname   = $ENV{'COMPUTERNAME'}   || "";
    my $domain  = $ENV{'ComputerDomain'} || "";
    my $user    = $ENV{'USERNAME'}       || "";
    print " ------------------------------------------------\n";
    $cname  and print "    Computer .... $cname\n";
    $domain and print "    Domain ...... $domain\n";
    $user   and print "    User ........ $user\n";
    $conn   and print "    Connected ... $conn\n";
    print " ------------------------------------------------\n";
    print "    Type '$iam -h' for help\n";
    print "\n";
}


sub show_interface_info {
    my ($a_info) = @_;

    my $space  = "   ";

    for (my $i = 0; $i < @$a_info; $i++) {
        my $h_if = $a_info->[$i];
        my $idx  = $i + 1;
        my $if   = $h_if->{'if'};
        printf " #%d [$if]\n", $idx;

        foreach my $item (@$a_items) {
            if (my $val = $h_if->{$item} || "") {
                ($item eq 'mac') and $val =~ s/-/:/g;
                my $label = $h_label->{$item} || " ";
                $label or fatal("No label found for item '$item'");
                my $dots = "." x ($maxwidth - length($label));
                printf "$space %s %s %s\n", $label, $dots, $val;
            }
        }

        print "\n";
    }
}


sub change_inteface_states {
    my ($a_info, $a_args) = @_;

    my $nifs = @$a_info;

    foreach my $arg (@$a_args) {
        if ($arg !~ /^~(\d+)$/) {
            print "Invalid arg '$arg' ignored\n";
        } else {
            my $idx = $1;
            if ($idx < 1 or $idx > $nifs) {
                print "Skipping interface '$idx' (not in range 1-$nifs
+)\n";
            } else {
                my $h_if = $a_info->[$idx-1];
                my $name = $h_if->{'name'};
                cycle_network_interface($name);
            }
        }
    }

    print "\n\n";
}


sub cycle_network_interface {
    my ($name) = @_;

    print "Type [RETURN] to DISABLE, then ENABLE interface '$name':";
    <STDIN>;

    my $netsh_dis  = qq{interface set interface "$name" DISABLED};
    my $netsh_en   = qq{interface set interface "$name" ENABLED};
    my $netsh_show = qq{interface ip show addresses "$name"};

    print "Command:  netsh $netsh_dis\n";
    system("$netsh $netsh_dis 1>nul 2>nul");

    print "Command:  netsh $netsh_en\n";
    system("$netsh $netsh_en 1>nul 2>nul");

    my $ntries  = 32;
    my $addr    = "";
    print "Renewing IP address ";

    while ($ntries-- > 0) {
        print ".";
        chomp(my @results = `$netsh $netsh_show`);
        map { /$re_ip_addr/ and $addr = $1 } @results;
        $addr and last;
        select(undef, undef, undef, 0.25);
    }

    print "\n";
    $addr or fatal("Failed to reenable interface '$name'");
}



[download]

BTW:
10 years ago I joined the monastery. Today I received a HappyMonks day greeting. That's a nice idea, and a thought it is a good occasion to share a script I wrote recently.

I recently implemented two of the algorithms that GMP uses for "fast" multiplication, in perl.

Karatsuba, was really easy to implement. It's a little faster if it's recursive, with a recursion threshold of about 1200 digits (and using plain multiplication, below that); but for demonstration; it's clearer to have neither a threshold nor recursion.

Toom-cook, was a difficult and fun challenge to implement. Initially, both of the descriptions of it, were totally incomprehensible. There's a speedup if all of the *1 *-1 and *0 multiplications are eliminated; but for demonstration, it's clearer to leave them in.

The test script,

References.
https://gmplib.org/manual/Karatsuba-Multiplication.html
https://gmplib.org/manual/Toom-3_002dWay-Multiplication.html
https://gmplib.org/manual/Unbalanced-Multiplication.html
http://en.wikipedia.org/wiki/Karatsuba_algorithm
http://en.wikipedia.org/wiki/Toom%E2%80%93Cook_multiplication

$client is doing a lot of heavy lifting (perhaps accidentally) in some Catalyst-driven Template Toolkit code. Apparently, it's far too easy to pass a DBIx::Class object into the stash, and then trigger things that end up hitting the database... from the view. That wouldn't be horrible, except the same exact queries are being used in multiple places in the templates, causing many redundant identical queries to the database per page hit. (Note aside: if this was Rose::DB... I'd trivially jump to Rose::DB::Object::Cached. Problem solved.)

I wanted a way to see what method calls were being invoked on the objects in the stash. Simple... just subclass Template::Stash! Now I get a list of the component invoking the method, the path from the root stash to the object, and the method call being made.

package Test::Stash;
use base qw(Template::Stash);

use strict;
use warnings;
use Scalar::Util qw( blessed reftype );

use Template::Config;

our @PATH;
our $BYPASS = 0;

sub _dotop {
  my ($self, $root, $item, $args, $lvalue) = @_;

  unless ($BYPASS) {
    my $rootref = ref $root;
    my $atroot  = (blessed $root && $root->isa(ref $self));

    if ($atroot) {
      @PATH = $item;
    } else {
      push @PATH, $item;
    }

    if (blessed $root && $root->can($item)) { # likely a method call
      if ($root =~ m{
              \A(
            DBIx::Class::QueryLog(::(Query|Analyzer))?
              |
            # (redacted Catalyst model class)
              |
            Template::Plugin::(Math|Date)
              |
            Moose::Meta::Class:: .*?
              )=}x) {
    ## ignore these
      } else {
    local $BYPASS = 1;
    my $component = $self->get(['component', 0, 'name', 0]);
    warn sprintf "%s: %s => %s\n",
      $component,
      join('.', @PATH),
      $root;
      }
    }
  }
  return (shift @_)->SUPER::_dotop(@_);
}

# warn "Loaded Test::Stash... before is $Template::Config::STASH";

$Template::Config::STASH = __PACKAGE__;

# warn "Loaded Test::Stash... after is $Template::Config::STASH";

1;
[download]

We developed an in-house tool called Napalm (NetApp Provision And Allocation Log Monitor) for this, and set it to work gathering configuration and usage metrics on our NetApps; what was made, what was destroyed, what took up what, everything, even down to the level of individual spindles. It's done a good job of continually documenting everything that's happened, the results of which now reside in a rather large MySQL database for us to draw upon.

2 years later, it's time to look at our growth statistics in preparation for the next round of purchasing. This presented a bit of a challenge, because our storage consumption is given by the NetApp(s) in terms of volumes, not applications. Management has requested a per-application breakdown of the data, to determine where the bulk of our storage is being used up. This required building a quick script in Perl that queried Napalm's database, collected a list of every single volume that has ever existed, and then attempted to determine what application that volume belonged to via simple regex pattern matching. The results of this are then stored back in the database as well, for future reference.

SANScape exists as a web-based app. It presents the user with a simple interface at the top that allows them to specify a date, and a series of checkboxes for different reports that can be run against the data in realtime. From this data, we can construct a picture of what our per-application storage consumption numbers were, on any given date over the past 2 years.

Now, here's the fun part. About 6 months ago, Napalm was moved to a newer monitoring server.. And a bug emerged. The code we'd written to gather up raw statistics off the NetApps stopped returning any results, but the script itself still appeared to be working. As a result, we have a pretty sizable chunk of the "recording" that is completely absent. We have the before picture, and the after picture, but nothing but silence over a period spanning several months until we caught the error and fixed it.

What began as a Perl script to simply fetch numbers and draw a resulting set of human-readable bar charts then became something a bit more intelligent. We modded the code such that for any date the user supplied, the resulting numbers will be interpolated against the last known "good" values before and after the date specified. This effectively filled in the giant hole in the data, allowing for reasonably accurate numbers to be presented regarding overall growth trends.

The interpolated data being generated during these queries is actually useful from a graphing perspective as well. Obviously, lacking real data points, interpolated data is as close as we can get to what actually occurred growth-wise during the blackout; Thankfully, the fact we're missing this data and are relying on interpolated data doesn't appear to change the overall picture that much.

The net result is a 100% Perl-based single pane of glass for doing realtime historical and statistical analysis on 2 years worth of SAN growth data. The main script underpinning it all, everything from the SQL calls to perform the data collection, parsing, and resulting HTML to render a respectable interface weighs in at less than 17KB; To do the equivalent in something like Java or some other monstrosity not only would have taken ages to develop and deploy, but it would have been slower, and the code base practically obese by comparison.

Here's a link to how SANScape looks in the wild (application names blurred out..it's my employer's info, after all.)

Imgur gallery for SANScape

Cheers,

Bowie J. Poag

For some time now I've been obsessed with clean decision trees. No solution is appropriate for all needs and, as usual, tradeoffs are in play. Today I hacked out one particular way of simplifying these trees.

    # Four-outcome tree
    my $cf      = !!$code;
    my $af      = !!( $args and ref $args );
    if    (  $cf &&  $af ) {
        @ARGV       = @$args;
    } 
    elsif (  $cf && !$af ) {
        @args       = ();
    } 
    elsif ( !$cf &&  $af ) {
        @args       = @$args;
        $code       = $unit . q{(@args)};
    } 
    elsif ( !$cf && !$af ) {
        @args       = ();
        $code       = $unit . q{()};
    } 
    else { die 'Fifth element!' };
[download]

Of course tim toady; and I don't doubt others will rush to display their favorite decision trees. This one may work for me sometimes.

I recently spent a while staring at some brainfuck code (in particular, the rot13 decoder on the oldest http://golf.shinh.org brainfuck challenge), trying to understand how it worked.

I didn't succeed, but ended up writing a static analyzer to eliminate simple loops like [<+>-] which occur fairly often.

# Copyright 2013,2014 Dakota Simonds

#    This program is free software: you can redistribute it and/or mod
+ify
#    it under the terms of the GNU General Public License as published
+ by
#    the Free Software Foundation, either version 3 of the License, or
#    (at your option) any later version.
#
#    This program is distributed in the hope that it will be useful,
#    but WITHOUT ANY WARRANTY; without even the implied warranty of
#    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#    GNU General Public License for more details.
#
#    You should have received a copy of the GNU General Public License
#    along with this program.  If not, see <http://www.gnu.org/license
+s/>.

use warnings;
use strict;

sub EXIT_SUCCESS (){ #C style
    1;
}

sub TRUE (){
    1;
}

sub FALSE (){
    0;
}

sub forceflush{
    our $| = 1;
    
    return EXIT_SUCCESS;
}

sub savefile{ #savefile(filename, data);
    my $SVFL;
    
    open $SVFL, ">>", $_[0];
    syswrite $SVFL, $_[1];
    close $SVFL;
    
    return EXIT_SUCCESS;
}

sub assert{ #C style
    
    my @assertions = @_;
    
    foreach my $testAssertion (@assertions){
    
        if( not eval $testAssertion ){
        
            print "Assertion failure: '$testAssertion'\n";
            exit 0;
            
        } #else{ print "win\n"; }
        
    }
    
    return EXIT_SUCCESS;
}

sub prompt{
    my $question = shift;
    my $style = shift;
    my $styleOut;
    my $input;
    
    my %styles=(
        plain => "\x20",
        normal => ': ',
        yn => ' (y/n) ? ',
    );
    
    if($style eq ""){
        $styleOut = $styles{"plain"};
    }
    
    else{
        $styleOut = $styles{$style};
    }
    
    
    { #these currlies makes redo work when input is not valid
    
        print $question, $styleOut;
        $input = <STDIN>;
        chomp $input;
        
        if(not $input =~ m/(y|n)/i and $style eq "yn"){
            print "\nThat is not a valid input!\n";
            redo;
        }
        
    }
    
    
    
    return $input;
}

sub strcat{
    my $compiled;
    
    for my $str (@_)
    {
      $compiled = $compiled . $str;
    }
    
    return $compiled;
}

sub longCatIsLoooooooooooooooooooooooooooooooooooooooooooooooooooooooo
+oooooooooooooooooooooooooooooooooooooooooooooooonnngggggg{
    return '';
}


1;

__END__

=head1 NAME

    Spice

=head1 SYNOPSIS

    technically all these are functions but these three return
    true or false and take no arguments. meant to reduce magic
    numbers.
    
    EXIT_SUCCESS - C style return (true)
    TRUE         - returns 1
    FALSE        - returns 0

    forceflush   - same as $|=1
    savefile     - appends data to a file
    assert       - C style fuction. Like eval but if code reurns a fal
+se the program exits otherwise returns 1. takes a list.
    prompt       - get input in one line
    strcat       - a funtion the concatinates it's inputs
    savefile     - writes to a file in one line
    
=head1 DESCRIPTION

    Simple PERL module to that fixes small anoying things and provides
+ a bit of C style funtionality

=head1 EXAMPLES

    forceflush;
    
    while( TRUE ){
    do something
    }
    
    savefile("meows.txt", "data");
    
    if($foobar == FALSE){
    do something
    }
    
    prompt("keywords","normal");
    prompt("do you want a cookie", "yn");
    prompt("do you want a cookie (Y/n)?", "plain");
    
    assert('$a=1');
    
    savefile($filename, $data);
    
    return EXIT_SUCCESS;

=cut

[download]

The basic theory behind this is the more you age the more cats you acquire. I'm asserting that you don't get your first cat until you are at least 19.

print "age: ";
my $age = <STDIN>;
chomp $age;

print int(( ($age - 12) / 10 ) / 0.618), " cats";
[download]

For anyone who's worked with IBM's pSeries line, you're probably familiar with the concept of LPARs. You're probably also familiar with the fact that IBM doesn't like people snooping around at the hypervisor layer without their blessings, let alone permission.

Halogen is a tool that allows you as an administrator to peek into the black box, and monitor LPAR and hypervisor metrics in near-realtime.

These days, doing LPAR virtualization requires a device called an HMC in order to manage it. The HMC is presented to the customer (you) as a walk-up 1U console that optionally can be accessed remotely via a web front-end. You might be surprised to learn that the HMC also gathers and stores a whole slew of different metrics behind the scenes for IBM, for the purposes of problem determination and analysis when things go wrong.

Lucky for us, the HMC accepts ssh connections, and allows users to authenticate using the same credentials used for logging into the web frontend. There's also a small set of commands available in the shell that aren't generally given to customers, 'lslparutil' and 'lshwres'. Between these two commands, we can automate the process of passively extracting and making sense out of performance metrics, live, as they are recorded.

It's just a guess on my part, but, i'm guessing IBM doesn't really advertise the fact that the HMC collects and stores performance metrics because the metrics themselves are horribly confusing and obtuse. There's also quite a bit of them; an individual sampling of one moment in time may return upwards of 50 different values. The only way we've been able to make use of these metrics is by careful examination of the data itself, to see how the numbers themselves vary from moment to moment. I would call it back-engineering if it weren't for the fact that at least the table columns are named, albeit poorly.

As I stated above, Halogen relies principally on two commands.. lslparutil and lshwres. The first one dumps the performance metrics, while the second allows you to make sense of what you're seeing from a configuration standpoint. Between the two, it's also possible to do a little bit of data correlation, and thus build a picture of hypervisor-layer statistics. Halogen wakes up every 5 minutes, uses ssh-pass to collect the last 5 minutes worth of metrics recorded on the HMC, and dumps the raw data into a MySQL database with column names that match the names given in the data. From there, the parts we're interested in are parsed.

Part of the difficulty in making sense of the data pumped out by lslparutil is how IBM chose to record the values from sample to sample. First off, they're only dumped to disk on the HMC perodically...(as best we can tell, roughly every 5 minutes give or take), which imposes both a limit on data granularity as well as a limit to how fresh a given set of readings presented to the user can be; To make matters worse, the values which end up being recorded are NOT recorded in terms of deltas accumulated since the last sample pass; they are more akin to meter readings, so, in order to make sense out of the data and get the deltas you're looking for, your script must either remember key points or look back at previous values within an output stream. Did I mention the contents of the stream may or may not be in chronological order, may or may not contain mentions of the resources you're looking for, and may not even be fully populated as well? :)

Figuring out pSeries metrics is a mess. I would liken it to figuring out how fast a car is going by measuring how much the odometer reading has changed in relation to the angle of the car's shadow on the road. You can figure out how much time has elapsed by using the car's shadow as a sundial, and and use the odometer to measure distance. If you know the two of those, then you can divine the car's speed. Thankfully, IBM's "odometer" and "shadow angle" measurements are extremely precise, so you'll get good results in the end....but it's horribly clunky. I'm at a loss to explain why IBM does it this way.

How clunky? Here's an example.. Here's the code snippet in Halogen that determines real processor utilization for a given LPAR. Doing so requires these sort of gymnastics be done mathematically:

## You have 6 measurements by this point in the code.
## Each one is anywhere from 0 to a number in the gazillions.
## lastCC = Capped CPU cycle count recorded in the last sample.
## lastUC = Uncapped CPU cycle count recorded in the last sample.
## lastEC = Entitled CPU cycle count recorded in the last sample.
## CC = Capped CPU cycles as of now.
## UC = Uncapped CPU cycles as of now.
## EC = Entitled CPU cycles as of now.

if ($EC-$lastEC>0) ## Div by zero check
{
    $delta=((($CC-$lastCC) + ($UC-$lastUC)) / ($EC-$lastEC)) * 100;
}
[download]

To handle the flood of data, we basically dump every line into a MySQL database, both to make querying the data simpler (why have Perl do the work of parsing when you can offload the work to the SQL server?) as well as giving us historical metrics we can look back on to determine growth patterns for planning purposes.

Despite it all, it is nonetheless possible to build a script in Perl intelligent enough to parse through the mountain of data being supplied by lslparutil, within the context of lshwres, and recreate the data you need. I'd imagine that lpar2rrd does this same trick to some extent, but, what lpar2rrd lacks, Halogen makes up for. Once a sane and clear picture of system performance can be obtained, it's possible to do reporting.. And with reporting, alerting.

For example, let's say we know from lshwres that four LPARs Alpha, Beta, Gamma and Delta are on a given pSeries box. By parsing their combined real CPU usage metrics out of lslparutil, we can infer the overall CPU load being placed on the cores by each LPAR. By seeing what load we're placing on the cores, we then have a valuable piece of information we can graph over time to see everything from if performance drag is being caused by CPU pool depletion to whether or not we need to buy new hardware to handle future demand. Same goes for alerting. In our particular setup, Halogen alerts us if a given pSeries box has greater than 95% CPU utilization for more than 5 minutes. This gives us a heads-up to when our customers may begin seeing performance degrade, and perhaps offload one or more LPARs to more idle servers to free up resources.

We've also built a front-end to Halogen that allows us to view metrics in terms of groups; all of our VIO servers, for example, are in one view... all of our database servers in another.. all of our app servers in another... So we can keep an eye on multiple systems that have a shared impact.

At some point in the next few months, we're going to explore the possibility of having Halogen automate the process of dynamically moving LPARs around via Partition Mobility to quieter systems in the manner mentioned above -- That if Halogen sees a pSeries box being overburdoned for too long, it will attempt to mitigate the issue by PM'ing the LPAR somewhere else, continually keeping all of our pSeries boxes at roughly equal utilization. Here's how it looks:

http://imgur.com/1rfsEU0

I keep this panel up during work hours, just to keep tabs on what's going on globally. It's nice to be able to have answers on-hand when someone comes by asking if a given server or application seems slow. It also allows us to call BS on vendors who claim our systems aren't keeping up with the demands of their products. Perhaps most importantly, we have eyes where we did not have them before, and can administer all of our systems in a more intelligent fashion.

Cheers,

Bowie J. Poag