Beefy Boxes and Bandwidth Generously Provided by pair Networks
We don't bite newbies here... much
 
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
Google API Browser
No replies — Read more | Post response
by localshop
on Nov 12, 2018 at 09:42

    As I continue my pilgrimage to becoming passably proficient with Mojo and Google Cloud Services I have been tinkering away with WebService::GoogleAPI::Client and as a working example I was reasonably happy with the ease with which I could produce a basic Google API Explorer that presents the method and parameters of all the Google Discoverable API Endpoints. This is proving a handy starting point to constructing working examples accessing the APIS.

    I plan to extend this to firstly include required scopes, then provide OpenAPI YAML and perhaps ultimately replicate many of the features of Google's API Explorer.

    You can see the Mojo Application running as a Hypnotoad socket served application under CPANEL/WHM hosted environment at https://pscott.com.au.

    Today I'm working on the Google Drive API Example available in the Github Repo as a demo of an alternative approach to using a dedicated CPAN module such as the just released Net::Google::Drive

    If anybody has any interesting use cases requiring access to Google Cloud Services let me know. I'm trying to add a new example every few days.

Binary vs. linear search
2 direct replies — Read more / Contribute
by reisinge
on Nov 12, 2018 at 07:46

    I was trying to get my head around the binary search algorithm. I did it by comparing it to the linear search algorithm

    #!/usr/bin/perl use warnings; use v5.14; # Find this word ... my $find = shift // ""; # ... in this sorted list of words ... my @words = qw(alpha bravo charlie delta echo foxtrot golf hotel india juliett k +ilo lima mike november oscar papa quebec romeo sierra tango uniform v +ictor whiskey xray yankee zulu); # ... using two search algorithms my %search = ( linear => \&linsearch, binary => \&binsearch, ); for my $alg ( sort keys %search ) { say "$alg searching '$find' in [@words] ..."; my $idx = $search{$alg}->( $find, \@words ); say defined $idx ? "found at index $idx" : "not found"; say ""; } sub binsearch { my ( $find, $array ) = @_; my $low = 0; my $high = @$array - 1; while ( $low <= $high ) { my $try = int( ( $low + $high ) / 2 ); say "--> trying at index $try"; $low = $try + 1, next if $array->[$try] lt $find; $high = $try - 1, next if $array->[$try] gt $find; return $try; } return; } sub linsearch { my ( $find, $array ) = @_; for ( my $i = 0 ; $i < @$array ; $i++ ) { my $try = $i; say "--> trying at index $try"; if ( $array->[$try] eq $find ) { return $try; } } return; }
    Genius is 1 percent inspiration and 99 percent perspiration. -- Thomas Edison
Achievements Steaming ahead
No replies — Read more | Post response
by GrandFather
on Nov 12, 2018 at 01:09

    I play a bit of Civ V. Like many games these days I downloaded it using Steam and one of the "features" of the system is that Steam keeps track of various in game achievements. So, silly me, I've been sucked into playing the "get the achievements" meta game.

    Which is all very fine, but Steam doesn't do a great job of showing you the achievements. It doesn't seem able to sort them in the order that they have been achieved so sometimes it can be hard to know if you got that last thing or not. So, Perl to the rescue! The following script parses the Copy & Pasted achievements list from the Steam page and sorts them, first list the "not yet achieved" entries, then the achieved items sorted by the order that they were achieved.

    use strict; use warnings; my %monthOrd = ( Jan => 1, Feb => 2, Mar => 3, Apr => 4, May => 5, Jun => 6, Jul => 7, Aug => 8, Sep => 9, Oct => 10, Nov => 11, Dec => 12, ); my @records = grep {/\n/ and /[^\n]/} do {local $/ = "\n\n"; <DATA>}; s/^\n+|\n$//gs for @records; for my $record (@records) { my @lines = split "\n", $record; $lines[0] //= ''; my ($day, $month, $year, $time) = $lines[0] =~ /(\d+)\s+(\w+)(?:, +(\d+))?\s+\@\s+(\S+)/; if(defined $month && exists $monthOrd{$month}) { $year ||= 2018; $lines[0] = sprintf "%04d %2d %2d %7s", $year, $monthOrd{$mont +h}, $day, $time; } else { unshift @lines, ''; } $record = \@lines; } # Sort records by not achieved first. Remove blank lines from records @records = map {$_ = [grep {$_} @$_]; $_} sort {$a->[0] cmp $b->[0]} @ +records; print join "\n", @$_, '', '' for @records; __DATA__ Unlocked 18 Feb, 2016 @ 11:39pm First in the Hearts of Your Countrymen Beat the game on any difficulty setting as Washington. Unlocked 2 Jun, 2016 @ 7:48pm Video et Taceo Beat the game on any difficulty setting as Elizabeth. Unlocked 18 Nov, 2017 @ 4:57pm Vivre La Revolution Beat the game on any difficulty setting as Napoleon. Unlocked 25 Apr, 2016 @ 9:44am Blood and Iron Beat the game on any difficulty setting as Bismarck. Red Badge of Courage Win the Civil War scenario on Deity. Pickett's Recharge Capture Gettysburg with a Confederate Infantry unit possessing the Geo +rge Pickett promotion. Sheridan's Valley Campaign As Union, control Winchester, Front Royal, Harrisonburg, Staunton, and + Lynchburg.

    Prints:

    Red Badge of Courage Win the Civil War scenario on Deity. Pickett's Recharge Capture Gettysburg with a Confederate Infantry unit possessing the Geo +rge Pickett promotion. Sheridan's Valley Campaign As Union, control Winchester, Front Royal, Harrisonburg, Staunton, and + Lynchburg. 2016 2 18 11:39pm First in the Hearts of Your Countrymen Beat the game on any difficulty setting as Washington. 2016 4 25 9:44am Blood and Iron Beat the game on any difficulty setting as Bismarck. 2016 6 2 7:48pm Video et Taceo Beat the game on any difficulty setting as Elizabeth. 2017 11 18 4:57pm Vivre La Revolution Beat the game on any difficulty setting as Napoleon.
    Optimising for fewest key strokes only makes sense transmitting to Pluto or beyond
Generating SVG Badges with Perl
No replies — Read more | Post response
by haukex
on Nov 10, 2018 at 09:20

    If you've looked at projects on GitHub or other sites, you may have noticed the little rectangular badges (aka shields) saying things like "build passing" with a nice green background (or yellow/red if something is wrong), and if you've used Travis CI or Coveralls, you probably know how to get these badges. There is also a nice service that can generate these badges for you, Shields.io, which is written in JavaScript.

    There didn't seem to be anything like that for Perl, so I wrote Badge::Simple!

    Thanks to a super quick turnaround by Kenichi Ishigaki, these badges are already integrated into CPANTS: Try accessing https://cpants.cpanauthors.org/dist/Your-Dist-Name.svg or https://cpants.cpanauthors.org/author/YOURCPANID.svg and you should see a badge for your Kwalitee score (PNG badges have also been available for quite some time, just use .png instead of .svg).

    In the respository, you can find the script cpantesters.pl, which you can use to generate CPAN Testers badges for your CPAN modules. There is an open issue to perhaps integrate this directly with CPAN Testers, if anyone would like to take a stab at that, please feel free :-)

    You can see all this in action, for example, in the Badge-Simple readme: the "Kwalitee" and "CPAN Testers" badges were generated with Perl!

[WEBPERL] dynamically importing non-bundled modules via http
2 direct replies — Read more / Contribute
by LanX
on Nov 09, 2018 at 10:07
    (in continuation to webperl: fetching data over the web)

    Webperl requires at the moment to statically bundle all needed modules.

    The following Proof of Concept shows how to dynamically use non-bundled modules.

    The modules need to be pure Perl and have to be present inside the $WEBLIB directory on your server (respecting the same domain policy avoids much trouble)

    I just copied the desired libs from my installation and listed allowed modules to %INC_FETCH (to limit unnecessary traffic) .

    The following page demonstrate how to use Data::Dump from weblib.

    Data::Dump is currently not bundled with Web-Perl. (Data::Dumper is since it's core)

    The mechanism of adding a call-back to @INC to dynamically fetch modules from various sources is described in require

    <!doctype html> <html lang="en-us"> <head> <meta http-equiv="Content-Type" content="text/html; charset=utf-8"> <title>WebPerl &lt;script&gt; Demos</title> <script type="text/javascript"> function xfetch(url) { var req = new XMLHttpRequest(); req.open('GET', url , false); req.send(null); if(req.status == 200) { return req.responseText; } else { return ""; } } // alert(xfetch('http://localhost:5000/lib/Data/Dump.pm')); // alert(xfetch('http://localhost:5000/webperl.js')); </script> <script src="webperl.js"></script> <!-- Please see the documentation at http://webperl.zero-g.net/using.h +tml --> <script type="text/perl"> use warnings; use strict; use Data::Dumper; use WebPerl qw/js/; BEGIN { my $WEBLIB = 'localhost:5000/lib'; # gather source of module my $fetch = sub { my ($module_path) = @_; return js("window.xfetch('http://$WEBLIB/$module_path')"); }; # allowed modules in weblib my %INC_FETCH = ( 'Data/Dump.pm' => 1, ); # loader hook for @INC my $loader = sub { my ($sub,$filename) = @_; if ( $INC_FETCH{$filename}) { my $source = $fetch->($filename); unless ($source) { warn "Fetching $filename from $WEBLIB failed"; return; } open my $fh_source, "<", \$source; my $pre = ''; #$pre = qq{warn '*** Loading $filename ***';}; return (\$pre, $fh_source); } return; }; push @INC, $loader; } use Data::Dump qw/pp/; my $HoA = { map { $_ => [reverse 1..5] } "a".."d" }; warn pp $HoA; #use Data::Dumper; #warn Dumper $HoA; </script> <!-- Optional STDOUT/STDERR text area (if you don't use this, output g +oes to Javascript console) --> <script> window.addEventListener("load", function () { document.getElementById('output') .appendChild( Perl.makeOutputTextarea() ); }); </script> </head> <body> <p>This is a demo of <a href="http://webperl.zero-g.net" target="_blan +k">WebPerl</a>!</p> <div id="output"></div> <div id="buttons"> <button id="my_button">Testing!</button> </div> </body> </html>

    OUTPUT:

    { a => [5, 4, 3, 2, 1], b => [5, 4, 3, 2, 1], c => [5, 4, 3, 2, 1], d => [5, 4, 3, 2, 1], } at /tmp/scripts.pl line 56.

    DISCLAIMER: This code is beta and follows the release often paradigm.

    Successfully tested with Chrome AND Firefox. FF showed new "Content Security Policy" problems, I didn't have the time to dig into and install the necessary PLACK CORS modules. °

    The principle is universal, as soon as webperl can run in a browser and has the capacity to dynamically fetch code, using unbundled (pure) Perl modules becomes trivial.

    Cheers Rolf
    (addicted to the Perl Programming Language :)
    Wikisyntax for the Monastery FootballPerl is like chess, only without the dice

    °) works like a charm in FF , forgot to disable "noscript" filtering for localhost! ;)

read an mp3 stream and save tracks using icy-metaint (ICY protocol)
No replies — Read more | Post response
by Discipulus
on Nov 08, 2018 at 03:12
    Hello folks!

    All begun when I discovered that my shoutcast bookmark was no more opening the usual list of internet strreaming ordered by genre..

    I said to myself I know a bit of Perl.. I'll do my own way.. and I started investigating mp3 streams (fulling my screen of binary #*%_ many times ;) and even if I've not reached my original goal I ended with someting useful and cool

    The program will listen an mp3 stream and save each song with the correct title, skipping advertisements if possible and doing it's best to produce an entire song in each file

    The POD documentation describes what I have understood of the ICY protocol (undocumented).

    Suggestions and improvements welcome, have fun!

    use strict; use warnings; use Net::HTTP; use URI; use File::Spec; use Getopt::Long; $|++; my $VERSION = 23; # SOME DEFAULTS my $debug = 0; # --extraparts default value my $cache_size = 2; my $url; my $agent = 'Stream-Cutter-v'.$VERSION; unless ( GetOptions ( 'url=s' => \$url, 'agent=s' => \$agent, 'extraparts|cache=i' => \$cache_size, 'debug=i' => \$debug, + )) {die "$0 -url URL [-agent STRING -extraparts N -debug [0-2] +]"} unless ( $url ){ print "which URL you want to open?"; $url = <STDIN>; chomp $url; } # OTHER VARIABLES # chunk number for debug purpose my $num = 0; # cache used to have more chunks wrote to a file when new song starts my @cache; # used to append to previous file # how_many parts will be equal to $cache_size when new song begin my %previous_file = ( name => undef, how_many => 0); my ( $socket, $icymetaint ) = open_connection( $url ); die "unable to get icy-metaint!" unless defined $icymetaint and $icymetaint > 0; read_stream( $socket, $icymetaint ); ###################################################################### +######### sub open_connection { my $url = shift; my $uri = URI->new( $url ); my $sock = Net::HTTP->new( Host => $uri->host, PeerPort => $uri->port, ) or die $@; $sock->write_request( GET => $uri->path, 'User-Agent' => $agent, # very important: ask for metadata! 'Icy-MetaData' => 1 ) or die $@; my ($http_code, $http_mess, %headers) = $sock->read_response_heade +rs; print join ' ', "\nConnecting to:\t",$uri->as_string, "\nStatus:\t",$http_code,$http_mess,"\n"; # go on if everything is OK 200 if ( $http_code == 200){ # grab useful headers and set them to empty string if undefine +d map {$headers{$_} = $headers{$_} // ''} 'Server','icy-name',' +icy-name', 'icy-genre','icy-br'; print join "\n","Server:\t".$headers{'Server'}, "name:\t".$headers{'icy-name'}, "genre:\t".$headers{'icy-genre'}, "byte rate:\t".$headers{'icy-br'}."kb/s\n\n"; if ( $debug ){ print "HEADERS:\n", (map {qq(\t$_\t=>\t$headers{$_}\n)} grep{defined $headers{$_}} %headers),"\n\n"; } return ($sock, $headers{'icy-metaint'}); } # return undef if not OK 200 else { print "Errors opening the given site..\n"; return undef; } } ###################################################################### +######### sub read_stream { my ($socket, $metaint) = @_; # output filehandle my $out; my $new_metadata; my $file_name; while( 1 ) { my $buffer; # READ the chunk of music $socket->read($buffer, $metaint); # CHECK for new metadata if ( $new_metadata = read_meta($socket)){ # WRITE and get back the NEW filehadle $out = write_stream( $buffer, $out, $new_metadata ); + } else{ # WRITE and get back the OLD filehadle $out = write_stream( $buffer, $out ); } } } ###################################################################### +######### sub read_meta{ my $socket = shift; my ( $metalen, $metabyte); $socket->read($metabyte, 1); $metalen = unpack("C",$metabyte) * 16; if( $metalen > 0) { # We have NEW metadata! JOY print "[$metalen metadata] " if $debug > 1; my $metadata; $socket->read($metadata, $metalen); $metadata = unpack("A$metalen", $metadata); print "\nMETADATA: [",$metadata,"]\n" if $debug > 1; return $metadata; } else { return undef; } } ###################################################################### +######### sub write_stream{ my ($buf, $out, $new_metadata) = @_; # count the overall chunk count for debug purpose $num ++; # NEW song got from metadata if ( $new_metadata ){ my $track_name = $1 if $new_metadata =~ /^StreamTitle='([^ +;]*)';/i; # if StreamTitle is empty probably is an advertisement. Fo +re example: # METADATA: [StreamTitle='';StreamUrl='';adw_ad='true'; # durationMilliseconds='20009';adId='12161';insertionType= +'preroll'; print "\ncurrently playing:\t". ($track_name ? $track_name : '**advertisement**'). +"\n"; if ($out and fileno $out and $cache_size){ print "writing part number [$num] to current file\n" i +f $debug; # DOUBLE write of the current buff print $out $buf ; } my $file_name; ($file_name = $track_name) =~ s/\s+/_/g; $file_name =~ s/\/\\:\*\?\"<>\|//g; $file_name.='.mp3'; # if StreamTitle is empty probably is an advertisement $file_name = File::Spec->devnull() unless $track_name; # set previous filename, but still how_many = 0 $previous_file{name} = $file_name; # the new file open $out, '>', $file_name or die "unable to write to $fil +e_name!"; binmode $out; if ( $cache_size > 0 ){ # PREPEND cache items to the new opened file while ( my $cache_item = shift @cache ) { print "writing cached part to new file: $file_name +\n" if $debug; print $out $cache_item; } } # WRITE $buf to a new file print "writing part number [$num] to new file: $file_name\ +n" if $debug; print $out $buf; } # no new track.. else { print "$num " if $debug > 1; # WRITE $buf to the already opened file if ( $out and fileno $out ){ print $out $buf or die; } # check previous_file if needed to be appended if ( $previous_file{name} and $previous_file{how_many} ){ print "appending part to previous file too\n" if $debug; open my $oldfh, '>>', $previous_file{name} or die "unable to open $previous_file{name} in ap +pend mode!"; binmode $oldfh; print $oldfh $buf or die "unable to write!"; close $oldfh or die "unable to close filehandle!"; $previous_file{how_many}--; } else{ $previous_file{name} = undef; $previous_file{how_many} = $cache_size ; } } # cache rotates.. if ( $#cache == $cache_size - 1 ){ shift @cache, } push @cache, $buf; # return the current file handle return $out; } __DATA__ =head1 NAME C<mp3streamcutter.pl> This program open an mp3 stream and save songs to distinct files. It's + intended to understand the ICY protocol and not intended to save copirighted da +ta. =head1 SYNOPSIS mp3streamcutter.pl -url URL [-agent STRING -extraparts N -debug 0- +2] --url URL is the only necessary argument. Url must be complete of the protoc +ol --agent STRING you can use a custom user-agent to send to server during the conne +ction. Agent defaults to Stream-Cutter-v with the version number of the p +rogram appended. You can find useful to use the string WinampMPEG/2.9 if +refused by some server --extraparts N This parameter governs how many extra parts of the stream have to +be prepended to a new file (via cache) and appended to the previous file (via reopening and appending). --extraparts defaults to 2 that is the b +est I found to have an entire song to the correct file and not to much junk in + it (parts of other songs). --cache is an alias for --extraparts --debug 0-2 With -debug 0 only few details of the server and the title of the +current song will be displayed. With -debug 1 also headers received from the server are shown and +all operations involving new files creation and extra parts possibly (see --extra +parts) wrote to these files Debug level 2 will display also each metadata received (if it cont +ains data) and a progressive number for each chunk of music received =head1 DESCRIPTION This program was inspired by a post wrote by qbxk for perlmonks (see r +eferences). The core part of the program is just a rewrite of the original code by + qbxk The ICY protocol is not well documented. It's build on top of the HTTP + one. This program can help you to understand it in a better way. Basically music + chunks are intercalated with metadata chunks at the position given by the C<icy-m +etaint> header value. At this position you will find a lone byte indicating the lengt +h of the following metadata. If this byte is not 0 but N, then the following N +bytes will be of metadata. Normally in the metadata you find the C<StreamTitle> cont +aining the title of the current song. You can also find the C<StreamUrl> generally empt +y and other things like C<adw_ad> related to advertisements, followed by the duration of +the advertisement and other characteristics of the advertisement. So a typical chunk of metadata for a new song in the stream will be li +ke: C<StreamTitle='Beethoven - Goldberg Variations';StreamUrl='';> or sometimes just like: C<StreamTitle='The Clash - Loose this skin';> without the C<StreamUrl> part, while an advertisemente will look like: C<StreamTitle='';StreamUrl='';adw_ad='true';durationMilliseconds='2000 +9';adId='12161';insertionType='preroll';> The current version of the program will try to skip advertisements che +cking for empty C<StreamTitle> and then using C<File::Spec>'s C<devnull()> a +s filename to save the stream. In the headers of the HTTP request you had to ask for C<Icy-MetaData>, + then the server will answer with various icy headers, notably C<icy-metaint> that is the dimension + of music chunks. After each chunk there will be a byte containing the lenght of the fol +lowing metadata. If this is 0 it means no metadata will follow, but if it is a number a + correnspondant number of bytes have to be read to have the metadata back, typically t +he title and the author. The problem is that the title will arrive when the song already starte +d, so I decided to add a cache (see C<--extraparts> argument) to append and prepend chunc +ks to songs. This way you will have probably unneeded data at start and at the end +of each file but for sure the entire song. Let's say Icy-MetaData is 5 (generally is 16k), you have a situation l +ike ( '=' it's a chunk): -unknown song(1)------ -------------- The Clash - Loose This Skin - +------ ... | | | | STREAM-> = = = [0] = = = = = [3][*][*][*] = = = = = [0] = = = = = [0 +] = = = ... | | | | | | | | | + | unknown song | new song | | | | ------ The Clash - Loo +se This Skin | | | | | empty metadata | ------------- metadata with new tit +le | length of metadata (1) about unknown song: probably you never get an unknown song: I su +spect that ICY protocol will send icy metadata as first part of a brand new response. =head1 REFERENCES See the original post by qbxk at L<perlmonks|https://www.perlmonks.org +/index.pl?node_id=534645> L<a post about ICY protocol|https://stackoverflow.com/questions/491106 +2/pulling-track-info-from-an-audio-stream-using-php/4914538#4914538> L<The ICY protocol explained|http://www.smackfu.com/stuff/programming/ +shoutcast.html> L<A very datailed tutorial|https://thecodeartist.blogspot.com/2013/02/ +shoutcast-internet-radio-protocol.html> L<a not complete but useful description of ICY|https://www.radiotoolbo +x.com/community/forums/viewtopic.php?t=74> L<a technical article about streaming networks|https://people.kth.se/~ +johanmon/dse/casty.pdf> =head1 AUTHOR This program is by Discipulus as found in perlmonks.org with the fund +amental inspiration of the above mentioned qbxk This program is licensed under the same terms of the Perl languange.

    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.
Migrate phone numbers from Nokia 6303c to Nokia 216 then to CAT B30, or the quest for a sane phone
2 direct replies — Read more / Contribute
by ambrus
on Nov 06, 2018 at 17:23

    For a very long time, I've been using a Nokia 6303 classic phone. I was very satisfied with that phone. the built-in camera made good photos, I could use the music player to listen to music through headphones, and the user interface was usable.

    You may recall that back in 2016, I even wrote a perl script to decode the contact lists after that phone backs it up into a zip file (with .NBF extension) containing indivdual files for each contact. That script exports phonebook entries into a semicolon-separated file with lines like this:

    BME központi;+3614631111

    That's a simple entry. Some lines list additional data, such as multiple phone numbers and possibly text notes in the same entry separated by a semicolon. I never figured out how to make a backup file that the phone could import though. In fact I once had to restore all the backups by hand.

    In 2017-11, I bought a Nokia 216 as a spare phone, because I figured that if I lose my phone or it becomes non-functional, I'd like to have a spare phone at hand immediately. That one only has a much worse camera, but that didn't matter anymore, because I had a pretty good compact camera now. I charged the phone and verified that it worked, then put it in a drawer.

    In 2018-08, I lost the Nokia 6303. I cleaned it with too much water, which in itself wouldn't have been a problem, but I then put the battery back in the phone before it dried properly. The phone turned on, but went off after a few seconds, and I couldn't revive it after drying. I'd like to add that this was the second time the phone got wet, it has survived falling into the toilet once before.

    So I mourned for the old phone, but was happy that I had the foresight to have bought a replacement earlier. For a few days.

    I actually also had the foresight to have most of the important phone numbers copied to the SIM card, so I could transfer those phone numbers to the new phone by copying from that, and entered a few more important ones from the dump of the backup, so I had like fifty important phone numbers in the phone. You may ask why I don't just transfer all phone numbers through SIM cards then, since SIM cards are pretty cheap, and I have several old spare ones in my drawer. The problem is that the contact list stored on SIM cards has some big limitations: names can't be longer than about 15 bytes (some characters take more than one byte, I don't know the exact rule), the card can only store 250 contacts (I already had more than that back then), and the card can't store additional information such as notes.

    Anyway, I at least got a phone that I could use for a temporary basis, and transfering the whole contact list was something that could wait a few days. But since I actually tried to use the phone for other tasks, and it turned out to be a disaster.

    It only took a few days to find out how terrible the user interface of the Nokia 216 was. How I raged!

    There are only three good things I can say about the Nokia 216: it generally reacts quickly enough to keypresses, it accepts two SIM cards, and it's possible to import a contact list prepared on a computer.

    Here's how I imported the contact list. After finding out the limitations of the phone, First, I edited the semicolon-separated backup file to shorten the names and otherwise clean up the list. While I was there, I fixed all the names to have the correct letters, because some of the entries actually had names inherited from one of the two even older phones, which didn't have a full character set, so they had characters like "ŕ" instead of "á" and "ö" instead of "ő" I never bothered to fix that on the 6303, even though that one already supported all letters of Hungarian, and I entered all the new names with the correct characters. Then I used a messy perl script to verify that the list of contacts looks fine, and convert them to the format that the 216 accepts, which I could reverse engineer from an exported contact list in a few tries. Here's the code, with a few details omitted.

    This emits a single contacts file in vcard format with entries like this.

    BEGIN:VCARD VERSION:2.1 N;ENCODING=QUOTED-PRINTABLE;CHARSET=UTF-8:;= BME=20k=C3=B6zponti;;; TEL;VOICE;CELL:+3614631111 END:VCARD

    Two phone numbers in the same entry are handled by writing it as two entries, but extra notes are discarded.

    You must copy that file to the SD card (either with an SD card reader or through a USB cable) as "/Backup/backup.dat", then restore the backup in the settings. Note that this will erase the existing contacts in the memory of the phone (but not the SIM card).

    Anyway, I eventually set off to try to buy a better phone. That's not easy. It's hard to find reviews of cheap feature phones, or find copies that I can try without having to buy them.

    Eventually in 2018-11, I bought a CAT B30 phone.

    So I had to figure out how to move the contact list to the CAT B30 phone.

    Copy the file from the Nokia 216 to the computer. Here I used the default filename "backup.dat" (I actually save the backups in more sensible names including a date so I can distinguish backups, but this is just an example). Get the backup rewritten with this one-liner:

    perl -we 'while (<>) { if (/^\r\n\z/) {} elsif ($c) { $c=0; /^(.*);;;\ +r\n\z/ or die "nc $_"; $f=";CHARSET=UTF-8;ENCODING=QUOTED-PRINTABLE:" +; print "N$f;$;$1;;;\r\nFN$f$1\r\n"; } elsif (/^N;/) { /^N;ENCODING=Q +UOTED-PRINTABLE;CHARSET=UTF-8:;=\r\n\z/ or die; $c=1; } elsif (/^TEL; +/) { /^TEL;[A-Z]+;(CELL:[+0-9#*p]+)\r\n/ or die qq(tel $_); print "TE +L;CELL:$1\r\n"; } elsif (/^(BEGIN:|VERSION:|END:)/) { print } else { +die "parse $_" } }' backup.dat > backup.vcf

    This outputs the records in the correct format for the CAT B30:

    BEGIN:VCARD VERSION:2.1 N;CHARSET=UTF-8;ENCODING=QUOTED-PRINTABLE:;BME=20k=C3=B6zponti;;; FN;CHARSET=UTF-8;ENCODING=QUOTED-PRINTABLE:BME=20k=C3=B6zponti TEL;CELL:CELL:+3614631111 END:VCARD

    Copy the output file ("backup.vcf") onto the CAT B30, and this time you can use any filename and any directory, as long as the extension is ".vcf". Delete the existing phone numbers from the contacts list, because the CAT B30 doesn't do this automatically, it merges the contact list. Then import the contacts from the contacts menu by selecting that file on the SD card.

    (This script doesn't handle assigning the custom ringtones to family members directly, I'll set those directly in the phone.)

Dancer2 Module for Generating HTML from markdown
1 direct reply — Read more / Contribute
by nysus
on Nov 03, 2018 at 20:50

    I wrote a new module for converting markdown files to HTML for use with Dancer2. No perl code is necessary to use! Just make some entries in your config.yml file and you are done. I think it'll be very useful. For example, you can now just throw your copy into a repo with markdown files and clone it to your local hard drive and you are done ever having to mess with HTML.

    It has two basic modes of operation right now: convert a single markdown file to a single HTML document or convert all markdown files in a directory to an HTML document. It can can also automatically generate a table of contents for the file that links to the headers in the content.

    I've used it to generate a pretty nifty looking tutorial that's super easy to navigate with a table of contents that's actually useful. It's all on one page so no annoying clicking around.

    See it on CPAN and the GitHub repo.

    I plan on making it have tight integration with GitHub in the near future. I also plan on creating yet another local POD viewer with it as well.

    I'd appreciate feedback and ideas for further improvements. Thanks!

    $PM = "Perl Monk's";
    $MCF = "Most Clueless Friar Abbot Bishop Pontiff Deacon Curate Priest Vicar";
    $nysus = $PM . ' ' . $MCF;
    Click here if you love Perl Monks

Implementing a 2-mode "Audiobutton" on the Raspberry Pi
1 direct reply — Read more / Contribute
by cavac
on Oct 25, 2018 at 06:40

    Some time ago, i saw those fake "emergency stop" buttons on Amazon that play a funny audio sample when you press them. But they were too expensive and - much more important - you can't change the sound on them. So i implemented my own.

    First i hooked up a real (non-latching) emergency button to a Raspberry Pi GPIO pin and a set of rather ancient and crappy Desktop speakers to the analog out of the Pi. I also prepared some audio files in raw format: Decoding MP3 costs performance, so it is not as instantaneous as playing a raw file, also the Pi runs some other performance critical stuff and using raw files instead of wav/mp3 fixed some timing issues.

    A short button press plays one of the 3 "bullshit detected" samples. Holding the button for about 1 second before releasing plays the 30 second jeopardy "thinking" music.

    Note: This is actually the "dumb" version of the script. My local implementation also triggers some LED display for the bullshit alerts and runs an analog meter (via an Arduino) from 100% to 0% while the jeopardy music ticks down the seconds.

    perl -e 'use MIME::Base64; print decode_base64("4pmsIE5ldmVyIGdvbm5hIGdpdmUgeW91IHVwCiAgTmV2ZXIgZ29ubmEgbGV0IHlvdSBkb3duLi4uIOKZqwo=");'
Perl and Kubernetes
No replies — Read more | Post response
by reisinge
on Oct 23, 2018 at 10:26

    Kubernetes documentation uses Perl (a one-liner) in an example Job:

    apiVersion: batch/v1 kind: Job metadata: name: pi spec: template: spec: containers: - name: pi image: perl command: ["perl", "-Mbignum=bpi", "-wle", "print bpi(2000)"] restartPolicy: Never backoffLimit: 4

    They're not afraid to mix and match venerable and newer technologies :-).

    What do you care what other people think? -- Richard Feynman
Cheat at Scrabble
5 direct replies — Read more / Contribute
by 1nickt
on Oct 21, 2018 at 09:51

    Calculates the highest score possible from the letters given, taking into account any bonuses on the squares to be covered.

    (Rudimentary tool that does not handle combinations with the words already on the board).

    My local newspaper has a Scrabble-based game that involves simply finding the highest scoring word from seven letters and bonus tile positions provided. Note: quite often the highest scoring word according to the newspaper is not found in my words list :-(

    Specify double- and triple-word bonuses with -dw and -tw, and double- and triple-letter bonuses with -dl=N and -tl=N where N is the letter position.

    Examples:

    $ perl scrabble.pl eoaprzn Found 13,699 1-7 letter strings in eoaprzn. Found 57 words in eoaprzn. zap : 14 $ perl scrabble.pl eoaprzn -dw Found 13,699 1-7 letter strings in eoaprzn. Found 57 words in eoaprzn. zap : 28 $ perl scrabble.pl eoaprzn -tl=3 Found 13,699 1-7 letter strings in eoaprzn. Found 57 words in eoaprzn. raze : 33

    use strict; use warnings; use feature 'say'; use Path::Tiny; use Algorithm::Permute; use Number::Format 'format_number'; use List::Util 'uniq'; use Getopt::Long; my @dl; my @tl; my $dw; my $tw; my $debug; GetOptions( 'dl=i' => \@dl, 'tl=i' => \@tl, 'dw' => \$dw, 'tw' => \$tw, 'v' => \$debug, ); my $input = shift or die 'Died: No input!'; my $length = length $input; my @input_chars = split '', $input; my $words_file = '/usr/share/dict/words'; my %words = map { $_ => 1 } path( $words_file )->lines({chomp => + 1}); my %worth = ( a => 1, b => 3, c => 3, d => 2, e => 1, f => 4, g => 2, h => 4, i => 1, j => 8, k => 5, l => 1, m => 3, n => 1, o => 1, p => 3, q => 10, r => 1, s => 1, t => 1, u => 1, v => 2, w => 2, x => 8, y => 4, z => 10, ); my @partials; for (1 .. $length) { my $P = Algorithm::Permute->new( \@input_chars, $_ ); while (my @res = $P->next) { push @partials, join '', @res; } } @partials = uniq @partials; say sprintf 'Found %s 1-%s letter strings in %s.', format_number(scalar @partials), $length, $input; my %found = map { $_ => calc_score($_) } grep { $words{$_} } @partials + ; say sprintf 'Found %s words in %s.', format_number(scalar keys %found) +, $input; for ( sort { $found{$b} <=> $found{$a} } keys %found ) { say "$_ : $found{$_}"; last if not $debug; } ############### sub calc_score { my $word = shift; my $val; $val += $worth{$_} for split '', $word; $val += 50 if length $word == 7; return $val + calc_bonus($word, $val); } sub calc_bonus { my ($word, $val) = @_; my @chars = split '', $word; my $bonus = 0; for (@dl) { $bonus += $worth{ $chars[$_ - 1] } if $chars[$_ - 1]; } for (@tl) { $bonus += 2 * $worth{ $chars[$_ - 1] } if $chars[$_ - 1]; } $bonus += $val if $dw; $bonus += 2 * $val if $tw; return $bonus; } __END__


WebPerlizator - automating WebPerl (by haukex) page creation
3 direct replies — Read more / Contribute
by Discipulus
on Oct 19, 2018 at 07:10
    Hello nuns and monks!

    did you heard the big news? WebPerl by haukex is here!

    I smell it as the best thing happened to Perl since years (alongside with MCE ..) and I already used to produce PM examples: very useful and shining.

    But as I'm really lazy I wrote the below snippet that try to automate the process of copying perl code to the page, creating input files, etc..

    Imagine that you have simple_reader.pl as follow:

    use strict; use warnings; open my $fh,'<', 'input1.txt' or die; while (<$fh>) {print if /b/}

    and input1.txt containing:

    aaa bbb ccc

    then you can just run:

    perl webperlizator.pl -s simple_reader.pl -i input1.txt https://webperl.zero-g.net/democode/perleditor.html#%7B%22script_fn%22 +%3A%22simple_reader.pl%22%2C%22script %22%3A%22use%20strict%3B%5Cnuse%20warnings%3B%5Cn%5Cnopen%20my%20%24fh +%2C%27%3C%27%2C%20%27input1.txt%27%20or %20die%3B%20%5Cnwhile%20%28%3C%24fh%3E%29%20%7Bprint%20if%20%2Fb%2F%7D +%22%2C%22inputs%22%3A%5B%7B%22text%22%3 A%22aaa%5Cnbbb%5Cnccc%5Cn%22%2C%22fn%22%3A%22input1.txt%22%7D%5D%2C%22 +cmdline%22%3A%22perl%20simple_reader.pl%22%7D

    or even perl webperlizator.pl  -s simple_reader.pl -i input1.txt --browse to open it directly in the browser!

    have fun and thanks haukex!!

    update newer version, with more features, is on my github

    use strict; use warnings; use URI::Escape; use Getopt::Long; use JSON::MaybeXS qw(encode_json); my (@infiles, @outfiles, $script, $lineofcode, $browse, $help); unless ( GetOptions ( "script=s" => \$script, "line|oneliner|code|c=s" => \$lineofcode, "inputfiles=s" => \@infiles, "outputfiles|o=s" => \@outfiles, "browse" => \$browse, "help" => \$help )) { print "GetOpt::Long returned errors (see a +bove), available options:\n\n".help(); exit; } if ($help){ print help(); exit 0;} my $json = {}; if ($lineofcode){ $$json{cmdline} = "perl $lineofcode"; } elsif ($script){ open my $fh, '<', $script or die "unable to read $script!"; while (<$fh>){ $$json{script} .= $_ ; } $$json{script_fn} = $script; $$json{cmdline} = "perl $script"; } else{ die "Please feed at least one script using -script or a line of pe +rl code via -code\n\n".help(); } if ( $infiles[0] ){ $$json{inputs}=[]; } foreach my $in (@infiles){ open my $fh, '<', $in or die "unable to read $in!"; my $file = { fn => $in}; while (<$fh>){ $$file{text}.=$_; } push @{$$json{inputs}},$file; } if ( $outfiles[0]){ $$json{outputs} = \@outfiles ; } my $url = 'https://webperl.zero-g.net/democode/perleditor.html#'.(uri_ +escape( encode_json( $json ) )); if ($browse){ if ($^O =~/mswin32/i) {exec "start $url"} else{ exec "xdg-open $url"} } else{ print $url; } #### sub help{ return <<EOH; $0 USAGE: --script file|--code line [--inputfile file [--inputfile file] --o +utputfile file [--outputfile file] --browse] $0 -script script.pl $0 -script script.pl [ -inputfile file1.txt -inputfile file2.txt +-outputfile file3.txt -browse] $0 -code "-e 'print qq(Hello WebPerl!)'" $0 -code "-e 'print qq(Hello WebPerl!)'" [ -i infile1.txt -i infil +e2.txt -o outfile3.txt -browse] --script -s accept a perl program filename as only argument. Both --script and --code make no sense: just specify one. --code -c is intended to be used to pass a oneliner. The execu +table name, aka perl, will be prepended automatically. Any perl switch must be explicitly passed + also -e For example: webperlizator.pl -code "-le 'print qq(Hello WebPerl!)'" webperlizator.pl -code "-lne 'print \"found a b\" if /b/' file1.tx +t" -i file1.txt -b Pay attention on quotes suitable for you OS. --inputfiles -i is for input files; more than one can be feed --outputfiles -o is for output file and more than one can be passe +d in --browse -b open the default browser, hopefully, pointing to the W +ebPerl right page --help -h prints this help EOH }

    L*

    PS updated to handle onliners in a better way

    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.
Resistor network simplifier
1 direct reply — Read more / Contribute
by roboticus
on Oct 13, 2018 at 18:41

    Hello, fellow monks!

    This isn't really all that cool, but I'm posting it just in case someone might be interested. I'm trying to get back to my QRP transmitter/receiver project and had just wanted to convince myself that Pi attenuators properly reduced to the expected input and output impedance. Rather than do a couple by hand, I went full nerd and wrote code to do it instead.

    Essentially, the code lets you create a network of resistors (via the build_impedance() function) and pi_pads (via build_pad()) and attach them together via the named ports. Once you've got the network built, remove all named nodes you don't care about and then tell it to generate the simplified network.

    The code, as it is now, should give you:

    $ perl attenuator_pad.pl ********************************************************************** +********** 10dB Attenuator terminated w/ 50 ohms ********************************************************************** +********** 10dB Pad N: in_neg(1) in_pos(2) out_neg(3) out_pos(4) (1 3 0.05), (2 1 100), (2 4 75), (4 3 100) 50 ohm terminator N: in_neg(5) in_pos(6) (6 5 50) 10dB Pad + terminator N: in_neg(1) in_pos(2) (1 3 0.05), (2 1 100), (2 4 75), (4 3 50), (4 3 100) Simplified network N: in_neg(1) in_pos(2) (1 2 52) ********************************************************************** +********** Two pads cascaded and terminated ********************************************************************** +********** PAD 10dB N: in_neg(1) in_pos(2) out_neg(3) out_pos(4) (1 3 0.05), (2 1 100), (2 4 75), (4 3 100) PAD 20dB N: in_neg(5) in_pos(6) out_neg(7) out_pos(8) (5 7 0.05), (6 5 68), (6 8 270), (8 7 68) TERM 50ohm N: in_neg(9) in_pos(10) (10 9 50) PAD 20dB + TERM 50ohm N: in_neg(5) in_pos(6) (5 7 0.05), (6 5 68), (6 8 270), (8 7 50), (8 7 68) PAD 10dB + PAD 20dB + TERM 50ohm N: in_neg(1) in_pos(2) (1 3 0.05), (2 1 100), (2 4 75), (3 7 0.05), (4 3 68), (4 3 100), ( +4 8 270), (8 7 50), (8 7 68) RESULT! N: in_neg(1) in_pos(2) (1 2 52.5)

    I just hardcode the commands to build the networks up front, and then let it do its thing.

    Comments about my coding style are always welcome, as I'm typically the only person who ever reads my code. Questions about it are just as welcome.

    ...roboticus

    When your only tool is a hammer, all problems look like your thumb.

[perl6] Game Statistics Package
No replies — Read more | Post response
by holyghost
on Oct 11, 2018 at 08:21
    I introduce a Game AI statistics package on GitHub next week, here is some code for it, it was written in Perl6. It uses evolvable distribution populations for the math formulas :
    class Population { has @.population; method BUILD() { .population = <>; } method add($x) { push(.population, $x); } }
    use Population; class DistributionPopulation is Population { method BUILD() { } method Expectance() { my $e = 0.0; for .population -> $p { $e += $p; } return $e / .population.length; } method Variance () { my $e = .Expectance(); my $var = 0.0; for .population -> $p { $var += ($p - $e) * ($p - $e); } return $var / (.population.length - 1); } }
    class Covariance { method Covariance($xpop,$ypop) { my $ex = $xpop.Expectance(); my $ey = $ypop.Expectance(); my $cov = 0.0; for $xpop.population, $ypop.population -> $p,$q { $cov += ($p - $ex) * ($q - $ey); } return $cov / $xpop.population.length; } }
    use Covariance; role ThisCovariance { method cov($xpop,$ypop) { return Covariance().Covariance($xpop,$ypop); } } class Correlation does ThisCovariance { method BUILD() { } method correlation($xpop,$ypop) { ### These are distribution a +rgs my $varx = $xpop.Variance(), $vary = $ypop.Variance(); my $cov = .cov($xpop, $ypop); return $cov / (sqrt($varx) * sqrt($vary)); } }
Embedding WebPerl Code Demos into Other Pages
1 direct reply — Read more / Contribute
by haukex
on Oct 10, 2018 at 14:14

    I was inspired by LanX's comment here:

    You know, you could use this technology to build a training site for Perl with interactive programming challenges...

    And I created a set of HTML pages that can be embedded into <iframe>s and run Perl!

    WebPerl Code Demo Editor

    Includes documentation, I hope it's clear, let me know if you have questions!


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 contemplating the Monastery: (4)
    As of 2018-11-12 19:42 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?
      My code is most likely broken because:
















      Results (144 votes). Check out past polls.

      Notices?