Beefy Boxes and Bandwidth Generously Provided by pair Networks
go ahead... be a heretic
 
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
Reading from an HC-SR04 ultrasonic distance sensor on the Raspberry Pi
1 direct reply — Read more / Contribute
by stevieb
on Jan 13, 2017 at 17:38

    I've completed another Raspberry Pi related distribution, RPi::HCSR04. This one allows you to use Perl to read data from the HC-SR04 ultrasonic distance sensor.

    It's trivial to use, however, because it uses wiringPi internally, your scripts require root privileges.

    use warnings; use strict; use feature 'say'; use RPi::HCSR04; my $trig_pin = 23; my $echo_pin = 24; my $sensor = RPi::HCSR04->new($trig_pin, $echo_pin); # each call is a separate poll say $sensor->raw; say $sensor->cm . " cm"; say $sensor->inch . " \"";

    Output:

    634 10.915135593358 cm 4.29729747772217 "

    There's still a bit more work I have to do (catch out-of-range measurements etc), but it works pretty well and is surprisingly accurate.

    Note that per the documentation, the HC-SR04 requires 5v in, and also returns 5v from the ECHO pin back to the Pi's GPIO (which only handles 3.3v), so a voltage regulator or voltage divider is required to limit the voltage to a healthy 3.29v. I opted for the divider while writing the software. Here's a diagram depicting how I achieved that.

    Next up, a SN74HC595 shift register, as I need it to continue to work on the other various projects I have going on. I've almost completed the dist for the BMP180 barometric/altimeter sensor, as well as the MCP300x series analog-to-digital converters.

Perl interface to analog inputs on the Raspberry Pi
2 direct replies — Read more / Contribute
by stevieb
on Jan 11, 2017 at 11:16

    Over the last few months, I've been writing Perl modules/distributions to interact with a Raspberry Pi, its GPIO, and external hardware/devices. My primary objective is to create a complete indoor grow room automation system.

    The past week and a half, I have been focusing on writing a distribution that provides Perl users a way to interact with Adafruit's ADS1xxx Analog to Digital Converters (ADC), so that I could communicate with analog devices via the Pi which does not have any analog inputs. Hence, RPi::ADC::ADS was born.

    The vast majority of functionality specified in the unit's datasheet has been incorporated into this XS-based module, and the documentation outlays all of the critical pieces from the hardware docs.

    Features:

    • operates on the i2c bus, can connect four units simultaneously for a total of 16 analog inputs
    • ability to access all four channels on each ADC
    • continuous and single conversion modes
    • all eight Data Rate settings available
    • ability to change comparator polarity
    • ability to modify the comparator queue
    • all programmable gain amplifier modes available
    • ability to operate in single-ended mode or differential mode**
    • ability to return either the input data as raw, as a percentage, or as voltage
    • very easy to configure and run; most users won't have to set any parameters or call any configuration methods; the defaults are very sane
    • the documentation is extensive and detailed, but easy to understand and laid out reasonably well (I hope)
    • it has zero dependencies, Perl or otherwise (well, other than the need for a C compiler for the XS file)
    • works with any ADS1xxx model, and will properly bit-shift according to whether we're on a 16-bit wide resolution model, or a 12-bit one

    ** - single-ended mode is the measurement of voltage of a single input relative to ground. Differential mode retrieves the voltage difference between two separate inputs.

    Here's a basic example, and for the most part, exactly how I use the software. Say I have a moisture sensor connected to analog input A0 (0 as far as the software is concerned) and I want to get the moisture level from it:

    use warnings; use strict; use RPi::ADC::ADS; my $adc = RPi::ADC::ADS->new; my $v = $adc->volts; my $p = $adc->percent; my $r = $adc->raw;

    Volts is a floating point number, percent is a float chopped at .2f and raw is the raw 16-bit unsigned int.

    If you have more than one channel active at a time, specify which channel you want to fetch from:

    # A0, A1 and A3 input channels for (0, 1, 3){ print $adc->percent($_) ."\n"; }

    All configuration register options can be changed on the fly, as they each have their own setter/getter. Say you are using two inputs (eg: A0 and A3) as single-ended inputs and at one point in code, you need to retrieve the value of the difference in levels between them. The documentation has a map for parameter value to hardware functionality for all settings. All fetch methods allow you to send in the channel to retrieve on the fly, so we don't have to do anything special here. Per the map in the docs above, either of these will work:

    my $diff_a0_a3 = $adc->percent(5); # or $adc->channel(5); my $diff_a0_a3 = $adc->percent;

    The software is quite complete, and I have tested the vast majority of the configuration settings. I'm about 85% test coverage so there's a bit more work to do there, but I digress.

    My next project is to write a Perl distribution for a BMP 180 barometric and altimiter sensor which I just bought and soldered yesterday, and an MCP3008 analog-digital converter. The 3008 has 10 input channels whereby the ADS only has four, but the ADS has 12-bit or 16-bit of resolution accuracy, where the MCP3008 only has 10-bit, so I decided I'd write code for both.

    See also:

    WiringPi::API, my original and nearly feature complete wrapper for the WiringPi libraries.

    RPi::WiringPi, OO interface for the above wrapper with error detection, safe exit on unexpected terminations, and more.

    RPi::DHT11, module to access the DHT11 temperature and humidity sensor.

    App::RPi::EnvUI, my Dancer2 and jQuery one-page app for indoor grow room control (not yet fully completed).

    RPi::WiringPi::Constant, module that contains commonly used names in the Raspberry Pi/electrical/electronics realm.

relink: Rewriting Symlinks with Perl
No replies — Read more | Post response
by haukex
on Jan 04, 2017 at 13:01

    Fellow Monks,

    I've just made the first public release of a tool I've been working on called relink (Update: it's GPLv3), and I wanted to tell you about it in the form of a short narrative, below. But first, just to whet your appetite:

    # Rewrite the targets of symlinks with Perl $ relink rewrite 's/foo/bar/' PATH(s) # Convert between absolute and relative targets $ relink abs2rel PATH(s) $ relink rel2abs PATH(s) # List links [only certain symlinks] $ relink list [-t '/foo/'] PATH(s)

    Regards,
    -- Hauke D

Drano - A tool for monitoring IBM POWER Series VIO Server NICs
No replies — Read more | Post response
by bpoag
on Dec 30, 2016 at 15:25
    We had a nasty performance bottleneck hit us about a year ago, one that we felt was sneaky enough to require some custom monitoring.. Hence the need for this script. Drano keeps tabs on a particular parameter of a NIC inside of a VIO server, and reports whether or not bandwidth choke may be occuring.
    #!/usr/bin/perl ## ## Drano v0.1 written 032415 by Bowie Poag ## ## Drano makes sure the pipes are clear by reporting when network buff +ers have been depleted. ## This script is designed to be run as root on a VIO server. ## ## It also requires a little tuning on your part -- Replace any instan +ce of "ent12" with the adapter of your choice. ## $DEBUG=0; $threshold=$ARGV[0] || 90; $problemTiny="NO"; $problemSmall="NO"; $problemMedium="NO"; $problemLarge="NO"; $problemHuge="NO"; print "\nDrano: Spinning up..\n"; print "Drano: Collecting netstat dump..\n"; print "Drano:\n"; @netstatDump=`netstat -v ent12 2>/dev/null`; foreach $item (@netstatDump) { chomp($item); $item=~s/^\s+//g; if ($item=~/Max Buffers/) { print "Drano: $item\n"; $item=~s/\s+/ /g; @line=split(" ",$item); $maxTiny=$line[2]; $maxSmall=$line[3]; $maxMedium=$line[4]; $maxLarge=$line[5]; $maxHuge=$line[6]; } if ($item=~/Allocated/ && $item!~/Max/) { print "Drano: $item\n"; $item=~s/\s+/ /g; @line=split(" ",$item); $alcTiny=$line[1]; $alcSmall=$line[2]; $alcMedium=$line[3]; $alcLarge=$line[4]; $alcHuge=$line[5]; } } print "Drano:\n"; $DEBUG && print "MxT:[$maxTiny] MxS:[$maxSmall] MxM:[$maxMedium] MxL:[ +$maxLarge] MxH:[$maxHuge]\n"; $DEBUG && print "AlT:[$alcTiny] AlS:[$alcSmall] AlM:[$alcMedium] AlL:[ +$alcLarge] AlH:[$alcHuge]\n"; print "Drano: Analyizing buffer stats..\n"; print "Drano:\n"; $conTiny=sprintf("%-2.2f",($alcTiny/$maxTiny)*100); $conSmall=sprintf("%-2.2f",($alcSmall/$maxSmall)*100); $conMedium=sprintf("%-2.2f",($alcMedium/$maxMedium)*100); $conLarge=sprintf("%-2.2f",($alcLarge/$maxLarge)*100); $conHuge=sprintf("%-2.2f",($alcHuge/$maxHuge)*100); if ($conTiny > $threshold) { $problemTiny="YES"; } if ($conSmall > $threshold) { $problemSmall="YES"; } if ($conMedium > $threshold) { $problemMedium="YES"; } if ($conLarge > $threshold) { $problemLarge="YES"; } if ($conHuge > $threshold) { $problemHuge="YES"; } printf("%-16s %16s %16s %11s\n","Drano: Buffer Size","Consumption (%)" +,"Threshold (%)","Problem?"); printf("%-16s %16s %16s %11s\n","Drano: -----------","---------------" +,"-------------","--------"); printf("%-16s %16f %16f %11s\n","Drano: Tiny","$conTiny","$threshold", +"$problemTiny"); printf("%-16s %16f %16f %11s\n","Drano: Small","$conSmall","$threshold +","$problemSmall"); printf("%-16s %16f %16f %11s\n","Drano: Medium","$conMedium","$thresho +ld","$problemMedium"); printf("%-16s %16f %16f %11s\n","Drano: Large","$conLarge","$threshold +","$problemLarge"); printf("%-16s %16f %16f %11s\n","Drano: Huge","$conHuge","$threshold", +"$problemHuge"); print "Drano:\n"; if ($problemTiny ne "YES" && $problemSmall ne "YES" && $problemMedium +ne "YES" && $problemLarge ne "YES" && $problemHuge ne "YES") { print "Drano: Everything looks fine. All your buffer consumpti +on percentages are below the given threshold of $threshold"."%".".\n" +; } else { print "Drano: Looks like you've run out of network buffers on +one or more fronts. Time to tune up.\n"; system("logger Drano Warning - Partial network buffer overflow + detected. Network interface requires additional tuning."); }
Slice and dice a ref to hash
2 direct replies — Read more / Contribute
by teun-arno
on Dec 07, 2016 at 16:53
    No question here! Just want to show some code.
    $systems = { 'xai61001' => { # ref to hash ip => '192.168.1.1' , name => 'xai61001', model => '8205_E6C', }, 'xai61002' => { # ref to hash name => 'xai61002', model => '9119_MME', ip => '192.168.1.2' , }, }; $merge = { 'xai61001' => { # ref to hash description => 'Dit is een test voor xai61001', ibm_description => 'IBM system power 8 xai61001', }, 'xai61002' => { # ref to hash description => 'Dit is een test voor xai61002', ibm_description => 'IBM system power 8 xai61002', }, }; #Most examples I've found on the internet are speaking about "normal" +hashes!! #Wanted to be able to process a scalar pointing to a hash. # this is perl5 , Not perl6. Yes still struggling with it's syntax!! ##################################################################### # sliceAndDice a ref to a hash, in the end you can determine the order + in which a hash is displayed!! # I created 2 arrays which have the same order. Could be expensive whe +n processing a large hash_ref. # $sys = 'xai61002'; # entrie of the $systems HASH! print "$systems->{$sys}\n"; # HASH(0xnumber} print "$systems->{$sys}{ip}\n"; # ip address @keys = ( qw/ip name model/ ); # hardcoded the order of the keys!! print keys %{$systems->{$sys}},"\n"; # the normal way to get at the k +eys @values = @{$systems->{$sys}}{@keys} ; # getting the at the values, i +n the order of @keys # the above is processing a hash ( looks like an A +RRAY, but is NOT ) #print @keys, @values,"\n"; print "\n\nOriginal hash_ref\n"; for $idx ( 0 .. $#keys ) { print "$keys[$idx] => $values[$idx]\n"; } # adding some keys and values, please notice : This is adding to a has +h!! (which is a scalar reference) # the keys in $systems and $merge must be THE SAME $systems->{$key} $m +erge->{$key} !!, but the reference keys MUST be different # otherwise the merge will overwrite an existing key!! @merge = ( qw/description ibm_description/ ); @{$systems->{$sys}}{ @merge } = ( $merge->{$sys}{$merge[0]} , $merge-> +{$sys}{$merge[1]}); @keys = ( qw/description ip name model ibm_description/ ); @values = @{$systems->{$sys}}{@keys} ; #print @keys, @values,"\n"; print "\n\nAdded some keys and values: showing all items\n"; for $idx ( 0 .. $#keys ) { print "$keys[$idx] => $values[$idx]\n"; }

    hope it's usefull to somebody!!

picwoodpecker -- a Tk program to choose and modify your photos
3 direct replies — Read more / Contribute
by Discipulus
on Nov 30, 2016 at 03:37
    Hello monks,

    after months of sparetime works I'm proud to present you picwoodpecker my last Tk effort (now also on github).

    It is application to review and copy pictures with many features.

    Suggestions are welcome.Tests with exif tags from different cameras are even more welcome.

    The post is splitted in 3 parts: here you have the rendered documentation, below there is the code and finally the POD that must be pasted after the __DATA__ token of the program.

                   This software is dedicated to my parents, who need to see printed pictures -- 6 July 1966 

    NAME

    PicWoodPecker

    SYNOPSIS

    perl picwoodpecker.pl [-s -d -debug -pr -wr -p -x -y -nothumbs -e -quality -pngcompression -df]

    OPTIONS

         -s|src|source        path
                        the path where search for jpg files to be loaded
                        Can be modified in the Tk interface

    -d|dest|destination path path used to save files Can be modified in the Tk interface

    -debug print more information on the screen Can be modified in the Tk interface

    -pr|phratio floating point the ratio used to display the current photo Can be modified in the Tk interface

    -wr|winratio floating point the ratio to size the window where the photo is displayed Can be modified in the Tk interface

    -p|preload integer how many photos load in memory after and before the current one. Can increase drawing speed time

    -x|gridx integer how many columns in the thumbnail grid

    -y|gridy integer how many rows in the thumbnail grid

    -nothumbs does not load thumbnails at all

    -e|extension jpg|gif|png|gd|gd2 the exstension of saved files Can be modified in the Tk interface

    -quality|jpegquality 0-100 the quality of the file used by GD when saving the current photo in jpeg format An empty value let GD to choose a good default Can be modified in the Tk interface

    -pngcompression 0-9 the compression factor used by GD when saving the current photo in png format -dateformat|df string the format used for dates. It defaults to %Y_%m_%d_%H_%M_%S in such way resulting pics can be ordered correctly. See C<strftime> in L<POSIX> to more hints about formatting.

    DESCRIPTION

    The program is aimed to let you to easely choose among photos and save one (or more) copy in the preferred format (jpg as default; gif png gd and gd2 are also available). The name of the copy is crafted using the timestamp when the photo was taken.

    Basically the program will load all jpg files found globbing the path given with command line parameter -source or entered in the graphical interface, and foreach file will examine some exif tags to get sizes, timestamps and the thumbnail (if not present showing a black empty one).

    Orientation of the image is handled automatically for thumbnails and main photo.

    Advanced options are available to manipulate how many photos are copied, in which format and let you to postprocess via exiftool each created image.

    The program uses GD for image manipulation and Image::ExifTool to load infos from photos and in the postprocess of them.

    THE GRAPHICAL INTERFACE

    A main control window and a display one are created. Optionally a third window is created to access the advanced copy options. The display window tends to take the focus being the program focused on displaying photos.

    control window

    The control window contains:

    • all controls to manipulate the photo list (&#39;browse&#39; &#39;new list&#39; &#39;view list&#39; &#39;add to list&#39; and &#39;clear list&#39;) Note the that the &#39;browse&#39; does not fill the list; you need to use &#39;new list&#39; or &#39;add to list&#39; after using it.
    • an entry to choose the destination folder (that will be checked for existence)
    • the photo ratio and the window ratio controls and the debug switch
    • an informative text about the current displayed photo or about the grid of thumbnails
    • the editable name of the current photo (and an eventual suffix) used to save it
    • an information text about the status of the main program (with only relevant information about copying and loading operations as eventual errors)
    • the save button and the advanced options one.
    • controls to navigate the photo list

    display window

    The display window will starts showing a grid of thumbnails. The first one is selected. You can navigate the grid using right arrow and left arrow of the keyboard to move the current selection on or back.

    up arrow and down arrow let you load previous or next grids of thumbanails.

    Enter key will open the currently selected thumbanil in a bigger resolution ( determinted by photo ratio parameter) photo filling the whole window.

    When just one photo is displayed right arrow and left arrow of the keyboard can be used to show next and previous photo while up arrow and down arrow bring you back to the thumbnail view.

    In both control and display window space bar can be used to save the current photo and p key can be used to toggle autoplay. If autoplay is active the time between photos can be set in the control window. Please note that specifying a short amount of time (shorter than the time needed to load photos data) can produce weird showing behaviours.

    advanced copy options

    This menu lets you to have a granular control about how original photo will be copied.

    The allow overwrite if checked silently overwrite a photo wich has the same name of what is composed for the current one.

    bypass original file elaboration (simple copy) make a copy of the original file using the new name but without processing it with GD

    output file type lets you to choose among different file fomrmats (jpeg, gif, png, gd and gd2) and to set the quality (0-100) for jpeg ones. For png files the compression factor (0-9) can be specified only via the command line parameter -pngcompression

    enable multiple copies is trickier. If enabled lets you to choose to copy the file many times, each one with a different resolution. In the multi copies pattern you can specify different resolutions in the format widthxheigth as in 800x600 or 1024x768 and for each format a copy will be created.

    enable post processing can be used to postprocess every image with exiftool program that ships with Image::ExifTool module. You can use alternative program to postprocess your image inserting the full path in the program field. Arguments to such program can be also specified where $ can be used to refer to the full path of the original image. In the exiftool command line you can also specify @ to refer to the current file. So you can postprocess every copy using the following arguments:

    -overwrite_original -all= -tagsFromFile $ -ImageSize -ImageWidth -ImageHeight -ThumbnailImage -Orientation -DateTimeOriginal

    This exiftool command will be issued for every copy made, overwriting each exif tags in the copy, removing them all but taking some tag frome the original file and applying them to the copy. See the exiftool page for a lot of options this wonderful program lets you to use.

    LIMITATIONS

    The program was tested against few different camera formats; i dont know if exif tags extracted are widely valid.

    The autoplay feature does not plays well with little time intervals: infact when the interval is smaller than the overall time taken to load the the photo and to redesign the display i'll notice photos and information skipped and the timer going on. I tried fixing this using waitVisibility Tk method, with no luck.

    COPYRIGHT

    This software and icons are copyright of Discipulus as found on www.perlmonks.org You may redistribute or modify it under the same term of Perl itself.

    L*

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)


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 imbibing at the Monastery: (7)
    As of 2017-01-16 20:52 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?
      Do you watch meteor showers?




      Results (151 votes). Check out past polls.