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

CUFP's
Does hash contain minimum keys?
2 direct replies — Read more / Contribute
by GotToBTru
on Nov 11, 2016 at 12:17

    Testing a hash to see if it has values for all required keys. Extraneous keys are okay.

    use strict; use warnings; use Test::More tests => 3; my (%required,%over,%under,%partial); $required{$_} = 1 for qw/header detail trailer/; $over{$_} = $_ for qw/title header subject detail trailer postscript/; $under{$_} = $_ for qw/header trailer/; $partial{$_} = $_ for qw/header trailer/; $partial{detail} = undef; ok(test_it(%over),'checking %over for required keys'); ok(test_it(%under),'checking %under for required keys'); ok(test_it(%partial),'checking %partial for required keys'); sub test_it { my %h = @_; # return (grep {$required{$_} && $h{$_}} keys %h) == (keys %required) +; return (grep {$required{$_} && defined $h{$_}} keys %h) == (keys %r +equired); }

    Update: use of defined suggested by choroba. I would have run into this because 0 is a value I would encounter.

    But God demonstrates His own love toward us, in that while we were yet sinners, Christ died for us. Romans 5:8 (NASB)

extracting strings from non-text files
2 direct replies — Read more / Contribute
by RonW
on Oct 20, 2016 at 21:09

    A coworker (on MS Windows) was cursing he couldn't see what symbol names might be hidden in a non-text configuration file for a proprietary, 3rd party tool he has to use. Since I didn't want to risk being constantly asked to "dump symbols" using my Lunix system, I took a few minutes to write the following program in Perl. Made him happy (for now, at least).

    Note: The tool being used only supports ASCII characters, so I didn't bother with encodings. Probably didn't need to specify ":bytes" in the open statement, but no harm in doing so.

    Maybe others will find this useful.

    #!perl use 5.010_000; use warnings; use strict; if ((@ARGV < 1)) { $0 =~ m#([^\\/]+$)#; my $name = $1 // $0; print STDERR "$name file ...\n" . <<'_DESCRIPTION_'; Extract ASCII strings from files listed. Multiple files allowed. _DESCRIPTION_ exit 1; } for my $file (@ARGV) { open my $fh, '<:bytes', $file or die "Error: Can't open '$file': $ +!\n"; my $buf; while (read $fh, $buf, 1024) { my @strings = split /\P{PosixGraph}/, $buf; for (@strings) { next if /^\s*$/; print "$_\n"; } } }
Fasta benchmark with multi-core processing via MCE
No replies — Read more | Post response
by marioroy
on Oct 17, 2016 at 01:01

    The following is a parallel demonstration for the fasta benchmark on the web. It runs nearly 3x faster versus the original code.

    Although nothing is relayed between workers, the relay capabilities in MCE is helpful for running a section of code orderly. A shared-scalar variable is used for retaining the $LAST value between chunks and subsequent runs.

    # perl fasta.pl 25000000 # The Computer Language Benchmarks game # http://benchmarksgame.alioth.debian.org/ # # contributed by Barry Walsh # port of fasta.rb #6 # # MCE version by Mario Roy use strict; use warnings; use feature 'say'; use MCE; use MCE::Candy; use MCE::Shared; use constant IM => 139968; use constant IA => 3877; use constant IC => 29573; my $LAST = MCE::Shared->scalar(42); my $alu = 'GGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGG' . 'GAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGA' . 'CCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAAT' . 'ACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCA' . 'GCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGG' . 'AGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCC' . 'AGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAA'; my $iub = [ [ 'a', 0.27 ], [ 'c', 0.12 ], [ 'g', 0.12 ], [ 't', 0.27 ], [ 'B', 0.02 ], [ 'D', 0.02 ], [ 'H', 0.02 ], [ 'K', 0.02 ], [ 'M', 0.02 ], [ 'N', 0.02 ], [ 'R', 0.02 ], [ 'S', 0.02 ], [ 'V', 0.02 ], [ 'W', 0.02 ], [ 'Y', 0.02 ] ]; my $homosapiens = [ [ 'a', 0.3029549426680 ], [ 'c', 0.1979883004921 ], [ 'g', 0.1975473066391 ], [ 't', 0.3015094502008 ] ]; sub make_repeat_fasta { my ($src, $n) = @_; my $width = qr/(.{1,60})/; my $l = length $src; my $s = $src x (($n / $l) + 1); substr($s, $n, $l) = ''; while ($s =~ m/$width/g) { say $1 } } sub make_random_fasta { my ($table, $n) = @_; my $rand = undef; my $width = 60; my $prob = 0.0; my $output = ''; my ($c1, $c2, $last); $_->[1] = ($prob += $_->[1]) for @$table; $c1 = '$rand = ($last = ($last * IA + IC) % IM) / IM;'; $c1 .= "\$output .= '$_->[0]', next if $_->[1] > \$rand;\n" for @$ +table; my $code1 = q{ my ($mce, $seq, $chunk_id) = @_; # process code-snippet orderly between workers MCE->relay_recv; my $last = $LAST->get; my $temp = $last; # pre-compute $LAST for the next worker for (1 .. ($seq->[1] - $seq->[0] + 1) * $width) { $temp = ($temp * IA + IC) % IM; } $LAST->set($temp); MCE->relay; # process code-snippet in parallel for ($seq->[0] .. $seq->[1]) { for (1..$width) { !C! } $output .= "\n"; } # gather output orderly MCE->gather($chunk_id, $output); $output = ''; }; $code1 =~ s/!C!/$c1/g; MCE->new( bounds_only => 1, chunk_size => 2000, init_relay => 0, max_workers => 4, ## MCE::Util->get_ncpu || 4, sequence => [ 1, ($n / $width) ], gather => MCE::Candy::out_iter_fh(\*STDOUT), user_func => sub { eval $code1; }, use_threads => 0, )->run; $last = $LAST->get; $c2 = '$rand = ($last = ($last * IA + IC) % IM) / IM;'; $c2 .= "print('$_->[0]'), next if $_->[1] > \$rand;\n" for @$table +; my $code2 = q{ if ($n % $width != 0) { for (1 .. $n % $width) { !C! } print "\n"; } }; $code2 =~ s/!C!/$c2/g; eval $code2; $LAST->set($last); } my $n = $ARGV[0] || 27; say ">ONE Homo sapiens alu"; make_repeat_fasta($alu, $n*2); say ">TWO IUB ambiguity codes"; make_random_fasta($iub, $n*3); say ">THREE Homo sapiens frequency"; make_random_fasta($homosapiens, $n*5);

    Regards, Mario.

Devel::Trace - TODOs done, trace per package
1 direct reply — Read more / Contribute
by shmem
on Oct 14, 2016 at 14:23

    Today, moritz asked on IRC whether there was anything like Devel::Trace on a package / namespace basis. I had never used this module before, installed it, looked at the code - hey nifty! - and whipped up the patch in a few minutes, it's just a few lines of code. Later, I looked at the TODO section and did do them, too.

    Dominus, being a busy man, might or not apply the patch I sent him, so I am leaving this here as a drop-in replacement, complete with the updated POD section. Comments welcome, enjoy ;-)

    <update>
    There are always bits to improve...

    - add statement modifier to $TRACE $FH $FORMAT @ORDER since they might have already been set
    e.g. like so:
    package yDebug; BEGIN { $file = 'trace.out'; # disable tracing while setting things up $Devel::Trace::TRACE = 0; } sub import { shift; $file = shift if @_ } CHECK { $Devel::Trace::FORMAT = "# line %d %s: %s"; @Devel::Trace::ORDER = (2,0,3); open MYFH, '>', $file or die "open '$file': $!"; $Devel::Trace::FH = *MYFH; # enable tracing for package Foo $Devel::Trace::PKG{Foo}++; # done, enable tracing $Devel::Trace::TRACE = 1; } 1;

    Calling perl -d:Trace -MyDebug foo.pl will restore STDERR and log the trace lines nicely to trace.out or to somefile using -MyDebug=somefile.

    Of course these bits could have also been handled within Devel::Trace, but that would require changes to its import() semantics, which change is forbidden for a drop-in replacement.
    But why yDebug.pm? well, because -MMyDebug looks like stuttering ;-)
    </update>

    perl -le'print map{pack c,($-++?1:13)+ord}split//,ESEL'
Spectral-Norm benchmark with multi-core processing via MCE
No replies — Read more | Post response
by marioroy
on Oct 13, 2016 at 02:16

    The following demonstrations show-case the use of MCE for the spectral-norm benchmark on the web. Both run on Perl compiled without threads support. The MCE::Hobo example largely resembles the threads version by Mykola Zubach.

    MCE::Map

    # perl spectral-norm.pl 5500 # output: 1.274224153 # The Computer Language Benchmarks Game # http://benchmarksgame.alioth.debian.org/ # # Contributed by Andrew Rodland # modified by R. Jelinek # multicore by Mykola Zubach # MCE::Map version by Mario Roy use strict; use MCE::Map; my $n = shift || 500; my $cpus = 4; ## MCE::Util->get_ncpu() || 4; MCE::Map->init( max_workers => $cpus, chunk_size => int(($n - 1) / $cpus) + 1, ); my @v = multiplyAtAv( multiplyAtAv( multiplyAtAv((1) x $n) ) ); my @u = multiplyAtAv(@v); my ($i, $vBv, $vv) = (0); for my $v (@v) { $vBv += $u[$i++] * $v, $vv += $v ** 2; } printf "%0.9f\n", sqrt($vBv / $vv); MCE::Map->finish(); sub multiplyAtAv { return multiplyAtv(multiplyAv(@_)); } sub eval_A { use integer; my $div = (($_[0] + $_[1]) * ($_[0] + $_[1] + 1) >> 1) + $_[0] + 1 +; no integer; 1 / $div; } sub multiplyAv { my @data = @_; return mce_map_s { my ($i, $sum) = ($_); $sum += eval_A($i, $_) * $data[$_] for (0 .. $#data); $sum; } 0, $#data; } sub multiplyAtv { my @data = @_; return mce_map_s { my ($i, $sum) = ($_); $sum += eval_A($_, $i) * $data[$_] for (0 .. $#data); $sum; } 0, $#data; }

    MCE::Hobo

    # perl spectral-norm.pl 5500 # output: 1.274224153 # The Computer Language Benchmarks Game # http://benchmarksgame.alioth.debian.org/ # # Contributed by Andrew Rodland # modified by R. Jelinek # multicore by Mykola Zubach # MCE::Hobo version by Mario Roy use strict; use MCE::Hobo; my $cpus = 4; ## MCE::Util->get_ncpu() || 4; my $n = shift || 500; my @v = multiplyAtAv( multiplyAtAv( multiplyAtAv((1) x $n) ) ); my @u = multiplyAtAv(@v); my ($i, $vBv, $vv) = (0); for my $v (@v) { $vBv += $u[$i++] * $v, $vv += $v ** 2; } printf "%0.9f\n", sqrt($vBv / $vv); sub multiplyAtAv { return multiplyAtv(multiplyAv(@_)); } sub eval_A { use integer; my $div = (($_[0] + $_[1]) * ($_[0] + $_[1] + 1) >> 1) + $_[0] + 1 +; no integer; 1 / $div; } sub multiplyAv { my($begin, $end, @procs); my $chunk = int($#_ / $cpus) + 1; for($begin = 0; $begin < $#_; $begin = $end + 1) { $end = $begin + $chunk; $end = $#_ if $end > $#_; push @procs, MCE::Hobo->create( sub { my $begin = shift; my $end = shift; return map { my ($i, $sum) = ($_); $sum += eval_A($i, $_) * $_[$_] for (0 .. $#_); $sum; } ($begin .. $end); }, $begin, $end, @_); } return map $_->join, @procs; } sub multiplyAtv { my($begin, $end, @procs); my $chunk = int($#_ / $cpus) + 1; for($begin = 0; $begin < $#_; $begin = $end + 1) { $end = $begin + $chunk; $end = $#_ if $end > $#_; push @procs, MCE::Hobo->create( sub { my $begin = shift; my $end = shift; return map { my ($i, $sum) = ($_); $sum += eval_A($_, $i) * $_[$_] for (0 .. $#_); $sum; } ($begin .. $end); }, $begin, $end, @_); } return map $_->join, @procs; }

    Regards, Mario.

cpanr - view cpan ratings from the command line
2 direct replies — Read more / Contribute
by marto
on Oct 05, 2016 at 06:41

    A while ago I threw together a short proof of concept script to display reviews from cpanratings on the command line, based upon Re^8: Switch and some subsequent discussions.

    Install WWW::Mechanize & Mojo::DOM, save the code below and run it as follows:

    $ cpanr Path::Tiny Reviews for Path::Tiny Reviewer: Michiel Beijen Review date: 2014-12-17 @ 03:13:06 Module version: 0.061 Rating: 5/5 Comment: I really, REALLY like this module. It makes managing files so + much easi er. Just opening them, reading them into a scalar or array, printing t +hem out. O f course it STARTED out as a true ::Tiny module but as seems to happen + with thos e it is now not so Tiny anymore, it even has support for stuff on plat +forms as A IX and such. I wrote a platform for managing Video on Demand files and + had to lo ad and process a whole lot of XML metadata files, images, and videos. +I used thi s module extensively to crawl directories, read files and so on. It ha +s helped m e a lot writing code faster while also making my code much easier to r +ead and ma intain. Thanks a LOT for this module! Reviewer: Keedi Kim Review date: 2013-11-21 @ 18:34:22 Module version: 0.044 Rating: 5/5 Comment: Awesome module. I can't believe this is tiny module. It has a +lmost ever ything related in file and directory. It doesn't have another dependen +cy except core modules just as you expected. And documentation is very detailed +and has ma ny examples. There is no reason not to use this module at all.

    cpanr

    #!/usr/bin/perl use strict; use warnings; use Mojo::DOM; use WWW::Mechanize; =head1 NAME cpanr - View cpan ratings from the command line. =head1 SYNOPSIS This script displays content from cpan ratings L<http://cpanratings.pe +rl.org> on the command line. Simply call it with the module name: $ cpanr Path::Tiny Reviewer: Michiel Beijen Review date: 2014-12-17 @ 03:13:06 Module version: 0.061 Rating: 5/5 Comment: I really, REALLY like this module. It makes managing files +so much easi er. Just opening them, reading them into a scalar or array, printing + them out. O f course it STARTED out as a true ::Tiny module but as seems to happ +en with thos e it is now not so Tiny anymore, it even has support for stuff on pl +atforms as A IX and such. I wrote a platform for managing Video on Demand files a +nd had to lo ad and process a whole lot of XML metadata files, images, and videos +. I used thi s module extensively to crawl directories, read files and so on. It +has helped m e a lot writing code faster while also making my code much easier to + read and ma intain. Thanks a LOT for this module! .... This short script was written in a few minutes based upon L<http://perlmonks.org/index.pl?node_id=1169281> and subsequent discus +sions just for fun. =cut my ($module) = @ARGV; unless ($module){ print "Usage: $0 Module::Name\n"; }else{ my $ratingsURL = 'http://cpanratings.perl.org/dist/'; print "Reviews for $module\n\n"; $module =~ s/::/-/g; $ratingsURL .= $module; my $mech = WWW::Mechanize->new(); $mech->get($ratingsURL); my $dom = Mojo::DOM->new($mech->content()); unless ( $dom->find('.review')->each ){ print "Can't find any reviews for $module\n"; } for my $review ($dom->find('.review')->each){ my $reviewer = $review->find('p.review_attribution a')->map('t +ext')->first; print "Reviewer: $reviewer\n"; my $reviewdate = $review->find('p.review_attribution')->map('t +ext')->first; $reviewdate =~ s/- //; $reviewdate =~ s/T/ @ /; $reviewdate =~ s/\( \)//g; print "Review date: $reviewdate\n"; my $moduleversion = $review->find('h3.review_header')->map('te +xt')->first; $moduleversion =~ s/(\)|\()//g; print "Module version: $moduleversion\n"; my $stars = $review->find('img')->map(attr => 'alt')->first; print 'Rating: ' . length( $stars ) . "/5\n"; my $comment = $review->find('.review_text')->map('text')->firs +t; print "Comment: $comment\n\n"; } }
EDI File Parsing Helps
No replies — Read more | Post response
by GotToBTru
on Sep 21, 2016 at 13:13

    Decompose ANSI X12 transmission into individual documents.

    use strict; use warnings; use Data::Dumper; my $ediFile = shift; my ($contents,$delim,$term,$txnCount,@transactions); { $/ = undef; open my $ifh,'<',$ediFile; $contents = <$ifh>; } ($delim,$term) = $contents =~ m/^ISA(.).{101}(.)/; $delim = quotemeta($delim); @transactions = $contents =~ m/(ST$delim.+?SE$delim\d+$delim\d+$term)/ +gs; ($txnCount) = $contents =~ m/${term}GE$delim(\d+)/; die "Parse error - transaction counts wrong" if ($txnCount != scalar @transactions); foreach my $transaction (@transactions) { # put into useful form for processing my @segments = split /$term/,$transaction; my ($segCount) = $transaction =~ m/${term}SE$delim(\d+)/; die "Parse error - segment counts wrong" if ($segCount != scalar @segments); my ($process_this); map { push @$process_this, [split /$delim/,$_] } @segments; print Dumper(\$process_this); }

    EDI File:

    ISA*00* *00* *02*AAAA *01*123456789 * +160921*075 1*U*00401*000099836*0*P*:~GS*FA*AAAA*123456789*20160921*0751*99836*X*0 +04010~ST*9 97*998360001~AK1*SM*7311~AK9*A*1*1*1~SE*4*998360001~ST*997*998360002~A +K1*SM*7312 ~AK9*A*1*1*1~SE*4*998360002~GE*2*99836~IEA*1*000099836~

    Output:

    $VAR1 = \[ [ 'ST', '997', '998360001' ], [ 'AK1', 'SM', '7311' ], [ 'AK9', 'A', '1', '1', '1' ], [ 'SE', '4', '998360001' ] ]; $VAR1 = \[ [ 'ST', '997', '998360002' ], [ 'AK1', 'SM', '7312' ], [ 'AK9', 'A', '1', '1', '1' ], [ 'SE', '4', '998360002' ] ];
    But God demonstrates His own love toward us, in that while we were yet sinners, Christ died for us. Romans 5:8 (NASB)

extract (a range of) numbered lines from a file
4 direct replies — Read more / Contribute
by shmem
on Sep 19, 2016 at 16:49

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

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

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

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

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

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

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

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

    : r ! l 1234-1500

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

    perl -le'print map{pack c,($-++?1:13)+ord}split//,ESEL'
XML::Parser Namespace example
No replies — Read more | Post response
by GotToBTru
on Aug 31, 2016 at 11:57

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

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

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

    #!/home/edi/perl/perl use strict; use warnings; use XML::Parser; my $parser = new XML::Parser( Handlers => { Start => \&hdl_start, End => \&hdl_end, Char => \&hdl_char, Default => \&hdl_def, }, Namespaces => 1); my (%message,$element); my %interesting = map { $_, 1 } qw/shipmentStatus responseToLoadTender customerIdentifier proNum lo +adTenderId eventType eventDate eventTime city seqnum customerId segme +ntId action date/; my $file = shift; $message{file} = $file; $parser->parsefile($file); #print "Placeholder\n"; sub hdl_start { my ($p,$elt,%attr) = @_; $element = $elt; } sub hdl_end { my ($p, $elt) = @_; return unless $interesting{$elt}; if ($elt eq 'shipmentStatus') { if ($message{eventType} !~ m/X6/ ) { printf "%-20s: %s\n", $_, $message{$_} for qw/file proNum loadTenderId city seqnum eventType eventDate + eventTime/; print "\n"; } } if ($elt eq 'responseToLoadTender') { printf "%-20s: %s\n", $_, $message{$_} for qw/file segmentId loadTenderId action date/; print "\n"; } } sub hdl_char { my ($p, $str) = @_; return unless $interesting{$element}; $message{$element} .= $str; } sub hdl_def {}
    But God demonstrates His own love toward us, in that while we were yet sinners, Christ died for us. Romans 5:8 (NASB)

Battleship solitaire puzzle generator
1 direct reply — Read more / Contribute
by toolic
on Aug 29, 2016 at 15:11

    What

    This is a battleship solitaire puzzle generator. It creates a puzzle grid with a random number of clues. It also can display the corresponding puzzle solution. The solution has 10 ships on a 10x10 grid.

    Why

    Mostly because I felt like it. Also because I could not find anything that already existed online to easily do exactly what I wanted. There are some puzzle generators available which have GUI's with nice features, but they limit you to one puzzle per week (or month, or whatever), and it is difficult to annotate hard puzzles on the screen. This generator allows you to play as many puzzles as you want and to print them on paper to make annotations.

    How

    Run the generator and redirect the output to a file. You can edit the file and fill in the ships directly in your editor. Or, you can print the file onto a piece of paper. Alternately, you could redirect the CSV output to a file, then use the conversion script to create an Excel file. Then you can complete the puzzle in Excel or print the Excel file onto paper.

    Status

    Consider this alpha code. Since I did not create any tests to automatically check the code, there are likely bugs. The approach is probably naive, and the ASCII representation is ugly. Any suggestions for improvements are welcome.

    Code for generator

    Code for Excel conversion

redirecting Molicious app to https
No replies — Read more | Post response
by Ea
on Aug 25, 2016 at 10:03
    (Quick post)

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

    1. Run 2 webservers: one to handle http and the other to handle https, which for me is two incantations of hypnotoad
    2. Add a route in your http App
      $r->get('/login')->to('MyApp#https_redirect');
    3. Add a sub to the http Controller
      sub https_redirect { my $self = shift; my $secure = $self->req->url->to_abs->scheme('https')->port(443); $self->redirect_to($secure); }
    4. Profit!

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

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

    Sometimes I can think of 6 impossible LDAP attributes before breakfast.

    http://act.yapc.eu/lpw2016/ It's that time of year again!

Displaying my PM post count and XP on an LCD with RPi::WiringPi
2 direct replies — Read more / Contribute
by stevieb
on Aug 24, 2016 at 20:50

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

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

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

    p: 1293 18:15 x: 10361

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

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

    Pics: before button press, and after button press.

    use warnings; use strict; use LWP::Simple; use RPi::WiringPi; use RPi::WiringPi::Constant qw(:all); # catch a sigint. This allows us to # safely exit the while() loop and perform # emergency LCD/pin cleanup. The main class # catches die() my $continue = 1; $SIG{INT} = sub { $continue = 0; }; # initialize a Raspberry Pi object using the # BCM GPIO pin numbering scheme my $pi = RPi::WiringPi->new(setup => 'gpio'); # prepare and initialize the LCD my $lcd = $pi->lcd; # the following list of args looks daunting, but # it's very straightforward, and the docs are # pretty clear my %args = ( cols => 16, rows => 2, bits => 4, rs => 21, strb => 16, d0 => 12, d1 => 25, d2 => 24, d3 => 23, d4 => 0, d5 => 0, d6 => 0, d7 => 0, ); $lcd->init(%args); # set up a pin with a button, and set an # interrupt handler to do something when # the button is pressed my $button_pin = $pi->pin(26); # we're going to interrupt when the pin # goes LOW (off), so we'll pull it HIGH # with the built-in pull up resistor. # only when the button is pressed, will the # pin briefly go LOW, and this triggers # an interrupt $button_pin->pull(PUD_UP); # the second arg to interrupt_set() is the # name of the perl sub I've defined below # that I want handling the interrupt $button_pin->interrupt_set( EDGE_FALLING, 'button_press' ); my $button_presses = 0; my ($posts, $xp, $next); while ($continue){ my ( $sec,$min,$hour,$mday,$mon, $year,$wday,$yday,$isdst ) = localtime(); $min = "0$min" if length $min == 1; # get my post and xp count from PM ($posts, $xp) = perlmonks(); # manually get xp needed for next level $next = 12000 - $xp; # set the LCD cursor to top row, first # column, and print my num of PM posts $lcd->position(0, 0); $lcd->print("p: $posts"); # sub for bottom line, because the # code needs to be called also in our # interrupt handler. What's printed depends # on the cumulative number of button presses display_xp(); # on top row of the LCD at column 12, # we print the time $lcd->position(11, 0); $lcd->print("$hour:$min"); print "$hour:$min posts: $posts, " . "xp: $xp, next lvl: $next\n"; # rinse, repeat every minute sleep 60; } # wipe the LCD clean $lcd->clear; # reset pins to default state $pi->cleanup; sub button_press { # this is the interrupt handler print "button pressed\n"; $button_presses++; display_xp(); } sub display_xp { # this is the manager for the bottom LCD # row. It'll update things even when the # main program is sleeping in the while() # loop # print XP for 0 and even number of button # presses, and print XP remaining to next level # on odd number of presses $lcd->position(0, 1); if ($button_presses % 2){ $lcd->print("r: $next"); } else { $lcd->print("x: $xp"); } } sub perlmonks { my $url = "http://perlmonks.org/?node_id=789891"; my $page = get $url; my @content = split /\n/, $page; my ($xp, $posts); my $i = 0; for (@content){ if (/Experience:/){ my $line = $i; $line += 2; $xp = $1 if $content[$line] =~ /(\d+)/; } if (/Writeups:/){ my $line = $i; $line += 2; $posts = $1 if $content[$line] =~ />(\d+)/; } $i++; } return ($posts, $xp); }

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

Raspberry Pi wiringPi API wrapper released
2 direct replies — Read more / Contribute
by stevieb
on Aug 16, 2016 at 15:06

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

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

    wiringPi is a set of C libraries that allow you to muck with a Raspberry Pi, it's GPIO pins, drive LCDs and many other things.

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

    use WiringPi::API qw(:wiringPi);
    ...import the renamed Perl functions:
    use WiringPi::API qw(:perl);
    ...or use the module in the normal OO way:
    use WiringPi::API; my $wpi = WiringPi::API->new;

    Here's but a few of the features:

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

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

    This was also posted here.

Elasticsearch and ntopng
1 direct reply — Read more / Contribute
by QuillMeantTen
on Aug 11, 2016 at 13:49

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

    1. Ntopng did the monitoring
    2. Elasticsearch retained ntopng logs for easy retrieval and analysis (one month were retained given the number of flows)
    3. Kibana was used for visualisation
    My orders were quite simple, they needed a network probe that would "just work", they needed a nice way to display the probe's data on any computer inside the department AND on the nice big screen in the IT den.

    Once the setup and the documentation was done I started writing a script to automate as many thing as I could. Namely database export, backup and restoration, service monitoring, interface monitoring (I spent a day wondering WHY an interface would go down by itself until someone told me that a maintenance crew did some voodoo on the routers and unplugged things) and such.
    So here is the code, I hope it will be useful to you, since I had most of en ELK stack there (except for the Logstash part) this script should be easily adapted to other situations.

Solution to A simple but difficult arithmetic puzzle
4 direct replies — Read more / Contribute
by talexb
on Aug 11, 2016 at 03:16

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

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

    Thanks mjd!

    Alex / talexb / Toronto

    Thanks PJ. We owe you so much. Groklaw -- RIP -- 2003 to 2013.


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.