Beefy Boxes and Bandwidth Generously Provided by pair Networks
No such thing as a small change

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.

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.


    $ perl eoaprzn Found 13,699 1-7 letter strings in eoaprzn. Found 57 words in eoaprzn. zap : 14 $ perl eoaprzn -dw Found 13,699 1-7 letter strings in eoaprzn. Found 57 words in eoaprzn. zap : 28 $ perl 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 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 -s -i input1.txt %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

    or even perl  -s -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 = ''.(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 $0 -script [ -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: -code "-le 'print qq(Hello WebPerl!)'" -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 }


    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 ********************************************************************** +********** 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.


    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!

Using a git filter to Cache HTML Resources Locally
1 direct reply — Read more / Contribute
by haukex
on Oct 07, 2018 at 14:50

    So I've been doing quite a bit of web development recently, and several of my HTML files use resources from CDNs, like jQuery or normalize.css. While I'm developing, I refresh pages quite often, and also usually use my browser's development tools to disable caching. This means that I hit the CDNs quite often, and aside from the speed and bandwidth usage, one of the CDNs actually started rate limiting me... oops. In other projects, I'd usually just pull those resources onto my local server, keep them there, and be done with it. But the stuff I'm currently working on is for distribution, so I'd like to keep the CDN URLs in the HTML, and not have to rewrite them by hand.

    Enter git filters: Documented in the Git Book Chapter 8.2 and in gitattributes, they provide a way to pipe source code files through an external program on checkout, as well as on diff, checkin, and so on. This allows you to have one version of a file checked into the repository, but to use a filter to make changes to the files that actually end up in the working copy on your machine. These changes are also reversed by the filter and not checked back into the repository on checkin, and don't show up in any commands like git diff, git status, etc.

    So in this case, the files I want to have in the repository will have lines that look something like this:

    <link rel="stylesheet" href="" /> <script src=""></script>

    but when I check these files out into my local working copy, they should get rewritten into something like this:

    <link rel="stylesheet" href="_cache/example.css" /> <script src="_cache/example.js"></script>

    Of course, Perl to the rescue!

Interprocess messaging with Net::Clacks
3 direct replies — Read more / Contribute
by cavac
on Oct 04, 2018 at 07:52

    So, your project is going fine, your codebase is groing fast. But now your have the problem that some of your processes have to communicate with each other. Maybe, some temperature sensor needs to report its sensor value every few seconds to the central heating system. Maybe the central heating system needs to know if the windows are open and close them before heating the house. Another process wants to count how many times the door has been opened and log the sum once a minute...

    Net::Clacks to the rescue!

    The Net::Clacks modules implement a client/server based interprocess messaging. Without going too much into the internals of the protocol, a client can either send notifications ("event xy has just happened") or values ("the reading for sensor xy is now 42"). Other clients may (or may not) choose to listen to those broadcasts.

    Net::Clacks also implements Memcached-like value storage and retrieval. So instead of broadcasting, a value can be stored, read out, incremented, decremented and deleted.

    A note on security: Currently, the system only implements a shared-secret type thing (all clients in a clacks network use the same username/password). This will get changed in the future. I'm planning to make it so that you can override the authentication checks with your own function and return which permissions the client has. But that is not yet implemented.

    Let's do a simple example project: Server, chatclient, chatbot and a clock process to trigger some actions at the start of every minute.

    "For me, programming in Perl is like my cooking. The result may not always taste nice, but it's quick, painless and it get's food on the table."
Pre-rendering graphics in ZPL label printers
No replies — Read more | Post response
by cavac
on Oct 02, 2018 at 09:31

    I've been working quite a lot with ZPL compatible label printers (Zebra, TSC) the last few years. When working with complex forms or large graphics, printing can be quite slow, because the printer has to - basically - calculate everything pixel-by-pixel for every single label. Not to mention the fact that the standard ZPL image format is not... well "nice" to work with with standard open source tools.

    ZPL has a way to store a rendered label, which it can reuse later quite a bit faster (in most cases). Basically, you load in the saved, pre-rendered label and then add you dynamic content.

    Here is the Perl script to convert a PNG file to ZPL, including the "save" command. E.g. this generates the ZPL file to pre-render the image and save it to the printers flash memory.

    #!/usr/bin/env perl use strict; use warnings; use GD; use Data::Dumper; my $xoffs = 20; my $yoffs = 20; my $minwhite = 200; my $verbose = 0; my $image = GD::Image->new('examplelogo.png'); my $w = $image->width(); my $h = $image->height(); print "Image size: $w x $h\n"; open(my $ofh, '>', 'savelogo.zpl') or die($!); # Start of form; print $ofh "^XA\n"; for(my $x = 0; $x < $w; $x++) { for(my $y = 0; $y < $h; $y++) { my $index = $image->getPixel($x,$y); my ($r,$g,$b) = $image->rgb($index); if($r < $minwhite) { print "#" if $verbose; print $ofh '^FO' , ($x*1) + $xoffs, ',' , ($y*1) + $yoffs, + '^GB1,1,1,B,0^FS', "\n"; } else { print " " if $verbose; } } print "\n" if $verbose; } # Save graphic to flash mem print $ofh "^ISR:LOGO.GRF,Y\n"; # End of form print $ofh "^XZ\n"; close $ofh;

    $xoffs and $yoffs change the upper left starting point where the image is drawn and $minwhite sets the threshold of what is considered a white vs. black pixel. This generates ZPL code like this (abbreviated), setting one pixel black per line:

    ^XA ^FO55,74^GB1,1,1,B,0^FS ^FO55,75^GB1,1,1,B,0^FS ^FO55,76^GB1,1,1,B,0^FS ^FO55,77^GB1,1,1,B,0^FS ^FO55,78^GB1,1,1,B,0^FS ... ^FO561,126^GB1,1,1,B,0^FS ^FO561,127^GB1,1,1,B,0^FS ^FO561,128^GB1,1,1,B,0^FS ^ISR:LOGO.GRF,Y ^XZ

    To actually save the image to the printer, on Linux you would run something like this if you run CUPS:

    lpr -P yourprintername -o raw savelogo.zpl

    Now you can use the saved image in a normal label print by loading it at the start:


    and then printing it:

    lpr -P yourprintername -o raw label.zpl

    Of course, this can trivially be used for dynamic content. But i leave it to the reader to figure out how to load label.zpl, replace XXCAPTIONXX with an increasing number, saving it to tmp.zpl and calling lpr...

    You also can get the whole example (including a badly made example png) with Mercurial SCM:

    hg clone

    Have fun!

    "For me, programming in Perl is like my cooking. The result may not always taste nice, but it's quick, painless and it get's food on the table."
Finding Differential Cryptanalysis Inputs with PDL
No replies — Read more | Post response
by mxb
on Sep 21, 2018 at 10:35

    In addition to Perl and PDL, one of my favourite topics is cryptography, specifically cryptanalysis.

    One 'common' cryptanalytical attack, for which modern ciphers are designed against is differential cryptanalysis. Some older ciphers are vulnerable to this attack and various tutorials exist to teach differential cryptanalysis. One of these is by Jon King against the FEAL cipher and is located here.

    One aspect of the differential cryptanalysis attack is to enumerate all potential differentials against the non-linear round function. The below code performs this analysis against the FEAL-4 cipher's round sub-function 'G'. It successfully identifies the two fixed input differentials.


    #!/usr/bin/env perl use 5.020; use warnings; use autodie; use PDL; use PDL::NiceSlice; # This code attempts to find all differential characteristics in the # FEAL-4 cipher round subfunction 'G'. # # Reference: # # # 'G' function is addition of a, b and x, then bitwise rotate left # by 2 bits # a, b, x and the final value are all 8 bits. # For our purposes, x can be ignored, as it's constant 0 or 1 # # a # | # x -> [+] <- b # | # [<<<] # | # OUT # # Perform addition my $G = sequence( byte, 256 ) + sequence( byte, 256 )->transpose; # Bitwise rotation $G = ( $G << 2 ) | ( $G >> 6 ); # At this point, $G contains all possible inputs for a and b, and # the associated output value # # Now we wish to find all differentials throughout this function # # To do this, we need to find differentials between each possible # inputs to 'a', and 'b' and observe the differential in the result # # There are two known differentials for this function. A differential # value of 0 and 0x80 (128) for 'a' will always return a constant # differential output (0 and 2) respectively. # Calculate the differential table my $diffs = $G ^ $G ( (0) ); # Find the minimum and maximum value for each differential my ( $min, $max ) = minmaxover($diffs); # Print index of differentials where minimum and maximum value are # equal. As the index is also in the input value, this returns the # actual differential: print "Contant differentials for input differentials of: ", which( $min == $max ), "\n";
Windows Automation by Sparrowdo
No replies — Read more | Post response
by melezhik
on Sep 11, 2018 at 10:36
    Sparrowdo is a universal task runner and CM tool written on Perl6/Perl5. It enables configuration and automation tasks with efficient and simple way. I have created a fresh post on introducing Sparrowdo automation for Windows OS. Everyone is interested in Windows automation by Perl5/Perl6 are welcome to read.
A hash that stores itself between runs
1 direct reply — Read more / Contribute
by Anonymous Monk
on Sep 06, 2018 at 10:53
    This is so small compared to the rest of the posts here in CUFP, I hesitated for a while before deciding to submit anyway:
    package cache { # no particular reason to use them, # but the syntax sugar is *so* sweet use experimental 'signatures'; use base 'Storable'; my %paths; sub new($class,$path) { my $self = eval { return Storable::retrieve($path) } || bless {}, $class; $paths{$self} = $path; return $self; } sub DESTROY($self) { $self->store($paths{$self}); } }
    How to use:
    • create the object as you usually would: my $cache = cache::->new("store.db");
    • anywhere you might find it useful to cache results in a hash between runs of a function, use defined-or assignment to retrieve the value if it's already cached: my $val = $cache->{$argument} //= func($argument);
    • next time you run the script again the cached values are still there, no need to recalculate
    • combine with memoization for best results
    The class uses inside-out objects so you could use objects as ordinary hashes with no reserved fields. This will get slower the bigger your cache gets because there is no RLU eviction, everything is stored in memory and the whole store has to be loaded from disk on startup and serialised on shutdown. Still, for small scripts I find it useful.
Creating random sentences from a dictionary
4 direct replies — Read more / Contribute
by Lotus1
on Sep 04, 2018 at 17:15

    Here's a bit of random nonsense. Create a random number of lines with a random number of random words from a dictionary. Repeated words are acceptable.

    use strict; use warnings; my @words = <DATA>; chomp @words; my $number_of_sentences = 3 + int( 10*rand() ); for (1..$number_of_sentences) { my $sentence_length = 2 + int( 9*rand() ); my @sentence = map {$words[int(rand($#words+1))]} 1..$sentence_len +gth; $sentence[0] = ucfirst $sentence[0]; print join(" ", @sentence), ".\n\n"; } __DATA__ abnormal blah crazy dolt dolthead doltish doltishly doltishness eccentric fallacious galling hapless illogical jabber kooky lame misguided nuisance officious pretense questionable resentful shaky tenuous untenable vague warp yawn zombie

    The output from a run was:

    Doltishly yawn yawn. Shaky warp yawn tenuous misguided illogical doltish. Warp blah officious kooky dolthead untenable eccentric untenable offic +ious. Galling officious. Abnormal doltish hapless tenuous. Galling crazy. Abnormal galling doltish. Kooky crazy doltishly doltishness. Eccentric blah fallacious galling. Pretense untenable questionable abnormal kooky zombie dolt jabber.
WebPerl Regex Tester (beta)
2 direct replies — Read more / Contribute
by haukex
on Sep 04, 2018 at 15:27

    I recently published a beta of WebPerl, and now I've written my first full web app with it: a browser-based regex tester.

    Since WebPerl is a full build of Perl, you have the full power of core Perl at your disposal, and it runs entirely in the browser - unlike some other online regex testers, which either run perl on a server, or only support PCRE (Perl Compatible Regular Expressions). It should work in modern browsers like Firefox and Chrome (not tested in IE yet, it might have issues there). Try it out, and let me know what you think, and report any issues you might find. I'd also be happy to accept issues and patches on GitHub. Please consider it a beta.
    (It may take a few seconds to load and initialize, WebPerl is currently a ~4MB download, but once it's in your cache it should be fine.)

    You can even create URLs to examples, here I'll use that to show off some features:

Tk Morse Code Ear tutor
2 direct replies — Read more / Contribute
by zentara
on Aug 26, 2018 at 13:12
    Hi, another Perl/Tk app. :-) Any comments or improvements welcome. The details are at the top of the script. Basically, this tutor forces you to use your ear to recognize letters, forcing the brain to make a direct auditory connection to the letter. It also demonstrates how to make PCM tones of any frequency and duration without the obsolete /dev/dsp.

    I'm not really a human, but I play one on earth. ..... an animated JAPH
Exploring Type::Tiny Part 5: match_on_type
No replies — Read more | Post response
by tobyink
on Aug 19, 2018 at 14:41

    Type::Tiny is probably best known as a way of having Moose-like type constraints in Moo, but it can be used for so much more. This is the fifth in a series of posts showing other things you can use Type::Tiny for. This article along with the earlier ones in the series can be found on my blog and in the Cool Uses for Perl section of PerlMonks.

    It's pretty common to do things like this:

    use Types::Standard qw( is_ArrayRef is_HashRef ); use Carp qw( croak ); sub process_data { my ($self, $data) = @_; if (is_ArrayRef($data)) { $self->_process_value($_) for @$data; } elsif (is_HashRef($data)) { $self->_process_value($_) for values %$data; } else { croak "Could not grok data"; } }

    Type::Utils provides a perhaps slightly neater way to do this:

    use Types::Standard qw( ArrayRef HashRef Any ); use Type::Utils qw( match_on_type ); use Carp qw( croak ); sub process_data { my ($self, $data) = @_; match_on_type $data, ArrayRef, sub { $self->_process_value($_) for @$data }, HashRef, sub { $self->_process_value($_) for values %$data } +, Any, sub { croak "Could not grok data" }; }

    The match_on_type function takes a value and a set of type–coderef pairs, dispatching to the first coderef where the value matches the type constraint. This function is stolen from Moose::Util::TypeConstraints.

    You can get an order of magnitude faster though by doing something similar to what Type::Params does — compiling the match once, then calling it as needed.

    Let's look at a naïve (and wrong) way to do this first and examine the problems:

    use Types::Standard qw( ArrayRef HashRef Any ); use Type::Utils qw( compile_match_on_type ); use Carp qw( croak ); sub process_data { my ($self, $data) = @_; state $matcher = compile_match_on_type ArrayRef, sub { $self->_process_value($_) for @$data }, HashRef, sub { $self->_process_value($_) for values %$data } +, Any, sub { croak "Could not grok data" }; $matcher->($data); }

    The big problem here is that the first time process_data is called, the matcher will close over $self and $data. Subsequent calls to $matcher will reuse the same closed over variables. Oops.

    The simplest way of solving this is to take advantage of the fact that a compiled matcher (unlike match_on_type) can take a list of arguments, not just one. Only the first argument is used for the type matching, but all arguments are passed to the coderefs on dispatch.

    use Types::Standard qw( ArrayRef HashRef Any ); use Type::Utils qw( compile_match_on_type ); use Carp qw( croak ); sub process_data { my ($self, $data) = @_; state $matcher = compile_match_on_type ArrayRef, sub { my ($d, $s) = @_; $s->_process_value($_) for +@$d }, HashRef, sub { my ($d, $s) = @_; $s->_process_value($_) for +values %$d }, Any, sub { croak "Could not grok data" }; $matcher->($data, $self); }

    Like many Type::Tiny interfaces that expect coderefs, compile_match_on_type also accepts strings of Perl code as an alternative, and is able to optimize things better if those are supplied:

    use Types::Standard qw( ArrayRef HashRef Any ); use Type::Utils qw( compile_match_on_type ); use Carp qw(); sub process_data { my ($self, $data) = @_; state $matcher = compile_match_on_type ArrayRef, q{ my ($d, $s) = @_; $s->_process_value($_) for @$d + }, HashRef, q{ my ($d, $s) = @_; $s->_process_value($_) for val +ues %$d }, Any, q{ Carp::croak("Could not grok data") }; $matcher->($data, $self); }

    The coderefs compiled by compile_match_on_type should be very efficient. The technique is very similar to how Type::Coercion compiles coercions.

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 exploiting the Monastery: (7)
    As of 2018-12-14 20:26 GMT
    Find Nodes?
      Voting Booth?
      How many stories does it take before you've heard them all?

      Results (69 votes). Check out past polls.