Beefy Boxes and Bandwidth Generously Provided by pair Networks
Don't ask to ask, just ask
 
PerlMonks  

Cool Uses for Perl

( #1044=superdoc: print w/replies, xml ) Need Help??

This section is the place to post your general code offerings -- everything from one-liners to full-blown frameworks and apps.

CUFP's
Perl 2FA Secret Store
No replies — Read more | Post response
by rdfield
on Apr 16, 2017 at 13:28
    Everywhere I looked there seemed to only be an "app" for storing 2FA "Google Authenticator" secrets, here is short script that stores an encrypted file with the entered password.

    2fa.pl:

    #!/usr/bin/perl use strict; use warnings; use Authen::OATH; use Convert::Base32; use File::Slurp; use Data::Serializer; =pod perl 2fa.pl password nickname [secret] prints out the current and next 6 digit "Google Authenticator" token the secret is from the first line of the .google_authenticator file (o +r the "Secret" from online 2FA codes) ./2fa.pl mylocalpassword myremoteacct@server WRFPU2CIXFIGYYYC stores the secret (WRFPU2CIXFIGYYYC) with the nickname myremoteacct@se +rver ./2fa.pl mylocalpassword myremoteacct@server prints 826651 377440 which is the current 6 digit code (826651) and the next one (377440), +just in case :-) Note: the save file (2fa.txt) is encrypted using your password A good tutorial for adding 2FA to your SSH connections: https://www.digitalocean.com/community/tutorials/how-to-set-up-multi-f +actor-authentication-for-ssh-on-ubuntu-14-04 Adding 2FA to Perl scripts: https://blog.darkpan.com/article/6/Perl-and-Google-Authenticator.html parameters: password - the password for the save file, which contains the map betw +een nicknames and secrets nickname - if the third parameter, secret, is not supplied then this d +isplays the 6 digit code secret - if supplied, then this secret is stored in the save file (./2 +fa.txt) for nickname =cut my $passwd = shift @ARGV; my $nickname = shift @ARGV; my $secret_base32 = shift @ARGV; my $filename = "2fa.txt"; my $ser = Data::Serializer->new( serializer => 'Storable', digester => 'MD5', cipher => 'DES', secret => $passwd, compress => 1 ); my $data; if (-e $filename) { eval { $data = $ser->deserialize("" . read_file($filename))}; if ($@) { die "error reading $filename: $@\n"; } } if (defined($secret_base32)) { $data->{$nickname} = $secret_base32; # no check on format of $secret_base32, if you can't get that right + it ain't my problem open FA2, ">", $filename or die "Can't open $filename for writing $ +@\n"; print FA2 $ser->serialize($data); close FA2; die "$nickname saved\n"; } die "$nickname not found\n" unless defined($data->{$nickname}); $secret_base32 = $data->{$nickname}; my $correct_token = sprintf("%06s", Authen::OATH->new->totp( decode_base32( $secret_base32 ) ) ); # the current token $correct_token .= " " . sprintf("%06s", Authen::OATH->new->totp( decode_base32( $secret_base32), time() + 30 ) ); # the next token die "$correct_token\n";

    rdfield

Happy unbirthday redux! and other birthday stuff
1 direct reply — Read more / Contribute
by Lady_Aleena
on Apr 15, 2017 at 01:34

    Hello everyone! About five and a half years ago, I posted Happy unbirthday!. When I saw my fifteenth PerlMonks anniversary, I decided to write something new. However, I began to notice the new code I was writing had similar aspects to the old code I wrote for Unbirthdays, specifically the date verification subroutines I was was writing. So, I opened up Unbirthdays and took a second look. So here is the updated Unbirthdays and the new Birthday scripts.

    Date::Verify

    Date::Verify verifies in input and returns the appropriate value.

    • four_digit_year verifies the user input a four digit year. Usage: four_digit_year($year)
    • month_name verifies the mount input is correct (such as inputting 13 as a month or the too short Ju). It returns a fully spelled out month name. Usage: month_name($month)
    • month_number verifies the same as month_name, but it returns a month number instead. Usage: month_number($month)
    • day_number verifies the day is a number and that the day exists within the month of the year. It returns the day number. Usage: day_number($year, $month, $day)

    I am thinking on localizing this to the various countries available on Date::Calc.

    unbirthdays.pl

    I have made several changes to unbirthdays.

    • First, I got rid of the Q&A. That became annoying to me while testing the changes I made to the script. To that end, I moved the input to the command line as @ARGV.
    • Second, the Q&A was written to recurse until the input was in the correct form, however, the script now dies if the input is not in the correct form.
    • Third, I fixed several things from the former unbirthdays thread.

    Usage is: unbirthdays.pl name month day year. However, if unbirthdays.pl help is used, a helpful message appears.

    birthday.pl

    I was writing birthday.pl when I realized I was writing similar code as was in unbirthdays.pl. This script will tell the user their tropical zodiace sign, their birth stone and flowers (flowers for the US and UK are listed), and birth day stone (based on day of the week the user was born).

    This is a silly little script, but it helped me fix the previous one.

    Usage is: birthday.pl name month day year. However, if birthday.pl help is used, a helpful message appears.

    In closing

    I know these scripts probably still need work. I just hope you find them fun, or at least interesting.

    No matter how hysterical I get, my problems are not time sensitive. So, relax, have a cookie, and a very nice day!
    Lady Aleena
RFC: Adding variable name to warning "Use of uninitialized value ??? in ..."
2 direct replies — Read more / Contribute
by LanX
on Apr 14, 2017 at 21:17
    Just a hack as prove of concept for Re^4: determine the variable causing the error: Use of uninitialized value

    Can be improved in different ways ...

    Due to limitations of B::Deparse it's only working if warning happens within a subroutine.

    use strict; use warnings; use Data::Dump qw/pp dd/; use B::Deparse qw/coderef2text/; use PadWalker qw/peek_my/; my %warncache; my $result; BEGIN { $SIG{__WARN__} = sub { my ($err)=@_; # ignore other warnings unless ($err =~ m/^(Use of uninitialized value) (in (\w+) .* +)$/) { warn "$err"; return; } # ignore other undef vars return if $warncache{$err}++; my ($msg_start, $msg_end, $msg_type) =($1,$2,$3); #warn "* OrigWarn:\t $err"; my ($file,$line) = (caller(0))[1,2]; my $subname = (caller(1))[3]; my ($subref,$subline) = get_subline($subname,$file,$line,$er +r); #warn "LINE:<$subline>"; my $peek_sub = PadWalker::peek_sub ($subref); my $sep = { concatenation => '\\.', printf => ',', sprintf => ',', }->{$msg_type}; my $chomp = { sprintf => '\)', }->{$msg_type}; $subline =~ s/$chomp$// if $chomp; my @split = split /\s*$sep\s*/, $subline; #dd [$subline, @split, $peek_sub]; my @undefined; for my $snippet ( @split) { while ( my ($var,$ref) = each %$peek_sub){ $var =~ s/^\%/\$/; $var =~ s/^\@/\$/; my $match="\\$var"; if ( $snippet =~ /^(.*?)($match)(.*)$/ ) { my $new="$1\$ref$3"; #warn "match VAR <$match> in $snippet as $new"; next if defined eval($new); #warn "UNDEF $snippet"; push @undefined, $snippet; } } } #dd \@undefined; # build new warning my $plural = @undefined > 1 ? "s" :""; my $new_err = "${msg_start}$plural @undefined $msg_end"; warn # ". NewWarn:\t". "$new_err\n"; $result = { oldmsg => $err, newmsg => $new_err, vars => [@undefined], line => $subline, split => [@split], peek => $peek_sub, }; }; } sub get_subline { my ($name,$file,$line,$err) =@_; #dd \@_; my $subref = \&{$name}; my $subbody = B::Deparse->new('-q','-l','-x0')->coderef2text($subr +ef); my $start = "#line \Q$line\E \"\Q$file\E\"\n"; my $end = "\n(#line|})"; #warn $subbody; #dd "match:", $subbody =~ m/($start)/; my ($subline) = $subbody =~ m/$start\s+(.*?);$end/s; return ($subref, $subline); } #warn "Version $]"; my %hash=(a=>undef,b=>[]); my $h=\%hash; my @array=({a=>undef}); my $a=\@array; while (my $case = <DATA>) { chomp $case; next unless $case; next if $case =~ /^#/; my ($name,$var) = split /\s*:\s*/,$case; warn "*** TESTING".pp [$name,$var]; no warnings 'redefine'; my $out =""; open OUT,">",\$out; my @lines = ( # one undef var qq# print OUT "$name: $var"; #, qq# printf OUT '$name %s',$var; #, qq# print OUT sprintf '$name %s',$var; #, # multiple undef vars qq# print OUT "$name: $var $var" #, qq# printf OUT '$name %s %s',$var,$var; #, qq# print OUT sprintf '$name %s %s',$var,$var; #, ); for my $line (@lines) { my $code = <<"__CODE__"; sub tst { $line }; __CODE__ eval $code; if ($@) { warn "SKIPPING TEST $@ in \n<<<$code>>>"; next; } undef $result; tst(); die "$case", pp $result if $result and not @{$result->{vars}}; #warn pp $code,$result; } #last; } exit; __DATA__ hash_ref: $h->{a} hoa_ref: $h->{b}[0] hash: $hash{a} hoa: $hash{b}[0] array: $array[1] aoh: $array[0]{a} array_ref:$a->[1] aoh_ref: $a->[0]{a} #aoh_ref: $a->[$b]{'a b'}

    Output:

    Cheers Rolf
    (addicted to the Perl Programming Language and ☆☆☆☆ :)
    Je suis Charlie!

IO::Socket::SSL GTk2 server and multiple clients
2 direct replies — Read more / Contribute
by zentara
on Apr 12, 2017 at 14:35
    Updated April 16,2017

    Hi, I addressed the problem in my first server script which noxxi pointed out, which was my server would hang if a non-ssl client tried to connect, leaving the server hung in a ssl handshake which it couldn't complete. I thought the solution would be rather involved with non-blocking sockets and a complicated select() setup. Fortunately, I found a simple solution, thanks to the article at socket timeouts made easy . I used a combination of IO:Socket::Timeout and a simple test of the SSL handshake, to weed out any non-ssl connection attempts.

    That only leaves the problem of how to use a certificate in the client, so I can use a real verify_mode.

    So here is the improved Server. The client has not changed, and it is in the original post below.

    #!/usr/bin/perl use warnings; use strict; use Glib qw(TRUE FALSE); use Gtk2 -init; use IO::Socket::SSL; $IO::Socket::SSL::DEBUG = 3; use IO::Socket::Timeout; # gtk2ssl-server, start server, then connect with gtk2ssl-client(s) $|++; my @clients; #used for server messaging to clients my $address = 'localhost:7070'; my $server = IO::Socket::SSL->can_ipv6 ->new( Listen => 5, LocalAddr => $address, Reuse => 1, timeout => .1 ) or die "failed to create SSL server at $address : $!"; print "listening on $address\n"; # Enable read and write timeouts on the socket IO::Socket::Timeout->enable_timeouts_on($server); # Setup the timeouts $server->read_timeout(0.5); $server->write_timeout(0.5); my $ctx = IO::Socket::SSL::SSL_Context->new( SSL_server => 1, SSL_cert_file => './host.crt', SSL_key_file => './host.key', SSL_verify_mode => 0x00, #SSL_VERIFY_PEER | SSL_VERIFY_FAIL_IF_NO +_PEER_CERT ) or die "cannot create context: $SSL_ERROR"; print "\n",$server,' fileno ',fileno($server),"\n"; if( ! defined $server){ print "\nERROR: Can't connect to $address: $!\n" ; exit; } else{ print "\nServer up and running on $address\n" } my $con_watcher = Glib::IO->add_watch ( fileno( $server ), 'in', \&new_connection, $server ); my $stdin_watcher = Glib::IO->add_watch ( fileno( 'STDIN' ), 'in', \&watch_stdin, 'STDIN' ); # make entry widget larger, colored text Gtk2::Rc->parse_string(<<__); style "my_entry" { font_name ="arial 18" text[NORMAL] = "#FF0000" } style "my_text" { font_name ="sans 18" text[NORMAL] = "#FFAA00" base[NORMAL] = "#000000" GtkTextView::cursor-color = "red" } style "my_cursor"{ fg[NORMAL] = "#FF0000" } widget "*Text*" style "my_text" widget "*Entry*" style "my_entry" __ my $window = Gtk2::Window->new; $window->signal_connect( delete_event => sub { $server->close; print "Server shutdown\ +n"; exit } ); $window->set_default_size( 700, 300 ); my $vbox = Gtk2::VBox->new; $window->add($vbox); my $scroller = Gtk2::ScrolledWindow->new; $vbox->add($scroller); my $textview = Gtk2::TextView->new; $textview ->set_editable (0); #read-only text $textview ->can_focus(0); # my $buffer = $textview->get_buffer; $buffer->create_mark( 'end', $buffer->get_end_iter, FALSE ); $buffer->signal_connect( insert_text => sub { $textview->scroll_to_mark( $buffer->get_mark('end'), 0.0, TRUE +, 0, 0.5 ); } ); $scroller->add($textview); my $entry = Gtk2::Entry->new(); $vbox->pack_start( $entry, FALSE, FALSE, 0 ); $vbox->set_focus_child ($entry); # keeps cursor in entry $window->set_focus_child ($entry); # keeps cursor in entry # allows for sending each line with an enter keypress my $send_sig = $entry->signal_connect ('key-press-event' => sub { my ($widget,$event)= @_; if( $event->keyval() == 65293){ # a return key press my $text = $entry->get_text; root_message( $text ); $entry->set_text(''); $entry->set_position(0); } }); #If you store the ID returned by signal_connect, you can temporarily #block your signal handler with # $object->signal_handler_block ($handler_id) # and unblock it again when you're done with ## $object->signal_handler_unblock ($handler_id). # we want to block/unblock the enter keypress depending # on the state of the socket #$entry->signal_handler_block($send_sig); #not connected yet #$entry->set_editable(0); #my $button = Gtk2::Button->new('Connect'); #$button->signal_connect( clicked => \&init_connect ); #$vbox->pack_start( $button, FALSE, FALSE, 0 ); my $bexit = Gtk2::Button->new('Exit'); $bexit->signal_connect( clicked => sub{ print "clients -> @clients\n"; foreach my $cli (@clients){$cli->close;} exit; }); $vbox->pack_start( $bexit, FALSE, FALSE, 0 ); $window->show_all; $buffer->insert( $buffer->get_end_iter, "Server up and running on $add +ress\n" ); Gtk2->main; exit; sub new_connection{ my ( $fd, $condition, $fh ) = @_; print "NEW CONNECTION callback start $fd, $condition, $fh\n"; # this grabs the incoming connections and hands them off to # a client_handler my $client = $server->accept() or warn "Can't accept connection @ +_\n"; $client->autoflush(1); # test for SSL connection, if not close client IO::Socket::SSL->start_SSL($client, SSL_server => 1, SSL_reuse_ct +x => $ctx) or do { warn "ssl handshake failed: $SSL_ERROR\n"; my $peerAddress = $client->peerhost(); my $peerPort = $client->peerport(); warn "bad incoming from $peerAddress $peerPort\n"; $buffer->insert( $buffer->get_end_iter, "client $client ssl handshake failed: $SSL_ERROR from $peerAddress $peerPort; \n" ); $client->close; return 1; # this client is no good, return and keep this callb +ack installed }; # if a good ssl connection if ($client ){ $buffer->insert( $buffer->get_end_iter, "Accepted a client $c +lient\n" ); push @clients, $client; # for root messaging # make a listener for this client my $client_listener = Glib::IO->add_watch ( fileno( $client ), + ['in', 'hup', 'err'], \&handle_connection, $clien +t ); } } sub handle_connection{ my ( $fd, $condition, $client ) = @_; # print "handle connection $fd, $condition, $client\n"; # since 'in','hup', and 'err' are not mutually exclusive, # they can all come in together, so test for hup/err first if ( $condition >= 'hup' or $condition >= 'err' ) { # End Of File, Hang UP, or ERRor. that means # we're finished. $buffer->insert( $buffer->get_end_iter, "Nohup or err received + from $client\n" ); #print "\nhup or err received\n"; #close socket @clients = grep { $_ ne $client } @clients; #remove from conne +cted list $client->close; $client = undef; return 0; #stop this callback } # if the client still exists, get data and return 1 to keep callba +ck alive if ($client) { if ( $condition >= 'in' ){ # data available for reading my $bytes = sysread($client,my $data,16324); if ( defined $data ) { # do something useful with the text. $buffer->insert( $buffer->get_end_iter, "$data\n" ); print $client "$data\n"; #echo back } } # the file handle is still open, so return TRUE to # stay installed and be called again. # print "still connected\n"; # possibly have a "connection alive" indicator #print "still alive\n"; return 1; } else { # we're finished with this job. start another one, # if there are any, and uninstall ourselves. $buffer->insert( $buffer->get_end_iter, "client $client exitin +g\n" ); return 0; #end this callback } } #end of client callback sub root_message { #sent to all clients my $text = $_[0]; # print "$text\n"; $buffer->insert( $buffer->get_end_iter, "ROOT MESSAGE-> $text\ +n" ); foreach my $cli(@clients){ if($cli->connected){ print $cli 'ROOT MESSAGE-> ', "$text\n"; }else{ # remove dead client @clients = grep { $_ ne $cli } @clients; + } } #always return TRUE to continue the callback return 1; } __END__
    ##############################

    Original Post and code

    Hi, this code is based on my previous post Gtk2 server and client GUI's with root messaging. I wanted to make the connection SSL, so this is my effort to convert it to use IO::Socket::SSL. It works for me fine on Linux.

    When I first started searching google for IO::Socket::SSL example code, I could not find any complete set of running server and client. All there was were snippets of code, pointing in the right direction, but no actual code examples. There were plenty of connection examples, which would connect then exit, nothing with persistence. The following code examples are persistent.

    Even the examples given in the IO::Socket::SSL's examples directory were hard to use, the use of GetOpt long obfuscated the script to make it look like mangled javascript. :-)

    I sorted it all out, and here are my findings. They say that IO::Socket::SSL is a drop-in-replacement the IO::Socket::INET but there are alot of things to watch out for.

    First, you need to use an IO::Socket::SSL::SSL_Context object to start_SSL on client sockets as they are accepted.

    Second, you cannot use a READLINE or variant to read and write the sockets. The SSL sockets are sent in frames of 16k (iirc), and newlines are meaningless in encrypted transfers. So use sysread and syswrite.

    Third, using select with the accepted clients can be tricky. Fortunately, Gtk2 handles it's socket callbacks with great detail, and it works. Read the code and see the detail in the Glib::IO->add_watch handlers.

    Fourth, self-generated certificates and keys will work, but with SSL_verify_mode => 0. This makes it susceptible to man in the middle attacks because you have no way to verify the keys. But it is about the only way to get the encryption going without a real Certificate of Authority. I'm just happy enough that nothing is sent in clear text over the network, and there are further protections you can take, like adding a symmetric encryption layer to all text using a mutally agreed upon common key between the server and client. That technique is not shown here, but is left up to you. :-)

    The easiest program I've found for sniffing the ports to watch the encryptions is tcpflow

    So here is the server and client, and hopefully it will stimulate someone or help someone who is looking for working snippets. Any improvements would be welcome, especially in how to verify with self-certified certs. The docs mention something about using key fingerprints, but that eludes me for now.

    Start the server, then start a few clients. Send text back and forth by entering text in the bottom Entry widgets. Play around killing the server or a client and watch the debug output.

    THE SERVER:

    #!/usr/bin/perl use warnings; use strict; use Glib qw(TRUE FALSE); use Gtk2 -init; use IO::Socket::SSL; $IO::Socket::SSL::DEBUG = 3; # gtk2ssl-server, start server, then connect with gtk2ssl-client(s) $|++; my @clients; #used for server messaging to clients my $address = 'localhost:7070'; my $server = IO::Socket::SSL->can_ipv6 ->new( Listen => 5, LocalAddr => $address, Reuse => 1, ) or die "failed to create SSL server at $address : $!"; print "listening on $address\n"; my $ctx = IO::Socket::SSL::SSL_Context->new( SSL_server => 1, SSL_cert_file => './host.crt', SSL_key_file => './host.key', SSL_verify_mode => 0x00, #SSL_VERIFY_PEER | SSL_VERIFY_FAIL_IF_NO +_PEER_CERT ) or die "cannot create context: $SSL_ERROR"; print "\n",$server,' fileno ',fileno($server),"\n"; if( ! defined $server){ print "\nERROR: Can't connect to $address: $!\n" ; exit; } else{ print "\nServer up and running on $address\n" } my $con_watcher = Glib::IO->add_watch ( fileno( $server ), 'in', \&new_connection, $server ); my $stdin_watcher = Glib::IO->add_watch ( fileno( 'STDIN' ), 'in', \&watch_stdin, 'STDIN' ); # make entry widget larger, colored text Gtk2::Rc->parse_string(<<__); style "my_entry" { font_name ="arial 18" text[NORMAL] = "#FF0000" } style "my_text" { font_name ="sans 18" text[NORMAL] = "#FFAA00" base[NORMAL] = "#000000" GtkTextView::cursor-color = "red" } style "my_cursor"{ fg[NORMAL] = "#FF0000" } widget "*Text*" style "my_text" widget "*Entry*" style "my_entry" __ my $window = Gtk2::Window->new; $window->signal_connect( delete_event => sub { $server->close; print "Server shutdown\ +n"; exit } ); $window->set_default_size( 700, 300 ); my $vbox = Gtk2::VBox->new; $window->add($vbox); my $scroller = Gtk2::ScrolledWindow->new; $vbox->add($scroller); my $textview = Gtk2::TextView->new; $textview ->set_editable (0); #read-only text $textview ->can_focus(0); # my $buffer = $textview->get_buffer; $buffer->create_mark( 'end', $buffer->get_end_iter, FALSE ); $buffer->signal_connect( insert_text => sub { $textview->scroll_to_mark( $buffer->get_mark('end'), 0.0, TRUE +, 0, 0.5 ); } ); $scroller->add($textview); my $entry = Gtk2::Entry->new(); $vbox->pack_start( $entry, FALSE, FALSE, 0 ); $vbox->set_focus_child ($entry); # keeps cursor in entry $window->set_focus_child ($entry); # keeps cursor in entry # allows for sending each line with an enter keypress my $send_sig = $entry->signal_connect ('key-press-event' => sub { my ($widget,$event)= @_; if( $event->keyval() == 65293){ # a return key press my $text = $entry->get_text; root_message( $text ); $entry->set_text(''); $entry->set_position(0); } }); #If you store the ID returned by signal_connect, you can temporarily #block your signal handler with # $object->signal_handler_block ($handler_id) # and unblock it again when you're done with ## $object->signal_handler_unblock ($handler_id). # we want to block/unblock the enter keypress depending # on the state of the socket #$entry->signal_handler_block($send_sig); #not connected yet #$entry->set_editable(0); #my $button = Gtk2::Button->new('Connect'); #$button->signal_connect( clicked => \&init_connect ); #$vbox->pack_start( $button, FALSE, FALSE, 0 ); my $bexit = Gtk2::Button->new('Exit'); $bexit->signal_connect( clicked => sub{ foreach my $cli (@clients){ $cli->close; exit; } }); $vbox->pack_start( $bexit, FALSE, FALSE, 0 ); $window->show_all; $buffer->insert( $buffer->get_end_iter, "Server up and running on $add +ress\n" ); Gtk2->main; exit; sub new_connection{ my ( $fd, $condition, $fh ) = @_; print "NEW CONNECTION callback start $fd, $condition, $fh\n"; # this grabs the incoming connections and hands them off to # a client_handler my $client = $server->accept() or warn "Can't accept connection @ +_\n"; $client->autoflush(1); IO::Socket::SSL->start_SSL($client, SSL_server => 1, SSL_reuse_ct +x => $ctx) or do { warn "ssl handshake failed: $SSL_ERROR\n"; next; }; $buffer->insert( $buffer->get_end_iter, "accepted a client $clien +t\n" ); push @clients, $client; # for root messaging # make a listener for this client my $client_listener = Glib::IO->add_watch ( fileno( $client ), ['in', 'hup', 'err'], \&handle_connection, $clien +t ); } sub handle_connection{ my ( $fd, $condition, $client ) = @_; # print "handle connection $fd, $condition, $client\n"; # since 'in','hup', and 'err' are not mutually exclusive, # they can all come in together, so test for hup/err first if ( $condition >= 'hup' or $condition >= 'err' ) { # End Of File, Hang UP, or ERRor. that means # we're finished. $buffer->insert( $buffer->get_end_iter, "Nohup or err received + from $client\n" ); #print "\nhup or err received\n"; #close socket $client->close; $client = undef; return 0; #stop this callback } # if the client still exists, get data and return 1 to keep callba +ck alive if ($client) { if ( $condition >= 'in' ){ # data available for reading my $bytes = sysread($client,my $data,1024); if ( defined $data ) { # do something useful with the text. $buffer->insert( $buffer->get_end_iter, "$data\n" ); print $client "$data\n"; #echo back } } # the file handle is still open, so return TRUE to # stay installed and be called again. # print "still connected\n"; # possibly have a "connection alive" indicator #print "still alive\n"; return 1; } else { # we're finished with this job. start another one, # if there are any, and uninstall ourselves. $buffer->insert( $buffer->get_end_iter, "client $client exitin +g\n" ); return 0; #end this callback } } #end of client callback sub root_message { #sent to all clients my $text = $_[0]; # print "$text\n"; $buffer->insert( $buffer->get_end_iter, "ROOT MESSAGE-> $text\ +n" ); foreach my $cli(@clients){ if($cli->connected){ print $cli 'ROOT MESSAGE-> ', "$text\n"; }else{ # remove dead client @clients = grep { $_ ne $cli } @clients; + } } #always return TRUE to continue the callback return 1; } __END__

    THE CLIENT

    #!/usr/bin/perl use warnings; use strict; use Glib qw(TRUE FALSE); use Gtk2 -init; use IO::Socket::SSL; $IO::Socket::SSL::DEBUG = 3; # gtk2ssl-client my $name = shift || 'anon'.time; my $host = 'localhost'; my $port = 7070; my $socket; # make entry widget larger, colored text Gtk2::Rc->parse_string(<<__); style "my_entry" { font_name ="arial 18" text[NORMAL] = "#FF0000" } style "my_text" { font_name ="sans 18" text[NORMAL] = "#FFAA00" base[NORMAL] = "#000000" GtkTextView::cursor-color = "red" } style "my_cursor"{ fg[NORMAL] = "#FF0000" } widget "*Text*" style "my_text" widget "*Entry*" style "my_entry" __ my $window = Gtk2::Window->new; $window->signal_connect( delete_event => sub { exit } ); $window->set_default_size( 500, 300 ); my $vbox = Gtk2::VBox->new; $window->add($vbox); my $scroller = Gtk2::ScrolledWindow->new; $vbox->add($scroller); my $textview = Gtk2::TextView->new; $textview ->set_editable (0); #read-only text $textview ->can_focus(0); # my $buffer = $textview->get_buffer; $buffer->create_mark( 'end', $buffer->get_end_iter, FALSE ); $buffer->signal_connect( insert_text => sub { $textview->scroll_to_mark( $buffer->get_mark('end'), 0.0, TRUE +, 0, 0.5 ); } ); $scroller->add($textview); my $entry = Gtk2::Entry->new(); $vbox->pack_start( $entry, FALSE, FALSE, 0 ); $vbox->set_focus_child ($entry); # keeps cursor in entry $window->set_focus_child ($entry); # keeps cursor in entry # allows for sending each line with an enter keypress my $send_sig = $entry->signal_connect ('key-press-event' => sub { my ($widget,$event)= @_; if( $event->keyval() == 65293){ # a return key press my $text = $entry->get_text; if(defined $socket){ print $socket $name.'->'. $text;} $entry->set_text(''); $entry->set_position(0); } }); #If you store the ID returned by signal_connect, you can temporarily #block your signal handler with # $object->signal_handler_block ($handler_id) # and unblock it again when you're done with ## $object->signal_handler_unblock ($handler_id). # we want to block/unblock the enter keypress depending # on the state of the socket $entry->signal_handler_block($send_sig); #not connected yet $entry->set_editable(0); my $button = Gtk2::Button->new('Connect'); $button->signal_connect( clicked => \&init_connect ); $vbox->pack_start( $button, FALSE, FALSE, 0 ); my $bexit = Gtk2::Button->new('Exit'); $bexit->signal_connect( clicked => sub{ exit } ); $vbox->pack_start( $bexit, FALSE, FALSE, 0 ); $window->show_all; Gtk2->main; exit; sub init_connect{ $socket = IO::Socket::SSL->new( PeerAddr => $host, PeerPort => $port, Proto => 'tcp', SSL_verify_mode => 0, #will work but less secure ); if( ! defined $socket){ $buffer->insert( $buffer->get_end_iter, "ERROR: Can't connect to port $port on $host: $!\n" ); return; }else{ $buffer->insert( $buffer->get_end_iter, "Connected\n"); } #if we have a socket $button->set_label('Connected'); $button->set_state('insensitive'); # install an io watch for this stream and # return immediately to the main caller, who will return # immediately to the event loop. the callback will be # invoked whenever something interesting happens. Glib::IO->add_watch( fileno $socket, [qw/in hup err/], \&watch +_callback, $socket ); #turn on entry widget $entry->set_editable(1); $entry->grab_focus; $entry->signal_handler_unblock ($send_sig); Gtk2->main_iteration while Gtk2->events_pending; } sub watch_callback { my ( $fd, $condition, $fh ) = @_; print "$fd, $condition, $fh\n"; if ( $condition >= 'in' ) { # there's data available for reading. my $bytes = sysread($fh,my $data,8192); # it seems if the server connection is lost # the condition is still 'in', not nohup or err # so test for zero data length if ( length $data ) { # do something useful with the text. $buffer->insert( $buffer->get_end_iter, "$data" ); } else{ # close socket as there is no data print "server closed\n"; #$socket->close; $socket->close( SSL_no_shutdown => 1, SSL_ctx_free => 1, ) or die "shutdown not ok: $SSL_ERROR"; print "OK: socket shutdown ok ... Closed\n"; $fh->close; $fh = undef; # stop ability to send $entry->set_editable(0); $entry->signal_handler_block ($send_sig); $buffer->insert( $buffer->get_end_iter, "Server connection los +t !!\n" ); #allow for new connection $button->set_label('Connect'); $button->set_sensitive(1); $button->grab_focus; Gtk2->main_iteration while Gtk2->events_pending; } } if ($fh) { # the file handle is still open, so return TRUE to # stay installed and be called again. # print "still connected\n"; # possibly have a "connection alive" indicator return TRUE; } else { # we're finished with this job. start another one, # if there are any, and uninstall ourselves. print "done\n"; return FALSE; } } __END__

    THE CERTIFICATE GENERATOR: create-keys-host

    #!/bin/bash openssl genrsa -out rootCA.key 2048 openssl req -x509 -new -nodes -key rootCA.key -days 365 -out rootCA.cr +t -subj '/C=US/ST=Texas/L=Dallas/CN=localhost' openssl genrsa -out host.key 2048 -subj '/C=US/ST=Georgia/L=Mauk/CN=lo +calhost' openssl req -new -key host.key -out host.csr -subj '/C=US/ST=Georgia/ +L=Mauk/CN=localhost' openssl x509 -req -in host.csr -CA rootCA.crt -CAkey rootCA.key -CAcre +ateserial -out host.crt -days 365
    Have fun!

    I'm not really a human, but I play one on earth. ..... an animated JAPH
Choose your own Adventure - for Perl & Windows
4 direct replies — Read more / Contribute
by FreeBeerReekingMonk
on Apr 10, 2017 at 14:30
    There is more than one way to Choose your own Adventure.

    Abstract: Self contained single thread Perl webbrowserserver with dancer-like URL paths and moustache-like templates ... but only using core modules. It uses jquery and bootstrap Contains a simple way to write text and buttons
    The basic HTML template comes after _END_ which is the end of the perl program. It is read as "<DATA>".

    Step 1. Download and install Perl for Windows.

    Step 2. Copy this file as story.pl to a directory on your harddrive.

    Step 3. You can run the story.pl Perl script by double clicking on it. It will ask for Windows Firewall permissions. Make sure only "Private Networks" is selected and "Public networks" is not. Then press on "Allow access". Oh, and download an image from the web, call it title.jpg and put it in the same directory.

    Step 4. Open a browser (preferably Firefox or Chrome, those do not complain about http://localhost being a security risk)

    Step 5. Point your browser to: http://localhost:1337


    Here is the code, scroll to the bottom for a "save" button

    use strict; use warnings; use IO::Socket; my $DEBUG = 1; print "STARTING($0)\n" if $DEBUG; # first we define our story: our %I; sub get {$I{'GET'}{$_[0]} = $_[1]} my $DEFAULTS = '*'; get $DEFAULTS => { 'title' => "The Foo of the Bar Baz", 'label' => 'story', 'paragraph' => 'story', 'link' => '/', 'content-page' => qq( <div class="clearfix"></div> <div class="row"> <div class="col-md-12 col-sm-12 col-xs-12"> <div class="page"> <div class="title"> <h2>{{title}}</h2> </div> <div class="clearfix"></div> <div id="paragraph"> {{paragraph}} </div> <div class="menupanel"> <br/> <div class="menu"> {{#button}} <a href="{{link}}" class="btn btn-primary" rol +e="button">{{label}}</a> {{/button}} </div> </div> </div> </div> </div> ), # Before and after parsing '(' => sub {my($page,$HAVE,$msg)=@_; return $msg }, ')' => sub {my($page,$HAVE,$msg)=@_; print "msg=$msg\nDmsg=$$msg\n" if $DEBUG; $$msg=~s{<div id="paragraph">([\s\S]*?)</div>}{PUTITBACKLATER} +; $_ = $1; if($_){ s{^\s*(\w)}{<span style="font-size: 150%">&nbsp;&nbsp; $1< +/span>}; s{\b(drunkard)\b}{<span title="Just a silly ol' drunkard"> +<b>$1</b></span>}gi; s{\b(pub)\b}{<span title="a tavern, really"><b>$1</b></spa +n>}gi; s{\b(cave)\b}{<span title="home sweat home... yup, it stin +ks"><b>$1</b></span>}gi; s{\b(dragon)\b}{<span title="The protagonist of this story +"><b>$1</b></span>}gi; s{\n\n}{<br/><br/>}gi; } $$msg =~ s{PUTITBACKLATER}{<div id="paragraph">$_</div>}; }, }; get '/' => { 'title' => 'The story of the Thirsty Dragon', 'paragraph' => "In a little cave, there once lived a dragon. It wa +s a scary dragon. Somewhat temperamental. And around it's abodes, the +re were small piles of skeletons. It was afternoon. And the dragon wa +s thirsty.", '&' => sub { my($page,$HAVE,$msg)=@_; $I{'HAVE'}{'STARTED'}++; $msg; }, 'button' => [ {'label' => 'Go out and drink', 'link' => '/outside'}, {'label' => 'Stay inside', 'link' => '/sleep'}, ], }; get '/sleep' => { 'title' => 'sleepy...', 'paragraph' => "And night fell, and the dragon got sleepy. He roll +ed up and fell asleep. Kind of a boring story, don't you think? How a +bout trying again?", '&' => sub { my($page,$HAVE,$msg)=@_; if($I{'HAVE'}{'STARTED'} > 1){ $I{$HAVE}{$page}->{'button'}[0]->{'label'} = "Not AGAIN! ( +$I{HAVE}{STARTED})"; } $msg; }, 'button' => [ {'label' => 'Try again', 'link' => '/'}, ], }; get '/outside' =>{ 'title' => 'Where to?', 'paragraph' => "Yes, well... I don't mind going to the pub, but I +could also go to the lake.", 'button' => [ {'label' => 'Go to the Pub', 'link' => '/pub'}, {'label' => 'Go to the Lake', 'link' => '/lake'}, ], }; get '/pub' =>{ 'title' => 'Dragons not welcome', 'paragraph' => "I will have to be careful though. Those humans do +not like dragons. And the pub is full of humans. Now, how do I disgui +se myself?", 'button' => [ {'label' => 'Put on a wig and walk like a chicken', 'link' => '/pubfrontchicken'}, {'label' => 'put on a hat and walk on back legs only', 'link' => '/pubfrontlegs'}, ], }; get '/pubfrontlegs' =>{ 'title' => 'A gentleman with a hat', 'paragraph' => "The dragon produces a gentleman's hat and puts it +on his head. he stands on his back legs, and starts walking towards t +he village. On the way, he picks up a stick, which he uses as a cane. + Suddenly he bumps into a drunkard. - Hic... pardon kind sir - And the drunkard walks off, a bottle in + his hand. You are now in a back alley, next to the pub. You can hear + laughter and loud noises. Want to try walking in from the main entra +nce, or use the back door?", 'button' => [ {'label' => 'Make a pompous entrance through the main gate...d +oor...whatever', 'link' => '/grandentrance'}, {'label' => 'sneak in through the side window', 'link' => '/sneak'}, ], }; # http://grammarist.com/spelling/toward-towards/ get '/pubfrontchicken' =>{ 'title' => 'Walk like an Egy^H^H^Hchicken', 'paragraph' => "This wig is too small, it barely covers the top of + the head of the Dragon. But that was all the props he had. He took a + deep breath, flapped his arms and walked towards the village. Near t +he village the dragon also started bobbing his head, like chickens do +. A drunkard gazed with open mouth and dropped his bottle. But nobody + else noticed. You are now in a back alley, next to the pub. You can +hear laughter and loud noises. Want to try walking in from the main e +ntrance, or use the back-door?", 'button' => [ {'label' => 'Make a pompous entrance through the main gate...d +oor...whatever', 'link' => '/grandentrance'}, {'label' => 'sneak in through the side window', 'link' => '/sneak'}, ], }; get '/grandentrance' =>{ 'title' => 'The grand entrance', 'paragraph' => "The dragon takes a deep breath, and walks into the + pub bobbing his head and flapping his arms. The bartender looks up a +nd points to a sign. The sign says 'No chickens allowed'. Patrons are + standing up towards you and shooing you out. Now you are standing in + the back alley. There is this other option: Use the window!", 'button' => [ {'label' => 'sneak in through the side window', 'link' => '/sneak'}, ], }; get '/sneak' =>{ 'title' => 'sneaking in', 'paragraph' => "This window is too small for dragons. You try to t +wist and shove. The window cracks and bends... you are stuck", 'button' => [ {'label' => 'look around', 'link' => '/lookaround'}, ], }; get '/lake' =>{ 'title' => 'Where to?', 'paragraph' => "Ah well... water is refreshing, although a bit bor +ing. The dragon drank, then returned to the cave to sleep", 'button' => [ {'label' => 'Go back to the cave', 'link' => '/sleep'}, ], }; get '/404' => sub { 'Sorry. This page has not been created yet. (press back on your br +owser)' }; # Some basic types we can serve. You can add your own of course. my %TYPES = ( 'PL' => "text/html", 'HTM' => "text/html", 'HTML' => "text/html", 'JS' => "text/javascript", 'CSS' => "text/css", 'ICO' => "image/vnd.microsoft.icon", "GIF" => "image/gif", "JPEG" => "image/jpeg", "JPG" => "image/jpeg", "BMP" => "image/bmp", "PNG" => "image/png", "SVG" => "image/svg+xml", "SVGZ" => "image/svg+xml", 'TXT' => "text/plain", ); my %CFG = ( 'MYPORT' => 1337, 'MAXCONNECT' => 10 ); # read the html template at the end of this file (after __DATA__) in o +ne gulp { local $/; $CFG{'TEMPLATE'} = <DATA>; close DATA; }; my %ESC_LIST = ('&'=>'&amp;', '>'=>'&gt;', '<'=>'&lt;'); # open a listening port on your computer. Note: ports under 1000 requi +re Administrator/superuser rights. my $server = IO::Socket::INET->new( LocalPort => $CFG{'MYPORT'}, Type => SOCK_STREAM, Reuse => 1, Listen => $CFG{'MAXCONNECT'}, Timeout => 2 ) or die "Can not open port $CFG{'MYPORT'}: $!\n"; # Automatically start a webbrowser to http://localhost:$CFG{'MYPORT'} if( ($0 =~/.exe$/i) && ($^O eq 'MSWin32') ){ system("start","http://localhost:$CFG{'MYPORT'}"); } # This is an infinite loop. (press control C on the commandline to sto +p the webserver) while(1){ my ($client,$client_adress,%request,$type); while ( ($client,$client_adress) = $server->accept() ) { my $DATA = ''; my ($client_port, $client_iaddr) = sockaddr_in($client_adress) +; my $client_dot_ip = inet_ntoa($client_iaddr); my $client_name = gethostbyaddr($client_iaddr, AF_INET); print "\nAccepting $client_dot_ip:$client_port [$client_name] +(".(scalar localtime).")\n" if $DEBUG; eval { local $SIG{ALRM} = sub { die 'TIMEOUT'; }; alarm 1; # does not work, default is 5 seconds... hardcode +d somewhere $client->recv($_,2048); alarm 0; }; alarm 0; print "$$ Read ".length($_)." bytes:$_\n" if $DEBUG; # Normally, here we would fork and let the child process (new +process) # do all the work, while the program is free to keep listening + to new connections # As webbrowsers make several connections at once, this is alm +ost a requirement # but makes the program harder to understand. if($_){ m{^\s*(\w+)\s+(.+)\s+HTTP/(\d.\d)}; $request{METHOD} = uc $1; # GET $request{URL} = $2; # / $request{KEEPALIVE} = 1 if m{Keep-Alive}i; $_ = $request{URL}; $_ = '/404' if m/\.\./; # not so waterproof way of not acc +essing any file on disk $_ = '/' if m/^index.html$/i; if(m/\./){ $DATA = slurp('./'.$_) || ''; s/.*\.//; # leave extension only $type = uc($_); # the type of file is the extension na +me }else{ $DATA = jap($request{METHOD},$_); $type = "HTML"; } } my $HEADER = http_header("OK",length($DATA)||0,$TYPES{$type}, +$request{KEEPALIVE}); print "$HEADER\n" if $DEBUG; print $client $HEADER . $DATA; if($request{KEEPALIVE}){ print "KEEPALIVE\n" if $DEBUG; }else{ close($client); print "CONNECTION CLOSED\n" if $DEBUG; } } } # setup an http header string sub http_header { my ($returnvalue, $size, $ctype, $keepalive) = @_; my $HEADER = "HTTP/1.0 " . $returnvalue . Socket::CRLF . ($ctype ? "Content-Type: ". $ctype ."; charset=utf-8". Socke +t::CRLF : '') . (defined($size)? "Content-Length: ". $size . Socket::CRLF : +'') . "Connection: ". ($keepalive?'Keep-Alive':'close') . Socket:: +CRLF . Socket::CRLF; return $HEADER; } sub slurp{ return "" unless -r $_[0]; open(IN,'<:raw',$_[0]) or return ""; # Windows requires binmode local $/; my $X = <IN>; close IN; $X } sub jap{ my($HAVE,$page) = @_; my $msg; $page = '/404' unless $I{$HAVE}{$page}; my $me = $I{$HAVE}{$page}; my $default = $I{$HAVE}{$DEFAULTS}; print "page=$page;me=$me;\n" if $DEBUG; # Run the default before if(ref($default) eq 'HASH'){ &{$_}($page,$HAVE,\$msg) if $_=$default->{'('}; } # First load template, then use sub code if(ref($me) eq 'HASH'){ &{$_}($page,$HAVE,\$msg) if $_=$me->{'('}; if(($_=$me->{_}) && -f $_){ $msg = slurp $_ }elsif($_=$me->{'#'}){ $msg = $_; } if($_=$me->{'&'}){ $msg = &{$_}($page,$HAVE,$msg); } &{$_}($page,$HAVE,\$msg) if $_=$me->{')'}; } # If there is no msg, use the appended template $msg = $CFG{'TEMPLATE'} unless $msg; # use the function as a post processing or independant $msg genera +tor if(ref($_=$me) eq 'CODE'){ $msg = &{$_}($page,$HAVE,$msg); } # Moustache $msg = TinyMoustache($msg, $me, $default); # Run the default after if(ref($default) eq 'HASH'){ &{$_}($page,$HAVE,\$msg) if $_=$default->{')'}; } return $msg; } # $escaped_string = esc("string>with<possible>html") sub esc { $_ = $_[0]; s/([&<>])/$ESC_LIST{$1}/gex; $_ } # template language; a subset of Moustache # Escaped: {{var}} # Non-Escaped: {{{var}}} # Loops: {{#loop}} here add {{{var}}} or {{var}} then {{/loop}} sub TinyMoustache { my($TXT, $ME, $DEFAULTS) = @_; my $i = 1; do{ $TXT =~ s/\{\{([\#\^])\s*([\w\-]+)\s*\}\}([\s\S]*?)\{\{\/\s*\2 +\s*\}\}/loop($1,$2,$3,($ME->{$2}||$DEFAULTS->{$2}||""))/gem; $TXT =~ s/\{\{\{\s*([\w\-]+)\s*\}\}\}/$ME->{$1}||$DEFAULTS->{$ +1}||""/gme; $TXT =~ s/\{\{\s*([\w\-]+)\s*\}\}/esc($ME->{$1}||$DEFAULTS->{$ +1}||"")/gme unless $TXT=~/\{\{#/; }while($TXT=~/\{\{/ && $i--); $TXT; } # handle moustache {{^tag}} or {{#tag}} ... {{/tag}} sub loop { my($n,$a,$b,$t,$r)=@_; print "loop($n,$a,$b,$t,$r)\n" if $DEBUG; return ($t ? '' : $b) if $n eq '^'; $t = &$t($a,$b) if ref($t) eq 'CODE'; if(ref($t) eq 'ARRAY'){ print " loop ARRAY @$t\n" if $DEBUG; $DEBUG && print " >> $_\n" for (@$t); for my $x (@$t){ $r .= TinyMoustache($b,$x); } #$r .= TinyMoustache($b,$_) for @$t; }elsif(ref($t) eq 'SCALAR'){ $r = $t; }elsif(ref($t) eq 'SUB'){ $r = &$t($a,$b,$t); } $r; } __DATA__ <!DOCTYPE html> <html lang="en"> <head> <meta http-equiv="Content-Type" content="text/html; charset=UTF-8" +> <!-- Meta, title, CSS, favicons, etc. --> <meta charset="utf-8"> <meta http-equiv="X-UA-Compatible" content="IE=edge"> <meta name="viewport" content="width=device-width, initial-scale=1 +"> <title>{{title}}</title> <!-- Latest compiled and minified Bootstrap CSS --> <link rel="stylesheet" href="https://maxcdn.bootstrapcdn.com/boots +trap/3.3.7/css/bootstrap.min.css"> <!-- Font Awesome not used --> <!-- Custom Theme Style --> <link href="/css/custom.css" rel="stylesheet"> </head> <body class="nav-md"> <div class="container body"> <div class="main_container"> <!-- page content --> <div class="page-title"> <div class="title_left"> <img src="/title.jpg" height=50/> </div> </div> {{{content-page}}} <!-- footer content --> <footer> <div class="pull-right"> Story by Foo Bar &nbsp;</div> </footer> <!-- /footer content --> <!-- /page content --> </div> </div> <!-- jQuery library --> <script src="https://ajax.googleapis.com/ajax/libs/jquery/3.2.0/jq +uery.min.js"></script> <!-- Latest compiled Bootstrap JavaScript --> <script type="text/javascript" src="https://maxcdn.bootstrapcdn.co +m/bootstrap/3.3.7/js/bootstrap.min.js"></script> <!-- Custom Theme Scripts (does not exist) --> <script src="/js/custom.js"></script> </body> </html>

    Ok, hopefully you made that work. Now, let's compile it to EXE!

    6. Drop to the cmd command shell and go to your directory with story.pl

    7. use pp to compile it: pp -o story.exe story.pl

    8. Unfortunately, the executable requires extra code to run (on other machines that do not have Perl installed), you need the following files:
    * perl524.dll (might have another version number, that is ok)
    * libstdc++-6.dll
    * libwinpthread-1.dll

    To know where these files are located, use the following commandline command: where perl

    you can ship your story.exe program (the story.pl is not required, it's inside the story.exe) with these DLL's

    Have fun perusing and editing!

    edits: incorporated windows check as suggested by afoken.

How to quickly make sense of 1800 log files
1 direct reply — Read more / Contribute
by afoken
on Apr 08, 2017 at 05:10

    Sorry, no code here, just a description. The code is propritary, and very specific to the problem. It does not make much sense without knowing the product and its source code.


    After a large clinical test of one of our products, we got back about 1800 log files. The task: make sense of those logs. What were the product's problems, what errors that should never happen did happen, how did the users (ab-)use the product, short: How can we improve the product?

    The log files are strictly line-oriented, roughly similar to logfiles generated by the Apache webserver. Each line starts with a time stamp, followed by a log source (which component caused the log line), followed by a log message. The three parts are separated by spaces. Log messages from one component are almost always further divided into a named log level, a source code reference (source file and line), a log message from a set of about 200 fixed messages, and some variable text. Other components also use fixed messages, but variable data might be mixed in (think of printf("Foo is %.2f cm, bar is %.2f N\n",foo,bar)).


    Perl to the rescue:

    A first script extracts the fixed log messages from the source code, and generates a perl module that contains the fixed messages and a function to mark the fixed message in a log line.

    A second script uses the module generated by the first script, DBI, DBD::SQLite, and File::Find to read all log files, extract the device serial number from the log files' path, splits each line into timestamp, source, and raw message. The raw message is then handled differently for the different sources, to extract fixed messages and variable parts, log level, and source reference, if present. All of the data is then inserted into an SQLite database containing a single, not normalised table, using columns for serial number, file name, line number, timestamp, source, raw message, fixed message, variable part, log level, source reference.

    A third script uses DBI, DBD::SQLite, and Text::CSV_XS reads a list of named SQL SELECT statements from a text file (example below), then creates a CSV file for each named SELECT statement, runs the query against the SQLite database, and writes the data fetched into the CSV file. Existing CSV files won't be overwritten.

    Exampe for the query file (from memory):

    -- Comments start with "--", "#", or ";". -- Section names are used as file names. [logfiles-per-device] SELECT serial, COUNT(*) FROM ( SELECT DISTINCT serial, filename FROM logs ) GROUP BY serial ORDER BY serial ; [errors-per-device] SELECT serial, fixedmsg, COUNT(*) FROM logs WHERE loglevel='Error' GROUP BY serial, fixedmsg ORDER BY fixedmsg, serial ; -- -- and so on

    The workflow is quite simple. Scripts 1 and 2 are executed once to create the database, then someone edits the query file and runs the third script. CSV files are opened in Excel. We make some educated guesses about what happened, add a few new queries to the query file, run the third script again, and look at the new output, again in Excel. Wash, rinse, repeat.


    Update:

    Why CSV and not Excel? I could have used Spreadsheet::WriteExcel or Excel::Writer::XLSX to generate native Excel files. But we may need to draw some graphs from the log data, and gnuplot needs CSV input. Plus, writing CSV files from Text::CSV_XS is much easier than writing Excel files.

    Alexander

    --
    Today I will gladly share my knowledge and experience, for there are no sweeter words than "I told you so". ;-)
Track open file handles
4 direct replies — Read more / Contribute
by shmem
on Apr 05, 2017 at 09:25

    nysus recently asked whether there was a way to get at all the currently open filehandles. Together with Discipulus I concocted a module which does that. It records open, close along with their respective time, and drops filehandles from the track record as soon as they get undefined or go out of scope.

    package FileHandle::Track; use Time::HiRes qw(gettimeofday); use Hash::Util::FieldHash qw(id_2obj); my %fd; BEGIN{ Hash::Util::FieldHash::fieldhash %fd; my $open = sub { @_ > 2 ? open $_[0],$_[1],$_[2] : open $_[0], $_[1]; }; my $close = sub { close $_[0] }; *CORE::GLOBAL::open = sub { my $result = $open->(@_); if ($result) { $fd{$_[0]}->{open} = join " ",@_[1,2],caller; $fd{$_[0]}->{opentime} = join ".", gettimeofday; } $result; }; *CORE::GLOBAL::close = sub { my $result = $close->(@_); $fd{$_[0]}->{close} = join " ", caller; if ($result) { $fd{$_[0]}->{close} .= " (closed)"; } else { $fd{$_[0]}->{close} .= " (close failed)"; } $fd{$_[0]}->{closetime} = join ".", gettimeofday; $result; }; } sub get_fds { return { map { id_2obj($_), $fd{$_} } keys %fd }; }

    After making that into a module proper (tests, documentation with due credits) I'll upload that to cpan.

    Any suggestions, critics, enhancements?

    perl -le'print map{pack c,($-++?1:13)+ord}split//,ESEL'
Reflections on graphic screwing!
2 direct replies — Read more / Contribute
by BrowserUk
on Apr 01, 2017 at 20:52

    A few examples of what the code below can produce (SFW): 1 2 3 4. The embedded text contains the parameters used.

    The command line parameters are:

    • -M=nn

      This is the size of the screw threads nominal major diameter. Eg M10 is a 10 mm diameter thread.

    • -P=n.m

      This is the pitch of the thread in mm. Can be fractional as in a M0.6x0.15 (using -M=0.6 -P=0.15)

    • -L=i

      This is the length (number of pitches or turns) of the thread that are drawn.

      The length of the screw in mm is M/P*L rounded up to the nearest whole turn.

    • -S=nnn

      Integer value for the scale (number of pixels per millimeter) used for the drawing.

      Lower numbers (50 or 100) give a pretty good impression of what you will see, fairly quickly. Higher numbers improve the "quality"of the drawing (upto a point). Much beyond 1000 will create huge images for little improvement.

    For most realistic "reflections", use relatively large pitch on small diameters. (eg. -M=4 -P=1.5 -S=200 -L=10 (shown above). It is easy to produce weird, unrealistic, confusing results, especially with large diameters and small pitches.

    There is a question: What is being reflected in the chrome screws?

    #! perl -slw no warnings 'pack'; use strict; use Data::Dump qw[ pp ]; use GD; use constant FNAME => 'CGScrew'; use constant { COS30 => 0.86602540378443864676372317075294, TAN30 => 0.57735026918962576450914878050196, DEG2RAD => 0.017453292519943295769236907684886, RAD2DEG => 57.295779513082320876798154814105, }; use enum qw[ X Y Z A ]; sub rgb2n{ unpack 'N', pack 'CCCC', 0, @_ } ## Construct thread profile segment sub constructThreadProfile { my @points; my( $dia, $pitch, $yInc ) = @_; my $H = $pitch * COS30; # draw flat crest my $x = $dia / 2; my $y = -$yInc; push @points, [ $x, $y += $yInc, 0, 1 ] while $y < ( $pitch / 16 ) +; ## draw upper 30deg flank. my $xd = $yInc / TAN30; my $yLim = $y + 5 / 16 * $pitch; push @points, [ $x -= $xd, $y += $yInc, 0, 0.5 ] while $y < $yLim; ## draw root radius $yLim = $y + $pitch / 4; ## cx = $dia /2 - 7/8*$H +$H/3 my( $cx, $cy, $r ) = ( ( $dia/2 - 7/8*$H + $H/3 ), $pitch / 2, $H +/ 6 ); while( $y < $yLim ) { my $dy = $cy - $y; my $dx = sqrt( $r**2 - $dy**2 ); push @points, [ $cx - $dx, $cy - $dy, 0, $dx / $r ]; $y += $yInc; } $y -= $yInc; ## draw lower 30deg flank $yLim = $y + 5 / 16 * $pitch; push @points, [ $x += $xd, $y += $yInc, 0, - 0.5 ] while $y < $yL +im; push @points, [ $x, $y += $yInc, 0, 1 ] while $y < $pitch; return \@points; } our $M //= 10; our $P //= 1.5; our $L //= 2; our $S //= 100; my $fname = sprintf "%sM%.2fxP%.2fxL%.2fxS%d.png", FNAME, $M, $P, $L, +$S; my $profile = constructThreadProfile( $M, $P, 1 / ( 10* $S ) ); #pp $profile; my( $w, $h ) = ( $M * $S + 200, int( $L / $P + 1 ) * $P * $S + 200 ); my $xc = $w / 2; my $im = GD::Image->new( $w, $h, 1 ); $im->fill( 0,0, rgb2n( 128, 128, 128 ) ); sub xformPoint { my( $point, $rot, $yTrans ) = @_; $rot *= DEG2RAD; my $x = $point->[X] * cos( $rot ); my $y = $point->[Y] + $yTrans; my $z = $point->[X] * sin( $rot ); my $a = $point->[A] * cos( 90 * DEG2RAD - $rot ); return [ $x, $y, $z, $a ]; } my $yTrans = $P / 360; my $maxRad = $M * $S / 2; my $yOff = 100; for my $turn ( 1 .. $L / $P ) { for my $p ( map $_/2, -$maxRad*2 .. $maxRad*2 ) { my $rot = RAD2DEG * atan2( sqrt( $maxRad**2 - $p**2 ), $p ); for my $point ( @$profile ) { my $newPoint = xformPoint( $point, $rot, $yTrans * $rot ); my( $newX, $newY ) = ( $xc + $newPoint->[X] * $S, $yOff + +$newPoint->[Y] * $S ); my $color = ( abs( $newPoint->[A] ) * 256 + (100 - $newY) +); $im->setPixel( $newX, $newY, rgb2n( ( $color ) x 3 ) ); } } $yOff += $P * $S; } $im->string( gdSmallFont, 0,0, $fname, 0 ); open O, '>:raw', $fname or die $!; print O $im->png; close O; system $fname;

    With the rise and rise of 'Social' network sites: 'Computers are making people easier to use everyday'
    Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error.
    "Science is about questioning the status quo. Questioning authority". The enemy of (IT) success is complexity.
    In the absence of evidence, opinion is indistinguishable from prejudice.
Ssh and qx
1 direct reply — Read more / Contribute
by cbeckley
on Mar 30, 2017 at 14:04

    It actually took a little digging to find out how to properly handle the output and the various return codes of qx when executing an ssh command.

    Why would you actually want to do such a thing to begin with? You wouldn't. Don't do it. Stop! For the love of ...

    If, however, you have a machine who's operating system hasn't had a vendor supported upgrade any time this century, you may not have a choice.

    I feel your pain. It runs deep, share it with me.

    sub ops_do_ssh_qx { my ($cmd) = @_; $cmd->{ssh_cmd_qx} = 'ssh ' . $cmd->{user} . '\@' . $cmd->{host} . + ' \'' . $cmd->{command} . '\'' . ' 2>/dev/null'; $cmd->{output} = qx($cmd->{ssh_cmd_qx}); if ( defined $cmd->{output} ) { $cmd->{cmd_ret_code} = $?; chomp $cmd->{output}; if ( $cmd->{cmd_ret_code} ) { $cmd->{success} = FAILURE; } } else { ($cmd->{ssh_ret_code}, $cmd->{ssh_ret_msg}) = (0 + $!, '' . $!); $cmd->{success} = FAILURE; } return $cmd; }

    The hash you pass in looks like this:

    my $cmd = { name => 'foo', user => 'foo_user', host => 'foo.bar.com', command => 'do_something_useful_here', success => SUCCESS };

    And you invoke it thusly:

    my $cmd_status = ops_do_ssh_qx($cmd); if ( $cmd_status->{success} ) { do_something_with $cmd_status->{output}; } else { do_something_with $cmd_status->{cmd_ret_code}, $cmd_status->{ssh_re +t_code}, $cmd_status->{ssh_ret_msg}; }

    Unfortunately the values you end up with in

    $cmd_status->{cmd_ret_code} $cmd_status->{ssh_ret_code} $cmd_status->{ssh_ret_msg}
    are, for both the OS and SSH, implementation dependent, which is just one of the reasons you shouldn't be doing this if you have a choice.

    If anybody finds this useful, you have my condolences.

    Thanks,
    cbeckley

    Update: haukex has a great write up regarding alternatives to qx/backticks here Re: curl without backticks and system() (updated x2). My Perl was too old for the ones I tried, but afoken has indicated that piped opens are available even in 5.004.

Automatically ensure your CPAN dists have up-to-date prereq version numbers
No replies — Read more | Post response
by stevieb
on Mar 26, 2017 at 19:29

    So... one of my distribution relies heavily on other distributions I've written, and it's hard to ensure my dependencies for my own modules are up-to-date in the prerequisite list in the build system. Sometimes I forget to bump a prereq before I do a release, which means I have to immediately do a one-line release the next day, because I'll have emails from CPAN Testers because tests are failing.

    I've been toying with a few ways to automatically check this for me. Below is one such hack I came up with. There's two vars that need to be set: $dist and $author. It then pulls the distribution from the CPAN, extracts all of it's prerequisite dependency information. Then, it fetches the list of all distributions I've put on the CPAN, and creates a dist/version hash.

    Note that this compares *only* the prereqs that I personally have uploaded. It'd be trivial to modify a bit to check them all.

    After the data is collected, it iterates the known dependencies, and if there's a match with one of my own other distributions, I compare versions. Currently, it just prints out the list, but I'm going to hack this into my Test::BrewBuild system as another command line option so that every build run, I'll be notified of any discrepancies. Eventually, I'll likely make it auto-update the Makefile.PL files for me with the new dep versions, as well as have it review the prereq versions in the current repo of the dist I'm working on, instead of comparing to the latest CPAN release, so I can correct the issues *before* pushing to PAUSE :)

    use warnings; use strict; use MetaCPAN::Client; my $c = MetaCPAN::Client->new; my $dist = 'RPi-WiringPi'; my $author = 'STEVEB'; check_deps($dist, $author); sub check_deps { my ($dist, $author) = @_; if ($dist =~ /:/){ die "\$dist must be hyphenated... don't use ::\n"; } my $release = $c->release($dist); my $deps = $release->{data}{dependency}; my $author_modules = author_modules($author); for my $dep (@$deps){ my $dep_mod = $dep->{module}; my $dep_ver = $dep->{version}; if (exists $author_modules->{$dep_mod}){ my $cur_ver = $author_modules->{$dep_mod}; print "$dep_mod: \n" . "\tdep ver: $dep_ver\n" . "\tcur ver: $cur_ver\n\n"; } } } sub author_modules { my ($author) = @_; my $query = { all => [ { author => $author }, { status => 'latest' }, ], }; my $limit = { '_source' => [ qw(distribution version) ] }; my $releases = $c->release($query, $limit); my %rel_info; while (my $rel = $releases->next){ my $dist = $rel->distribution; $dist =~ s/-/::/g; $rel_info{$dist} = $rel->version; } return \%rel_info; }

    Output:

    perl perl/dependency_version_compare/compare.pl RPi::DigiPot::MCP4XXXX: dep ver: 2.3603 cur ver: 2.3603 RPi::BMP180: dep ver: 2.3603 cur ver: 2.3603 RPi::ADC::MCP3008: dep ver: 2.3603 cur ver: 2.3603 RPi::SPI: dep ver: 2.3606 cur ver: 2.3606 RPi::DAC::MCP4922: dep ver: 2.3604 cur ver: 2.3604 RPi::WiringPi::Constant: dep ver: 0.02 cur ver: 0.02 RPi::DHT11: dep ver: 1.02 cur ver: 1.02 WiringPi::API: dep ver: 2.3609 cur ver: 2.3609 RPi::ADC::ADS: dep ver: 1.01 cur ver: 1.01
oneliner: autorun script when I save it in the editor
3 direct replies — Read more / Contribute
by FreeBeerReekingMonk
on Mar 26, 2017 at 18:08
    Sometimes you get spoiled by IDE's that have F5 to save and run what you have scripted so far... so... what can you do if you have 2 xterms (one for vi, the other for the output)?

    perl -E 'while(-f $ARGV[0]){ $now=(stat(_))[9]; system($^X,@ARGV) if($ +now-$prev); $prev=$now; sleep 1}' /home/user/test.pl foo bar

    with test.pl having:

    #! env perl my $p1 = $ARGV[0]; my $p2 = $ARGV[1]; print "param1=$p1 param2=$p2\n";

    yields:

    param1=foo param2=bar

    Tested to work under Win10 and Linux

    Of course, there are better implementations. inotifywait or auditd if available on your system...

    any perl golfers?

    Update: we now incorporate the improvement made by haukex. Feel free to add more parameters if you need these

Sparrow - your own script manager
3 direct replies — Read more / Contribute
by melezhik
on Mar 23, 2017 at 16:06

    Sparrow - script manager. One can easily create and distributes scripts using Sparrow/Outthentic tool chain.

    Here are some examples. ( You may find a detailed information at Sparrow docs )

    # install sparrow

    $ cpanm Sparrow
    

    # create useful script

    $ cat story.bash
    /etc/init.d/nginx status # tell me if nginx server is running
    $ touch story.check
    

    # upload script to SparrowHub repository

    $ cat sparrow.json
    {
      "name" : "nginx-check",
      "version" : "0.0.1",
      "description" : "nginx check script"
    }
    $ sparrow plg upload
    

    # run sparrow script at other host

    $ ssh 192.168.0.1
    $ sparrow plg install nginx-check
    $ sparrow plg run  nginx-check
    
    p> nginx-check at 2017-03-23 23:00:27
    ● nginx.service - A high performance web server and a reverse proxy server
       Loaded: loaded (/lib/systemd/system/nginx.service; enabled)
       Active: active (running) since Thu 2017-03-23 23:00:20 MSK; 6s ago
      Process: 10062 ExecStart=/usr/sbin/nginx -g daemon on; master_process on; (code=exited, status=0/SUCCESS)
      Process: 10060 ExecStartPre=/usr/sbin/nginx -t -q -g daemon on; master_process on; (code=exited, status=0/SUCCESS)
     Main PID: 10064 (nginx)
       CGroup: /system.slice/nginx.service
               ├─10064 nginx: master process /usr/sbin/nginx -g daemon on; master_process on
               └─10065 nginx: worker process
    ok      scenario succeeded
    STATUS  SUCCEED
    

    Interested? You may know more - other plugins ready to use, tasks, cron jobs, check lists, YAML/JSON/Config::General configuration, other languages support and even more! Follow https://sparrowhub.org

Mutex::Flock - Fcntl advisory locking supporting processes and threads.
2 direct replies — Read more / Contribute
by marioroy
on Mar 23, 2017 at 02:59

    Greetings,

    Re: Scheduling Perl Tasks

    This is a nice to have module for anybody that wants it. Lately, I lack the time to make a module and publish on CPAN. It is well tested on all supported platfoms including support for threads. It is also optimized, thus low overhead.

    ## Mutex::Flock - Fcntl-based advisory locking. package Mutex::Flock; use strict; use warnings; no warnings qw( threads recursion uninitialized once ); our $VERSION = '0.007'; use Fcntl ':flock'; use Carp (); my $has_threads = $INC{'threads.pm'} ? 1 : 0; my $tid = $has_threads ? threads->tid() : 0; sub CLONE { $tid = threads->tid() if $has_threads; } sub DESTROY { my ($pid, $obj) = ($has_threads ? $$ .'.'. $tid : $$, @_); $obj->unlock(), close(delete $obj->{_fh}) if $obj->{ $pid }; unlink $obj->{path} if ($obj->{_init} && $obj->{_init} eq $pid); return; } sub _open { my ($pid, $obj) = ($has_threads ? $$ .'.'. $tid : $$, @_); return if exists $obj->{ $pid }; open $obj->{_fh}, '+>>:raw:stdio', $obj->{path} or Carp::croak("Could not create temp file $obj->{path}: $!"); return; } ## Public methods. my ($id, $prog_name) = (0); $prog_name = $0; $prog_name =~ s{^.*[\\/]}{}g; $prog_name = 'perl' if ($prog_name eq '-e' || $prog_name eq '-'); sub new { my ($class, %obj) = (@_); if (! defined $obj{path}) { my ($pid, $tmp_dir, $tmp_file) = ( abs($$) ); if ($ENV{TEMP} && -d $ENV{TEMP} && -w _) { $tmp_dir = $ENV{TEMP}; } elsif ($ENV{TMPDIR} && -d $ENV{TMPDIR} && -w _) { $tmp_dir = $ENV{TMPDIR}; } elsif (-d '/tmp' && -w _) { $tmp_dir = '/tmp'; } else { Carp::croak("no writable dir found for temp file"); } $id++, $tmp_dir =~ s{/$}{}; # remove tainted'ness from $tmp_dir if ($^O eq 'MSWin32') { ($tmp_file) = "$tmp_dir\\$prog_name.$pid.$tid.$id" =~ /(.* +)/; } else { ($tmp_file) = "$tmp_dir/$prog_name.$pid.$tid.$id" =~ /(.*) +/; } $obj{_init} = $has_threads ? $$ .'.'. $tid : $$; $obj{ path} = $tmp_file.'.lock'; } # test open open my $fh, '+>>:raw:stdio', $obj{path} or Carp::croak("Could not create temp file $obj{path}: $!"); close $fh; # update permission chmod 0600, $obj{path} if $obj{_init}; return bless(\%obj, $class); } sub lock { my ($pid, $obj) = ($has_threads ? $$ .'.'. $tid : $$, @_); $obj->_open() unless exists $obj->{ $pid }; flock ($obj->{_fh}, LOCK_EX), $obj->{ $pid } = 1 unless $obj->{ $pid }; return; } *lock_exclusive = \&lock; sub lock_shared { my ($pid, $obj) = ($has_threads ? $$ .'.'. $tid : $$, @_); $obj->_open() unless exists $obj->{ $pid }; flock ($obj->{_fh}, LOCK_SH), $obj->{ $pid } = 1 unless $obj->{ $pid }; return; } sub unlock { my ($pid, $obj) = ($has_threads ? $$ .'.'. $tid : $$, @_); flock ($obj->{_fh}, LOCK_UN), $obj->{ $pid } = 0 if $obj->{ $pid }; return; } sub synchronize { my ($pid, $obj, $code, @ret) = ( $has_threads ? $$ .'.'. $tid : $$, shift, shift ); return if ref($code) ne 'CODE'; $obj->_open() unless exists $obj->{ $pid }; # lock, run, unlock - inlined for performance flock ($obj->{_fh}, LOCK_EX), $obj->{ $pid } = 1 unless $obj->{ $p +id }; defined wantarray ? @ret = $code->(@_) : $code->(@_); flock ($obj->{_fh}, LOCK_UN), $obj->{ $pid } = 0; return wantarray ? @ret : $ret[-1]; } *enter = \&synchronize; sub timedwait { my ($obj, $timeout) = @_; local $@; local $SIG{'ALRM'} = sub { alarm 0; die "timed out\n" }; eval { alarm $timeout || 1; $obj->lock_exclusive }; alarm 0; ( $@ && $@ eq "timed out\n" ) ? '' : 1; } 1; __END__ =head1 NAME Mutex::Flock - Fcntl advisory locking =head1 SYNOPSIS { use Mutex::Flock; ( my $mutex = Mutex::Flock->new( path => $0 ) )->lock_exclusive +; ... } { my $mutex = MCE::Mutex::Flock->new( path => $0 ); # terminate script if a previous instance is still running exit unless $mutex->timedwait(2); ... } { use threads; use Mutex::Flock; my $mutex = Mutex::Flock->new; threads->create('task', $_) for 1..4; $_->join for ( threads->list ); } { use MCE::Hobo; use Mutex::Flock; my $mutex = Mutex::Flock->new; MCE::Hobo->create('task', $_) for 5..8; MCE::Hobo->waitall; } sub task { my ($id) = @_; $mutex->lock; # access shared resource print $id, "\n"; sleep 1; $mutex->unlock; } =head1 DESCRIPTION This module implements locking methods that can be used to coordinate +access to shared data from multiple workers spawned as processes or threads. =head1 API DOCUMENTATION =head2 Mutex::Flock->new ( [ path => "/tmp/file.lock" ] ) Creates a new mutex. When path is given, it is the responsibility of t +he caller to remove the file. Otherwise, it establishes a C<tempfile> internally + including removal on scope exit. =head2 $mutex->lock ( void ) =head2 $mutex->lock_exclusive ( void ) Attempts to grab an exclusive lock and waits if not available. Multipl +e calls to mutex->lock by the same process or thread is safe. The mutex will r +emain locked until mutex->unlock is called. The method C<lock_exclusive> is an alias for C<lock>. =head2 $mutex->lock_shared ( void ) Like C<lock_exclusive>, but attempts to grab a shared lock instead. =head2 $mutex->unlock ( void ) Releases the lock. A held lock by an exiting process or thread is rele +ased automatically. =head2 $mutex->synchronize ( sub { ... }, @_ ) =head2 $mutex->enter ( sub { ... }, @_ ) Obtains a lock, runs the code block, and releases the lock after the b +lock completes. Optionally, the method is C<wantarray> aware. my $val = $mutex->synchronize( sub { # access shared resource return 'scalar'; }); my @ret = $mutex->enter( sub { # access shared resource return @list; }); The method C<enter> is an alias for C<synchronize>. =head2 $mutex->timedwait ( timeout ) Blocks until taking obtaining an exclusive lock. A false value is retu +rned if the timeout is reached, and a true value otherwise. my $mutex = MCE::Mutex::Flock->new( path => $0 ); # terminate script if a previous instance is still running exit unless $mutex->timedwait(2); ... =head1 AUTHOR Mario E. Roy, S<E<lt>marioeroy AT gmail DOT comE<gt>> =cut

    Regards, Mario

    Edit: Removed the underscore after the sigil in variables.
    Edit: Updated synopsis and code for construction.
    Edit: Added timedwait method. Completed documentation.

Solaris: make iostat output clearer
1 direct reply — Read more / Contribute
by johngg
on Mar 22, 2017 at 18:49

    This might be useful for sysadmins who manage Solaris servers. The iostat -En command can be used to check for cumulative disk errors but the output is rather dense so it can be difficult to sort the wood from the trees. This script uses Term::ANSIColor to make errors easier to spot.

    use strict; use warnings; use Term::ANSIColor qw{ :constants }; my $rxTriggers = do { my @triggers = ( q{Soft Errors: }, q{Hard Errors: }, q{Transport Errors: }, q{Media Error: }, q{Device Not Ready: }, q{No Device: }, q{Recoverable: }, q{Illegal Request: }, q{Predictive Failure Analysis: }, ); local $" = q{|}; qr{(@triggers)(\d+)} }; my @iostatCmd = qw{ /usr/bin/iostat -En }; open my $iostatFH, q{-|}, @iostatCmd or die qq{open: @iostatCmd |: $!\n}; print q{-} x 60, qq{\n}; while ( not eof $iostatFH ) { my $record; $record .= $_ for map { eof $iostatFH ? () : scalar <$iostatFH> } 1 .. 5; substr $record, 16, 0, RESET; substr $record, 0, 0, BOLD; $record =~ s{$rxTriggers} { $2 eq q{0} ? $1 . GREEN . $2 . RESET : YELLOW . $1 . RED . $2 . RESET }eg; print $record; print q{-} x 60, qq{\n}; } close $iostatFH or die qq{close: @iostatCmd |: $!\n};

    I no longer have a working Solaris box to provide example output but I hope this will be useful for somebody out there.

    Cheers,

    JohnGG

Wrapping a C shared library with Perl and XS
3 direct replies — Read more / Contribute
by stevieb
on Mar 17, 2017 at 14:23

    So, I've been asked by a couple of people now if I would take some of the experience I've gained over the last half year or so, and put together some form of tutorial on wrapping a C library, and more generally, XS. This is the first cut of that tutorial.

    Relatively, I am still very new to all of this, as it's a pretty complex world. Before I started, I didn't have any real C experience, so I've been dealing with that learning curve at the same time, so I know there are better and more efficient ways of doing what I do, and would appreciate any feedback.

    I'll get right to it. Here's an overview:

    • find something to wrap. In this case, I've written a shared C library called xswrap (I'll detail that whole procedure in the first reply to this node)
    • create a shell distribution that'll allow us to load our eventual XS code, which in turn has wrapped the C library
    • update relevant files to make things hang together
    • run into a function that can't be returned to Perl as-is, so we learn how to write our own C/XS wrapper so we can get what we need
    • package it all together into a distribution

    The actual C code is irrelevant at this point, but knowing the definitions in use is, so here they are for the xswrap library:

    int mult (int x, int y); void speak (const char* str); unsigned char* arr (); // returns (0, 1, 2)

    Create a new shell distribution

    I use Module::Starter:

    module-starter \ --module=XS::Wrap \ --author="Steve Bertrand" \ --email=steveb@cpan.org \ --license=perl

    Now change into the new XS-Wrap directory, which is the root directory of the new dist. The Perl module file is located at lib/XS/Wrap.pm. I've removed a bunch of stuff for brevity, but the shell looks something like this:

    package XS::Wrap; use warnings; use strict; our $VERSION = '0.01';

    Create the base XS file

    I use Inline::C to do this for me, as like most Perl hackers, I'm often lazy. Note the flags in use. clean_after_build tells Inline to not clean up the build directory (_Inline after build). This allows us to fetch our new .xs file. name is the name of the module we're creating this XS file for.

    use warnings; use strict; use Inline Config => disable => clean_after_build => name => 'XS::Wrap'; use Inline 'C'; __END__ __C__ #include <stdio.h> #include <xswrap.h>

    The resulting XS file is located in _Inline/build/XS/Wrap/Wrap.xs. Copy it to the root directory of the dist:

    cp _Inline/build/XS/Wrap/Wrap.xs .

    Here's what our base XS file looks like. It doesn't do anything yet, but we'll get there:

    #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include "INLINE.h" #include <stdio.h> #include <xswrap.h> MODULE = XS::Wrap PACKAGE = main PROTOTYPES: DISABLE

    See the PACKAGE = main there? Change main to the name of our dist, XS::Wrap.

    Adding the functions from the shared library to XS

    Now we need to define our C functions within the XS file. After I've done that using the C definitions for the functions above, my XS file now looks like this

    #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include "INLINE.h" #include <stdio.h> #include <xswrap.h> MODULE = XS::Wrap PACKAGE = XS::Wrap PROTOTYPES: DISABLE int mult (x, y) int x int y void speak (str) const char* str unsigned char* arr ()

    Note that at this point, because we're not using Inline anymore, you can remove the include for the INLINE.h header file. However, in our case, we're going to be using some Inline functionality a bit later on, so instead of removing that, copy the INLINE.h file to the same directory we copied our XS file into: cp _Inline/build/XS/Wrap/INLINE.h .

    Readying the module file for use

    Now we have some work to do to pull in the XS, wrap the functions, and export them. Note that you do not *need* to wrap the functions with Perl, you can export them directly as depicted in the XS file if you wish, as long as you know you don't need to add any further validation or functionality before the XS imported C function is called. I'll wrap all three. The functions that each wrapped function calls is the literal C function, as advertised through the XS file we hacked above.

    use warnings; use strict; our $VERSION = '0.01'; require XSLoader; XSLoader::load('XS::Wrap', $VERSION); use Exporter qw(import); our @EXPORT_OK = qw( my_mult my_speak my_arr ); our %EXPORT_TAGS; $EXPORT_TAGS{all} = [@EXPORT_OK]; sub my_mult { my ($x, $y) = @_; return mult($x, $y); } sub my_speak { my ($str) = @_; speak($str); } sub my_arr { my @array = arr(); return @array; }

    Telling the Makefile to load the external C library

    Because we're using an external shared library, we need to add a directive to the Makefile.PL file. Put the following line anywhere in the Makefile.PL's WriteMakefile() routine:

    LIBS => ['-lxswrap'],

    Building, installing and initial test

    Let's build, install and write a test script for our new distribution.

    perl Makefile.PL make make install

    At this point, if everything works as expected, you're pretty well done. However, in the case here, we're going to unexpectedly run into some issues, and we'll need to do other things before we finalize our distribution.

    Test script (example.pl). Very basic, it just tests all three wrapped functions:

    use warnings; use strict; use feature 'say'; use XS::Wrap qw(:all); say my_mult(5, 5); my_speak("hello, world!\n"); my @arr = my_arr(); say $_ for @arr;

    Output:

    25 hello, world!

    Hmmm, something is not right. The arr() C function was supposed to return an array of three elements, 0, 1, 2, but we get no output.

    This is because arr() returns an unsigned char* which we can't handle correctly/directly in Perl.

    In this case, I will just wrap the arr() function with a new C function (I've called it simply _arr()) that returns a real Perl array based on the output from the original C arr() function. Technically, I won't be returning anything, I'm going to just use functionality from Inline to push the list onto the stack (one element at a time), where Perl will automatically pluck it back off of the stack.

    To do this, I'll be leveraging Inline again, but with a couple of changes. We change the name, and add also bring in our shared library because we need it directly now.

    Returning a Perl array from a C function

    use warnings; use strict; use Inline config => disable => clean_after_build => name => 'Test'; use Inline ('C' => 'DATA', libs => '-lxswrap'); print "$_\n" for _arr(); __END__ __C__ #include <stdio.h> #include <xswrap.h> void _arr (){ unsigned char* c_array = arr(); inline_stack_vars; inline_stack_reset; int i; for (i=0; i<3; i++){ inline_stack_push(sv_2mortal(newSViv(c_array[i]))); } free(c_array); inline_stack_done; }

    After I execute that Perl script, I'm left with a new XS file within the _Inline/build/Test/Test.xs.. It looks like this:

    #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include "INLINE.h" #include <stdio.h> #include <xswrap.h> void _arr (){ unsigned char* c_array = arr(); inline_stack_vars; inline_stack_reset; int i; for (i=0; i<3; i++){ inline_stack_push(sv_2mortal(newSViv(c_array[i]))); } free(c_array); inline_stack_done; } MODULE = Test PACKAGE = main PROTOTYPES: DISABLE void _arr () PREINIT: I32* temp; PPCODE: temp = PL_markstack_ptr++; _arr(); if (PL_markstack_ptr != temp) { /* truly void, because dXSARGS not invoked */ PL_markstack_ptr = temp; XSRETURN_EMPTY; /* return empty stack */ } /* must have used dXSARGS; list context implied */ return; /* assume stack size is correct */

    We only need a couple of pieces of it, so get out your CTRL-V and CTRL-C. Here are the sections (cleaned up a bit for brevity) that we need to copy into our real Wrap.xs file.

    The C portion:

    void _arr (){ unsigned char* c_array = arr(); inline_stack_vars; inline_stack_reset; int i; for (i=0; i<3; i++){ inline_stack_push(sv_2mortal(newSViv(c_array[i]))); } free(c_array); inline_stack_done; }

    The XS portion:

    void _arr () PREINIT: I32* temp; PPCODE: temp = PL_markstack_ptr++; _arr(); if (PL_markstack_ptr != temp) { PL_markstack_ptr = temp; XSRETURN_EMPTY; } return;

    The C part goes near the top of the XS file, and the XS part goes in the XS section at the bottom. Here's our full XS file after I've merged in these changes.

    Finalized XS file

    #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include "INLINE.h" #include <stdio.h> #include <xswrap.h> void _arr (){ unsigned char* c_array = arr(); inline_stack_vars; inline_stack_reset; int i; for (i=0; i<3; i++){ inline_stack_push(sv_2mortal(newSViv(c_array[i]))); } free(c_array); inline_stack_done; } MODULE = XS::Wrap PACKAGE = XS::Wrap PROTOTYPES: DISABLE int mult (x, y) int x int y void speak (str) const char* str unsigned char* arr () void _arr () PREINIT: I32* temp; PPCODE: temp = PL_markstack_ptr++; _arr(); if (PL_markstack_ptr != temp) { PL_markstack_ptr = temp; XSRETURN_EMPTY; } return;

    So, in our XS, we have four functions. Three that are imported directly from the C shared lib (mult(), speak() and arr()) and one new one written in C locally that wraps an imported XS function (_arr()).

    We need to do a quick update to the wrapper in the module file. Change the call to arr() to _arr() in the .pm file within the my_arr() function:

    sub my_arr { my @array = _arr(); return @array; }

    Repeat the build/install steps, then test again:

    perl example.pl 25 hello, world! 0 1 2

    Cool! Our custom C wrapper for arr() works exactly how we want it to.

    We're ready for release!

    Creating a release of our distribution

    It's very trivial to do:

    rm -rf _Inline perl Makefile.PL make make test make manifest make install make dist

    Of course, you have written all of your POD and unit tests before reaching this point, but I digress :)

    I've also posted this at blogs.perl.org.

    update: I want to thank all of the Monks here who have provided me help, feedback, advice and in a couple of cases, some ego-kicking. I will not name said Monks because I'm very afraid of leaving someone out, but you know who you are.


Add your CUFP
Title:
CUFP:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":


  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Titles consisting of a single word are discouraged, and in most cases are disallowed outright.
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.
  • Log In?
    Username:
    Password:

    What's my password?
    Create A New User
    Chatterbox?
    LanX ts ... always those operl testers ...

    How do I use this? | Other CB clients
    Other Users?
    Others studying the Monastery: (7)
    As of 2017-09-24 13:18 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?
      During the recent solar eclipse, I:









      Results (274 votes). Check out past polls.

      Notices?