This section is the place to post your general code offerings.

CUFP's
"Spritz" crypto algorithm
No replies — Read more | Post response
by RonW
on Mar 24, 2015 at 16:41

    For testing purposes, I implemented Rivist's new crypto algorithm in Perl. It is a proposed replacement for his (once very popular) RC4 algorithm. Thought there might be some curiosity value to it.

Distribute the leftovers
No replies — Read more | Post response
by GotToBTru
on Mar 20, 2015 at 12:46

    We get the quantity of a product shipped from the database, and a list of individual carton labels from an external file. The actual contents of each carton are unknown. Working assumption would be qty per carton = shipped qty / carton count. Easy enough. But what if the division doesn't come out clean?

    use POSIX qw/ceil/; ... $sq = $shipped_quantity; $cc = $carton_count; foreach $label(@label_list) { if ($cc == 0) { print "Qty per carton math error"; next OUTER; } $per_container = ceil($sq/$cc); $sq -= $per_container; $cc -= 1; ... }

    If shipped quantity is 8 and carton count is 5, first 3 cartons will have 2 each, last 2 have 1.

    Yeah, almost too simple to mention. But this came up today, and I remember little code bits like this better when I write them down somewhere.

    Update: s/box/carton/

    Dum Spiro Spero
ppi-outline.pl -- from perl source generate Main logic of this script (summary/abstract/outline)
1 direct reply — Read more / Contribute
by Anonymous Monk
on Mar 13, 2015 at 04:03
Extract names and email addresses from a maildir folder
No replies — Read more | Post response
by peterr
on Mar 11, 2015 at 04:25

    Had a lot of help from Mark Overmeer with this one ..

    #!/usr/bin/perl # # Name: multipart-mo.pl # # Extract names and email addresses from a maildir folder # # - Also displays the number of messages (files) found and the numb +er of parts in each message # - Displays structure of each message and then outputs the names a +nd email addresses # - Where the name/email address is found in the 'body' part of a m +essage (i.e NOT in From:, To:, Cc: etc,etc), # then usually only the email address will be returmed # # This script has been adapted from multipart.pl , which is part of +the Mail::Box module , vers 2.118, # by Mark Overmeer (http://http://search.cpan.org/dist/Mail-Box/ ) # # This code can be used and modified without restriction. # # Usage: perl multipart-mo.pl Smith\,\ Bill\ \&\ Nancy/ (maild +ir folder name) # use warnings; use strict; use lib '..', '.'; use Mail::Box::Manager; sub emails_from_body($); # # Get the command line arguments. # die "Usage: $0 folderfile\n" unless @ARGV==1; my $foldername = shift @ARGV; # # Open the folder # my $mgr = Mail::Box::Manager->new; my $folder = $mgr->open($foldername, access => 'r') or die "Cannot open $foldername: $!\n"; # # List all messages in this folder. # print "Mail folder $foldername contains ", $folder->nrMessages, " mess +ages:\n"; my %emails; foreach my $message ($folder->messages) { my @parts = ($message, $message->parts('RECURSE')); print $message->seqnr, ' has '.@parts." parts\n"; $message->printStructure; foreach my $part (@parts) { foreach my $fieldname (qw/To Cc Bcc From Reply-To Sender/) { my $field = $part->study($fieldname) or next; $emails{$_}++ for $field->addresses; } my $ct = $part->contentType || 'text/plain'; $ct eq 'text/plain' || $ct eq 'text/html' or next; $emails{$_}++ for emails_from_body $part->body->decoded; } } print "$_\n" for sort keys %emails; $folder->close; exit 0; ### HELPERS sub emails_from_body($) { $_[0] =~ /([-\w.]+@([a-z0-9][a-z-0-9]+\.)+[a-z]{2,})/gi; }

    It works. :)

Convert Doxygen to POD
No replies — Read more | Post response
by RonW
on Mar 06, 2015 at 19:01

    This is a work in progress, but usable.

    Because, at work, my team and I use Doxygen to aid in producing code documentation, and not being satisfied with the available preprocessors for handling Perl in Doxygen, I considered improving one of them or maybe writing a new one. Then it occurred to me that converting Doxygen markup in to POD might make more sense.

    For my team and I, Doxygen has been very handy in documenting our code. Partly because the document source is right there with the code source. And because it helps us avoid violating the "Don't Repeat Yourself (DRY)" rule. This "filter" brings some of Doxygen's features to documenting Perl.

    Currently, this "filter" only generates POD from Doxygen-style markup. Any POD markup is passed through as-is. A future version, possibly based on PPI, might include an enhanced POD markup to provide these features.

    Again, this is a work in progress. I know I need to improve the structure. Also, it is not yet a module. There are also quirks I haven't put time in to working out.

    Update: Fixed bugs in handling of $VERSION and in handling of parameters.

    #! perl -w use strict; use warnings; our $VERSION = 0.013; our $NAME = 'PerlDox'; =head1 NAME PerlDox - Prefilter for POD that adds features inspired by Doxygen. =head1 SYNOPSIS perl PerlDox.pl file > file.pod =head1 DESCRIPTION This is a filter for POD documentation. It is B<not> a parser nor form +atter. The output is suitable for processing by available POD formatters such + as pod2html, pod2man, perldoc and others. =head2 Intent Perl POD's simplicity is good. Also, it comes with a cost. That of dup +licating information contained in the source of the program or module it docume +nts. Because POD is the primary standard for documenting Perl programs and +modules, it makes sense to bring a little extra capability to POD. The features added are to aid in documenting entities defined in the s +ource code, including variables, functions and others. In this version, these extra features are only supported with Doxygen- +style comments. In the future, processing of POD-style comments will be adde +d. =head3 Special Note The rest of the documentation comments in this program are meant to be filtered by this program. To properly view, please filter +this with itself, either piping to a POD formatter or directing to a file ( +see L</SYNOPSYS>). =begin PerlDox =head2 Details PerlDox markup is added immediately before or after each declaration d +efining entities to be documented. This filter assumes the first entity in the + source line is the one being documented. When finding the entity, the filter +is able to skip declaration keywords (see L</"Declaration Keywords">). A Dox c +omment that preceeds the symbol it documents is introduced by C<##>. A Dox co +mment that follows the symbol it documents is introduced by C<#E<lt>>: ## Buffer to hold data items to be processed. my @data; my $datum; #< Current item being processed. A list of variables can be documented by listing them one per line: ## Processing state my ($phase, $v, #< Value at location $x, #< X Coordinate of location $y, #< Y Coordinate of location ); The core Perl declaration keywords are recognized, plus a few common k +eywords provided by modules. See L</"Declaration Keywords"> B<Note>: The variable C<$VERSION> is treated specially. Like CPAN, thi +s filter looks for a version number/string in the line of text. Typical usage: package Foo; #< The Great and Powerful our $VERSION = 0.1; #< (this comment ignored, but the C<< #< >> is + required) B<Note>: At this time, Doxygen's "document all" feature is not support +ed. If an entity is not explicitly documented, it won't be mentioned in the o +utput. =head3 Enhancements over Doxygen In Doxygen, to document a group of related things, for example, variab +les, as a single entity, they must be members of a struct, enum or class. I +n this filter, they can simply be placed together: my $x; #< my $y; #< my $z; #< Coordinates of a point in 3 dimensional space. Note that this only works for C<< #< >> document comments. =head4 Hash Keys and Other Words This filter also allows documenting the use of hash keys as tag names: my %records = ( #< Hash to hold name/value records. phase => 0, #< Processing state x => 0, #< X coordinate y => 0, #< Y coordinate 'v' => 0, #< Value at location ); Note that, for quoted words, use of C<< => >> is still required. This support is very general, so can be used to treat other bare, or q +uoted, words as, for example, named parameters or enumeration tags. In this, +C<-> is treated like a sigal. Otherwise, bare words must still be valid var +iable names. Quoted "words" followed by C<< => >> will be accepted even if t +hey are not valid identifiers (See L</CAVEATS>). bare => 1, #< completely bare word, must be a valid name for v +ariables -pseudo => 2, #< - as a pseudo sigal, still must be a valid varai +ble name '&=' => 3, #< quoted and has =>, so otherwise invalid name acc +epted Note that this filter does not check Perl syntax, so it will extract w +hat appears valid even if it is not. =head3 POD and PerlDox Blocks Ordinary POD blocks are passed through with no further processing. PerlDox comment blocks are processed into POD blocks, using the surrounding context to provide details similar to how Doxygen works. POD formatting codes are passed through with no further processing. Also, POD commands are passed through, but will probably result in invalid POD being output. C<=begin PerlDox> and C<=end PerlDox> are allowed as means to hide par +ts of the documentation when unfiltered source is fed to a POD formatter. Otherwise, this filter ignores and removes them. C<=for PerlDox> is slightly special in that, absent an introducer, it +is treated as a forward referencing (C<##>) comment block. But see L</CAV +EATS>. =head3 PerlDox Blocks PerlDox blocks are introduced by: =cut my %DoxIntro = ( '##' => \&IntroFwd, #< Introduces block documenting the next entit +y defined. '#<' => \&IntroBck, #< Introduces block documenting the previous e +ntity. ); =pod B<Note>: For foreward referencing, if the current block is not immedia +tely followed by a source line, it is considered a continuation of the docu +mentation for the previous entity. B<Note>: For back referencing, the entity must be on current line or p +revious line, not counting blank lines. PerlDox paragraphs may be continued in succeding lines as normal comme +nts. The command will continue until either an empty comment, a line with no co +mment or another command. =head3 PerlDox Codes and Commands These are an enhanced subset of Doxygen directives. Doxygen formatting + codes were omitted in favor of POD formatting codes, so only commands and sp +ecial codes are implemented. Like Doxygen codes and commands, they are prefixed by a sigal, C<@> or + C<\>. Commands are only recognized after a PerlDox block introducer, or afte +r a comment introducer (C<#>). Some are extensions made to accommodate idi +osyncrasies of Perl. With no command, a Dox block will document the current symbol, as desc +ribed above. =cut my %DoxCmds = ( '' => \&CmdDef, # Perform default processing as deter +mined by context. return => \&CmdReturn, #< Starts a paragraph documenting the +return value of current function. returns => \&CmdReturn, #< Equivalent to @@return todo => \&CmdToDo, #< Inserts a "To Do" paragraph in plac +e and in "To" Do section. bug => \&CmdBug, #< Inserts a "Bug" paragraph in place +and in "Bugs" section. fix => \&CmdFix, #< Inserts a "Fix" paragraph in place +and in "Fixes" section. note => \&CmdNote, #< Inserts a "Note" paragraph in place +. params => \&CmdParams, #< Starts a parameter list. endparams => \&CmdEndp, #< Ends a parameter list. param => \&CmdParam, #< Manually document a parameter. (Usu +ally when directly using $_[n]) properties => \&CmdProps, #< Starts a property list. endProps => \&CmdEndPr, #< Ends a property list. property => \&CmdProp, #< Manually document a property. par => \&CmdPar, #< Starts a generic paragraph. internal => \&CmdIntern, #< Followed by text, it is used as int +ernal documentation through the # end of the Dox block. By itself, be +gins a region of internal # documentation. endinternal => \&CmdEndi, #< Ends a region of internal documenta +tion. ); my ($HereCmd) = ( 'here' => #< Designates a "Here Doc" whose conten +t is to be included in the documentation. # The end of the Here Doc is found aut +omatically. (see L</"Here Doc Processing">) ); =pod Special codes may appear anywhere in a Dox block. =cut my %DoxCodes = ( i => \&CodeItem, #< Insert value of item named in follow +ing word. empty => \&CodeEmpty, #< @internal Internal placeholder ); =head3 Declaration Keywords Currently recognized declaration keywords are: =cut ## @internal Map declaration keywords to descriptive phrases my %declarationMap = ( my => 'Variable lexical', #< our => 'Variable global', #< state => 'Variable state', #< 'package' => 'Package', #< sub => 'Function', #< Core Perl declaration keyw +ords. fun => 'Function', #< Added by Function::Paramet +ers and Kavorka method => 'Method', #< Added by Function::Paramet +ers, Kavorka and Method::Signatures func => 'Function', #< Added by Method::Signature +s ); =pod Besides being able to skip over the keywords, the keywords also specif +y which format to use for the symbol being documented. C<use vars> and C<use subs> sort of work, but have to be used carefull +y (see L</CAVEATS>). =head3 Here Doc Processing Here docs (see L<perlop/"Quote-Like Operators") can be designated, by +C<@here>, for processing. C<@here> will attempt to extract the identifier, or qu +oted text, after the C<<< << >>> to use as the end of data marker. Then it will p +ass through the following lines of text until it finds the end of data marker. Sta +cked here docs are not supported. This is useful when it is desired to include literal text that is part + of the code in the documentation. Use of a blank line as end of data is not supported. Also, escaped quo +tes within an end of data marker are not currently handled. Further, this tool cannot interpolate variables or expressions in Here + Docs. That is a run time feature of Perl. This tool only scans the Perl source. B<Note> Dox codes are not processed. However, any POD codes and comman +ds are passed through. =end PerlDox =head1 CAVEATS =head2 General This tool was written before discovering PPI (aka, Parse::Perl::Isolat +ed). It should be rewritten using PPI. "Valid" symbol names are limited to those matching C<[_A-Za-z][_A-Za-z +0-9:]*> This filter relies on the mark-up to find definitions of symbols to do +cument. Also, since it doesn't parse Perl, it doesn't find symbols that are burried +in systax. For example: for my $item (@items) #< Current record being processed. C<$item> is not found despite the presence of mark-up intended to docu +ment it. (Loop control variables probably aren't worth the extra complexity. Be +tter to avoid the "slippery slope".) Also: use vars qw( $thing ); #< description of $thing does not work. In general C<use vars> and C<use subs> are discouraged. + In particular, C<qw( $thing #< description )> will probably cause them to produce une +xpected results. Ordinary comments after a C<##> block will make the following declarat +ion invisiable. Note that a muti-line C<##> (or C<< #< >>) block starts with C<##> (or + C<< #< >>) but continues with C<#>. The block ends with a blank line or another C<##> + (or C<< #< >>) line. ## This is an example subroutine/function. # More description of the subroutine. sub foo; # This subroutine documented by above ## block ## This will be rendered as a paragraph documentation, # presumably a continuation of the previous ## block. # This comment isolates the immediately above ## block # from the the following subroutine. sub bar; # Will not be documented. Declaritive keywords are not always required. The intent of this is to allow hash keys to be treated like variables, primarily to support a c +ommon form of named subroutine/function/method paramters. As a consequence, +a symbol name can potentialy be extracted from non-declaration code line +s. =head2 =for PerlDox A C<=for PerlDox> paragraph will only behave like a C<##> paragraph wh +en it is followed by C<=cut>: =for PerlDox This paragraph documents the following sub, my_sub. =cut sub my_sub { ... } Other POD mark-up before the C<=cut> will make the following declarati +on invisiable to the C<=for> paragraph. Like C<##> paragraphs, intervening comments will also make the followi +ng declaration invisiable to the C<=for> paragraph. Likewise, other code +will be examined for a symbol instead of the declaration. =head1 SEE ALSO =head1 AUTHOR =head1 COPYRIGHT =head1 LICENSE This program licensed under the GNU Public License (GPL) version 3. =cut ## @internal my $opt_w = 0; # supress warnings if set my $opt_i = 0; # include internal documentation if set my $codeLine; #< Current line of source code my $symbol; #< Name of current symbol my $symbolDec; #< Declarator of current symbol my $CurIntro; #< PerlDox introducer in affect my $block; #< Accumulated document comment text my $CurFunc; #< Name of current function my $CurVar; #< Name of current variable my %items; #< Keys and values of L<Named Items> my @todo; #< List of To Do items from Dox comments my @bugs; #< List of Bug items from Dox comments my @fixes; #< List of fixes from Dox commentts my $inParam; #< True when processing a parameter list my $internal; #< True when processing internal documentation my $hereTarg; #< Target of a 'Here doc' (set when handling a here doc +) my $inPOD; my $cutPOD; my $inFor; my $decKeywords = join('|', map($_ . '\b', keys %declarationMap)); my $reExSym1 = q/(\s*)[']([^']+)[']\s*[=][>]/; #< my $reExSym2 = q/(\s*)["]([^"]+)["]\s*[=][>]/; #< my $reExSym3 = '\s*(' . $decKeywords . q/)?\s*[(]?\s*([-$@%]?[_A-Za-z] +[_A-Za-z0-9:]*)\b/; #< Regular expressions to extract a symbol from the current line of co +de. # Skips declaritive key words (see L</"Declaration Keywords">). # Because the expressions are designed to handle variables, subroutio +ns, # packages and, as described in L</Details>, quoted and bare words, t +hey # must be single quoted. But since it contains a B<'>, C<qr''> cannot + be # used. Therefore, C<q//> is used, instead. # See L</"Hash Keys and Other Words">. my $reDox1 = qr/^\s*([#]\S)(.*)/; #< my $reDox2 = qr/\s([#]\S)(.*)/; #< Regular expressions to extract a +Dox comment. ## Map type sigals to descriptive words. # Because C<//> is relatively new, the default is C<''> and # there are only 3 sigals, doing this as a sub instead of a hash. sub typeMap ($) { ## @params my $s = $_[0]; #< Symbol to map ## @endparams return ($s =~ m'^[$]') ? 'scalar' : ($s =~ m'^[@]') ? 'array' : ($s =~ m'^[%]') ? 'hash' : '' ; } # Forward declarations sub procBlock ($); # Utility function to output a warning about input being processed. sub whine ($) { return if ($opt_w); # Are warnings being supressed? warn 'Warning: ' . $_[0] . " at $. in $ARGV\n"; } ## Find first symbol on a source code line. sub extractSymbol ($) { ## @params my $cl = $_[0]; #< Line of code for extraction ## @endparams return unless defined $cl; if (($cl =~ /$reExSym1/o) or ($cl =~ /$reExSym2/o) or ($cl =~ /$re +ExSym3/o)) { $symbolDec = ''; if (defined($1)) { $symbolDec = $1; } if (defined($2)) { $symbol = $2; } if ($symbolDec eq 'package') { $items{'package'} = $symbol; } } } ## Map POD special characters to POD escape codes. sub encodeString ($) { ## @param $p1 String to encode my @c = (split(//,$_[0])); for (@c) { s#[<]#E<lt># or s#[>]#E<gt># or s#[|]#E<verbar># or s#[/]#E<sol>#; } return join('', @c); } ## Handle item Dox code sub CodeItem { ## @params my $t = $_[0]; #< text to process ## @endparams $t =~ s/^\w+(?:\s+(\w+))?//; # First word is the Dox code, second +is item name. unless (defined $1) { return $t; } if ((exists $items{$1}) && (defined $items{$1})) { return $items{$1} . $t; } return $1 . $t; } ## Handle "empty" sub CodeEmpty { return ' '; } ## Handle a PerlDox code. sub procCode ($) { ## @params my $t = $_[0]; #< Dox code to process ## @endparams $t =~ /^(\w+)/; return $t unless defined($1); # sigal by itself is effectively rem +oved my $c = $1; ## @todo Might need to handle other Doxygen escapes if ((exists $DoxCodes{$c}) && (defined $DoxCodes{$c})) { return &{$DoxCodes{$c}}($t); } else { whine "Invalid PerlDox code '$c'"; ## @todo Should the invalid code be removed? return $t; } } ## Handle any PerlDox codes. sub procCodes ($) { $DB::single = 1 if ($symbol =~ /Type_P4SM/); ## @params my $bl = $_[0]; #< Comment block to process ## @endparams my $r = ''; my @p = split(/([\\@])/, $bl); # seperator will be captured into a + field while (@p) { my $t = shift @p; if ($t =~ /[\\@]/) { $t = shift @p; if ($t) # non-empty field should be a di +rective { $r .= procCode($t); } else # empty field between seperators { $r .= shift @p; # should be the seperator being +escaped } } else # other text { $r .= $t; } } return $r; } ## Parameter processing sub procParam ($) { ## @params my $bl = $_[0]; #< Comment block to process ## @endparams my $s = encodeString($symbol); # A quoted name might need encoding +. See L</"Hash Keys and Other Words">. my $t = typeMap($symbol); my $d = ($declarationMap{$symbolDec} or ''); if (($d =~ /^Variable/) || ($d eq '')) { return "\n=head4 Parameter $t $s\n\n$bl\n\n" } else { whine "$symbol is not a variable or tag"; } return ''; } ## Default PerlDox block processing sub CmdDef ($) { if ($inParam) { return procParam($_[0]); } ## @params my $bl = $_[0]; #< Comment block to process ## @endparams my $s = encodeString($symbol); # A quoted name might need encoding +. See L</"Hash Keys and Other Words">. my $t = typeMap($symbol); my $d = ($declarationMap{$symbolDec} or ''); if ($d eq 'Package') { return "\n$s - $bl\n\n"; } elsif (($d eq 'Function') || ($d eq 'Method')) { $CurFunc = "$d $s"; return "\n=head3 $d $s\n\n$bl\n\n"; } elsif ($symbol eq '$VERSION') { $codeLine =~ /([0-9]+\.[0-9]+[0-9._]*)/; return "\n=head4 Version: $1\n\n"; } else { $CurVar = "$d $t $s"; return "\n=head4 $d $t $s\n\n$bl\n\n"; } } ## Handle a note sub CmdNote ($) { ## @params my $bl = $_[0]; #< Comment block to process ## @endparams return "\n\nI<Note:> $bl\n\n"; } ## Manually document a symbol. Usually used when name is not extractab +le. sub CmdParam ($) { my $bl = $_[0]; #< @param - Comment block to process $bl =~ s/^\s+//; if ($bl =~ /^-\s/) ## However, '- ' is a placeholder for an extrac +ted symbol name. { $bl =~ s/^-\s//; return procParam($bl); } my $saveSym = $symbol; my $saveDec = $symbolDec; $symbol = undef; $symbolDec = ''; my $o = ''; extractSymbol($bl); if ($symbol) { $bl =~ s/^.*?\Q$symbol\E\s*//; $o = procParam($bl); } else { whine 'Could not extract a parameter name'; } $symbol = $saveSym; $symbolDec = $saveDec; return $o; } ## Start of parameter list sub CmdParams { if ($inParam) { whine 'Nested "params" regions not supported'; } $inParam = 1; return ''; } ## End of parameter list sub CmdEndp { unless ($inParam) { whine '"endparams" without matching "params"'; } $inParam = 0; return ''; } ## Format 'to do' comment sub CmdToDo ($) { ## @params my $bl = $_[0]; #< Comment block to process ## @endparams return '' if (($internal) && (! $opt_i)); my $s = $CurFunc ? $CurFunc : ( $CurVar ? $CurVar : ''); push @todo, qq{L</"$s">, $bl\n\n}; return "\nI<To Do:> $bl\n\n"; } ## Format 'bug' comment sub CmdBug ($) { ## @params my $bl = $_[0]; #< Comment block to process ## @endparams return '' if (($internal) && (! $opt_i)); my $s = $CurFunc ? $CurFunc : ( $CurVar ? $CurVar : ''); push @bugs, qq{L</"$s">, $bl\n\n}; return "\nI<Bug:> $bl\n\n"; } ## Format 'fix' comment sub CmdFix ($) { ## @params my $bl = $_[0]; #< Comment block to process ## @endparams return '' if (($internal) && (! $opt_i)); my $s = $CurFunc ? $CurFunc : ( $CurVar ? $CurVar : ''); push @fixes, qq{L</"$s">, $bl\n\n}; return "\nI<Fix:> $bl\n\n"; } ## Format return description sub CmdReturn ($) { ## @params my $bl = $_[0]; #< Comment block to process ## @endparams return "\nI<Returns:> $bl\n\n"; } ## Start internal region or handle one-off internal doc comment sub CmdIntern ($) { ## @params my $bl = $_[0]; #< Comment block to process ## @endparams if ($bl =~ /\S+/) # if any text, handle as one-off internal doc { procBlock($bl) if ($opt_i); } else { if ($internal) { whine 'Nested "internal" regions not supported'; } $internal = 1; } return ''; } ## End of internal region sub CmdEndi { unless ($internal) { whine '"endinternal" without matching "internal"'; } $internal = 0; return ''; } ## Handle a 'Here Doc'. sub startHere { if ($hereTarg) { whine 'Nested "Here Docs" not supported'; return ''; } $codeLine =~ m|<<([_A-Za-z][_A-Za-z0-9]*)| or $codeLine =~ m|<<'([^']+)'| or $codeLine =~ m|<<"([^"]+)"| or $codeLine =~ m|<<(\s)|; unless (defined $1) { whine 'End of data symbol for Here Doc not found'; return ''; } my $t = $1; if ($t =~ /\s/) { whine 'Blank end of data for Here Doc not supported'; return ''; } $hereTarg = $t; return ''; } ## Finalize processing of a 'Here Doc'. sub endHere ($) { ## @params my $bl = $_[0]; #< Here Doc text. ## @endparams return "\n\n$bl\n\n"; } ## Insert a generic paragraph sub CmdPar { ## @params my $bl = $_[0]; #< Comment block to process ## @endparams $bl =~ s/^\s+//; return "$bl\n\n"; } ## Process the current document comment block sub procBlock ($) { ## @params my $bl = $_[0]; #< Comment block to process ## @endparams my $h; $bl =~ s/^\s+//; # trim leading white space if ($CurIntro) # Dox block { $bl = '@empty' if (($CurIntro eq '#<') &&($bl =~ /^[\n\r]*$/)) +; # allow empty docs for back reference my $o = ''; for my $ln (split(/(?:[\n\r]+\s*)+/, $bl)) { # $DB::single = 1; # First, parse out the command, if present if ($ln =~ /^[\\@]([a-z]+)/) # Dox code at begining of lin +e might be a Dox command { my $c = $1; if ((exists $DoxCmds{$c}) && (defined $DoxCmds{$c})) { $h = $DoxCmds{$c}; $ln =~ s/[\\@]([a-z]+)//; } } # Now, process any codes $ln = procCodes($ln) unless (($internal) && (! $opt_i)); # Then execute the command if (defined $h) { $o = &{$h}($ln); } else { $o = CmdDef($ln); } print $o unless (($internal) && (! $opt_i)); } } else # POD block { print $bl unless (($internal) && (! $opt_i)); } } sub help { } sub procOptions { if (0 != @ARGV) { if ($ARGV[0] =~ /^-w/) { $opt_w = 1; shift @ARGV; } } } ## Preparations for a foreword referencing command sub IntroFwd { } ## Preparations for a backward referencing command sub IntroBck { extractSymbol($codeLine); } ## Validate PerlDox comment introducer and do common preparations sub validIntro ($) { ## @params my $c = $_[0]; #< Introducer to validate ## @endparams if ((exists($DoxIntro{$c})) && (defined($DoxIntro{$c}))) { $CurIntro = $c; # set here to allow handler to override. &{$DoxIntro{$c}}; return 1; } $CurIntro = undef; whine "Invalid doc comment introducer: $c"; return 0; } ## Handle start of a POD block # @return 0 for normal processing, non-0 to request mainloop redo sub startPOD { procBlock($block) if ($block); # Implicit end of current block. $inPOD = 1; $cutPOD = 0; # in case last non-blank, non-comment was =cut $inFor = 0; $CurIntro = undef; # As a simplifaction, just skip our own begin/end because # it is just used to hide from other POD processors. if (/^[=](for\b|begin\b|end\b)\s+:?(?:Perl)?Dox/) { $block = ''; if ($1 eq 'for') # Munge "=for PerlDox" into a Dox block { s/=for\s+:?(?:Perl)?Dox\s*//; $_ = '## ' . $_ unless (/^[=#]/); $inFor = 1; return 1; # request main loop to redo } } else { $block = $_; } return 0; # normal processing } ## Handle end of a POD block sub finshPOD { extractSymbol($codeLine); if ($block) { if ($inFor) # Were we in a =for paragraph? { # Process probable Dox block if (($block =~ /$reDox1/) || ($block =~ /$reDox2/)) { if (validIntro($1)) # Sets $CurIntro if valid { $block =~ s/^\s*$1//; } } } procBlock($block); } $block = ''; $cutPOD = 0; $inFor = 0; $CurIntro = undef; # Because we may have set this } procOptions(); if (0 == @ARGV) { die "Nothing to process.\n"; } print "# Generated by $NAME $VERSION\n\n"; while (<>) { s/[\n\r]+$//; # trim off potentially platform specific line termin +ator $_ .= "\n"; # replace with "normalized" line terminator if (defined $hereTarg) # Processing a Here Doc? { if (/^$hereTarg$/) # End of Here Doc { endHere($block); $hereTarg = undef; $block = ''; } else { $block .= $_; } next; } next if (/^\s*[#][!]/); # skip sharp-bang construct. $DB::single = 1 if (/Type_P4SM/); if ($inPOD) { if (/^[=]/) # Start of next POD block { if (/^[=]cut/) # Actual end of the current block { # Defer block processing until a non-blank, # non-comment line is found. This allows opportunity # to pick up the next source symbol, first. $inPOD = 0; $cutPOD = 1; } else { redo if startPOD(); } } else { $block .= $_; } } else { if (/^[=]/) # Start of a POD block { redo if startPOD(); next; } unless ((/^\s*[#]/) || (/^\s*$/)) # Don't collect code from a +blank or comment line { $codeLine = $_; finshPOD() if ($cutPOD); # if a POD block ended with =cut } if (defined($CurIntro)) { if ((/$reDox1/) || (/$reDox2/)) # Start of next PerlDox bl +ock { my ($intro, $content) = ($1, $2); extractSymbol($codeLine) if ($CurIntro eq '##'); procBlock($block) if ($block); $block = ''; if (validIntro($intro)) { $block = ($content ? $content : ' '); if ($block =~ /[@\\]$HereCmd/o) # Begining of a He +re Doc? { startHere; $block = ''; # discard anything after here com +mand (content starts on nect line) } } } elsif (/[#]\s*(\S.*)/) # Continuation of PerlDox block { my $t = $1; $block .= "\n" if ($t =~ /[\\@]/); # Assume Dox code a +t start of line is a command $block .= ' ' . $t; } else # Implicit end of PerlDox block { ## @todo Handle blank and empty comment lines. Also, h +ow to handle "interrupted" block. extractSymbol($codeLine) if ($CurIntro eq '##'); procBlock($block) if ($block); $block = ''; $CurIntro = undef; } } else { if ((/$reDox1/) || (/$reDox2/)) # Start of a PerlDox block { my ($intro, $content) = ($1, $2); finshPOD() if ($cutPOD); # if a POD block ended with = +cut $block = ''; if (validIntro($intro)) { $block = ($content ? $content : ' '); if ($block =~ /[@\\]$HereCmd/o) # Begining of a He +re Doc? { startHere; $block = ''; # discard anything after here com +mand (content starts on next line) } } } } } } continue { # check if end of current file if (eof) # Not eof()! { # Clean up at end of current file procBlock($block) if ($block); # Implicit end of current bloc +k. $block = ''; $inPOD = 0; $cutPOD = 0; close ARGV; # Force reset of Perl's line counter with explicit + close } } if (0 < @todo) { print "\n\n=head1 To Do\n\n"; for (@todo) { print "$_\n\n"; } } if (0 < @bugs) { print "\n\n=head1 Bugs\n\n"; for (@bugs) { print "$_\n\n"; } } if (0 < @fixes) { print "\n\n=head1 Bugs\n\n"; for (@fixes) { print "$_\n\n"; } } =end PerlDox
EEPROM on i2c Real Time Clock Modules
1 direct reply — Read more / Contribute
by anita2R
on Mar 03, 2015 at 18:16

    Recently I bought a Real Time Clock module to attach to a Raspberry Pi using i2c. Getting the RTC up and running was pretty straight forward, but then I noticed that the board included an Atmel AT24C32 eeprom.

    Despite extensive searches I could not find information on accessing the eeprom. I already had the HiPi::BCM2835::I2C module installed, but again the available documentation was limited, but in the end I produced two scripts for reading and writing to the eeprom, using its sequential 32 byte read and write function. This allows sequential reads or writes for up to 32 bytes from a page address.

    As a 'less than Perl Monks novice' I humbly place the following two scripts here for others who want to use the eeproms on their RTC modules. Any advice on improving my code would be welcome

    Write to eeprom

    The script must be called as root, but permissions are put back to a normal user in the script. The two variables $user and $group need to be entered, and if necessary the eeprom address on the i2c bus should be changed - it is currently 0x57, and is on the i2c-1 bus (change to i2c-0 for rev. 1 Raspberry Pi's)

    The write program requires a start address after the -a parameter (there is no default) and input can be piped to the script, entered as text in quotes after a -t parameter, or put as a path/filename after -t for a text file to be used as source

    Example calls

    Write to eeprom code (improved commenting - thanks to roboticus)

    Read from eeprom

    The script to read from the eeprom is simpler. It requires a start address after the -a parameter (defaults to 0) and a length of data to read after the -l parameter (defaults to 32). Optionally a -o parameter takes a path/filename to receive output. A valid path is required, but if the file is not present it is created. Existing files are appended to. With no -o option the output is to screen, formatted with the eeprom hex addresses, if a -h parameter is included the data is displayed in hex, rather than the default character display.

    Revised Read from eeprom code based on feedback from roboticus

    anita2R

binmode can save your bacon
No replies — Read more | Post response
by poltr1
on Feb 28, 2015 at 02:02

    Another "war story" here -- not a question, but something worth passing on: A previous client of mine had some Summit and Zeiss precision measuring (i.e. metrology) machines, and about 6,000 programs to perform measurements on the various parts this company manufactured. They were in the process of migrating network operating systems (from Novell to Microsoft), and thus, had to change the hardcoded drive mappings in these files. All 6,000 of them.

    No way was I going to do this manually. (Laziness, y'know?) I could write a perl script to perform a search-and-replace mission. And I did. But there was another problem: the script wasn't finding the filepaths based on the regex I wrote. So I then did a hexdump on a couple of these files. That's when I discovered the files were in binary format, but the filepaths were plain-text. What was I to do? RTFD. I came across the binmode command, which enabled me to open up files in binary format. So I tried it. And it worked -- it finally matched the regex, and replaced the old drive mapping with the new path.

    binmode FILEHANDLE;

    But there were still some paths that didn't get converted. These were mostly for external shape definition files, and comprised about 10% of the total set of programs. So I called the vendor to see if they had a product to do what we wanted to do. And the vendor told me "it couldn't be done". I knew otherwise, but I wasn't going to tell the vendor that they were wrong.

    Bottom line: Using binmode, Perl can be used to edit binary files. But Be Careful How You Use It!

Color highlighted perl grep
1 direct reply — Read more / Contribute
by FreeBeerReekingMonk
on Feb 23, 2015 at 12:49

    To highlight a grep, we use grep --color, however, sometimes either grep does not have highlighting (AIX), or, we want to highlight multiple expressions with different colors.

    usage: ls -l | grep -e foo -e bar |./highlight.pl this that foo bar

    #!/usr/bin/perl use Term::ANSIColor; while(<STDIN>){ for $i (1..15){ next unless(defined($ARGV[$i-1])); s/($ARGV[$i-1])/&colored($1,"ansi15 on_ansi$i")/gexi; } print; }

    Of course, just use an alias or put it in the path and call it just "hl" for sanity. It supports 15 different arguments, but can be extended to the 255 different combinations Linux has. On some terminals however, you want your own selected colours, in that case, you will need to specify them by hand, for example:

    #!/usr/bin/perl use Term::ANSIColor; $VERSION = '1.1'; @C = ('black on_yellow','black on_green','black on_cyan','black on_red +', 'red on_white', 'black on_magenta', 'white on_red', 'white on_blue +', 'blue on_white', 'yellow on_cyan' ); while(<STDIN>){ for $i (0..$#C){ s/($ARGV[$i])/&colored($1,$C[$i])/gexi if($ARGV[$i]); } print; }

    In the latter example, you can specify many more attributes, like bold and underscore, even blink... peruse ANSIColor.pm for examples.

    Caveats: Do not grep on digits 0..15 (except as first argument), as the ansi codes also contain numbers...

random file script
1 direct reply — Read more / Contribute
by etherald
on Jan 30, 2015 at 23:50
    here's my random file script to recursively choose a number of random files matching a regex from a directory or list of directories
    #!/usr/bin/env perl # recursively choose a number of files optionally matchinng a regex # from a directory or list of directories. defaults to cwd. # outputs absolute paths by default, relative with -r # use like so: # randomfile -n 23 -p \(mp3\|ogg\|flac\)$ ~/music ~/music2 use strict; use warnings; use Getopt::Long; use Cwd; use File::Random qw/random_file/; use File::Spec; my $pat = '^.+$'; my $num = 1; my $relative = 0; GetOptions( 'p|pattern=s' => \$pat, 'n|number=i' => \$num, 'r|relative' => \$relative, ); while ($num) { my $random_file; my $dir; do { $dir = $ARGV[rand @ARGV] or cwd(); $random_file = random_file( -dir => $dir, -check => qr/$pat/, -recursive => 1); } until $random_file; $random_file = "$dir/$random_file"; $random_file = File::Spec->abs2rel($random_file) if $relative; print "$random_file\n"; --$num; }
Alphabetize in Esperanto
1 direct reply — Read more / Contribute
by aplonis
on Jan 30, 2015 at 10:21

    A hobby of mine is translating Jack Vance into Esperanto. And yes, I have permission for this! These I distribute for free in EPub format. In each ebook I like to embed a mini linked-in dictionary to help out beginners.

    I was wanting to re-organize some standalone EPubs into one omnibus EPub. I wanted one end-of-book dictionary instead of six end-of-chapter ones. That meant re-alphabetizing hundreds of anchor links. No big deal to do it in Perl...except that it's Unicode...and Esperanto. Here's how I did it.

yellow pages
2 direct replies — Read more / Contribute
by japh2963
on Jan 29, 2015 at 01:32

    was looking for freelance work and came across a request for a script that would scrape yellow pages website. Hopefully the poster will google more before they spend $300 bucks for this...

     

    #!/usr/bin/perl # program: yp.pl # purpose: search for phone number on www.yellowpages.com # date: 2015.01.28 use strict; use warnings; use LWP::Simple; my $usage = "\n\tusage: perl $0 [PHO-NEN-UMBR]\n"; my $baseUri = 'http://www.yellowpages.com/search?search_terms=+'; my $phoneNumber = $ARGV[0]; die $usage unless($phoneNumber =~ m/^\d{3}-?\d{3}-?\d{4}$/); my $content = get("$baseUri$phoneNumber"); $content =~ s/\s+/ /g; $content =~ s/\&nbsp;/ /g; $content =~ s/>\s*</\n/g; my $hits = 0; foreach my $e(split /\n/, $content){ chomp $e; if($e =~ m/^.*itemprop=['|"](\S+)['|"].*>(.*),?<\/\S+.*$/i){ my $itemProp = $1; my $itemValue = $2; $itemValue =~ s/,\s*$//; print "$itemProp: $itemValue\n"; $hits++; } } print "no results found for number '$phoneNumber'\n" if(!$hits); exit;
MD5 checksums for Windows
1 direct reply — Read more / Contribute
by golux
on Jan 13, 2015 at 11:58
    This program "sum.pl" (for Windows) generates checksums matching those produced by the "md5sum" program in Linux. I wrote it because I often need to validate whether 2 files on different computers are the same.

    Enter "sum.pl" without arguments for a syntax message. Both files and/or directories (ie. "folders") are accepted as arguments. With the switch -R subdirectories are searched recursively. The switches -s <key> and -r control how the output is sorted. The -d switch gives a final report of any duplicate checksums found.

    Hope this might be of general use to others as well!

    Update:   At Anonymous Monk's suggestion, I've added a "-c" switch which produces a checksum format compatible with "md5sum". It does this by skipping the filesize, and prefixing the path with '*' to signify that the checksum was done in binary mode.

    say  substr+lc crypt(qw $i3 SI$),4,5
How to perldebug a Term::ReadLine application
1 direct reply — Read more / Contribute
by LanX
on Dec 01, 2014 at 09:42

    the problem

    I recently heard monks complaining that applications using Term::ReadLine can't be debugged within the perldebugger b/c it's interface relies on Term::Readline.

    the trick

    here one solution (at least for linux) I wanted to have documented (before I forget it again ;)

    call the script you want to debug (here calc_TRL.pl ) from a shell with

    PERLDB_OPTS="TTY=`tty` ReadLine=0" xterm -e perl -d ./calc_TRL.pl

    and a second xterm will be opened running the program.

    how it works

    a second xterm is started running the debugger, but b/c of the TTY setting in PERLDB_OPTS all debugger communication goes via the parent xterm , while the calc app normally displays in the child xterm .

    ReadLine=0 tells the debugger not to rely on a working Term::ReadLine.

    NB: It's important that calling the second xterm blocks the execution in the first xterm till it's finished. Like this keystrokes aren interpreted by two applications in the first xterm. Just put an & at the end to see how things get messed up otherwise if the shell tries to step in.

    how it looks like

    first xterm

    becomes the front end for the debugger

    as you see I get the lines from the app in the second xterm listed can set a breakpoint at the end of the loop and tell twice to continue till next breakpoint.

    second xterm

    runs the application, I'm asked to enter a calculation which is evaluated, interupted twice by a breakpoint at line 9.

    Enter code: 1+2 3 Enter code: 4+4 8

    the test script

    > cat ./calc_TRL.pl use Term::ReadLine; my $term = Term::ReadLine->new('Simple Perl calc'); my $prompt = "Enter code: "; my $OUT = $term->OUT || \*STDOUT; while ( $_ = $term->readline($prompt) ) { my $res = eval($_); warn $@ if $@; print $OUT $res, "\n" unless $@; $term->addhistory($_) if /\S/; }

    tested with Term::ReadLine::Gnu installed.

    generalisation

    you can use this approach whenever you want the debugger communication separated into a separate term. e.g. Curses::UI comes to mind

    discussion

    the solution is not "perfect", of course you need to arrange the windows and switch with Alt-Tab between them. (maybe screen could solve this or an emacs inegration)

    Furthermore you won't have a history with arrow navigation within the debugger, cause TRL was disabled.

    another approach is to communicate via sockets with a debugger run within emacs, since emacs has it's own TRL-emulation this shouldn't interfere.

    see also Re: Testing terminal programs within emacs (SOLVED) for an approach to handle all this automatically, by restarting a script with altered environment and different terminal.

    TIMTOWTDI

    see perldebguts , perldebtut and perldeb,

    Also "Pro Perl Debugging" book and various TK tools on CPAN.

    Cheers Rolf

    (addicted to the Perl Programming Language and ☆☆☆☆ :)

The hills are alive...
4 direct replies — Read more / Contribute
by Lady_Aleena
on Nov 26, 2014 at 22:25

    ..with The Sound of Music. ;)

    I had @SoM_notes and $SoM sitting around doing nothing, so this evening, I made them do something. In make_SoM_song and get_SoM_def, you enter a string of alphabetical notes (c, d, e, f, g, a, b). The notes can be separated by a comma, semicolon, or a space. The functions will return the note name given by Maria von Trapp in The Sound of Music.

    I wrote random_SoM_note and random_SoM_song because I couldnt' help myself. Most of you know how much I love to randomly generate things. :)

    make_SoM_song, get_SoM_def, and random_SoM_song all return array references.

    Enjoy the code!

    package SoundofMusicSong; use strict; use warnings; use Exporter qw(import); our @EXPORT_OK = qw(make_SoM_song get_SoM_def random_SoM_note random_S +oM_song); my @base_notes = qw(c d e f g a b); my @SoM_notes = qw(do re me fa so la te); my %notes; @notes{@base_notes} = @SoM_notes; my $SoM = { 'do' => 'a deer a female deer', 're' => 'a drop of golden sun', 'me' => 'a name I call myself', 'fa' => 'a long long way to run', 'so' => 'a needle pulling thread', 'la' => 'a note to follow so', 'te' => 'a drink with jam and bread', }; sub make_SoM_song { my ($user_song) = @_; my @song_notes = split(/[ ,;]/, $user_song); my @new_song = map { $_ = $_ =~ /^[a-g]$/ ? $notes{$_} : 'not a note +'; $_ } @song_notes; return \@new_song; } sub get_SoM_def { my ($user_song) = @_; my $notes = make_SoM_song($user_song); my @new_song = map { $_ = $$SoM{$_} ? $_.' '.$$SoM{$_} : 'not a note +'; $_ } @$notes; return \@new_song; } sub random_SoM_note { my $note = $SoM_notes[rand @SoM_notes]; return $note; } sub random_SoM_song { my ($number_of_notes) = @_; my $notes = $number_of_notes ? $number_of_notes : int(rand(100)) + 1 +; my @new_song; push @new_song, random_SoM_note for (1..$notes); return \@new_song; } 1;
    No matter how hysterical I get, my problems are not time sensitive. So, relax, have a cookie, and a very nice day!
    Lady Aleena
CPAN Namespace Navigator
1 direct reply — Read more / Contribute
by Discipulus
on Nov 25, 2014 at 06:23
    CPAN Namespace Navigator is an interactive program that let you to navigate all namespaces on CPAN.
    The idea born when i read that before upload something to CPAN is better to explore existing modules, but when i asked here in the chat how to browse it i discovered that ther is not a real exploration program to do it.

    So the challenge was to hack directly the fomous file 02packages.details.txt that we receive (gzipped) when we search some module with some CPAN client. I used Term::ReadLine not without some headache.

    I decided (unwisely) to eval directly the data received to build up a big HoH with the whole hierarchy of CPAN modules and reletad infos. As suggested (wisely) by ambrus and yitzchak i looked at tye's Data::Diver and on my own at an ancient and unmaintained Data::Walker one.

    I was not able to bind Data::Diver at my will to add to the structure others infos like parent namespace or version, so i reinvented that wheel evaluating everything by myself.

    Surprisingly it worked.

    This is the usage and the navigation commands available during the navigation:
    USAGE: cpannn.pl [02packages.details.txt] NAVIGATION: . simple list of contained namespaces .. move one level up + detailed list of contained namespaces * read the readme file of current namespace ** download the current namespace's package ? print this help TAB completion enabled on all sub namespaces cpannn.pl by Discipulus as found at perlmonks.org
    And here you have the code, finally crafted after 37 steps of development.


    HtH
    L*

    update: take a look also at Re: Autocomplete in perl console application
    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.

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!
  • 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
  • Outside of code tags, you may need to use entities for some characters:
            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.