Beefy Boxes and Bandwidth Generously Provided by pair Networks
Welcome to the Monastery
 
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
Remove Tabs and Newlines Inside Fields of Text Tab Delimited Files from Excel
1 direct reply — Read more / Contribute
by perldigious
on Jul 13, 2016 at 11:15

    I don't know if this is something that is common knowledge or not, but I figured this out once, and at the time I was overly pleased with myself. Now, wallowing in my hubris from this past epiphany (it felt like one for me anyway), I thought I'd share. I do realize there are simpler ways to read such files via various CPAN modules, but I still consider the code I write to be pretty amateurish (I'm actually an Electronics Engineer), so I'm still proud I figured this out at all.

    As far as I can tell, Text Tab Delimited type files saved out of Excel will have quotes added around individual tab delimited fields that have certain characters inside those fields, presumably so Excel can better handle them itself. My "trick" is essentially exploiting this to efficiently resolve lines that are read in from such files and split on tabs when the fields themselves can have tabs and/or newlines inside of them.

    while (my $line = <$TD_fh>) { chomp($line); my @data = split /\t/, $line; # This block of code strips tabs and newlines from inside individu +al tab delimited data fields. # Each individual tab or newline is replaced with a single space c +haracter. my $last_index = $#data; for (my $field_index=0; $field_index<$last_index; $field_index++) { if (($data[$field_index] =~ tr/"//) % 2 == 1) { my $new_string = "$data[$field_index] $data[$field_index+1 +]"; splice @data, $field_index, 2, $new_string; $line = join "\t", @data; $last_index--; $field_index--; } } if (($data[$last_index] =~ tr/"//) % 2 == 1) { $line .= " " . <$TD_fh>; redo; } # Make use of the resolved line and/or data however you please her +e. }

    So essentially it just comes down to always checking each field for an even number of quotes, and if that isn't found, some action needs to be taken (as far as I can tell, Excel "escapes" quotes themselves by adding another quote beside it). For all but the last field, the code assumes an extra tab was in there and consolidates the next field with the current one being looked at. For the last field, the code assumes an extra newline was in there and consolidates the next line with the current one being looked at. It's not glamorous or overly complex, but that's actually why I was proud of it. Relative to the other things I tried, it's extremely efficient as well.

    I did ultimately write this code in to a subroutine that returned the resolved split on tabs array for a line, but the biggest change to the code there is just replacing the "redo" line with a recursive call to the subroutine assigned to its local "@data" array.

    # This subroutine accepts a filehandle and a line read from that fileh +andle as arguments given in that order, it is meant for "Text (Tab de +limited)" type files. # It strips tabs and newlines from inside individual tab delimited dat +a fields. # It will modify the line that was passed to it (as if passed by refer +ence) to resolve it, and return an array of the completely resolved l +ine split on tabs. sub resolve_tab_delimited_file_line { my $fh = $_[0]; chomp($_[1]); # $_[1] being the read line passed in to this subrou +tine that is to be modified if necessary (as if passed by reference) my @data = split /\t/, $_[1]; my $last_index = $#data; for (my $field_index=0; $field_index<$last_index; $field_index++) { if (($data[$field_index] =~ tr/"//) % 2 == 1) { splice @data, $field_index, 2, "$data[$field_index] $data[ +$field_index+1]"; $_[1] = join "\t", @data; $last_index--; $field_index--; } } if (($data[$last_index] =~ tr/"//) % 2 == 1) { $_[1] .= " " . <$fh>; @data = &resolve_tab_delimited_file_line; } return @data; }

    Any thoughts from the monastery? Just curious if the monks think this is cool, stupid, obvious, irrelevant, or anything else? Or for that matter good or bad? Or can anyone point out any glaring oversight in the code where it isn't dealing with something that would make it choke and die a miserable death if encountered? That last one would make most of my office mates happy. I'm one of only two Perl Advocates swimming in a sea of Python Zealots, a group of which I recently read is sometimes referred to as a "smug". *snicker*

    I love it when things get difficult, after all, difficult pays the mortgage. - Dr. Keith Whites
    I hate it when things get difficult, so I'll just sell my house and rent cheap instead. - perldigious
Gray Code
2 direct replies — Read more / Contribute
by jdporter
on Jul 12, 2016 at 16:39

    I needed a quick Gray code (specifically, a binary reflected Gray code), so I whipped this up. The one CPAN module which seems to implement Gray code, Math-PlanePath is wayy too heavy for my needs.

    # returns a list of vectors of numbers in (0,1) sub gray2; sub gray2 { my($i) = @_; $i <= 1 and return([0],[1]); my @a = gray2($i-1); ( ( map { [ 0, @$_ ] } @a ), map { [ 1, @$_ ] } reverse @a ) } my @a = gray2(3); print "@$_\n" for @a;
    I reckon we are the only monastery ever to have a dungeon stuffed with 16,000 zombies.
Perl 6 SDL2 example - continued
1 direct reply — Read more / Contribute
by holyghost
on Jul 09, 2016 at 08:28
    In my previous example I said you could draw images on the screen of an SDL2 window. Here's how you create a texture (or surface) which has width 320 and height 200. Think of it as a rectangle where you can draw on :
    use SDL2::Raw; my $tile = SDL_CreateTexture($renderer, RGBA8888, STREAMING, 320, 200);
    To put pixels on the $tile texture, you can update the texture with an array of pixels (pixelpoints on the surface) Each pixel is 32 bits wide in SDL2, there is red, green blue and an alpha (transparent) channel (RGBA8888, where 8+8+8+8=32 bits).
    my $data = 0; ### pixelbuffer is empty sub render { SDL_UpdateTexture($tile, NULL, $data, 320*32); ### update 32 bits of 3 +20 pixels }
Perl 6 SDL2 example
1 direct reply — Read more / Contribute
by holyghost
on Jul 08, 2016 at 07:06
    If you install SDL2 ('panda install SDL2::Raw' in your command line), you can get this example from the SDL2 modules to work. Take a look at the render method and optionally draw images on a screen apart of points.
    use NativeCall; use SDL2::Raw; use nqp; my int ($w, $h) = 800, 600; my SDL_Window $window; my SDL_Renderer $renderer; my int $particlenum = 1000; constant $sdl-lib = 'SDL2'; sub SDL_RenderDrawPoints( SDL_Renderer $, CArray[int32] $points, int32 + $count ) returns int32 is native($sdl-lib) {*} SDL_Init(VIDEO); $window = SDL_CreateWindow( "Particle System!", SDL_WINDOWPOS_CENTERED_MASK, SDL_WINDOWPOS_CENTERED_MASK, $w, $h, SHOWN ); $renderer = SDL_CreateRenderer( $window, -1, ACCELERATED ); SDL_ClearError(); my SDL_RendererInfo $renderer_info .= new; SDL_GetRendererInfo($renderer, $renderer_info); say $renderer_info; say %PIXELFORMAT.pairs.grep({ $_.value == any($renderer_info.texf1, $r +enderer_info.texf2, $renderer_info.texf3) }); my num @positions = 0e0 xx ($particlenum * 2); my num @velocities = 0e0 xx ($particlenum * 2); my num @lifetimes = 0e0 xx $particlenum; my CArray[int32] $points .= new; my int $numpoints; sub update (num \df) { my int $xidx = 0; my int $yidx = 1; my int $pointidx = 0; loop (my int $idx = 0; $idx < $particlenum; $idx = $idx + 1) { my int $willdraw = 0; if (@lifetimes[$idx] <= 0e0) { if (rand < df) { @lifetimes[$idx] = rand * 10e0; @positions[$xidx] = ($w / 20e0).Num; @positions[$yidx] = (3 * $h / 50).Num; @velocities[$xidx] = (rand - 0.5e0) * 10; @velocities[$yidx] = (rand - 2e0) * 10; $willdraw = 1; } } else { if @positions[$yidx] > $h / 10 && @velocities[$yidx] > 0 { @velocities[$yidx] = @velocities[$yidx] * -0.6e0; } @velocities[$yidx] = @velocities[$yidx] + 9.81e0 * df; @positions[$xidx] = @positions[$xidx] + @velocities[$xidx] * df; @positions[$yidx] = @positions[$yidx] + @velocities[$yidx] * df; @lifetimes[$idx] = @lifetimes[$idx] - df; $willdraw = 1; } if ($willdraw) { $points[$pointidx++] = (@positions[$xidx] * 10).floor; $points[$pointidx++] = (@positions[$yidx] * 10).floor; } $xidx = $xidx + 2; $yidx = $xidx + 1; } $numpoints = ($pointidx - 1) div 2; } sub render { SDL_SetRenderDrawColor($renderer, 0x0, 0x0, 0x0, 0xff); SDL_RenderClear($renderer); SDL_SetRenderDrawColor($renderer, 0xff, 0xff, 0xff, 0x7f); SDL_RenderDrawPoints($renderer, $points, $numpoints); SDL_RenderPresent($renderer); } my $event = SDL_Event.new; my @times; my num $df = 0.0001e0; main: loop { my $start = nqp::time_n(); while SDL_PollEvent($event) { my $casted_event = SDL_CastEvent($event); given $casted_event { when *.type == QUIT { last main; } } } update($df); render(); @times.push: nqp::time_n() - $start; $df = nqp::time_n() - $start; } @times .= sort; my @timings = (@times[* div 50], @times[* div 4], @times[* div 2], @ti +mes[* * 3 div 4], @times[* - * div 100]); say "frames per second:"; say (1 X/ @timings).fmt("%3.4f"); say "timings:"; say ( @timings).fmt("%3.4f"); say ""; 'raw_timings.txt'.IO.spurt((1 X/ @times).join("\n"));
Perl 6 RPG base code (SDL)
No replies — Read more | Post response
by holyghost
on Jul 04, 2016 at 03:47
    This is preliminary code for game hackers, it is based on the current SDL and includes NPCs, Enemies, a map and a player character. There is also a collision detection system :

Undumping Perl
No replies — Read more | Post response
by haukex
on Jul 03, 2016 at 14:27

    Respected Monks,

    I'd like to present to you today, in hopes you might find it interesting or even useful, the result of scratching an itch I had for quite some time: parsing Perl data structures without eval; instead I do it with the great module PPI. The result is Config::Perl. A nice additional benefit is that the module can round-trip much of the output of Data::Dumper, for which I provide the helper module Data::Undump::PPI.

    Let me demonstrate with code:

    Data::Undump::PPI makes round-tripping Perl data structures to and from strings (and files, see below) easier:

    use Data::Dumper; $Data::Dumper::Purity=1; # setting these two options like this $Data::Dumper::Terse=0; # is important (see also "Dump" below) use Data::Undump::PPI; my @input = ( {foo=>"bar"}, ["Hello","World"], "undumping!" ); my $str = Dumper(@input); my @parsed = Undump($str);

    In the above example, @parsed now looks identical to @input, and is essentially a deep copy. Another example:

    So if you get a chance to play around with the modules, I'd be happy to hear your (constructive) feedback, bug reports, and so on :-)

    Regards,
    -- Hauke D

i2c lcd Custom Characters
2 direct replies — Read more / Contribute
by anita2R
on Jun 10, 2016 at 14:30

    LCD character displays typically include some RAM where custom characters can be stored.

    Here is a short Perl script that allows custom characters to be written to the character generator RAM (CGRAM). Two parameters are used, one is the number of the custom character (0 to 7) and the other is a string of 8 hex characters that represent the character.
    An example call is: sudo ./lcd_i2c_cg.pl --charAddr 0 --charStr '00,00,0E,11,11,0F,01,0E'. This creates a custom lower case 'g' which descends into the cursor line, and IMHO looks better than the standard 'g' used on my lcd !

    Each of the 8 bytes for each custom character consist of 5 bits (3 high-order bits all zero). These are the 5 of the 5x8 character width or columns and the 8 bytes are the 8 rows. This site shows how the hex bytes are constructed http://www.circuitvalley.com/2012/02/lcd-custom-character-hd44780-16x2.html. There are, no doubt, many others.

    This script is based on my previous script for an i2c-connected lcd. The initialization routine has been changed slightly to correct some logic errors in the enable high/low masking, and to remove some unintended obfuscation (The write byte calls in the initialization sequence had additional variables that were not used).

    If this script is called without a '--charStr' parameter, the 8 existing custom characters are displayed.

    As part of developing my display script for the i2c-attached lcd, I wanted a swap line function. Being able to read the existing data from the lcd display made this easier to achieve. This led to the conclusion that the Raspberry Pi's i2c bus can safely read from an attached i2c device operating at 5 volts. Results are consistent and have been working, at this stage, for around three weeks.

    I hope to post the new display script shortly. It includes multiple user functions from the simple swap line to more complicated message display formats. Custom characters are included - displayable using escape sequences in the text

    If you use this script, remember to put your username and group name into the two variables $user and $group (lines 38 & 39). This is for the script to fall back to regular user permissions as soon as the i2c object has been created.

    #!/usr/bin/perl # # lcd_i2c_cg.pl # Version 1.00 # June 2016 # anita2R # # A script to create custom characters for # an lcd character display # Eight 5x8 pixel characters are possible # # Call this script with two parameters: # --charAddr # --charStr # The address is a single value in the range 0 to 7 # The character string is 8 hex bytes (comma delimited) # Example # for a lower case 'g' that descends into the cursor row: # sudo ./lcd_i2c_cg.pl --charAddr 0 --charStr 00,00,0E,11,11,0F,01,0E # use HiPi::BCM2835::I2C qw( :all ); use HiPi::Utils; use Getopt::Long; # use strict; # # get the command line parameters my ($cstrParam, $caddrParam); GetOptions( 'charStr=s' => \$cstrParam, 'charAddr=i' => \$caddrParam ); # #setup bus number, speed and i2c 'backpack' address. my $i2cBus = BB_I2C_PERI_1; # bus #1 on vers 2. my $i2cSpeed = BB_I2C_CLOCK_100_KHZ; # fastest reliable on RPi my $i2cAddr = 0x3f; # SainSmart i2c lcd at 0x3f # setup regular user & group id's - for permission drop-back my $user = '<YourUserName>'; my $group = '<YourGroupName>'; # setup values specific to the 2 row 16 character SainSmart i2c LCD my $dWidth = 16; # Displayed characters per line my $mWidth = 40; # Memory size per line my $dataMode = 0x09; # Mode - send data with backlight on my $cmdbMode = 0x08; # Mode - send command with backlight on my $line1 = 0x80; # Address command for the 1st line my $line2 = 0xC0; # Address command for the 2nd line my $loMask = 0xF0; # Masks off low-order bits in byte my $setEn = 0x04; # 0000 0100 mask: set enable bit my $clrEn = 0x0B; # 0000 1011 mask: clear enable bit/data # hold/wait times are in the code but do not seem to be required # perhaps the delay inherent in 12c serial # to parallel conversion is sufficient my $enHold = 0; # hold enable high (microseconds) my $wait = 0; # wait before next write (microseconds) # ****************************************** # # ***************** Setup ****************** # # # create an i2c device object my $objI2c = HiPi::BCM2835::I2C->new( peripheral => $i2cBus, address => $i2cAddr ); HiPi::Utils::drop_permissions_name( $user, $group ); $objI2c->set_baudrate( $i2cSpeed ); # # Initialize &init; # # ****************************************** # # ************** Main Program ************** # # # If a character byte string is present create the character # else just display the custom characters if( $cstrParam ) { # Set character generator RAM address to the # start of required custom character (0x00 to 0x07) &sendByte( &cgConv( $caddrParam ), $cmdbMode ); # Read 8 bytes from character string parameter # and write to CGRAM my @newChar = split( /,/, $cstrParam ); foreach( @newChar ) { &sendByte( hex $_, $dataMode ); } } # On line 1, display the 8 possible custom characters &sendByte( $line1, $cmdbMode ); for( my $n = 0; $n < 8; $n++ ) { &sendByte( $n, $dataMode ); &sendByte( 0x20, $dataMode ); } exit 0; # # # ****************************************** # # ************** Subroutines *************** # # # *************** Initialize *************** # sub init { # 8-bit write (Control bits not LCD data in lower nibble) &writeByte ( 0x38 ); # 0011 xxxx Sets 8-bit mode &writeByte ( 0x38 ); # repeat in case LCD was in # 4-bit mode/out of sync &writeByte ( 0x38 ); # & 4-bit mode needs # next byte to action cmd. &writeByte ( 0x28 ); # 0010 xxxx Sets 4-bit mode # now in 4-bit mode - both nibbles of data sent to LCD &sendByte ( 0x28, $cmdbMode ); # 0010 1000 - 2 lines, small chars &sendByte ( 0x0C, $cmdbMode ); # 0000 1100 Display On, no cursor &sendByte ( 0x01, $cmdbMode ); # 0000 0001 Clear display } # # *************** Write Byte *************** # sub writeByte { my $byte = $_[0]; # # writes byte to i2c object (LCD) # 'Enable' toggled high-low to latch byte # # write data with enable high $objI2c->bus_write( $byte | $setEn ); $objI2c->delayMicroseconds( $enHold ); # clear enable - keep backlight and mode bits $objI2c->bus_write( $byte & $clrEn ); $objI2c->delayMicroseconds( $wait ); } # # **************** Send byte *************** # sub sendByte { my $data = $_[0]; my $mode = $_[1]; # # splits data into high & low-order # puts each nibble into high-order bits # then adds mode bits into low-order bits # mode can be with or without backlight (cmdbMode/cmdxMode) # or dataMode (always with backlight) # # mask off 4 low-order bits & 'add' mode my $data_high = (( $data & $loMask ) | $mode ); # shift 4 low bits to high bits, # mask-off low order bits & 'add' mode my $data_low = ((( $data << 4 ) & $loMask ) | $mode ); # Send both nibbles of data to write routine &writeByte( $data_high ); &writeByte( $data_low ); } # # ***** CG Character Number to Command ***** # sub cgConv { my $cgAdd = $_[0]; # convert character number to address command value # bit 6 high for CG RAM addresses # Character data starts every 8 bytes $cgAdd = ( ($cgAdd *8) | 0x40); #0x40 = 0100 0000 return( $cgAdd ); } # ****************************************** #
Let's play poker
2 direct replies — Read more / Contribute
by reisinge
on Jun 09, 2016 at 03:50

    I haven't coded in a while, so I did this small exercise to refresh my programming skills and to have some fun:

    #!/usr/bin/env perl use 5.014; use warnings; use autodie; use charnames ':full'; use List::Util 'shuffle'; use Getopt::Long; use Pod::Usage; GetOptions( "h|?|help" => \( my $help ), "hands=i" => \( my $hands ), "cards=i" => \( my $cards ), ) or pod2usage(1); pod2usage( -exitval => 0, -verbose => 2, -noperldoc => 1 ) if $help; deal(deck(), $cards, $hands); sub deck { my $n_cards = 52; my @suit = ( "\N{BLACK HEART SUIT}", "\N{BLACK SPADE SUIT}", "\N{BLACK DIAMOND SUIT}", "\N{BLACK CLUB SUIT}", ); my @rank = ((2 .. 10), qw(J Q K A)); my @deck; my $i = 0; while (@deck < $n_cards) { for my $s (@suit) { for my $r (@rank) { $deck[$i++] = "$r$s"; } } } return \@deck; } sub deal { my $deck = shift; my $n_cards = shift // 5; my $hands = shift // 1; my @shuffled = shuffle(@$deck); binmode STDOUT, ':utf8'; for (1 .. $hands) { my @hand; for (1 .. $n_cards) { die "no more cards in deck ...\n" unless @shuffled; push @hand, shift @shuffled; } say(join " ", @hand); } } __END__ =head1 NAME cards - deal cards from deck of 52 cards =head1 SYNOPSIS cards [options] options: -h, -?, --help brief help message --hands N number of hands to deal [1] --cards N cards per hand [5] =cut

    The script is to be seen on GitHub too.

    It looks to me it might benefit from OOP, something like:

    deck->new(cards => 52); deck->shuffle(); deck->deal(cards => 5, hands => 4);

    I have little experience with OOP, so if you have some hints how to get started, just let me know.

    There is not such thing as best practice unless you specify the context. -- brian d foy
i2c attached LCD Character Display for a Raspberry Pi
1 direct reply — Read more / Contribute
by anita2R
on May 24, 2016 at 12:28

    I was unable to find a Perl script to make my SainSmart LCD character display with i2c 'backpack' work from my Raspberry Pi.

    Code for using these devices is available mainly for the Arduino. There is also code in C and python, but I could not find a simple working example in Perl. There is a module for an HTBackpackV2 (HiPi::Interface::HTBackpackV2), but I wasn't able to get this working with the SainSmart LCD.

    I found a python script written by Matt Hawkins here: https://bitbucket.org/MattHawkinsUK/rpispy-misc/raw/master/python/lcd_i2c.py and I used his python script as the basis for my Perl Script - thanks Matt.

    This script only provides basic display functionality and is run by calling it with two parameters, -s a string of text to display and -l the line number to display the text on. Hopefully it will provide both a way for others to get one of these LCD's working as well as provide the basis for more comprehensive implementations. The subroutines writeByte and sendByte are the key ones, together with the initialization sequence in the init subroutine.

    The script must be run as root to set up the i2c object, but drops back to the regular user immediately after - enter your user name and user group in the two variables $user and $group which you will find at lines 39 & 40.

    When called with no text and no line parameter the LCD initialization code is run.

    After the code I have added some explanation about the way the data is transferred from the backpack to the LCD, including the transition from the power-up 8-bit mode to 4-bit mode. It took me some time to get my head round this!

    In addition to -l 1 & -l 2 for the two lines, -l 50 & -l 51 turn the display off and back on. When the display is turned off with -l 50, the data remains in the LCD's DDRAM memory and the previous text will be displayed by -l 51 (a simple flashing display can be implemented)

    If no line number is given, the text is printed on line 1 and overflows to line 2 if required. All existing text is cleared.

    Examples (run as root/sudo):


    Code for a Raspberry Pi with SainSmart 2 line, 16 character LCD display with i2c backpack at 0x3f, attached to the Pi's default i2c pins.

    Mode of operation & initialization

Automate and dispatch unit test runs across perl/berrybrew on remote Windows and Unix systems
No replies — Read more | Post response
by stevieb
on Apr 27, 2016 at 13:17

    My Test::BrewBuild test deployment system is now reasonably stable, and has the ability to dispatch test runs to remote test servers. This means with a single command, you can run your unit tests across any number of perl instances on any Operating Systems automatically, and get the results delivered back to you.

    To do this, we use the bbdispatch to send brewbuild commands to previously configured remote testers. To start a bbtester, log on to the system and run bbtester start. That'll start the tester and put it in the background.

    Now's probably a good time to state that Git is required to be installed on all systems used for network testing, and one should peruse the basic system setup doc.

    In these examples, I have three testers set up. tester1 is the DNS name of a Ubuntu Linux system running perlbrew, tester2 is a Windows 2008 Server running berrybrew, and the localhost is a FreeBSD server, again running perlbrew.

    There are three flags for bbdispatch:

    • -c: A quoted string containing the brewbuild commands to run. Eg: "brewbuild -i 5.20.3 -R". If omitted, we will default to simply "brewbuild"
    • -r: A string containing a repository you want to test. Eg: https://github.com/stevieb9/mock-sub. If you are currently in a repository directory, we'll automatically fetch and use it and you can omit this flag
    • -t: These are your testers. This flag can be specified multiple times.

    Note that you can alternatively use a config file to store the dispatcher information.

    Here's the most basic example. We're already in a repository working directory so we can omit -r, we're only working on a tester on localhost, and we'll just use the default brewbuild test run:

    # start a tester on the localhost me@host:~/repos/mock-sub$ bbtester start Started the Test::BrewBuild test server at PID 20584 on IP address 0.0 +.0.0 and TCP port 7800... # dispatch a test run of my [metamod://Mock::Sub] # module (from within the repo dir) me@host:~/repos/mock-sub$ bbdispatch -t localhost localhost - x86_64-linux 5.18.4 :: PASS 5.20.3 :: PASS 5.22.1 :: PASS

    Things get more useful when you have multiple testers across multiple different Operating Systems.

    This example does a basic run using the same repo as above, but this time I'm explicitly setting it. I'm also dispatching to three tester systems:

    $ bbdispatch -t localhost -t tester1 -t tester2 -r https://github.com/ +stevieb9/mock-sub tester1 - MSWin32-x64-multi-thread 5.22.1_64 :: PASS 5.10.1_32 :: PASS 5.20.3_32 :: PASS tester2 - x86_64-linux 5.18.4 :: PASS 5.20.3 :: PASS 5.22.1 :: PASS localhost - amd64-freebsd 5.10.1 :: PASS 5.14.4 :: PASS 5.22.1 :: PASS

    Below, we use the -c flag to tell brewbuild that we want to perform test on the current module (I'm back in the repo dir again so I omit -r), and then have brewbuild run unit tests of all the module's reverse dependencies (-R) to ensure our proposed updated module doesn't break down-river (ie. modules that require/use your module) modules.

    $ bbdispatch -t localhost -t tester1 -t tester2 -c "brewbuild -R" tester1 - MSWin32-x64-multi-thread reverse dependencies: File::Edit::Portable, Devel::Examine::Subs, Deve +l::Trace::Subs File::Edit::Portable 5.10.1_32 :: PASS 5.20.3_32 :: PASS 5.22.1_64 :: PASS Devel::Examine::Subs 5.20.3_32 :: PASS 5.22.1_64 :: PASS 5.10.1_32 :: FAIL Devel::Trace::Subs 5.20.3_32 :: PASS 5.22.1_64 :: PASS 5.10.1_32 :: FAIL localhost - amd64-freebsd reverse dependencies: File::Edit::Portable, Devel::Examine::Subs, Deve +l::Trace::Subs File::Edit::Portable 5.10.1 :: PASS 5.22.1 :: PASS 5.14.4 :: FAIL Devel::Examine::Subs 5.10.1 :: PASS 5.14.4 :: PASS 5.22.1 :: PASS Devel::Trace::Subs 5.10.1 :: PASS 5.14.4 :: PASS 5.22.1 :: FAIL tester2 - x86_64-linux reverse dependencies: File::Edit::Portable, Devel::Examine::Subs, Deve +l::Trace::Subs File::Edit::Portable 5.18.4 :: PASS 5.20.3 :: PASS 5.22.1 :: PASS Devel::Examine::Subs 5.18.4 :: PASS 5.20.3 :: PASS 5.22.1 :: PASS Devel::Trace::Subs 5.18.4 :: PASS 5.20.3 :: PASS 5.22.1 :: FAIL

    Notice that some results are FAIL. In this case, we create a bblog directory in the directory you're working in, and generate log files for each individual fail. This allows you to see what broke and where, without having to go to each individual system. You can then update/fix code, then run another dispatch. Here's an example of the files that were generated by the above run:

    $ ls bblog tester1_Devel-Examine-Subs-5.10.1_32-FAIL.bblog tester1_Devel-Trace-Subs-5.10.1_32-FAIL.bblog tester2_Devel-Trace-Subs-5.22.1-FAIL.bblog localhost_Devel-Trace-Subs-5.22.1-FAIL.bblog localhost_File-Edit-Portable-5.14.4-FAIL.bblog

    The log files contain all errors that the tester would have produced to STDOUT and STDERR, with the cpanm build logs appended.

    On a normal dispatch run (without running revdep), the log file would have appeared as tester1_5.10.1_32-FAIL.bblog. Running brewbuild in standalone mode (no dispatching): 5.10.1_32-FAIL.bblog. You can optionally save even the PASS logs if you choose by using the -S, --save flag to brewbuild.

    FURTHER READING:

    Notes:

    • we don't actually shell out and run the brewbuild commands directly with system() or backticks or the like. We dissect the command string, turn the arguments into their respective parameters, and use the API to do the actual testing
Saving some seconds.
No replies — Read more | Post response
by BrowserUk
on Apr 26, 2016 at 15:14

    After posting my solution to 1161491 I had some 'free time' so I was playing.

    My REPL which (can) time chunks of code for me automatically, produced some depressing numbers:

    C:\test>p1 [0]{0} Perl> use Algorithm::Combinatorics qw[ permutations ];; [0]{0.00943684577941895} Perl> $iter = permutations( [ reverse 1 .. 9 +] );; [0]{0.000318050384521484} Perl> printf "\r%s\t", join '', @$_ while de +fined( $_ = $iter->next );; 123456789 [0]{22.5874218940735} Perl>

    22.5 seconds to generate 9! = 362880 permutations seemed longer than I would have expected; so then I wondered how much of that was down to the generation and how much the formatting and printing:

    [0]{0} Perl>@d = permutations( [ reverse 1 .. 9 ] );; [0]{2.31235218048096} Perl> [0]{0} Perl> printf "\r%s\t", join '', @$_ for @d;; 123456789 [0]{18.9919490814209} Perl>

    So less than 2.5 seconds for the generation and almost 19 for the formatting and printing. (Leaving 1 second 'lost in the mix'.)

    Of course, that one line for printing is doing rather a lot. Unpacking the contents of the anon arrays to a list; joining the list of digits into a string; and then interpolating that into another string before writing it out. So then I wondered about the cost of each of those elements of the task.

    Looking at the code I saw that I could avoid 300,000 calls to each of join and printf by interpolating the lists from the array references directly into a string; provided I set $" appropriately:

    [0]{0} Perl> $"=''; $_ = "@$_" for @d;; [0]{1.93835282325745} Perl>

    That was a nice saving, so then I thought about writing the output. Rather than use a loop: print for @d; which means calling print 300,000 times -- with all the calls into the kernel that involves -- why not join those 300,000 strings into a single string (one call to join) and the output it with a single call to print:

    [0]{} Perl> $d = join "\r", @d;; [0]{0.0442740917205811} Perl> print $d;; 123456789 [0]{4.72821307182312} Perl>

    Summing the individual parts came out to ~10 seconds rather than the original 22.5. So let's put it all together and verify it:

    [0]{0} Perl> $"=''; @d = permutations( [ reverse 1 .. 9 ] ); $_ = "@$_ +" for @d; $d = join "\r", @d; print $d;; 123456789 [0]{9.26112604141235} Perl>

    Sure enough. Under 10 seconds; over 50% saved. Nice.

    Can we go further?:

    [0]{0} Perl> $"=''; print join "\r", map "@$_", permutations( [ revers +e 1 .. 9 ] );; 123456789 [0]{10.0599029064178} Perl> [0]{0} Perl> $"=''; print join "\r", map "@$_", permutations( [ revers +e 1 .. 9 ] );; 123456789 [0]{10.086268901825} Perl>

    And the answer is no. Sometimes the elimination of intermediate variables -- especially intermediate arrays when the alternative is several long lists -- backfires.

    Still. Another 5 minutes of 'idle time' waiting for another long simulation run occupied with an fun exercise, the lessons of which just might stay in my consciousness long enough to become influencial in the code I write in future.

    A few otherwise idle minutes spent now, saving a few seconds on something that doesn't really benefit from that saving; that just might save me hours or days if the lessons happen to be applicable to my next project; or the one after that.

    (If only I could apply those same level of savings to the simulation software I using -- open source, but I cannot compile it locally -- as perhaps then I would be lookng at a 20 hour wait for its completion rather than the 40+ I have in prospect :().


    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". I knew I was on the right track :)
    In the absence of evidence, opinion is indistinguishable from prejudice.
Script to copy files from directory 'a' to 'b' by newest time no more than 'max' files in dest
No replies — Read more | Post response
by symgryph
on Apr 25, 2016 at 19:39

    This is my rather convoluted way of ensuring that the following is true: 1. No more than x number of files in my 'to' directory 2. Newest files will be given the highest precedence in the move 3. Zero length files will be killed 4. Only move .log files via glob. If anyone wants to use or improve, feel free, since I think a hash would have been a lot less complex than an array with a sort and regex substring match....ick.

    #!/usr/bin/perl -w #This file sees how many files are currently in a target directory use File::Copy; chdir "/tmp/to/"; @filesto = glob("*.log"); $numFiles = scalar @filesto; #maxfiles needs to be 1 larger than your maximum value due to perl usi +ng a 0 based index for arrays. $maxfiles = 5 - $numFiles; if ($maxfiles <=0) { exit; } chdir "/tmp/from"; @filesfrom = glob("*.log"); $counter=0; foreach (@filesfrom) { ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, $atime,$mtime,$ctime,$blksize,$blocks) = stat($filesfrom[$counter]); #Unlink files that are zero bytes prior to copy. if ($size eq 0) { unlink $filesfrom[$counter]; $counter--; next; } $filestoCreated[$counter] = $ctime . " " .$filesfrom[$counter]; $counter++; } #@sortedlist = reverse sort @filestoCreated; #This is a particularly nasty sort which essentially uses a regex as s +ubstring match to only sort the numeric part of my hacked up array. E +nsures that we get #a numeric sort only. @sortedlist = sort { ($b =~ /(^\d+)/)[0] <=> ($a =~ /(^\d+)/)[0] || uc($a) cmp uc($b) } @filestoCreated; #This section ensures that the system will never copy more than the ma +x number of files defined in maxfiles. $loopcounter=scalar (@sortedlist); if ($loopcounter > $maxfiles) { $loopcounter = $maxfiles-1; print "Loopcounter is greater than than maxfiles: $maxfiles Loopc +ounter: $loopcounter\n"; } $countfinals=0; while ($countfinals<$loopcounter) { my @execute= split / /, $sortedlist[$countfinals]; system "/bin/mv /tmp/from/$execute[1] /tmp/to/$execute[1]"; $countfinals++; }
    "Two Wheels good, Four wheels bad."
[perl6] Open "regex.ext" file with corresponding program and ask for deletion
No replies — Read more | Post response
by mimosinnet
on Apr 25, 2016 at 05:28

    I have been happily playing with perl6. This code opens with the corresponding program and asks for deletion of files with a defined pattern and extension. For example:

    $ Files perl pdf

    Open the pdf files that have 'perl' in the name and asks for deletion. Available in github

    #!/usr/bin/env perl6 # Reads files in the form of pattern.extension and asks for deletion # Modules {{{ use v6; use IO::Glob; # }}} # Variables {{{ # Program associated to extension my %exe = 'pdf' => 'mupdf', 'PDF' => 'mupdf', 'txt' => 'less', 'odt' => 'lowriter', 'doc' => 'antiword', # Exolore using docx2txt 'docx' => 'lowriter', # Explore using feh and delete with ctrl-del 'JPG' => 'xv', 'jpg' => 'xv', 'png' => 'xv', 'flv' => 'mpv', 'vimbackup' => 'gvim' ; # extensions my @extensions = %exe.keys; # }}} # sub main {{{ sub MAIN($pattern is rw, $ext) { die "The extension '$ext' has not been defined" unless $ext ~~ @ex +tensions.any; # variables {{{ $pattern = "*" if $pattern eq "all"; my $program = %exe{$ext}; my @files = glob("*$pattern*.$ext"); # }}} # Read and Delete Files {{{ for @files -> $file { my @args = $program, $file; my $command = run @args; $command.exitcode == 0 or die "system @args failed: $!"; my $delete = prompt("\n \n Delete file $file (s/n) "); last if $delete eq ""; next if $delete ne "s"; say "mv $file /tmp/$file"; my $io = IO::Path.new($file); $io.rename("/tmp/$file"); prompt("\n Press 'return' to continue "); } # }}} # Exit and list files {{{ @files = glob("*.$ext"); say "-" x 60; for @files -> $file {say "$file ";} say "-" x 60; # }}} } # }}} # sub usage {{{ sub USAGE () { say "USAGE:\n Files regex/all [ @extensions ]"; } # }}}
Perlocracy
No replies — Read more | Post response
by QuillMeantTen
on Apr 10, 2016 at 14:04

    As older and wiser monks mill around the courtyard, no one wonders about the lack of news from young Quill. Last time he was seen he got a well deserved beating for tempting those who lack in wisdom with tools beyond their understanding that could easily be made to wreck havoc on their home networks.

    So, even if his arrival is of no surprise, his cries of
    I REKT IT!
    prove challenging to ignore and disturb many an elder from their own medidations.

    Fast enough, one of those whose deep thoughts got interrupted ask him:
    "you rekt what?"
    "Exactly, EUREKA, that's it!" answers the feverish apprentice.

    As more monks come to the courtyard he begins to expose his latest idea...


    After spending long hours reflecting on the foolishness of my misdeeds and how providing script kiddies with weapons is the most desecrating act one could perpetrate inside those holy walls, I found something even more subversive and potentially destructive.

    Some of you, if interested in voting methods might have heard about condorcet methods. I for one think that those are way better than the currently used one. And I have my favorite. Mam or Maximize Affirmed Majorities, aka MTM (minimize thwarted minorities) can be considered a variant of the Tideman method. Once I started reading about it I wanted to use it and tell others about it.

    As many of you know by now when I get my eyes and mind on an algorithm I can not rest until I have implemented it myself to try and understand it as completely as possible.


    Today I give you a small script that implements the MAM voting procedure, you can use it to simulate elections with as many ballots as you want or to run it on ballots you may have collected, just put votes in text files with a .bt extension.


    Say you have 6 candidates, a possible ballot could be:

    1 3 2,4
    Meaning, you wish one to win, if not one then three, if three does not win you dont care whether 2 or 4 win. Any candidates left out of a ballot are considered equally ranked at the bottom. Hence this ballot is equivalent to:
    1 3 2,4 5,6


    Update:Patched the code for eventualities that did not happen during testing:
    1. no one ranks two candidates strictly, then complete the tiebreak from a randomly generated strict ballot
    2. Make tiebreaking rules conform so if the two majorities concern the same winner then the loser will be compared using the tiebreak
    3. Make majorities calculation output two different majorities in case of 1 vs 2 has same votes as 2 vs 1 and let the tiebreak mechanism do its work
    4. patch bug in majorities calculation where < and = would be treated the same way
    5. Now allows for any number of candidate (regex \d limited it to 9)
    6. To allow result comparison I added the schulze voting method, now accessible with the -s option
    7. Fixed a typo causing a miscalculation when in shulze mode
    So here is the code, I hope you'll have as much fun using it as I had writing it! Cheers :-)

Etags for Emacs and Moose
No replies — Read more | Post response
by choroba
on Apr 05, 2016 at 18:17
    When working on a larger project (50k+ lines), I usually can't remember the structure of the packages and I need some kind of a tool to help me. The simplest but still quite a powerful solution is etags (yes, I use Emacs). It generates a TAGS file that Emacs can use to show where a given subroutine is declared, etc. (Similar tool exists for vim, but I'm not familiar with the output format enough to make my script support both the editors.)

    The problem is that the default setting for Perl reports not only all the subroutine declarations, but also declarations of lexical variables (my). I don't need to know where a lexical variable was declared: normally, it's in the same block where the cursor is, maybe one level higher. What I'd like to have, though, are the attributes' accesors that Moo(se) provides; they're declared with has which etags can't handle.

    I haven't found a way how to persuade etags to handle multiline declarations, neither have I found any other solution. So, I created a simple script that creates the TAGS file that's more useful for me than the default. It still doesn't handle all the possibilities (different names for setters/getters, builders, delegation, etc.) - you can check the END section for all the constructs it can parse.

    The current version of the code is here, but you can find it at GitHub where it might change as I (or you!) add new features.

    ($q=q:Sq=~/;[c](.)(.)/;chr(-||-|5+lengthSq)`"S|oS2"`map{chr |+ord }map{substrSq`S_+|`|}3E|-|`7**2-3:)=~y+S|`+$1,++print+eval$q,q,a,

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 the web crawler heard nothing...

    How do I use this? | Other CB clients
    Other Users?
    Others lurking in the Monastery: (4)
    As of 2016-07-24 05:01 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?
      What is your favorite alternate name for a (specific) keyboard key?


















      Results (221 votes). Check out past polls.