Beefy Boxes and Bandwidth Generously Provided by pair Networks
more useful options
 
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
GPS tracking with Perl
1 direct reply — Read more / Contribute
by stevieb
on May 16, 2017 at 20:56

    I finally got my little GPS unit for my Raspberry Pi, which cost me $50 CDN. It connects via the Rx and Tx pins of the serial interface. My new GPSD::Parse module (may not have indexed yet) is not Pi specific though. Any serial connected GPS device will work (even USB ones).

    There aren't any non-core modules in use so it's exceptionally lightweight. The only requirement is to have gpsd daemon installed and running. I run it like this: sudo gpsd /dev/ttyS0 -n -F /var/log/gpsd.sock at startup.

    Note that there is a much more extensive distribution Net::GPSD3 that does the same sort of thing, but I had a nightmare trying to install it with a whole long chain of dependencies, and it was a little confusing to use. I wrote this one for simplicity. All tests effectively skip until the next version, when I re-implement a test regime that uses a data file as the input instead of a network socket, which most may not have running. I also have immediate plans for new features, but I just wanted to get it up after 100% test coverage (locally) and 100% POD coverage so that I can see what it looks like on the CPAN.

    I've put together a tiny demo of some basic output below, but the information that can be extracted is quite extensive. The documentation explains all of the various attributes and how to get at them. It even shows how to extract the entire raw JSON data returned from the device, or that raw data after it's been converted into a Perl data structure.

    Tiny example. Of course in the real world, you'd put something like this in a loop, polling every second or whatever. Note that I've obfuscated the coordinates a tiny bit, but they are accurate right to my front door, literally:

    use warnings; use strict; use GPSD::Parse; my $gps = GPSD::Parse->new; $gps->poll; print "poll time: " . $gps->time . "\nlattitude: " . $gps->tpv('lat') . "\nlongitude: " . $gps->tpv('lon') . "\ndirection: " . $gps->tpv('track') . "\naltitude: " . $gps->tpv('alt') . "\n";

    I've also got this working in C on my Arduino Trinket Pro, which I'm going to use to make a hiking GPS so I can track my movements in the field.

    Here's the output. The altitude defaults to metres.

    poll time: 2017-05-17T00:48:16.000Z lattitude: 51.00000000 longitude: -114.000000000 direction: 324.87 altitude: 1084.9

    Here's a list of items you can fetch in regards to the TPV (Time Position Velocity):

    time => '2017-05-16T22:29:29.000Z' # date/time in UTC lon => '-114.000000000' # longitude lat => '51.000000' # latitude alt => '1084.9' # altitude (metres) climb => '0' # rate of ascent/decent (metres/sec) speed => '0' # rate of movement (metres/sec) track => '279.85' # heading (degrees from true north) device => '/dev/ttyS0' # GPS serial interface mode => 3 # NMEA mode epx => '3.636' # longitude error estimate (metres) epy => '4.676' # latitude error estimate (metres) epc => '8.16' # ascent/decent error estimate (meters) ept => '0.005' # timestamp error (sec) epv => '4.082' # altitude error estimate (meters) eps => '9.35' # speed error estimate (metres/sec) class => 'TPV' # data type (fixed as TPV) tag => 'ZDA' # identifier

    ...and information you can gather about the satellites you can see (using the satellites() method). Currently, after having the unit on for about 24 hours, I'm 'using' nine in total to pinpoint me:

    PRN => 16 # PRN ID of the satellite # 1-63 are GNSS satellites # 64-96 are GLONASS satellites # 100-164 are SBAS satellites ss => 20 # signal strength (dB) az => 161 # azimuth (degrees from true north) used => 1 # currently being used in calculations el => 88 # elevation in degrees
fun with induce
1 direct reply — Read more / Contribute
by daxim
on May 10, 2017 at 02:34
    use Kavorka qw(fun); use Scalar::Induce qw(induce void); fun repeat($val!, $times!) { induce { $_-- ? $val : void undef $_ } $times; } repeat('foo', 5); # ('foo', 'foo', 'foo', 'foo', 'foo') repeat({bar => 42}, 3); # 0 HASH(0x138be78) # bar => 42 # 1 HASH(0x138be78) # -> REUSED_ADDRESS # 2 HASH(0x138be78) # -> REUSED_ADDRESS fun range(:$from = 1, :$to!, :$step = 1) { induce { my $curr = $_; undef $_ if ($_ += $step) > $to; return $curr; } $from; } range(step => 1.1, from => 4, to => 17); # (4, 5.1, 6.2, 7.3, 8.4, 9.5, 10.6, 11.7, 12.8, 13.9, 15, 16.1) range(to => 7); # (1, 2, 3, 4, 5, 6, 7) fun partition($n!, @l!) { induce { my @part = splice @$_, 0, $n; undef $_ unless @$_; return \@part; } \@l } partition(3, qw(Aragorn Boromir Frodo Gandalf Gimli Legolas Merry Pipp +in Sam)); # ( # ['Aragorn', 'Boromir', 'Frodo'], # ['Gandalf', 'Gimli', 'Legolas'], # ['Merry', 'Pippin', 'Sam'] # ) fun factor($n!) { induce { for my $i (2..$_/2) { unless ($_ % $i) { $_ /= $i; return $i; } } my $curr = $_; undef $_; return $curr; } $n } factor(138600); # (2, 2, 2, 3, 3, 5, 7, 11)
Entity Tree for 2D isometric games
2 direct replies — Read more / Contribute
by holyghost
on May 09, 2017 at 02:42
    Hello, I've made a z-order speedy Game Entity Tree for use in 2D isometric view games. The thing is you can use an adapter on the tree and use references to alleviate the algorithm. You make lists of entities which get drawn when descending in the balanced tree, a key value is the depth of e.g. the house entities on a background. If you want a more OOP tree, you can use leaf and node tags, consed to data and check these before returning data from e.g. a leaf.
    ### Copyright (C) The Holy Ghost 2017 ###This program is released under the GPL 3.0 and artistic license 2.0 +. use EntityTreeAdapter; package EntityTree; sub new { my ($class) = @_; my $self = { %nodes => {}, @data = (), @_ }; bless ($self, $class); } sub adapter { my ($class) = @_; return EntityTreeAdapter($self); } sub insert { my ($self, $key, $d) = shift; foreach my $k (keys $self->{nodes}) { if ($k == $key) { push ($self->{data}, $d); return $self->{data}; } if ($k > $key and $k < $key) { $self->nodes = {}; $self->{nodes}{$key} .= EntityTree->new->(data + => $d, nodes => $self->collect_nodes($self->nodes)); return $self->{data}; } else { @keys = keys $self->nodes; while (@keys) { $self->insert(pop(@keys), $d); } } } } ### Normally there are only 2 keys per node sub collect_nodes { my ($self, $collection) = shift; my @keys = keys $collection; my @values = values $collection; foreach my $k (@keys) { $collection .= ($k => pop(@values)); } return $collection; } ### depth-frist search sub search { my ($self, $key) = shift; for my $k (keys $self->{nodes}) { if ($self->{nodes}{$k} == $key) { return push ($self->{nodes}{$k}->search($key), + $self->{nodes}{$key}); } else { return $self->{nodes}{$k}->search($key); } } return (); } 1;
    ### Copyright (C) The Holy Ghost 2017 ###This program is released under the GPL 3.0 and artistic license 2.0 +. package EntityTreeAdapter; sub new { my ($class) = @_; my $self = { $tree = shift, @_ }; bless ($self, $class); } sub insert { return $self->{tree}->insert($key, $d); } sub search { return $self->{tree}->search($key); } 1;
    Holly
solve cubic equations
4 direct replies — Read more / Contribute
by no_slogan
on May 03, 2017 at 01:51
    Everybody knows the quadratic formula, which lets you solve this equation: a x2 + b x + c = 0. Turns out it's not hard to solve when there's also an x3 term. There are either one or three solutions. This algorithm makes me happy.
    use constant pi => 3.141592653589793; sub cubic { # solve a cubic equation in the form # x^3 + a x^2 + b x + c = 0 my ($a, $b, $c) = @_; my $q = $a*$a/9 - $b/3; my $r = ($a*$a/27 - $b/6)*$a + $c/2; my $s = $a / -3; my $d = $r*$r - $q*$q*$q; if ($d > 0) { my $t = (sqrt($d) + abs($r)) ** (1/3); my $u = ($t + $q / $t); return $r > 0 ? $s - $u : $s + $u; } else { my $t = atan2(sqrt(-$d), $r) / 3; my $u = 2 * sqrt($q); # $d <= 0 implies $q >= 0 return ( $s - $u * cos($t), $s - $u * cos($t + 2/3*pi), $s - $u * cos($t - 2/3*pi), ); } }
Prima + MCE::Hobo demonstration
4 direct replies — Read more / Contribute
by marioroy
on Apr 29, 2017 at 03:03

    Respected Monks,

    Starting with MCE 1.828 and MCE::Shared 1.825, running MCE with Prima is possible. The following is based on the Tk + MCE::Hobo demonstration (2nd example in the post). I tested Prima + MCE on Linux using CentOS 7.x and Windows with Strawberry Perl 5.22.x.

    use strict; use warnings; use MCE::Hobo; use MCE::Shared; use Prima qw( Application Buttons Label ); my $que = MCE::Shared->queue(); my $msg = MCE::Shared->scalar("Start"); my $hobo = MCE::Hobo->create("bg_task"); my $wm = Prima::MainWindow->new( size => [ 250, 200 ], text => 'Hello world!', onDestroy => \&quit ); my $lbl1 = Prima::Label->create( owner => $wm, size => [ 220, 50 ], text => 'Prima + MCE Demo', alignment => ta::Center, valignment => ta::Middle, pack => {} ); my $btn1 = Prima::Button->new( owner => $wm, size => [ 120, 50 ], text => $msg->get, onClick => \&fun, pack => {} ); my $btn2 = Prima::Button->new( owner => $wm, size => [ 120, 50 ], text => 'Quit', onClick => sub { $::application->close }, pack => {} ); my $timer = Prima::Timer->create( timeout => 100, onTick => sub { my $new_text = $msg->get; if ($new_text ne $btn1->text) { $btn1->set( text => $msg->get ); } } ); $timer->start; run Prima; sub fun { $que->enqueue("some event"); return; } sub quit { $timer->stop; $hobo->exit->join; $::application->close; } sub bg_task { while ( my $event = $que->dequeue ) { $msg->set("Step One"); sleep 1; $msg->set("Step Two"); sleep 1; $msg->set("Step Three"); } }

    So that the quit function isn't called twice, I'm only calling $::application->close inside the Quit handler. That closes the window which then triggers the MainWindow's onDestroy handler.

    Regards, Mario

    Update: Updated the timer handler. Thanks zentara.

    Update: On the Mac, mouse clicks between windows is greatly improved by setting an option in XQuartz -> Preferences -> Windows -> Click-through Inactive Windows. When enabled, clicking on an inactive window will cause that mouse click to pass through to that window in addition to activating it.

    Update: To improve performance on the Mac, set XQuartz -> Preferences -> Output -> Colors to Thousands. Then relaunch XQuartz for the option to take effect. Prima for the most part runs very well. Thank you, Dmitry.

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.

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 browsing the Monastery: (8)
    As of 2017-05-23 12:00 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?