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

CUFP's
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
2 direct replies — Read more / Contribute
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,
Decode contact list from Nokia phone.
No replies — Read more | Post response
by ambrus
on Apr 05, 2016 at 17:03

    The Nokia 6303c mobile phone can save a backup of the contact list (i.e. phone book) to the SD card. This node tells how to extract the list of contacts from such a backup to a human-readable file.

    This description comes with no warranty. If you lose your contacts, you are on your own.

    Note that the following procedure only saves the contacts from the phone memory. If you have contacts in the SIM card, you may have to copy those to the phone memory first.

    I know of no procedure to restore a contact list to the phone. As far as I've tried, the phone can't even load the backups it wrote itself.

GqrxRawAudioPlot(wxPerl, GD, UDP client, UDP server, & memory file)
No replies — Read more | Post response
by jmlynesjr
on Apr 03, 2016 at 21:19

    GqrxRawAudioPlot(wxPerl, GD, UDP client, UDP server, & memory file)

    AKA - Another wxPerl example.

    Back in June I was looking into the purchase of Digilent's Analog Discovery USB O-scope(still looking). I was considering wrapping the SDK shared library until kovacslattila pointed out that a Linux version of the Waveforms software was under development(now available). The result was that I dropped my plan to wrap the SDK shared library. What I had put together at that point was a simulated O-scope display based on wxPerl and GD. Reference: Digilent Inc. Analog Discovery

    Fast forward to October... I had been playing with the Gqrx Software Defined Radio package and had developed a wxPerl script that used Telnet and threads to implement a scanner function on top of Gqrx. Reference: SDR Scanner(aka Threaded wxPerl Example)

    Last month, a user on the Gqrx google group asked if there was a way to display the raw audio produced by Gqrx. As it turns out, one channel of the demodulated audio is output to a UDP port. It sounded like a fun challenge and a reason to dig out the simulated O-scope code. Listed below is the GqrxRawAudioPlot.pl script and the udpserver.pl script(provides test UDP packets so that the plot code can be run without having to have SDR hardware and Gqrx installed). If you don't want to run these scripts, you can see a screen snapshot at jmlynesjr.

    If nothing else, it's another wxPerl example along with GD graphics, memory file usage, a UDP client and a UDP server.

    GqrxRawAudioPlot.pl

    udpserver.pl

    James

    There's never enough time to do it right, but always enough time to do it over...

Activate your perl programs by touch with Touchable.pm!
2 direct replies — Read more / Contribute
by Discipulus
on Apr 01, 2016 at 03:09
    Touchable.pm is not yet published, but perlmonks deserves a preview
    Just by including this incredibly simple module
    you can prevent unwanted access to
    your perl programs and
    protect your compiled application from
    unintended double clicks. Here the code and example usage
    #!/usr/bin/perl use strict; use warnings; package Touchable; exit 0 unless (stat ($0))[9] && (($^T - (stat ($0))[9] ) < 3);

    Example of usage:
    # consuming script: yourprogram.pl use strict; use warnings; use Touchable; print "here $0\n"; # usage example perl yourprogram.pl # works only if touch activated.. touch yourprogram.pl & perl yourprogram.pl here yourprogram.pl

    Have a nice 1st of April!

    Have fun!

    L*

    There are no rules, there are no thumbs..
    Reinvent the wheel, then learn The Wheel; may be one day you reinvent one of THE WHEELS.
Automate Perl/BerryBrew unit testing on Unix/Windows (Take 2)
No replies — Read more | Post response
by stevieb
on Mar 18, 2016 at 21:46

    Disclaimer: this isn't just a cool use for/of Perl, it's a request to get some testers of an extremely easy to use app so I can hopefully get feedback.

    NOTE: The current version this doc is based on is v0.05. I only uploaded it to CPAN a while ago, so it may not be indexed yet. Previous versions won't act according to this doc. You can either wait for it to be indexed, or fetch the zip/tarball file and install manually.

    When I say easy to use, I mean it. If you have PerlBrew or BerryBrew installed and a module you've developed that's structured in a sane way:

    cpan Test::BrewBuild cd /path/to/MyModule brewbuild

    Output:

    perl-5.8.9 :: PASS perl-5.10.1 :: PASS perl-5.22.1 :: PASS perl-5.23.8 :: PASS

    ...yep, that's it. It'll run all of your unit tests across all of your currently installed *brew instances. We can get much deeper, however, I'll start with some explanations. I'm looking for feedback, so if you aren't interested in forking and submitting a PR or opening a bug report and it errors/warns on you, all you have to do is set a debug level and either post the output here, or email me at my CPAN email address.

    brewbuild --debug 7 # or brewbuild -d 7

    This app/module works across both *nix and Windows, recognizes both ExtUtils::MakeMaker and Module::Build installers, and can be configured *very* easily with custom build plugins if neither of these work for you. I'll show the default plugin, then I'll provide an example of how to include your own.

    Default bundled plugin:

    package Test::BrewBuild::Plugin::DefaultExec; sub brewbuild_exec { return <DATA>; } 1; __DATA__ if ($^O eq 'MSWin32'){ my $make = -e 'Makefile.PL' ? 'dmake' : 'Build'; system "cpanm --installdeps . && $make && $make test"; } else { my $make = -e 'Makefile.PL' ? 'make' : './Build'; system "cpanm --installdeps . && $make && $make test"; }

    That's it. Unfortunately at this time, it's not possible via CLI args to include a non-installed plugin, so unless you want to write one to put on the CPAN, you just need to copy a CustomPlugin.pm file into ~/perl5/perlbrew/perls/*PERLVER*/lib/site_perl/*PERLVER*/Test/BrewBuild/Plugin directory. Then:

    brewbuild --plugin 'Test::BrewBuild::Plugin::CustomPlugin' # or just set the TBB_PLUGIN environment variable to make it persisten +t

    Using local plugins is imminent, just not there yet.

    Now, here are some use cases. Note that all command line arguments have a single letter (ie. -d for --debug) shortforms:

    Remove all existing *brew perl instances (less the one you may be using), install two new random versions, and test against all instances including the pristine ones:

    brewbuild --remove --count 2

    Run against all currently installed instances, and install one random new one and test against it too:

    brewbuild --count 1

    Install a few specific versions (use just the number portion from *brew available) and test against all installed:

    brewbuild --version 5.20.3 -v 5.22.1 -v 5.8.9

    The current documentation describes more situations, and you can read the docs for all installed pieces of the module here.

    Note that ironically, I wrote this project to perform unit testing as I'm a huge stickler (I often have 100 times the number of lines of test code than I do code), but in this case, it has happened backwards. Don't worry, tests are coming fast and furious.

    I wrote this module because Travis-CI doesn't perform tests on Windows. This module allows me to run my tests against all perl versions on both nix and Windows prior to putting it into the CPAN Testers wheelhouse.

    Thanks for reading, and if you get a chance to test it out, I'd greatly appreciate any and all feedback.

    Cheers,

    -stevieb


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.