Decompose ANSI X12 transmission into individual documents.

use strict;
use warnings;
use Data::Dumper;

my $ediFile = shift;
my ($contents,$delim,$term,$txnCount,@transactions);
{ $/ = undef;
  open my $ifh,'<',$ediFile;
 $contents = <$ifh>;
}
($delim,$term) = $contents =~ m/^ISA(.).{101}(.)/;
$delim = quotemeta($delim);
@transactions = $contents =~ m/(ST$delim.+?SE$delim\d+$delim\d+$term)/
+gs;
($txnCount) = $contents =~ m/${term}GE$delim(\d+)/;
die "Parse error - transaction counts wrong"
  if ($txnCount != scalar @transactions);

foreach my $transaction (@transactions) {
  # put into useful form for processing
  my @segments = split /$term/,$transaction;
  my ($segCount) = $transaction =~ m/${term}SE$delim(\d+)/;
  die "Parse error - segment counts wrong"
    if ($segCount != scalar @segments);
  my ($process_this);
  map { push @$process_this, [split /$delim/,$_] }
    @segments;
  print Dumper(\$process_this);
}
[download]

EDI File:

ISA*00*          *00*          *02*AAAA           *01*123456789      *
+160921*0751*U*00401*0
00099836*0*P*:~GS*FA*AAAA*123456789*20160921*0751*99836*X*004010~ST*99
+7*998360001~AK1*SM*73
11~AK9*A*1*1*1~SE*4*998360001~ST*997*998360002~AK1*SM*7312~AK9*A*1*1*1
+~SE*4*998360002~GE*2*
99836~IEA*1*000099836~
[download]

Output:

$VAR1 = \[
            [
              'ST',
              '997',
              '998360001'
            ],
            [
              'AK1',
              'SM',
              '7311'
            ],
            [
              'AK9',
              'A',
              '1',
              '1',
              '1'
            ],
            [
              'SE',
              '4',
              '998360001'
            ]
          ];
$VAR1 = \[
            [
              'ST',
              '997',
              '998360002'
            ],
            [
              'AK1',
              'SM',
              '7312'
            ],
            [
              'AK9',
              'A',
              '1',
              '1',
              '1'
            ],
            [
              'SE',
              '4',
              '998360002'
            ]
          ];
[download]

Ever wanted to get a range of lines extracted from some file? Easy: load into editor, highlight lines, copy (usually Ctrl<c>), go to target, paste (usually Ctrl<v>).

You want to do that from the command line? With UNIX/Linux you have some options, combining the output of wc -l with head and tail.
You could also combine sed and awk (TIMTOWTDI applies):

sed -e '10,15p;4p;s/.*//' file | awk '!/^$/{print $0}' somefile
[download]

I'm not aware of Windows tools to do this task.
But anyways, this is unwieldy, specially if you want to read piped input into your editor of choice calling an external command.
Perl to the rescue:

#!/usr/bin/perl -n
my $usage;
BEGIN {
    $usage = "usage: $0 linespec file\n"
           . "linespec example: 2,5,32-42,4\n"
           . "this extracts lines 2,4,5 and 32 to 42 from file\n";
    $spec=shift;
    die $usage unless $spec;
    @l=split/,/,$spec;
    for(@l){
        ($s,$e)=split/-/;
        $e||=$s;
        $_=[$s,$e];
    }
}
CHECK {
    unless(@ARGV) {
        push @ARGV, <DATA>;
        chomp @ARGV;
    }
    die $usage unless @ARGV;
    $file = $ARGV[0];
}
# === loop ====
for $l(@l){
    print if $.>=$l->[0] and $.<=$l->[1]
}
# === end ===
#
END {
    if ($file) {
        open $fh,'<', $0;
        @lines = <$fh>;
        close $fh;
        open $fh,'>',$0;
        for(@lines){
            print $fh $_;
            last if /^__DATA__$/;
        }
        print $fh $file,"\n";
    }
}
__DATA__
[download]

Above script, concisely named l (or e.g. lines if that one-letter identifier is already taken) and stored somewhere in any of your private $PATH locations, allows you to e.g. in vi

: r ! l 11-13,42,125-234 somefile
[download]

and have the specified lines from somefile read into your current buffer after the line of your cursor.
To do the same with emacs, ask LanX, he knows the proper Ctrl-Shift-Meta-Alt-X encantations to do so.
This code is self-modifying: it places the filename it is invoked upon after the __DATA__ token, so if you want to include more lines of the same file, it suffices to say

: r ! l 1234-1500
[download]

For that reason this piece of cr.. code is strictly personal and not suitable to be installed system-wide.

We use an application at $work that uses XML internally for everything. The applications that feed it often wrap the files into a single line, which is a nuisance. vi won't display them, and grep will return the entire file on any match. I've created the code below, based almost entirely on sample code from others, to extract some key information from files.

The first interation (everything below except line 13) worked great until I encountered the namespace prefixes. It didn't take long to find out the solution, but I did not see it implemented in actual code. I guess everybody else thought it was obvious! The Namespaces => 1 in the constructor tells the parser to pull the namespace prefixes from the tag names (they are stored elsewhere), and for my simple example, that's all I need.

Program notes: %interesting is the list of tags the parser will store as it parses the file. The values are stored in the hash %message with the tag as key. In my end handler, I choose a subset of tags based on the document type to display.

#!/home/edi/perl/perl

use strict;
use warnings;
use XML::Parser;

my $parser = new XML::Parser( Handlers => {
        Start   => \&hdl_start,
        End     => \&hdl_end,
        Char    => \&hdl_char,
        Default => \&hdl_def,
        },
        Namespaces => 1);

my (%message,$element);
my %interesting = map { $_, 1 } 
   qw/shipmentStatus responseToLoadTender customerIdentifier proNum lo
+adTenderId eventType eventDate eventTime city seqnum customerId segme
+ntId action date/;
my $file = shift;
$message{file} = $file;
$parser->parsefile($file);
#print "Placeholder\n";

sub hdl_start {
  my ($p,$elt,%attr) = @_;
  $element = $elt;
}

sub hdl_end {
  my ($p, $elt) = @_;
  return unless $interesting{$elt};
  if ($elt eq 'shipmentStatus') {
    if ($message{eventType} !~ m/X6/ ) {
     printf "%-20s: %s\n", $_, $message{$_} 
       for qw/file proNum loadTenderId city seqnum eventType eventDate
+ eventTime/;
     print "\n";
    }
  }
  if ($elt eq 'responseToLoadTender') {
   printf "%-20s: %s\n", $_, $message{$_} 
     for qw/file segmentId loadTenderId action date/;
   print "\n";
  }
}

sub hdl_char { 
  my ($p, $str)  = @_;
  return unless $interesting{$element};
  $message{$element} .= $str;
}
 
sub hdl_def {}
[download]

What

Why

How

Status

Code for generator

Code for Excel conversion

Searched the fine web and didn't find a quick answer to how to redirect an http request to https in Mojolicious. I wanted to insure that logins were always secure. Finally cobbled together a solution and thought I should share and maybe get some improvements.

1. Run 2 webservers: one to handle http and the other to handle https, which for me is two incantations of hypnotoad
2. Add a route in your http App

   $r->get('/login')->to('MyApp#https_redirect');
   [download]

3. Add a sub to the http Controller

   sub https_redirect {
       my $self = shift;
   
       my $secure = $self->req->url->to_abs->scheme('https')->port(443);
       $self->redirect_to($secure);
   }
   [download]

4. Profit!

All the sub does is redirect the request to the new protocol at the same url. I've seen a method in the docs to a is_secure method which could be useful somewhere. Also, I tried using $r->any('/login'), but it doesn't work for me and I'm moving on.

Yes, I probably could've gotten a better answer inside 2 minutes on IRC (people are so very helpful), but it never occurs to me until afterwards.

Well, I've finally released RPi::WiringPi. This uses the WiringPi::API wrapper that wraps the C-based wiringPi Raspberry Pi hacking software.

Anyway, I thought I'd throw something together that's kind of silly to play around with it. A couple of points: a) I know this isn't the proper way to web-scrape, it's just an example ;) b) forgive the global variables. The interrupt code in wiringPi library does not allow you to pass in any parameters, so until I submit a possible patch, globals are all I have. This was not meant to be prod code :D

The following code, infinitely looping every 60 seconds, scrapes my number of posts and XP from PerlMonks (in a *very* crude way), collects up the current time, then prints the data out onto an LCD display attached to my Pi:

p: 1293    18:15
x: 10361
[download]

Number of posts and then the time on the top line, XP on the bottom.

We introduce a button connected to a pin, when pressed, triggers an interrupt, and the interrupt handler rewrites the bottom line with the amount of XP remaining until my next PM level, instead of current XP (changes from x: 10361 to r: 1638. Every button press flips this back and forth.

Pics: before button press, and after button press.

use warnings;
use strict;

use LWP::Simple;
use RPi::WiringPi;
use RPi::WiringPi::Constant qw(:all);

# catch a sigint. This allows us to
# safely exit the while() loop and perform
# emergency LCD/pin cleanup. The main class
# catches die()

my $continue = 1;
$SIG{INT} = sub { $continue = 0; };

# initialize a Raspberry Pi object using the 
# BCM GPIO pin numbering scheme

my $pi = RPi::WiringPi->new(setup => 'gpio');

# prepare and initialize the LCD

my $lcd = $pi->lcd;

# the following list of args looks daunting, but
# it's very straightforward, and the docs are
# pretty clear

my %args = (
    cols => 16,
    rows => 2,
    bits => 4,
    rs => 21,
    strb => 16,
    d0 => 12,
    d1 => 25, 
    d2 => 24, 
    d3 => 23,
    d4 => 0,
    d5 => 0, 
    d6 => 0, 
    d7 => 0,
);

$lcd->init(%args);

# set up a pin with a button, and set an
# interrupt handler to do something when
# the button is pressed

my $button_pin = $pi->pin(26);

# we're going to interrupt when the pin
# goes LOW (off), so we'll pull it HIGH
# with the built-in pull up resistor.

# only when the button is pressed, will the
# pin briefly go LOW, and this triggers
# an interrupt

$button_pin->pull(PUD_UP);

# the second arg to interrupt_set() is the
# name of the perl sub I've defined below
# that I want handling the interrupt

$button_pin->interrupt_set(
    EDGE_FALLING, 
    'button_press'
);

my $button_presses = 0;
my ($posts, $xp, $next);

while ($continue){
    my (
        $sec,$min,$hour,$mday,$mon,
        $year,$wday,$yday,$isdst
    ) = localtime();
    $min = "0$min" if length $min == 1;

    # get my post and xp count from PM
    
    ($posts, $xp) = perlmonks();

    # manually get xp needed for next level

    $next = 12000 - $xp;

    # set the LCD cursor to top row, first
    # column, and print my num of PM posts

    $lcd->position(0, 0);
    $lcd->print("p: $posts"); 
   
    # sub for bottom line, because the
    # code needs to be called also in our
    # interrupt handler. What's printed depends
    # on the cumulative number of button presses

    display_xp();

    # on top row of the LCD at column 12,
    # we print the time

    $lcd->position(11, 0);
    $lcd->print("$hour:$min");

    print "$hour:$min posts: $posts, " .
          "xp: $xp, next lvl: $next\n";

    # rinse, repeat every minute

    sleep 60;
}

# wipe the LCD clean

$lcd->clear;

# reset pins to default state

$pi->cleanup;

sub button_press {
    # this is the interrupt handler

    print "button pressed\n";
    $button_presses++;
    display_xp();
}
sub display_xp {
    # this is the manager for the bottom LCD
    # row. It'll update things even when the
    # main program is sleeping in the while()
    # loop

    # print XP for 0 and even number of button
    # presses, and print XP remaining to next level
    # on odd number of presses

    $lcd->position(0, 1);
    if ($button_presses % 2){
        $lcd->print("r: $next");
    }
    else {
        $lcd->print("x: $xp");
    }
}
sub perlmonks {
    my $url = "http://perlmonks.org/?node_id=789891";
    my $page = get $url;
    my @content = split /\n/, $page;

    my ($xp, $posts);
    my $i = 0;

    for (@content){
        if (/Experience:/){
            my $line = $i;
            $line += 2;
            $xp = $1 if $content[$line] =~ /(\d+)/;
        }
        if (/Writeups:/){
            my $line = $i;
            $line += 2;
            $posts = $1 if $content[$line] =~ />(\d+)/;
        }
        $i++;
    }
    return ($posts, $xp);
}
[download]

Here's the code without all of the comments....

I was going to hold off on announcing my new WiringPi::API distribution until my larger project that depends on it is done, but since it's CPAN day, well...

The module wraps the majority of documented and undocumented functions in wiringPi.

You can import the C functions directly keeping their original names as is:

    use WiringPi::API qw(:wiringPi);
[download]

    use WiringPi::API qw(:perl);
[download]

    use WiringPi::API;
    my $wpi = WiringPi::API->new;
[download]

Here's but a few of the features:

• get Pi board revision
• do conversions for the three pin numbering schemes (wiringPi, BCM and physical)
• change pin modes and state
• enable/disable internal pin pull-up/down resistors
• utilize Pulse Width Modulation (PWM) on a per-pin basis
• set/unset pin interrupts for EDGE_FALLING, EDGE_RISING and EDGE_BOTH events. These interrupts are run in separate C threads, and call back to a user defined Perl sub as the handler
• initialize, manipulate and write data to external LCD screens (useful for sensor data, warnings etc)

My larger project, RPi::WiringPi, which is currently in feature-freeze to give me time to finish unit tests and documentation, will take that much further, and make it much easier to do things. It should hit v1.00 (stable) within the next week. At that time, I'll make another announcement... I do have an initial basic howto written so far that covers some of the basics. Note that this distribution may not be stable until v1.00 is released.

This was also posted here.

Greetings,
During my internship I had to set up a network probe. They basically gave me root on a server with three network interfaces and 0 budget.
I set up the following solution:

1. Ntopng did the monitoring
2. Elasticsearch retained ntopng logs for easy retrieval and analysis (one month were retained given the number of flows)
3. Kibana was used for visualisation

From mjd's post A simple but difficult arithmetic puzzle, I present my solution.

I ran this script and piped to output through egrep '17$' which gave me the answer (well, the four different arrangements of the answer that are mathematically equivalent). I won't reveal the solution to the puzzle, but suffice to say it's one of those solutions where you go, "Oh, right", but it's difficult enough that unlikely you'd come up with it quickly.

Thanks mjd!

I found several chunks of code on the internet which were supposed to convert a 0-based column number in Excel to a letter, but I could get none of them to work with a value above 25. So here's the code I got working, for everyone's use. Enjoy.

######################################################################
# 7/25/2016
# In: Column index, 0-n.
# Out: Letter(s) representing column in Excel. 0=A, 1=B, 25=Z, 26=AA..
+.
# 
# Inspired by http://stackoverflow.com/questions/3302857/algorithm-to-
+get-the-excel-like-column-name-of-a-number
# 7/25/2016 WORKS!
sub excelpos2ltr
{my($oldcol)=@_; # Col starts at 0='A'
my($procname,$numeric,$ltr,$num2,$outs);

$procname="excelpos2ltr";

# Alt method 4.
$numeric = $oldcol % 26;
$ltr = chr(65 + $numeric);
#$num2 = intval($oldcol / 26); # old line
$num2 = int($oldcol / 26);
if ($num2 > 0)
    {
    $outs=excelpos2ltr($num2 - 1) . $ltr;
    }
else
    {
    $outs=$ltr;
    }
return $outs;
}
[download]

If you found any problems please put the code fix as a comment below.

I don't know if this is something that is common knowledge or not, but I figured this out once, and at the time I was overly pleased with myself. Now, wallowing in my hubris from this past epiphany (it felt like one for me anyway), I thought I'd share. I do realize there are simpler ways to read such files via various CPAN modules, but I still consider the code I write to be pretty amateurish (I'm actually an Electronics Engineer), so I'm still proud I figured this out at all.

As far as I can tell, Text Tab Delimited type files saved out of Excel will have quotes added around individual tab delimited fields that have certain characters inside those fields, presumably so Excel can better handle them itself. My "trick" is essentially exploiting this to efficiently resolve lines that are read in from such files and split on tabs when the fields themselves can have tabs and/or newlines inside of them.

while (my $line = <$TD_fh>)
{
    chomp($line);
    my @data = split /\t/, $line;
    
    # This block of code strips tabs and newlines from inside individu
+al tab delimited data fields.
    # Each individual tab or newline is replaced with a single space c
+haracter.
    my $last_index = $#data;
    for (my $field_index=0; $field_index<$last_index; $field_index++)
    {
        if (($data[$field_index] =~ tr/"//) % 2 == 1)
        {
            my $new_string = "$data[$field_index] $data[$field_index+1
+]";
            splice @data, $field_index, 2, $new_string;
            $line = join "\t", @data;
            $last_index--;
            $field_index--;
        }
    }
    if (($data[$last_index] =~ tr/"//) % 2 == 1)
    {
        $line .= " " . <$TD_fh>;
        redo;
    }
    
    # Make use of the resolved line and/or data however you please her
+e.
}
[download]

So essentially it just comes down to always checking each field for an even number of quotes, and if that isn't found, some action needs to be taken (as far as I can tell, Excel "escapes" quotes themselves by adding another quote beside it). For all but the last field, the code assumes an extra tab was in there and consolidates the next field with the current one being looked at. For the last field, the code assumes an extra newline was in there and consolidates the next line with the current one being looked at. It's not glamorous or overly complex, but that's actually why I was proud of it. Relative to the other things I tried, it's extremely efficient as well.

I did ultimately write this code in to a subroutine that returned the resolved split on tabs array for a line, but the biggest change to the code there is just replacing the "redo" line with a recursive call to the subroutine assigned to its local "@data" array.

# This subroutine accepts a filehandle and a line read from that fileh
+andle as arguments given in that order, it is meant for "Text (Tab de
+limited)" type files.
# It strips tabs and newlines from inside individual tab delimited dat
+a fields.
# It will modify the line that was passed to it (as if passed by refer
+ence) to resolve it, and return an array of the completely resolved l
+ine split on tabs.
sub resolve_tab_delimited_file_line
{
    my $fh = $_[0];
    chomp($_[1]); # $_[1] being the read line passed in to this subrou
+tine that is to be modified if necessary (as if passed by reference)
    my @data = split /\t/, $_[1];
    
    my $last_index = $#data;
    for (my $field_index=0; $field_index<$last_index; $field_index++)
    {
        if (($data[$field_index] =~ tr/"//) % 2 == 1)
        {
            splice @data, $field_index, 2, "$data[$field_index] $data[
+$field_index+1]";
            $_[1] = join "\t", @data;
            $last_index--;
            $field_index--;
        }
    }
    if (($data[$last_index] =~ tr/"//) % 2 == 1)
    {
        $_[1] .= " " . <$fh>;
        @data = &resolve_tab_delimited_file_line;
    }
    
    return @data;
}
[download]

Any thoughts from the monastery? Just curious if the monks think this is cool, stupid, obvious, irrelevant, or anything else? Or for that matter good or bad? Or can anyone point out any glaring oversight in the code where it isn't dealing with something that would make it choke and die a miserable death if encountered? That last one would make most of my office mates happy. I'm one of only two Perl Advocates swimming in a sea of Python Zealots, a group of which I recently read is sometimes referred to as a "smug". *snicker*

I needed a quick Gray code (specifically, a binary reflected Gray code), so I whipped this up. The one CPAN module which seems to implement Gray code, Math-PlanePath is wayy too heavy for my needs.

# returns a list of vectors of numbers in (0,1)
sub gray2;
sub gray2
{
    my($i) = @_;
    $i <= 1 and return([0],[1]);
    my @a = gray2($i-1);
    ( ( map { [ 0, @$_ ] } @a ), map { [ 1, @$_ ] } reverse @a )
}

my @a = gray2(3);
print "@$_\n" for @a;
[download]

use SDL2::Raw;

my $tile = SDL_CreateTexture($renderer, RGBA8888,
                        STREAMING, 320, 200);
[download]

my $data = 0; ### pixelbuffer is empty

sub render {

SDL_UpdateTexture($tile, NULL, $data, 320*32); ### update 32 bits of 3
+20 pixels
}
[download]

use NativeCall;
use SDL2::Raw;
use nqp;
my int ($w, $h) = 800, 600;
my SDL_Window $window;
my SDL_Renderer $renderer;
my int $particlenum = 1000;
constant $sdl-lib = 'SDL2';
sub SDL_RenderDrawPoints( SDL_Renderer $, CArray[int32] $points, int32
+ $count ) returns int32 is native($sdl-lib) {*}
SDL_Init(VIDEO);
$window = SDL_CreateWindow(
"Particle System!",
SDL_WINDOWPOS_CENTERED_MASK, SDL_WINDOWPOS_CENTERED_MASK,
$w, $h,
SHOWN
);
$renderer = SDL_CreateRenderer( $window, -1, ACCELERATED );
SDL_ClearError();
my SDL_RendererInfo $renderer_info .= new;
SDL_GetRendererInfo($renderer, $renderer_info);
say $renderer_info;
say %PIXELFORMAT.pairs.grep({ $_.value == any($renderer_info.texf1, $r
+enderer_info.texf2, $renderer_info.texf3) });
my num @positions = 0e0 xx ($particlenum * 2);
my num @velocities = 0e0 xx ($particlenum * 2);
my num @lifetimes = 0e0 xx $particlenum;
my CArray[int32] $points .= new;
my int $numpoints;
sub update (num \df) {
my int $xidx = 0;
my int $yidx = 1;
my int $pointidx = 0;
loop (my int $idx = 0; $idx < $particlenum; $idx = $idx + 1) {
my int $willdraw = 0;
if (@lifetimes[$idx] <= 0e0) {
if (rand < df) {
@lifetimes[$idx] = rand * 10e0;
@positions[$xidx] = ($w / 20e0).Num;
@positions[$yidx] = (3 * $h / 50).Num;
@velocities[$xidx] = (rand - 0.5e0) * 10;
@velocities[$yidx] = (rand - 2e0) * 10;
$willdraw = 1;
}
} else {
if @positions[$yidx] > $h / 10 && @velocities[$yidx] > 0 {
@velocities[$yidx] = @velocities[$yidx] * -0.6e0;
}
@velocities[$yidx] = @velocities[$yidx] + 9.81e0 * df;
@positions[$xidx] = @positions[$xidx] + @velocities[$xidx] * df;
@positions[$yidx] = @positions[$yidx] + @velocities[$yidx] * df;
@lifetimes[$idx] = @lifetimes[$idx] - df;
$willdraw = 1;
}
if ($willdraw) {
$points[$pointidx++] = (@positions[$xidx] * 10).floor;
$points[$pointidx++] = (@positions[$yidx] * 10).floor;
}
$xidx = $xidx + 2;
$yidx = $xidx + 1;
}
$numpoints = ($pointidx - 1) div 2;
}
sub render {
SDL_SetRenderDrawColor($renderer, 0x0, 0x0, 0x0, 0xff);
SDL_RenderClear($renderer);
SDL_SetRenderDrawColor($renderer, 0xff, 0xff, 0xff, 0x7f);
SDL_RenderDrawPoints($renderer, $points, $numpoints);
SDL_RenderPresent($renderer);
}
my $event = SDL_Event.new;
my @times;
my num $df = 0.0001e0;
main: loop {
my $start = nqp::time_n();
while SDL_PollEvent($event) {
my $casted_event = SDL_CastEvent($event);
given $casted_event {
when *.type == QUIT {
last main;
}
}
}
update($df);
render();
@times.push: nqp::time_n() - $start;
$df = nqp::time_n() - $start;
}
@times .= sort;
my @timings = (@times[* div 50], @times[* div 4], @times[* div 2], @ti
+mes[* * 3 div 4], @times[* - * div 100]);
say "frames per second:";
say (1 X/ @timings).fmt("%3.4f");
say "timings:";
say ( @timings).fmt("%3.4f");
say "";
'raw_timings.txt'.IO.spurt((1 X/ @times).join("\n"));
[download]