Beefy Boxes and Bandwidth Generously Provided by pair Networks
Keep It Simple, Stupid
 
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
Parallel::ForkManager + MCE::Shared demonstration
1 direct reply — Read more / Contribute
by marioroy
on Apr 23, 2017 at 22:26

    Respected Monks,

    In preparation for the upcoming MCE 1.828 and MCE::Shared 1.825 releases, am testing various modules with MCE::Shared. One of which is Parallel::ForkManager.

    Discipulus introduced me to zentara recently. zentara am pleased to meet you. Discipulus, imho, folks may choose any parallel module of their liking. It doesn't need to be MCE and the reason for this thread. I like Parallel::ForkManager too.

    Some time back, zentara wrote a Parallel::ForkManager + IPC::Shareable demonstration. Fast forward 2.5 years and here's another way. MCE::Shared provides users of Parallel::ForkManager with threads-like sharing capabilities. Below is zentara's example updated with MCE::Shared bits.

    Not to worry, MCE::Shared performs reasonably well.

    #!/usr/bin/perl # Based on Parallel::ForkManager + IPC::Shareable by zentara. # Found here: http://www.perlmonks.org/?node_id=1104697 use strict; use Parallel::ForkManager; use MCE::Mutex; use MCE::Shared; my $mutex = MCE::Mutex->new(); my $parent_share = tie my %final_parent_hash, 'MCE::Shared'; my $fork_manager = new Parallel::ForkManager(5); $fork_manager->set_waitpid_blocking_sleep(0); foreach my $child ( 1 .. 10 ) { my $pid = $fork_manager->start($child) and next; # Optional, to have the shared-manager assign a data channel. # Helpful when involving heavy IPC usage, not the case here. # Increase 20 to 2000 to see perf-increase from calling ->init. MCE::Shared->init(); for my $id ( 1 .. 20 ) { my $key = $child . '-' . $id; # $mutex->lock; # mutex not necessary when storing unique keys # $parent_share->set($key => qq{|Kid $child pushed $id}); # OO $final_parent_hash{$key} = qq{|Kid $child pushed $id}; # $mutex->unlock; } $fork_manager->finish($child); } print "Waiting for Children...\n"; $fork_manager->wait_all_children; foreach my $child ( 1 .. 10 ) { for my $id ( 1 .. 20 ) { my $key = $child . '-' . $id; if (! exists $final_parent_hash{$key} ) { print "Missing data for Kid $child , data $id\n"; } else { print "$key = $final_parent_hash{$key}\n"; } } }

    The following are recommended modules for MCE::Shared.

    ## MCE::Shared 1. Sereal::Decoder 3.015+ 2. Sereal::Encoder 3.015+ 3. Sereal (ok for completeness, but MCE::Shared doesn't load this) ## MCE::Shared applies to Condvar, Handle, and Queue 1. IO::FDPass 1.2+

    Q. Why is Sereal beneficial?

    A. The main reason is for extra performance. To ensure minimum memory consumption, there's no reason to load the Storable module if Sereal is available in Perl. This is handled transparently.

    Q. Why is IO::FDPass beneficial?

    A. Being able to construct a shared condvar, handle, or queue while the shared-manager is running greatly adds to the ease-of-use. These involve handles behind the scene. Basically, am able to send the relevant fd descriptors to the shared-manager. Without FDPass, one must be careful to construct Condvar, Handle, and Queue first before other shared objects and later starting the shared-manager manually. Note: MCE and MCE::Hobo starts the shared-manager if not already started.

    Q. What is MCE::Shared->init all about?

    A. For MCE, MCE::Hobo, and threads (via CLONE), MCE::Shared->init() is called automatically. It assigns the worker 1 of 12 data channels for use during IPC. Calling init is totally optional. If the worker is sending data one time, probably not necessary. On the other hand, if doing lots of IPC, then yes worth it.

    For further reading, see also this thread made by karlgoethebier or this reply regarding performance characteristics (TIE and Mutex or OO). Basically, performance is possible. And so is fun.

    Regards, Mario.

Generic De Bruijn Sequence
5 direct replies — Read more / Contribute
by QM
on Apr 19, 2017 at 12:38
    I needed to write a sequence for a test, where there are N elements, and all T-tuples of elements are used, in the shortest sequence. A search turned up De Bruijn sequences.

    The easy algorithm takes N elements and produces every N-tuple permutation. With a little tinkering, I have the B(N,T) version. Not fast, can't handle large sequences, and runs out of space quickly. But for small T, does what I need.

    It quickly became apparent that large T values would not be useful in my test, though N could be about 50.

    Here are some results:

    > debruijn.pl 3 3 AAACCCBCCACBBCBACABCAABBBABAA > debruijn.pl 4 4 AAAADDDDCDDDBDDDADDCCDDCBDDCADDBCDDBBDDBADDACDDABDDAADCDCDBDCDADCCCDCC +BDCCADCBCDCBBDCBADCACDCABDCAADBDBDADBCCDBCBDBCADBBCDBBBDBBADBACDBABDB +AADADACCDACBDACADABCDABBDABADAACDAABDAAACCCCBCCCACCBBCCBACCABCCAACBCB +CACBBBCBBACBABCBAACACABBCABACAABCAAABBBBABBAABABAAA > debruijn.pl 4 2 AADDCDBDACCBCABBA > debruijn.pl 5 2 AAEEDECEBEADDCDBDACCBCABBA

    Here's the code.

    #!/usr/bin/env perl # # Generate a string with the longest non-repeating subsequences possib +le. # Include overlaps. # # Input N, size of the alphabet. # Input T, tuples (pairs, triples, quadruples, etc.) # # Start with all N-length permutations. # Create a graph of all pairs A(B...Y)Z, # such that every pair whose left member ends with B...Y, # the right member starts with B...Y (for some length n-1) # Find an Eulerian path through the permutations (visit every node onl +y once) # The sequence of starting node, plus each additional ending letter, # is the De Bruijn sequence for this alphabet. use strict; use warnings; my $n = (shift or 4); # N for alphabet size my $t = (shift or $n); # T for Tuples (pairs, triples, quadruples) my $n1 = $n - 1; my $t1 = $t - 1; my @alphabet = ('A'..'Z','0'..'9','a'..'z'); if (@alphabet < $n) { die "Alphabet is smaller than $n\n"; } # glob character of length 1 my $alphabet = '{' . join(',', @alphabet[0..$n1]) . '}'; # Generate all strings of length $t in the given alphabet my $glob_string = $alphabet x $t; my @nodes = glob("$glob_string"); # Generate the graph of all strings that overlap in t-1 characters. my %graph; for my $node1 (@nodes) { for my $node2 (@nodes) { next if $node1 eq $node2; # If they overlap, add node2 to the array for node1 if (substr($node1,1,$t1) eq substr($node2,0,$t1)) { push @{$graph{$node1}}, $node2; } } } # String starts with first node's full string. # Walk through the graph: # Delete the node behind # Add the last char of next node to string # Print result my $node1 = $nodes[0]; my $q = 0; # print "$q : $node1\n"; # debug my $string = $node1; while (scalar keys %graph > 1) { my $moved = 0; # "reverse" here somehow "does the right thing", and enables an # Eulerian circuit with no added logic. for my $node2 (reverse @{$graph{$node1}}) { if (exists($graph{$node2})) { $string .= substr($node2,$t1,1); # Add last char to string delete($graph{$node1}); $node1 = $node2; $moved = 1; # print ++$q, " : $node2\n"; # debug last; } } # Avoid endless loops on pathological cases unless ($moved) { warn "Didn't find next node ($node1)\n"; last; } } print "$string\n"; exit;

    I'm interested in tweaks to make it faster, smaller, better, etc. Or pointers to other solutions.

    -QM
    --
    Quantum Mechanics: The dreams stuff is made of

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.


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?
    and all is quiet...

    How do I use this? | Other CB clients
    Other Users?
    Others chilling in the Monastery: (3)
    As of 2017-07-22 12:01 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?
      I came, I saw, I ...
























      Results (338 votes). Check out past polls.