Beefy Boxes and Bandwidth Generously Provided by pair Networks
Clear questions and runnable code
get the best and fastest answer

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.

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

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

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

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

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

    Sometimes I can think of 6 impossible LDAP attributes before breakfast. It's that time of year again!

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

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

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

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

    p: 1293 18:15 x: 10361

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

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

    Pics: before button press, and after button press.

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

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

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

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

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

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

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

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

    Here's but a few of the features:

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

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

    This was also posted here.

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

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

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

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

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

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

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

    Thanks mjd!

    Alex / talexb / Toronto

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

Get excel column letter from number
5 direct replies — Read more / Contribute
by bulrush
on Jul 26, 2016 at 06:33

    I found several chunks of code on the internet which were supposed to convert a 0-based column number in Excel to a letter, but I could get none of them to work with a value above 25. So here's the code I got working, for everyone's use. Enjoy.

    ###################################################################### # 7/25/2016 # In: Column index, 0-n. # Out: Letter(s) representing column in Excel. 0=A, 1=B, 25=Z, 26=AA.. +. # # Inspired by +get-the-excel-like-column-name-of-a-number # 7/25/2016 WORKS! sub excelpos2ltr {my($oldcol)=@_; # Col starts at 0='A' my($procname,$numeric,$ltr,$num2,$outs); $procname="excelpos2ltr"; # Alt method 4. $numeric = $oldcol % 26; $ltr = chr(65 + $numeric); #$num2 = intval($oldcol / 26); # old line $num2 = int($oldcol / 26); if ($num2 > 0) { $outs=excelpos2ltr($num2 - 1) . $ltr; } else { $outs=$ltr; } return $outs; }

    If you found any problems please put the code fix as a comment below.

Perl 6 SDL2 game
No replies — Read more | Post response
by holyghost
on Jul 25, 2016 at 02:04
    I need to have something to make a buffer for C32 byte arrays. This is for the SDL2 texture. I choose an Xpm file, as it faster parsable in perl. Buffer filling and swapping from a png package is less expensive, therefor I started a PNGImageObject. With PERL 6, SDL2::Raw panda package you can make the following perliminary game :
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 =; 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 :-)

    -- 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 ./ --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 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 # # # 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 ./ --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

Add your 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?

    What's my password?
    Create A New User
    and the web crawler heard nothing...

    How do I use this? | Other CB clients
    Other Users?
    Others perusing the Monastery: (5)
    As of 2016-08-29 08:20 GMT
    Find Nodes?
      Voting Booth?
      The best thing I ever won in a lottery was:

      Results (399 votes). Check out past polls.