Beefy Boxes and Bandwidth Generously Provided by pair Networks
"be consistent"

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.

Read and manage IMAP mails for me
No replies — Read more | Post response
by Discipulus
on Jan 30, 2023 at 07:17
    Hello community!

    Here you have my recent project using Mail::IMAPClient intended to manage some of my incoming emails. It is able to speak too, but the current speaking ability is provided by Win32::SAPI5 so if you want to use on other platforms, just modify the small voice sub at the end of the program (and lines 8 and 22).

    The core of this simple client is the infinite while (1) loop at line 135: an incoming message will be passed to process_message (line 164).

    Here in the process_message sub I put some simple example of managing emails: extract the sender (both address and display name), subject and body and some IMAP operation: mark as read, move the message.. modify to your needs.

    On windows and using the SAPI voice this program will use the system default voice: you can modify it under control panel -> Speech recognition -> properties (or somthing like that.. you can figure it).

    The program handles two signals: BREAK to show the current status of the program and, more important, INT to premit the IMAP logout and so a clean exit.

    Here a small example of session:

    shell>perl -u -s +m -p 993 -ssl 1 -i 5 Enter password for on VOICE: succesfully authenticated on + port 993. Checking INBOX for incoming messages every 5 seconds. CTRL-C to exit the program permitting the IMAP logout CTRL-BREAK to review the current status of the program Tabella codici attiva: 1252 + # I press CTRL-BREAK ====================================================================== PID 5052 Mon Jan 30 12:33:45 2023 - connected checked messages: 3 ====================================================================== + # a new message triggering default rule ====================================================================== Mon Jan 30 12:47:29 2023 ====================================================================== VOICE: Default rule. New message from: Johann Sebastian Bach. Subject: + Listen to my new album! ====================================================================== + # I press CTRL-C Logging out.. VOICE: IMAP logout.. Exiting..

    ..and obviously the code:


    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.
gd_tiler using GD to create tiled images
1 direct reply — Read more / Contribute
by Discipulus
on Dec 03, 2022 at 11:47
    Hello folks!

    ..since its raining.. :) inspired by my own challenge (yes: I feel brave enough!) I wrote a nice subroutine to tile images horizontally or vertically. No need to get more complicate: if you need a tiled 3x3 image just build up three times a 3x1 and use them to create the 3x3 one.

    Being the space divided evenly, if you pass images very different in shape the result will be ugly to see, but the sub is as much as generic it can.

    Resulting dimensions will be adjusted pixel by pixel until they become evenly divisible for the number of images processed: so if you ask to create an image with 899 as width and 3 images you'll get an image of 900 pixel width

    Here the small test script containing the gd_tiler sub and few line of code. Pass please as @ARGV 3 images of approximately same shape (or modify the code as you need.. it is free ;)

    use strict; use warnings; use GD; # for semplicity pass 3 images my @test_images = ($ARGV[0],$ARGV[1],$ARGV[2]); sub gd_tiler{ my %params = @_; my $width = $params{width} or die "Missing width (or zero)!"; my $hight = $params{height} or die "Missing height (or zero)!"; my $direction = $params{direction}; my $format = defined $params{format} ? $params{format} : 'jpeg'; my $filename = $params{filename} or die "Missing filename for outp +ut image"; my @images = ref $params{images} eq 'ARRAY' ? @{$params{images}} : die "Images should be passed as array reference!"; my $verbosity = $params{verbosity}; # offset used after my $woffset = 0; my $hoffset = 0; # adjust for horizontal tiling if ( $direction =~ /^h/i){ unless ( int($width / scalar @images) == ($width / scalar @ima +ges) ){ $width++ until int($width / scalar @images) == ($width / s +calar @images); print "Adjusted width to $width..\n" if $verbosity; $woffset = ($width / scalar @images); } $direction = 'h'; } # adjust for vertical tiling elsif ( $direction =~ /^v/i ){ unless ( int($hight / scalar @images) == ($hight / scalar @ima +ges) ){ $hight++ until int($hight / scalar @images) == ($hight / s +calar @images); print "Adjusted hight to $hight..\n" if $verbosity; $hoffset = ($hight / scalar @images); } $direction = 'v'; } else { die "Unrecognized direction [$direction]! Should be 'horizo +ntal' or 'vertical'" } print "New image $filename ($width x $hight) will be tiled ", ( $direction eq 'v' ? "vertically" : "horizontally" ), " using ",scalar @images," images\n" if $verbosity; # default to truecolor GD::Image->trueColor(1); # resulting GD image my $gdtiled = GD::Image->new($width, $hight); my $count = 0; foreach my $img( @images ){ die "Image [$img] not found!" unless -e $img; print "\nProcessing $img" if $verbosity; # transform into a GD object # automatically recognized: GIF, PNG, JPEG, XBM, XPM, GD2, TIF +F, WEBP, HEIF or AVIF $img = GD::Image->new($img); my $dstX = 0 + $woffset; my $dstY = 0 + $hoffset; my $srcX = 0; my $srcY = 0; my $destW = $direction eq 'h' ? ($width / scalar @images) : $width; my $destH = $direction eq 'v' ? ($hight / scalar @images) : $hight; my $srcW = $img->width(); my $srcH = $img->height(); if ( $verbosity ){ print " (",$img->width()," x ",$img->height(),")\n", "destX $dstX\n", "destY $dstY\n", "srcX $srcX\nsrcY $srcY\n", "destW $destW,\n", "destH $destH\n", "srcW $srcW\nsrcH $srcH\n"; } #$image-%3EcopyResampled($sourceI +mage,$dstX,$dstY, $gdtiled->copyResampled( $img, $dstX, $dstY, $srcX, $srcY, $destW, $destH, $srcW, $srcH, ); last if $count == $#images; $count++; # increment offset if ( $direction eq 'h'){ $woffset += ($width / scalar @images); print "(adjusting width offset += ".($width / scalar @imag +es).")\n" if $verbosity; } else{ $hoffset += ($hight / scalar @images); print "(adjusting hight offset += ".($hight / scalar @ +images).")\n" if $verbosity; } } # write the output image open my $out, '>', $filename or die "Unable to open [$filename] fo +r writing!"; binmode $out; die "Unsupported GD method [$format]!" unless $gdtiled->can($forma +t); print $out $gdtiled->$format or die "Error printing $gdtiled into +$filename using $format!"; print "\nSuccesfully wrote $filename.\n\n" if $verbosity; } # horizontally gd_tiler( width => 900, height => 400, direction => 'h', format => 'jpeg', filename => 'tiled-horizontally.jpg', images => [ @test_images ], verbosity => 1, ); # vertically gd_tiler( width => 300, height => 1200, direction => 'v', format => 'jpeg', filename => 'tiled-vertically.jpg', images => [ @test_images ], verbosity => 1, ); # use the first one to build a 3x3 tiled gd_tiler( width => 900, height => 1200, direction => 'v', format => 'jpeg', filename => 'tiled-3x3.jpg', images => ['tiled-horizontally.jpg','tiled-horizon +tally.jpg','tiled-horizontally.jpg' ], verbosity => 1, );

    If you are too lazy to run it, here the output calling the program as: perl uno.jpg DSCN0077.JPG uno.jpg


    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.
Artificial Intelligence with Perl in 2023
No replies — Read more | Post response
by ait
on Dec 01, 2022 at 06:27
Using regex as an alternative to usual loops on 1D data
No replies — Read more | Post response
by rsFalse
on Nov 23, 2022 at 14:16

    Here I will share a collection of examples how to use regex instead of usual loops (for, foreach, while) on one-dimensional data.
    The idea is that if our array has known type of data (letters, words, numbers, and similar) and if we can reserve few characters as a separators (which our data do not contain), then we can join our array by separator to a string and then apply iterative regex search (or substitution) on it.

    This text is for advanced users of regular expressions. Perldocs perlre is for your help in case. Beware of warnings met across the script.

    Firstly, as the simplest case, I will show three simple lines, which operate on a simple string, character by character.
    s/./ do_smth( $& ) /eg; m/.(?{ do_smth( $& ); })(*FAIL)/; do_smth( $& ) while m/./g;
    • The first case uses the substitution. It is destructive -- it changes the letters of the string. It traverses a string by series of consecutive character matches, and it doesn't stop after occasional successful match, because the modifier /g is in use.
    • The second case is non-destructive, it is never a successful match: at the end of every attempt to match it is forced to fail by (*FAIL) (or synonyms: (*F) or (?!)). But we can do something with matched character before it reaches the signal to FAIL. We use code-block (?{ }) (or (??{ })).
    • The 2nd case is an alternative to common 3rd case -- a while loop. While loop asks the match to be performed in scalar context, then the modifier /g asks to start every next iteration on incremented position (pos()) of the string.

    Next I will show a self-documented script with examples. Every example is written in few different ways: in a common style for (and/or foreach) loop and in a regex-style "loop". Before looking at examples, I want to emphasize the importance of using correct border check between elements. If an element is multi-character, the regex may split it and match any substring of it, if border is not clear. Usually I use space or punctuation marks for joining array elements, so that the simple m/\b/ can be applied as a border of element (when they contain only alphanumeric characters).
    Right after the code of the script, there is an OUTPUT of it. Some comments about the script is further after its OUTPUT. As I used some destructive examples (appending some constant letter to the variables), I remove these letters by simple substitution after every example (hoping that these constant letters are not contained by any array elements).
    #!/usr/bin/perl use strict; use warnings; print "# The need of clear borders of the elements:\n"; print "## Without borders (wrong):\n"; "1 23 456" =~ m/\d+(?{ print "[$&]" })(*FAIL)/; print "\n"; print "## With borders (correct):\n"; "1 23 456" =~ m/\b\d+\b(?{ print "[$&]" })(*FAIL)/; print "\n"; print "## Alternative (correct):\n"; "1 23 456" =~ m/\d+(*SKIP)(?{ print "[$&]" })(*FAIL)/; print "\n"; my @A = ( 1 .. 3, 'abc', 'zz', 79, 444 ); my $A = join ',', @A; # ',' -- one reserved character; m/[,]/ and die "Elem '$_' of \@A contains separator '$&'!\n" for @A; print "# SIMPLE LOOPING through an array:\n"; print "## NON-DESTRUCTIVE:\n"; for( my $i = 0; $i < @A; $i ++ ){ print "[$A[ $i ]]"; } print "\n"; for my $A ( @A ){ print "[$A]"; } print "\n"; $A =~ m/ \b([^,]+)\b (?{ print "[$1]" }) (*FAIL) /x; print "\n"; print "## DESTRUCTIVE:\n"; for( my $i = 0; $i < @A; $i ++ ){ $A[ $i ] .= 'X'; print "[$A[ $i ]]"; } print "\n"; chop for @A; for my $A ( @A ){ $A .= 'X'; print "[$A]"; } print "\n"; chop for @A; $A =~ s/ \b([^,]+)\b / $1 . 'X' /gex; print $A =~ s/\b([^,]+)\b,?/[$1]/gr; print "\n"; $A =~ s/X//g; print "# LOOPING through an array by evaluating several (2-3) consecut +ive elements:\n"; print "## NON-DESTRUCTIVE:\n"; for( my $i = 0; $i < @A - 1; $i ++ ){ print "[$A[ $i ]-$A[ $i + 1 ]]"; } print "\n"; for my $i ( 0 .. @A - 2 ){ print "[$A[ $i ]-$A[ $i + 1 ]]"; } print "\n"; $A =~ m/ \b([^,]+)\b, \b([^,]+)\b (?{ print "[$1-$2]" }) (*FAIL) /x; print "\n"; # ---- for( my $i = 0; $i < @A - 1; $i += 2 ){ print "[$A[ $i ]-$A[ $i + 1 ]]"; } print "\n"; for my $i ( grep $_ % 2 == 0, 0 .. @A - 2 ){ print "[$A[ $i ]-$A[ $i + 1 ]]"; } print "\n"; $A =~ m/ \b([^,]+)\b,(*SKIP) \b([^,]+)\b (?{ print "[$1-$2]" }) (*FAIL) /x; print "\n"; # ---- for( my $i = 0; $i < @A - 2; $i ++ ){ print "[$A[ $i ]-$A[ $i + 1 ]-$A[ $i + 2 ]]"; } print "\n"; for my $i ( 0 .. @A - 3 ){ print "[$A[ $i ]-$A[ $i + 1 ]-$A[ $i + 2 ]]"; } print "\n"; $A =~ m/ \b([^,]+)\b, \b([^,]+)\b, \b([^,]+)\b (?{ print "[$1-$2-$3]" }) (*FAIL) /x; print "\n"; # ---- for( my $i = 0; $i < @A - 2; $i += 2 ){ print "[$A[ $i ]-$A[ $i + 1 ]-$A[ $i + 2 ]]"; } print "\n"; for my $i ( grep $_ % 2 == 0, 0 .. @A - 3 ){ print "[$A[ $i ]-$A[ $i + 1 ]-$A[ $i + 2 ]]"; } print "\n"; $A =~ m/ \b([^,]+)\b,(*SKIP) \b([^,]+)\b, \b([^,]+)\b (?{ print "[$1-$2-$3]" }) (*FAIL) /x; print "\n"; # ---- for( my $i = 0; $i < @A - 2; $i += 3 ){ print "[$A[ $i ]-$A[ $i + 1 ]-$A[ $i + 2 ]]"; } print "\n"; for my $i ( grep $_ % 3 == 0, 0 .. @A - 3 ){ print "[$A[ $i ]-$A[ $i + 1 ]-$A[ $i + 2 ]]"; } print "\n"; $A =~ m/ \b([^,]+)\b, \b([^,]+)\b,(*SKIP) \b([^,]+)\b (?{ print "[$1-$2-$3]" }) (*FAIL) /x; print "\n"; print "## DESTRUCTIVE:\n"; # ---- for( my $i = 0; $i < @A - 2; $i ++ ){ $A[ $i ] .= $A[ $i + 1 ] gt $A[ $i + 2 ] ? 'X' : 'Y'; print "[$A[ $i ]-$A[ $i + 1 ]-$A[ $i + 2 ]]"; } print "\n"; s/[XY]// for @A; for my $i ( 0 .. @A - 3 ){ $A[ $i ] .= $A[ $i + 1 ] gt $A[ $i + 2 ] ? 'X' : 'Y'; print "[$A[ $i ]-$A[ $i + 1 ]-$A[ $i + 2 ]]"; } print "\n"; s/[XY]// for @A; $A =~ s/ \b([^,]+)\b (?= ,\b([^,]+)\b ,\b([^,]+)\b ) / my $new = $1 . ( $2 gt $3 ? 'X' : 'Y' ); print "[$new-$2-$3]"; $ +new /gex; print "\n"; $A =~ s/[XY]//g; print "# 'TRIANGLE' LOOPING through an array (loop in loop):\n"; for my $i ( 0 .. @A - 2 ){ for my $j ( $i + 1 .. @A - 1 ){ printf "%10s", " [$A[ $i ]-$A[ $j ]]"; } print "\n"; } $A =~ m/ \b([^,]+)\b .*? \b([^,]+)\b (?{ printf "%10s", " [$1-$2]" }) (?=$) (?{ print "\n" }) (*FAIL) /x; print "# 'RECTANGLE' LOOPING through two arrays (loop in loop):\n"; my @B = @A[ 2 .. 4 ]; my $AB = $A . ';' . join ',', @B; # ',' and ';' -- two reserved charac +ters; m/[,;]/ and die "Elem '$_' of set { \@A, \@B } contains separator '$&' +!\n" for @A, @B; for my $i ( 0 .. @A - 1 ){ for my $j ( 0 .. @B - 1 ){ printf "%10s", " [$A[ $i ]-$B[ $j ]]"; } print "\n"; } $AB =~ m/ \b([^,]+)\b .*; .*? \b([^,]+)\b (?{ printf "%10s", " [$1-$2]" }) (?=$) (?{ print "\n" }) (*FAIL) /x;
    # The need of clear borders of the elements: ## Without borders (wrong): [1][23][2][3][456][45][4][56][5][6] ## With borders (correct): [1][23][456] ## Alternative (correct): [1][23][456] # SIMPLE LOOPING through an array: ## NON-DESTRUCTIVE: [1][2][3][abc][zz][79][444] [1][2][3][abc][zz][79][444] [1][2][3][abc][zz][79][444] ## DESTRUCTIVE: [1X][2X][3X][abcX][zzX][79X][444X] [1X][2X][3X][abcX][zzX][79X][444X] [1X][2X][3X][abcX][zzX][79X][444X] # LOOPING through an array by evaluating several (2-3) consecutive ele +ments: ## NON-DESTRUCTIVE: [1-2][2-3][3-abc][abc-zz][zz-79][79-444] [1-2][2-3][3-abc][abc-zz][zz-79][79-444] [1-2][2-3][3-abc][abc-zz][zz-79][79-444] [1-2][3-abc][zz-79] [1-2][3-abc][zz-79] [1-2][3-abc][zz-79] [1-2-3][2-3-abc][3-abc-zz][abc-zz-79][zz-79-444] [1-2-3][2-3-abc][3-abc-zz][abc-zz-79][zz-79-444] [1-2-3][2-3-abc][3-abc-zz][abc-zz-79][zz-79-444] [1-2-3][3-abc-zz][zz-79-444] [1-2-3][3-abc-zz][zz-79-444] [1-2-3][3-abc-zz][zz-79-444] [1-2-3][abc-zz-79] [1-2-3][abc-zz-79] [1-2-3][abc-zz-79] ## DESTRUCTIVE: [1Y-2-3][2Y-3-abc][3Y-abc-zz][abcX-zz-79][zzX-79-444] [1Y-2-3][2Y-3-abc][3Y-abc-zz][abcX-zz-79][zzX-79-444] [1Y-2-3][2Y-3-abc][3Y-abc-zz][abcX-zz-79][zzX-79-444] # 'TRIANGLE' LOOPING through an array (loop in loop): [1-2] [1-3] [1-abc] [1-zz] [1-79] [1-444] [2-3] [2-abc] [2-zz] [2-79] [2-444] [3-abc] [3-zz] [3-79] [3-444] [abc-zz] [abc-79] [abc-444] [zz-79] [zz-444] [79-444] [1-2] [1-3] [1-abc] [1-zz] [1-79] [1-444] [2-3] [2-abc] [2-zz] [2-79] [2-444] [3-abc] [3-zz] [3-79] [3-444] [abc-zz] [abc-79] [abc-444] [zz-79] [zz-444] [79-444] # 'RECTANGLE' LOOPING through two arrays (loop in loop): [1-3] [1-abc] [1-zz] [2-3] [2-abc] [2-zz] [3-3] [3-abc] [3-zz] [abc-3] [abc-abc] [abc-zz] [zz-3] [zz-abc] [zz-zz] [79-3] [79-abc] [79-zz] [444-3] [444-abc] [444-zz] [1-3] [1-abc] [1-zz] [2-3] [2-abc] [2-zz] [3-3] [3-abc] [3-zz] [abc-3] [abc-abc] [abc-zz] [zz-3] [zz-abc] [zz-zz] [79-3] [79-abc] [79-zz] [444-3] [444-abc] [444-zz]
    As you see I used C-style for in the beginning of every example. It is versatile, because we can manipulate 2nd and 3rd fields of it. However, when we operate on several consecutive elements, it consumes additional logic on correctly manipulating arrays of any length.
    Note that "true"-foreach loop lacks ability to perform 'triangle' loop (it could do strict 'square' loop of one array, or strict 'rectangle' loop of two arrays). Therefore I used "indexed"-foreach loop when "true"-foreach was not able.
    With (*FAIL) usually the (*SKIP) control verb is useful: it forces to skip backtracking.
    Note .*? in 'triangle' loop which is non-greedy. Greediness inverts the direction of traversing elements. (Non-)greediness may be a matter for discussion on a performance speed.
    Modifier /x is crucial for readability of longer regex examples.
    Note that 'rectangle'-looping requires one additional separator character.
    IMPORTANT: distances between elements of the array increase when the elements by themselves are longer. Therefore this method may be time-inefficient when elements of the array are e.g. long strings. But if these elements are practical numbers, they rarely exceed billions of billions (that is no longer than couple of dozens of characters each).

    A word on new experimental feature from 5.36. From 'perldelta':
    "You can now iterate over multiple values at a time by specifying a list of lexicals within parentheses. For example, for my ($left, $right, $gripping) (@moties) { ... }". More in: Foreach Loops.
    This looks as useful option. But here are couple of limitations: 1) it creates additional undef values if the number of array elems are not divisible by number of iterators, 2) its step is constant == the number of iterators (i.e. chunks of iterators can not overlap, kinda similar to use of \G anchor in regex). But the experimental feature may change its behavior in the future.
    Example code:
    #!/usr/bin/perl use strict; use warnings; my @A = ( 1 .. 3, 'abc', 'zz', 79, 444 ); my $A = join ',', @A; print "# With 'undef's:\n"; for my( $i, $j, $k )( @A ){ print "[$i-$j-$k]"; } print "\n"; for( my $i = 0; $i < @A; $i += 3 ){ print "[$A[ $i ]-$A[ $i + 1 ]-$A[ $i + 2 ]]"; } print "\n"; print "Without 'undef's -- no stepping out of an array:\n"; for my $i ( grep $_ % 3 == 0, 0 .. @A - 3 ){ print "[$A[ $i ]-$A[ $i + 1 ]-$A[ $i + 2 ]]"; } print "\n"; $A =~ m/ \b([^,]+)\b, \b([^,]+)\b,(*SKIP) \b([^,]+)\b (?{ print "[$1-$2-$3]" }) (*FAIL) /x; print "\n";
    for my (...) is experimental at <...> # With 'undef's: Use of uninitialized value <...> Use of uninitialized value <...> [1-2-3][abc-zz-79][444--] Use of uninitialized value <...> Use of uninitialized value <...> [1-2-3][abc-zz-79][444--] Without 'undef's -- no stepping out of an array: [1-2-3][abc-zz-79] [1-2-3][abc-zz-79]
    • Squeeze an array.
    • Check if an array is monotonic.
    • Count inversions (number of pairs of indices i and j, i<j, that ai>aj).
    Some exercises on platform:
    Thank you for reading.
Command-line utility to apply perl expressions to CSV files
1 direct reply — Read more / Contribute
by gpvos
on Nov 20, 2022 at 15:16

    Here's csved, an old script of mine that I use to quickly munge CSV files.

    Essentially, it works similar to perl -a or awk. After reading each line, it is parsed into fields and put into @F. Then it executes your expression, and after that, unless -n is given, it prints @F again in CSV format. You can mangle @F any way you like, changing, reordering or deleting entries or completely reassigning it. You can also use next to skip printing a particular line.

    I recently thought it would be useful to be able to address columns by their name if the CSV file has those in its first line, so I added the -h option which, via an egregious abuse of tying that I'm very proud of, allows you to also address the fields using the hash %F and field names taken from the first line of the CSV file. Any access through %F actually affects @F directly except via a fieldname-to-index mapping. You can delete entries by assigning undef to them, or delete $F{fieldname} also works: it doesn't delete anything from the tied hash, but instead immediately deletes it from the underlying array @F representing the current line/row.

    Also I added -b and -e options which work similarly to BEGIN and END, but I haven't really used them yet. Options to read and write CSV with different separator characters are also available.

    This also called for a (still incomplete) test suite; you can look at the results here:

    I hope you will find it useful.

    #!/usr/bin/perl -w # # csved - apply a Perl expression to all records of a CSV file # # Copyright (c) 2003-2022 Gerben Vos. All rights reserved. # This program is free software; you can redistribute it and/or # modify it under the same terms as Perl 5.8.0. # # Run without arguments for usage information. # # Requires the Text::CSV_XS module by Jochen Wiedmann and Alan Citterm +an, # available from . use v5.10; use strict 'vars', 'refs'; # This is a weird usage of tying because the hash is tied only once, # but the underlying data changes for every processed line. package Tie::FieldNames; sub TIEHASH { my $self = shift; my $i = 0; my $tied = { HEADERS => { map { ($_, $i++) } @_ }, }; die "Duplicate field names: " . join(", ", map { "'$_'" } _dups(@_)) unless scalar keys %{$tied->{HEADERS}} == scalar @_; return bless $tied, $self; } sub _dups { my %count; ++$count{$_} for @_; return grep { $count{$_} > 1 } keys %count; } sub setcurrent { $_[0]->{CURRENT} = $_[1]; } sub FETCH { my ($self, $key) = @_; die "$key: No such field name" unless exists $self->{HEADERS}->{$k +ey}; return $self->{CURRENT}->[$self->{HEADERS}->{$key}]; } sub STORE { my ($self, $key, $value) = @_; die "$key: No such field name" unless exists $self->{HEADERS}->{$k +ey}; $self->{CURRENT}->[$self->{HEADERS}->{$key}] = $value; } sub DELETE { my ($self, $key) = @_; die "$key: No such field name" unless exists $self->{HEADERS}->{$k +ey}; delete $self->{CURRENT}->[$self->{HEADERS}->{$key}]; } sub EXISTS { my ($self, $key) = @_; die "$key: No such field name" unless exists $self->{HEADERS}->{$k +ey}; return exists $self->{CURRENT}->[$self->{HEADERS}->{$key}]; } sub FIRSTKEY { my ($self) = @_; my $dummy = keys %{$self->{HEADERS}}; each %{$self->{HEADERS}}; } sub NEXTKEY { return each %{$_[0]->{HEADERS}}; } sub SCALAR { return scalar grep { defined } @{$_[0]->{CURRENT}}; } package main; use Text::CSV_XS; use IO::Handle; my $_silent = 0; my $_use_headers = 0; my $_begin = ""; my $_end = ""; my $_sep = ','; my $_quote = '"'; my $_escape = '"'; my $_progname; ($_progname = $0) =~ s#.*/##; my $_usage = <<USAGE; Usage: $_progname [option...] expr [file...] Apply a Perl expression to all records of a CSV file. -n suppress printing -h treat first line as field names and allow access through \%F -b expr execute expr before processing any input -e expr execute expr after processing all input -F char set the character that separates fields (default: comma) -Q char set the character for quoting fields that contain a separat +or character or end-of-line (default: double quote) -E char set the character for escaping a quote character (default: +double quote) The input is processed line by line. expr should be a Perl expression modifying the \@F array; indexes are +0-based. With -h, you can also modify the \%F hash with the same effect. Deleti +ng an array or hash entry, or setting it to undef, will cause it not to be o +utput. The value of \@F after executing expr is sent to the standard output. With -h, field names are read from the first line just before executin +g expr on it, so if e.g. field 8 is named "comment", you can use "delete \$F{ +comment}" and that would be equivalent to "delete \$F[8]". Duplicate field names + in the input or a field name in expr that does not exist in the input will ca +use a fatal error. A field name for \%F refers to a fixed index in \@F, so i +f you rearrange the data in \@F, accesses through \%F may refer to incorrect + fields. Works with binary files (for example, with embedded newlines). You can use next (to suppress printing), last and redo in expr. \$. works in expr, so you can e.g. use "if (\$. > 1) { ... }" to not a +pply some code to the first line. Variable names starting with _ are reserved, don't use them in expr. Uses the Text::CSV_XS module by Jochen Wiedmann and Alan Citterman, wi +th thanks. USAGE while (@ARGV > 0 and $ARGV[0] =~ m{^-}) { my $opt = shift; $_silent = 1, next if $opt eq '-n'; $_use_headers = 1, next if $opt eq '-h'; $_begin = shift, next if $opt eq '-b'; $_end = shift, next if $opt eq '-e'; $_sep = shift, next if $opt eq '-F'; $_quote = shift, next if $opt eq '-Q'; $_escape = shift, next if $opt eq '-E'; die $_usage; } die $_usage unless @ARGV > 0; my $_expr = shift; my $_csv = Text::CSV_XS->new({ sep_char => $_sep, quote_char => $_quot +e, escape_char => $_escape, binary => 1, eol => "\n" }); unshift(@ARGV, '-') unless @ARGV; { no strict; eval $_begin; die $@ if $@; } my %F; my $_tied; while ($ARGV = shift) { open(_IN, $ARGV); my $_fields; while ($_fields = $_csv->getline(\*main::_IN) and @$_fields) { my(@F) = @$_fields; if ($_use_headers) { if ($. == 1) { $_tied = tie %F, 'Tie::FieldNames', @F; } $_tied->setcurrent(\@F); } # This means you can use next, last, and redo in expr # without excessive noise. Also turn off strictness. no warnings "exiting"; no strict; eval $_expr; die $@ if $@; $_csv->print(STDOUT, [ grep { defined } @F ]) unless $_silent; } } if ($_use_headers) { undef $_tied; untie %F; } { no strict; eval $_end; die $@ if $@; }
A word game
1 direct reply — Read more / Contribute
by jwkrahn
on Nov 05, 2022 at 21:15

    A word game program, similar to "Wordle".

    Now with Term::ReadKey

    #!/usr/bin/perl use warnings; use strict; # Version 1.0 my $me = $0 =~ s|.*/||r; my $usage = <<USAGE; usage: $me -h -g N -w N -f WORD_FILE -h This help message. -g Number of guesses Defaults to 6 -w Word length Defaults to 5 -f Word file to use Defaults to /usr/share/dict/words USAGE use Getopt::Std; getopts( 'hg:w:f:', \my %opts ) or die $usage; die $usage if exists $opts{ h }; use Term::ReadKey; ReadMode 4; END { ReadMode 0; } use Term::ANSIColor ':constants'; my $clear = `clear`; my $reset = RESET; my $white_on_red = BRIGHT_WHITE . ON_RED; my $white_on_green = BRIGHT_WHITE . ON_GREEN; my $white_on_yellow = BRIGHT_WHITE . ON_YELLOW; my $white_on_gray = BRIGHT_WHITE . ON_BRIGHT_BLACK; my $pre = qr/\e\[\d+m\e\[\d+m/; # colour my $post = qr/\e\[0m/; # reset # guesses allowed = number of lines displayed my $guesses = $opts{ g } || 6; # length of words to use my $word_size = $opts{ w } || 5; # file name to use my $file_name = $opts{ f } || '/usr/share/dict/words'; my $divider = ' ---' x $word_size . "\n"; my $kb = <<KB; Q W E R T Y U I O P A S D F G H J K L Z X C V B N M BS RET ESC to exit KB my @lines = map [ ( ' ' ) x $word_size ], 1 .. $guesses; my $curr_line = 0; my %dict; { open my $FH, '<', $file_name or die "Cannot open '$file_name' beca +use: $!"; # exclude proper nouns and punctuation # words must have at least one vowel @dict{ map uc, grep /[aeiouy]/, map /^([a-z]{$word_size})$/, <$FH> + } = (); } my $curr_word = ( keys %dict )[ rand keys %dict ]; my @letters; { local $| = 1; print $clear, "\n\n", map( { my $line = $_; $divider, ' ', map( " |$_|", @{ $lines[ +$line ] } ), "\n", $divider } 0 .. $#lines ), "\n\n", $kb, "\n"; if ( $curr_line == @lines ) { print "\L$curr_word\n"; last; } # Only accept keys we want to use # alphabetic, back space, return or escape my $key; 1 until defined( $key = ReadLine( -1 ) ) && $key =~ /\A[a-zA-Z\177 +\n\e]\z/; last if $key eq "\e"; if ( $key eq "\177" ) { pop @letters if @letters; for my $index ( 0 .. $#{ $lines[ $curr_line ] } ) { $lines[ $curr_line ][ $index ] = defined $letters[ $index +] ? " $letters[$index] " : ' '; } redo; } if ( $key =~ /\A[a-zA-Z]\z/ ) { push @letters, uc $key if @letters < $word_size; for my $index ( 0 .. $#{ $lines[ $curr_line ] } ) { $lines[ $curr_line ][ $index ] = defined $letters[ $index +] ? " $letters[$index] " : ' '; } redo; } if ( $key eq "\n" && @letters == $word_size ) { my $word = join '', @letters; # Not a valid five letter word unless ( exists $dict{ $word } ) { $lines[ $curr_line ] = [ map "$white_on_red $_ $reset", @l +etters ]; redo; } # The correct answer if ( $word eq $curr_word ) { $lines[ $curr_line ] = [ map "$white_on_green $_ $reset", +@letters ]; for my $letter ( @letters ) { $kb =~ s/$pre? $letter $post?/$white_on_green $letter +$reset/; } $curr_line = @lines; redo; } # Default; all letters to white on gray $lines[ $curr_line ] = [ map "$white_on_gray $_ $reset", @lett +ers ]; for my $letter ( @letters ) { $kb =~ s/$pre? $letter $post?/$white_on_gray $letter $rese +t/; } # Find exact matches my @found = ( 0 ) x $word_size; my $xor_word = $word ^ $curr_word; while ( $xor_word =~ /\0/g ) { $found[ $-[ 0 ] ] = 1; my $letter = $letters[ $-[ 0 ] ]; $lines[ $curr_line ][ $-[ 0 ] ] = "$white_on_green $letter + $reset"; $kb =~ s/$pre? $letter $post?/$white_on_green $letter $res +et/; } my $curr_remains = join '', ( split //, $curr_word )[ grep !$f +ound[ $_ ], 0 .. $#found ]; # Find other correct letters while ( my ( $index, $letter ) = each @letters ) { next if $found[ $index ]; if ( $curr_remains =~ s/$letter/ / ) { $lines[ $curr_line ][ $index ] = "$white_on_yellow $le +tter $reset"; $kb =~ s/$pre? $letter $post?/$white_on_yellow $letter + $reset/; } } ++$curr_line; @letters = (); } redo; }
Convert BMP to HTML
5 direct replies — Read more / Contribute
by harangzsolt33
on Oct 30, 2022 at 00:57

    I wrote a Perl script that reads a BMP file and converts it to pure HTML and then sends it to a file. Then I take the file and paste it here. Please don't punish me.

Improved reliability on the Windows platform with new MCE releases
1 direct reply — Read more / Contribute
by marioroy
on Oct 10, 2022 at 05:02


    1.880 Mon Oct 10 04:00:00 EST 2022 * Improved reliability on the Windows platform. * Improved MCE::Mutex::Channel::timedwait on the Windows platform. * Improved MCE::Mutex::Channel performance on UNIX platforms. * Resolved edge case in MCE::Child reaching deadlock.


    1.878 Mon Oct 10 04:00:00 EST 2022 * Improved reliability on the Windows platform. * Added deeply-shared demonstration to POD.


    1.007 Mon Oct 10 04:00:00 EST 2022 * Improved reliability on the Windows platform. * Improved Mutex::Channel::timedwait on the Windows platform. * Improved Mutex::Channel performance on UNIX platforms.
Type::Tiny v2 is Coming
No replies — Read more | Post response
by tobyink
on Sep 16, 2022 at 11:19

    Eagle-eyed watchers of CPAN may have noticed that I've recently been releasing Type::Tiny development releases with version numbers 1.999_XYZ.

    Type::Tiny v2 is intended to be compatible with Type::Tiny v1. If you've used Type::Tiny v1, you shouldn't need to change any code, but Type::Tiny v2 has a few new features which may make your code simpler, more maintainable, and more readable if you adopt them.

    Type::Params v2 API

    Type::Params can be used to provide typed subroutine signatures:

    use feature qw( state ); use Type::Params qw( compile ); use Types::Standard qw( Num ); sub add_numbers { state $signature = compile( Num, Num ); my ( $x, $y ) = $signature->( @_ ); return $x + $y; }

    However, things like named paramaters, catering for $self in methods, etc felt like afterthoughts. Here is how you'd write the same signature in version 1 as a method call using named parameters:

    use feature qw( state ); use Type::Params qw( compile_named_oo ); use Types::Standard qw( Num ); sub add_numbers { state $signature = compile_named_oo( { head => [ Any ] }, 'x' => Num, 'y' => Num, ); my ( $self, $arg ) = $signature->( @_ ); return $arg->x + $arg->y; }

    While the old API is still supported, Type::Params v2 has two new functions, signature and signature_for, which I feel provide a more powerful and more consistent interface.

    signature works much the same as compile, but takes a top-level hash of options, allowing it to cater for both positional and named parameters.

    Here is an example for positional parameters:

    use feature qw( state ); use Type::Params qw( signature ); use Types::Standard qw( Num ); sub add_numbers { state $signature = signature( method => 0, positional => [ Num, Num ], ); my ( $x, $y ) = $signature->( @_ ); return $x + $y; }

    Here is an example for named parameters:

    use feature qw( state ); use Type::Params qw( signature ); use Types::Standard qw( Num ); sub add_numbers { state $signature = signature( method => 1, named => [ 'x' => Num, 'y' => Num ], ); my ( $self, $arg ) = $signature->( @_ ); return $arg->x + $arg->y; }

    And signature_for allows you to turn that definition inside-out.

    use experimental qw( signatures ); use Type::Params qw( signature_for ); use Types::Standard qw( Num ); signature_for add_numbers => ( method => 1, named => [ 'x' => Num, 'y' => Num ], ); sub add_numbers ( $self, $arg ) { return $arg->x + $arg->y; }

    Handy import shortcuts

    A handy way to define an Enum type in Type::Tiny 2 is:

    use Type::Tiny::Enum Size => [ qw( S M L XL ) ];

    You can use this in a class like:

    package Local::TShirt { use Moose; use Types::Common -types; use Type::Tiny::Enum Size => [ qw( S M L XL ) ]; use namespace::autoclean; has size => ( is => 'ro', isa => Size, required => 1, ); sub price { my $self = shift; my $size = $self->size; if ( $size eq SIZE_XL ) { return 10.99; } elsif ( $size eq SIZE_L ) { return 9.99; } else { return 8.99; } } }

    Yes, Enum type constraints now provide constants like SIZE_XL above.

    Type::Tiny::Class provides a similar shortcut:

    sub post_data ( $url, $data, $ua=undef ) { use Type::Tiny::Class -lexical, 'HTTP::Tiny'; $ua = HTTPTiny->new unless is_HTTPTiny $ua; $ua->post( $url, $data ); }

    Type::Tiny::Role and Type::Tiny::Duck also provide shortcuts.


    Having checked out a lot of modules which use Type::Tiny, I've noticed that the most common modules people import from are Types::Standard, Type::Params, Types::Common::Numeric, and Types::Common::String.

    Types::Common is a new module that combines all of the above. For quick scripts and one-liners, something like this may save a bit of typing:

    use Types::Common -all;

    Though like always, you can list imports explicitly:

    use Types::Common qw( signature_for Num NonEmptyStr ); </pre> <p>If you have a bleeding-edge Perl installed, you can import function +s lexically:</p> <c> use Types::Common -lexical, -all;

    A type divided against itself shall stand

    You can now divide a type constraint by another:

    has lucky_numbers => ( is => 'ro', isa => ArrayRef[ Num / Any ], );

    What does this mean?

    Under normal circumstances, Num/Any evaluates to just Any. Num is basically just documentation, so you're documenting that lucky_numbers is intended to be an arrayref of numbers, but as a speed boost, the attribute will just check that it's an arrayref of anything.

    When the EXTENDED_TESTING environment variable is switched on though, Num/Any will evaluate to Num, so stricter type checks will kick in.

    Type defaults

    Instead of this:

    has output_list => ( is => 'ro', isa => ArrayRef, default => sub { [] }, );

    You can now write this:

    has output_list => ( is => 'ro', isa => ArrayRef, default => ArrayRef->type_default, );

    This is more typing, so why do this? Well, for ArrayRef it might be more typing, but in this case:

    has colour_scheme => ( is => 'ro', isa => ColourScheme, default => sub { my %colours = ( foreground => 'black', background => 'white', links => 'blue', highlight => 'red', ); return \%colours; }, );

    It might be neater to include the default in the definition of your ColourScheme type.

    The new DelimitedStr type

    Types::Common::String now has a DelimitedStr type.

    This allows DelimitedStr[ "|", Int ] to accept strings like "12|34|-99|0|1".


    There have been numerous internal refactorings in Type::Tiny v2, so if you're using Type::Tiny and its related modules in more unorthodox ways, it may be worth explicitly testing your code still runs on the new version.

    However, I have taken care to avoid breaking any documented APIs. The vast majority of the Type:Tiny v1 test suite still passes with Type::Tiny v2, with test cases that inspect the exact text of error messages being the only real change.

'rgb_palette' - Term::ANSIColor Helper
2 direct replies — Read more / Contribute
by kcott
on Aug 15, 2022 at 03:37

    G'day All,

    I've been playing around with Term::ANSIColor recently. I found the named colours to be very limited. The rgbRGB format provides additional colours but the codes are not particularly intuitive. Then I found rNNNgNNNbNNN; at first, I thought I'd need a different terminal but it turns out that it works just fine on my xterm.

    I'm quite familiar with the hex notation #rrggbb, but less so with the decimal equivalents; so I wrote myself a helper program: rgb_palette. I thought I'd share; but there are a few things you'd probably want to know up-front.

    • Obviously, you'll need a true color (aka direct-color) terminal.
    • Change the shebang line if it doesn't fit your setup.
    • Install IO::Prompter.
    • The code, as is, has "use v5.36;". You can downgrade this but, if you do, deal with the subroutine signatures (either turn off experimental warnings or rewrite the two short subroutines, e.g. "sub fg ($r, $g, $b) { ..." --> "sub fg { my ($r, $g, $b) = @_; ..."). Also, add in whatever pragmata you're no longer getting for free.
    • I use a black background. You may need to fiddle with some of the text colours if you use something else.
    • I initially had the hex values on each of the coloured swatches in either black or white. I found this distracting; change the commented code in fg() if you want to put it back that way. As it stands, the foreground and background colours are the same making the text invisible but the swatch colour more prominent. I just double-click on a swatch; middle-click to paste; then "Enter" to get the rNNNgNNNbNNN conversion.
    • I've aimed to get a lot of colours without needing a giant screen. You'll need 100 columns and scrolling will almost certainly be necessary. You can also type in your own hex codes if you want: the output shows a swatch of the input value as well as the rNNNgNNNbNNN code.

    Alright, that's enough blathering, here's the code:

    #!/usr/bin/env perl use v5.36; use IO::Prompter [ -style => 'bold blue', -echostyle => 'bold magenta', ]; use Term::ANSIColor 5.00; my @nums_under_255 = qw{0 26 51 77 102 127 153 179 204 230 243}; say ''; for my $r (@nums_under_255, 255) { for my $g (@nums_under_255, 255) { print ' '; for my $b (@nums_under_255) { print colored(text("r${r}g${g}b${b}"), join(' on_', fg($r, + $g, $b), "r${r}g${g}b${b}")); } say colored(text("r${r}g${g}b255"), join(' on_', fg($r, $g, 25 +5), "r${r}g${g}b255")); } } say ''; my $rgb; while (1) { $rgb = prompt 'Convert hex to decimal rgb (or just hit "Enter" to +quit): ', -return => ''; # Fix for MSWin -- see +?id=118255 $rgb =~ s/\R\z//; unless (length $rgb) { say ''; last; } if ($rgb =~ /^([0-9a-fA-F]{2})([0-9a-fA-F]{2})([0-9a-fA-F]{2})$/) +{ my $ansi_rgb = sprintf 'r%dg%db%d', map hex, $1, $2, $3; print colored(' --> [', 'bold white'); print colored(' ' x 8, "$ansi_rgb on_$ansi_rgb"); print colored('] --> ', 'bold white'); say colored($ansi_rgb, 'bold cyan'); } else { say colored("\nERROR: '", 'r255g0b0 on_r51g51b51'), colored($rgb, 'r255g255b0 on_r51g51b51'), colored( "' is invalid. Six hexadecimal characters are expected +; such as in the table above.", 'r255g0b0 on_r51g51b51' ); } } sub fg ($r, $g, $b) { #return $r + 2 * $g + $b > 204 ? 'black' : 'white'; return "r${r}g${g}b${b}"; } sub text ($str) { return sprintf ' %02x%02x%02x ', $str =~ /^r(\d+)g(\d+)b(\d+)$/; }


    Updates: Some people encountered problems, so I've made changes.

    • Term::ANSIColor introduced support for 24-bit colour in v5.00 (see Changes). I wasn't aware of this. I've changed "use Term::ANSIColor;" to "use Term::ANSIColor 5.00;". Thanks ++pryrt for reporting this.
    • For MSWin users, there's a bug in IO::Prompter. Again, thanks ++pryrt for reporting this. As a workaround, I've added:
      # Fix for MSWin -- see +?id=118255 $rgb =~ s/\R\z//;
    • Also for MSWin users, there's been some discussion, in a number of responses, about whether the module Win32::Console::ANSI, or the registry setting VirtualTerminalLevel, is required for this code to work. Not being in a position to test this, I can't comment further.

    — Ken

Challenge: sort weekdays in week-order (elegantly and efficiently)
10 direct replies — Read more / Contribute
by bliako
on Jul 21, 2022 at 10:08

    It just occured to me that I do not know how to sort weekdays in week-order except with this:

    my @weekdays = qw/Monday Saturday Thursday/; my %order = ( monday => 1, tuesday => 2, wednesday => 3, thursday => 4, friday => 5, saturday => 6, sunday => 7, ); print join ",", map { $_->[0] } sort { $a->[1] <=> $b->[1] } map { [$_, $order{lc $_}] } @weekdays;

    is there a way without using that %order?

    bw, bliako

Range check with unordered limits
4 direct replies — Read more / Contribute
by hexcoder
on Jul 10, 2022 at 14:00
    Suppose you want to check if an integer is inside a given range. That seems trivial, if the range minimum and maximum are known ahead.
    $inRange = $a <= $x && $x <= $b;

    But if you don't know which one is minimum and which one is maximum, the algorithm should be a bit more flexible. Here is where Perl's spaceship operator can help. I came up with:

    $inRange = (($a <=> $x) * ($b <=> $x)) < 1;
    where $a and $b are the unordered range limits and $x is the variable to be tested.

    Could this be optimized (reduced) further? I would be interested to know.

    Thanks, hexcoder

Bulk check for successful compilation
2 direct replies — Read more / Contribute
by davebaker
on Jul 02, 2022 at 17:16

    Just a note to say how much fun it was for me to try the Test::Compile::Internal module, which zips through every Perl module and script in my cgi-bin directory and its subdirectories, making sure each such file successfully compiles.

    This lets me feel more at ease about there not being any lurking problems that have arisen due to my having renamed or deleted some custom module, and that scripts or modules I'm still developing haven't "use"d a module and its specified subroutines (whether custom or in my Perl libraries) in a way that misspelled the module name or the subroutine name, or that tries to import a subroutine that doesn't actually exist in the "use"d module (such as a subroutine I meant to add to a "use"d custom module but never got around to adding).

    #!/opt/perl524 use strict; use warnings; use Test::Compile::Internal; my $test = Test::Compile::Internal->new(); $test->all_files_ok( '/www/cgi-bin' ); $test->done_testing();

    (Edited 7/7/2022 to add hypertext link to page of the Test::Compile::Internal module)

Mite: an OO compiler for Perl
No replies — Read more | Post response
by tobyink
on Jul 02, 2022 at 13:34

    This article has also been posted on here.

    Moose is great, but it does introduce a slight performance hit to your code. In the more than 15 years since it was first released, hardware improvements have made this less of a problem than it once was. Even so, if performance is a concern for your project, Moose might not be what you want. It also has a fairly big collection of non-core dependencies.

    Moo is a lighter weight version, minus with meta-object protocol, but supporting nearly all of Moose's other features. It loads faster, sometimes runs faster, and has fewer dependencies. (And most of the dependencies it does have are just modules which used to be part of Moo but were split out into separate distributions.)

    But what if you could have fast Moose-like object-oriented code without the dependencies?

    In 2013, Michael Schwern started work on Mite to do just that. It was abandoned in 2014, but I've taken it over and expanded the feature set to roughly equivalent to Moo.

    Mite is an object-oriented programming compiler for Perl. It allows you to write familiar Moose-like object-oriented code, then compile that into plain Perl with zero non-core dependencies. Your compiled code does not even have a dependency on Mite itself!

    How do I use Mite?

    Here's how you could start a project with Mite or port an existing Moose/Moo project.

       cd Your-Project/
       mite init 'Your::Project'
       mite compile

    After you've run those commands, Mite will create a module called Your::Project::Mite. This module is your project's own little gateway to Mite. This module is called the shim.

    Now let's write a test case:

       # t/unit/Your-Project-Widget.t
       use Test2::V0
          -target => 'Your::Project::Widget';
       can_ok( $CLASS, 'new' );
       my $object = $CLASS->new( name => 'Quux' );
       isa_ok( $object, $CLASS );
       subtest 'Method `name`' => sub {
          can_ok( $object, 'name' );
          is( $object->name, 'Quux', 'expected value' );
          my $e = dies {
             $object->name( 'XYZ' );
          isnt( $exception, undef, 'read-only attribute' );
       subtest 'Method `upper_case_name`' => sub {
          can_ok( $object, 'upper_case_name' );
          is( $object->upper_case_name, 'QUUX', 'expected value' );

    And a class to implement the functionality:

       # lib/Your/Project/
       package Your::Project::Widget;
       use Your::Project::Mite;
       has name => (
          is     => 'ro',
          isa    => 'Str',
       sub upper_case_name {
          my $self = shift;
          return uc( $self->name );

    Run mite compile again then run the test case. It should pass.

    How does Mite work?

    It's important to understand what Mite is doing behind the scenes.

    When you ran mite compile, Mite created a file called lib/Your/Project/ (Yes, a triple file extension!) This file contains your class's new method. It contains the code for the accessor.

    That file does not contain the code for upper_case_name which is still in the original lib/Your/Project/

    When Perl loads Your::Project::Widget, it will see this line and load the shim:

       use Your::Project::Mite;

    The shim just loads lib/Your/Project/, exports a has function that does (almost) nothing, and then gets out of the way. This gives Perl a working class.

    What features does Mite support?

    Most of what Moo supports is supported by Mite. In particular:

    extends @superclasses

    Mite classes within your project can inherit from other Mite classes within your project, but not from non-Mite classes, and not from Mite classes from a different project.

    with @roles

    As of version 0.002000, Mite also supports roles. If you want your package to be a role instead of a class, just do:

       package Your::Project::Nameable;
       use Your::Project::Mite -role;
       has name => (
          is => 'ro',
          isa => 'Str',

    As with extends, a limitation is that you can only use Mite roles from within your own project, not non-Mite roles, nor Mite roles from a different project.

    (A future development might add support for Role::Tiny roles though.)

    has $attrname => %spec

    Attributes are obviously one of the main features people look for in a Perl object-oriented programming framework and Mite supports nearly all of Moose's features for defining attributes.

    This includes is => 'ro', is => 'rw', is => 'bare', is => 'rwp' (like Moo), and is => 'lazy' (like Moo); required and init_arg for attribute initialization; reader, writer, accessor, predicate, clearer, and trigger; lazy, default, and builder; weak_ref; isa and coerce for type constraints, including support for any type constraints in Types::Standard, Types::Common::Numeric, and Types::Common::String; and delegation using handles. It also supports an option which Moose doesn't provide: alias for aliasing attributes.

    Mite builds in the functionality of MooseX::StrictConstructor, dying with an appropriate error message if you pass your class's constructor any parameters it wasn't expecting.


    Methods you can define to control the life cycle of objects.

    before $method => sub { ... }
    after $method => sub { ... }
    around $method => sub { ... }

    Mite classes and roles can define method modifiers.

    As long as your needs aren't super-sophisticated (introspection using the MOP, runtime application of roles, etc), Mite probably has the features you need for even medium to large projects.

    Mite itself uses Mite!

    Be honest, what are the drawbacks?

    This code still doesn't have a lot of testing "in the wild". Moose and Moo have proven track records.

    You need to remember to mite compile your code after making changes before running your test suite or packaging up a release. This can be annoyingly easy to forget to do. (Though Mite does also include extensions for ExtUtils::MakeMaker and Module::Build to help integrate that into your workflow.)

    The Mite compiler's scope of only looking at the files within your own project limits the ability to create roles which can be composed by third-parties, or classes which can easily be extended by third-parties. If you want that, Moose or Moo are a better option.

    Okay, I'm interested

    If you've read this and you're thinking about porting a Moose or Moo project to Mite, feel free to @-mention tobyink on Github in issue tickets, pull requests, etc if you need any help.

    If there are features which you think Mite is missing which you'd need to port your project to Mite, file bugs with the Mite issue tracker.

COMET DANCER - scafolding for Dancer2
No replies — Read more | Post response
by AlexP
on Jun 19, 2022 at 06:33

    After several months of development, I would like to present COMET DANCER - scaffolding for your Dancer2 apps.

    You could find all code, screenshots and description here -> github/comet-dancer.


    Dancer is minimalist, and if you are developing a small app or simple api it's very convenient to use. But if you try to create a bigger app you will encounter a lack of documentation and any examples.

    What is Comet Dancer

    You could think about it like a foundation for web-app. It provides you with a ready environment for application development. You just clone it and get a complete set of tools.

    How to start

    Visit the link above and go through the easy installation process.

    Do you need contributors?

    Yes. If you are interested in Perl and Dancer - you are welcome!

Add your CUFP
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post, it's "PerlMonks-approved HTML":

  • Are you posting in the right place? Check out Where do I post X? to know for sure.
  • Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
    <code> <a> <b> <big> <blockquote> <br /> <dd> <dl> <dt> <em> <font> <h1> <h2> <h3> <h4> <h5> <h6> <hr /> <i> <li> <nbsp> <ol> <p> <small> <strike> <strong> <sub> <sup> <table> <td> <th> <tr> <tt> <u> <ul>
  • Snippets of code should be wrapped in <code> tags not <pre> tags. In fact, <pre> tags should generally be avoided. If they must be used, extreme care should be taken to ensure that their contents do not have long lines (<70 chars), in order to prevent horizontal scrolling (and possible janitor intervention).
  • Want more info? How to link or How to display code and escape characters are good places to start.
Log In?

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

How do I use this? | Other CB clients
Other Users?
Others studying the Monastery: (4)
As of 2023-01-30 17:55 GMT
Find Nodes?
    Voting Booth?

    No recent polls found