for bronto

use strict;
use warnings;

use Quantum::Superpositions;
use Test::More qw/no_plan/;

$|++;

my %corr = (
    a => any( 'a', '@', '4' ),
    b => any( 'b', '6', '8', '&' ),
    d => any( 'd', '0' ),
    e => any( 'e', '3', '&' ),
    g => any( 'g', '9' ),
    i => any( 'i', '1', 'l' ),
    j => any( 'j', '1' ),
    l => any( 'l', '1' ),
    o => any( 'o', '0' ),
    p => any( 'p', '9' ),
    q => any( 'q', '9' ),
    s => any( 's', '$', '5' ),
    t => any( 't', '+' ),
    z => any( 'z', '2', '7', '%' )
);


sub compare_strings 
{
    my $s1 = shift;
    my $s2 = shift;

    my @c1 = split //, lc $s1;
    my @c2 = split //, lc $s2;

    @c2 = map { exists $corr{ $_ } ? $corr{ $_ } : $_ } @c2;
    print "c1: @c1\nc2: @c2\n";

    my $res = 1;
    for ( my $index = 0; $index < scalar @c1; $index++ ) {
        $res = $res && ($c1[ $index ] eq $c2[ $index ]);
    }

    return $res;
}

ok( 'a' eq any( '4', 'a', '@' ) );
ok( compare_strings( 'l4rsen',        'larsen' ) );
ok( compare_strings( 'b4rsen',        'larsen' ) );
ok( compare_strings( 'b4rsen',        'larsen' ) );
ok( compare_strings( 'm@rc0m4r0n91u', 'marcomarongiu' ) );
[download]

for princepawn

$_ = qq|
1
           d4 f5 2 Nc3 d5 3 Bg5 c6 4 e4 fxe4 5 f3 exf3 6 Nxf3 Bg4 7 h3
+ Bxf3 8
           Qxf3 Nf6 9 Bd3 Nbd7 10 0-0-0 Qc7 11 Rhe1 0-0-0 12 Bf4 Qb6 1
+3
           Re6 g6 14 Nb5 Ne8 15 Be2 a6 16 Qa3 g5 17 Na7+!! Qxa7 18  Rx
+c6+! bxc\
6 19 Bxa6+ Qb7 20 Qa5
|;

s{\b(\d+)\b}{\1.}g;

print;
[download]

for Dogma

use strict;

use CGI;
use Template;

$|++;


# Dispatch table is a hash where
# every value is a sub-reference
# When the user doesn't provide
# a run-mode, then list() is
# triggered (default case, see
# the last line

my %dispatch_table = (
        list => \&list,
        item => \&item,
        fetch_image => \&fetch_image,
        '' => \&list,
);

my $query = new CGI;

print $query->header;
print $query->start_html(
  -title => 'A small example...'
);

# Now we read the param mode from
# the query. The string is used to
# fetch the hash table. We got a
# reference to a function, so we
# can call it...

my $mode = $query->param('mode');
&{ $dispatch_table{$mode}};

print $query->end_html;

sub list
{
    print "<h1>List mode</h1>\n";

    my $action = $query->param('action');

    # What we can do with $action?
    # Another dispatch table here is not
    # possible (one can't define procedures
    # local to other procedures, like in 
    # Pascal). Another possibility is to 
    # define other procedures "at the same
    # level" of list(), item() and so on...
    # but it isn't elegant and easily maintanable.
    # So we could use different
    # packages for different "top level run-modes".
    # Or, simply, we can cope with $action
    # here, with a if-elsif-else construct.

}

sub item
{
    print "<h1>Item mode</h1>\n";
}

sub fetch_image
{
    print "<h1>Fetch_image mode</h1>\n";
}
[download]

Random links...

PmDev Stuff

Useful resources for pmdevs

• Node Lister
• pmdev wiki
• pmdev task lister
• displaytype=viewcode

Nodes for which I've submitted a patch so far...

• addtoscratchpad Fixed a problem with link generation (see Re (tilly) 2: Outputing HTML files). Minor HTML adjustements
• userbody Better logic. Minor HTML adjustements.
• add your code Automatic <code> tags (see Auto CODE tags when posting Code examples?)

A silly patch for user display page

# Modified by larsen - Nov 17 2001

<table>
<tr>

[%
    use Everything::Experience;
    return unless $NODE->{imgsrc};
    my $SETTING = getNode('home node image cheaters','setting');
    my $CHEATERS = getVars $SETTING;
    return unless isGod($NODE) or  
                    getLevel($NODE) >= 5 or 
                    $CHEATERS->{$NODE->{title}} or 
                    $CHEATERS->{$NODE->{node_id}};
    return qq(
        <td rowspan="10">
        <img src="http://perlmonks.org/$NODE->{imgsrc}">
        </td>
    );
%]

<td valign="top">
[%
    use Everything::Experience;
    if ($NODE->{imgsrc} and getLevel($NODE)<5 and !isGod($NODE))
        return linkNodeTitle("I want my picture back|*");
    return "";
%]
<br />

<table>
    <tr>
    <td>User since:</td>
    <td>[{parsetime:createtime}]</td>
    </tr>

    <tr>
    <td>Last here:</td>
    <td>[{parsetime:lasttime}]
        <i>([{timesince:$NODE->{lasttime}}])</i></td>
    </tr>

    <tr>
    <td>Experience:</td>
    <td>
        <b>[% $NODE->{experience} || "none yet" %]</b>
    </td>
    </tr>

    <tr>
    <td>Level:</td>
    <td><b>
    [%  
        use Everything::Experience;              
        my $lvl = getLevel($NODE);
        my $LT = getVars(getNode('level titles', 'setting'));

        my %is_inquisitor = ();

                # larsen - Nov 17 2001
                # Maybe an hash here is overkill.
                # Since there are only two Inquisitors,
                # a simple OR clause could be fine.

        foreach( qw|larsen OeufMayo| ) $is_inquisitor{ $_ }++;

        my $leveltitle;
        if ($is_inquisitor{ $NODE->{title} }) {
            $leveltitle = 'Inquisitor';
        } else {
            $leveltitle=$LT->{$lvl};
        }

        return $leveltitle . " ($lvl)";
    %]
    </b>
    </td>
    </tr>

    <tr>
    <td>Writeups:</td>
    <td>
    <b>
    [%
        my $count = htmlcode('displaySingleVar', 'numwriteups');
        $count ||= 0;
        my $title = $NODE->{title};
        $title =~ s/ /\+/g;
        "<a href=" . urlGen({
                node => 'Perl Monks User Search',
                usersearch => $NODE->{title},
                orderby => 'createtime DESC'}) . 
        ">$count</a>"; 
    %]</b>
    </td>
    </tr>

    <tr>
    <td>Location:</td>
    <td>[{displaySingleVar:location}]</td>
    </tr>

    <tr>
    <td>User's localtime:</td>
    <td>
    [%
        my $USERVARS = getVars($NODE);
        htmlcode('userlocaltime', $USERVARS->{timezone});
    %]
    </td>
    </tr>

    <tr>
    <td>User's scratchpad:</td>
    <td>
    [%
        # crazyinsomniac Sat Nov  3 00:39:08 2001 GMT

        my $USERVARS = getVars($NODE);

        if($$USERVARS{scratchpublic})
        {
            return qq( <a href="/index.pl?node_id=108949&user= )
                   . $query->escape($NODE->{title}) .
                   qq(">this pad be public, scratch it</a>);
        }
        else {   
            return "<i>not public</i>";  
        }
    %]
    </td>
    </tr>

    </table>
    </tr>

</tr>
</table>

<p>
[%
    use Everything::Experience;
    my $str;
    $str .= htmlcode('parselinks', 'doctext,override');
    $str =~ s/<img(\n|.)*?src\s*=.*?>//igs 
          unless(getLevel($NODE)>=5 or isGod($NODE));
    $str =~ s/<script[^>]*>.*?<\/script[^>]*>//igs if $$USER{jsoff};
    $str;
%]

<p>
[%

    if(getId($USER) == getId($NODE) and getId($USER) != $HTMLVARS{defa
+ult_user}){
        my $str .= "Change your " . linkNodeTitle("user settings") . "
+<br />";
        $str .= linkNode($NODE, 'Edit', {displaytype => 'edit'}) . 
                " your user information";
    }
%]
[download]

for dree

#!/usr/bin/perl

use strict;
use warnings;

package Foo;

# un package finto...

sub bar
{
    my $code_ref = shift;
    my $str1 = shift;
    my $str2 = shift;

    return \&$code_ref( $str1, $str2 );
}
# Una funzione finta, che si aspetta di ricevere una
# reference ad una funzione che vuole un paio di stringhe
# e restituisce qualcosa (uno scalare, in questo caso)

package main;

# Chiuso il package Foo, si passa a main
# Che contiene...

sub mySub1
{
    my $str1 = shift;
    my $str2 = shift;
    
    print "mySub1: $str1 $str2\n";    
}

# mySub1(), una sub che vuole solamente un paio di stringhe...

sub mySub2
{
    my $array_ref = shift;
    my $str1 = shift;
    my $str2 = shift;
    
    print "mySub2: $str1 $str2 @$array_ref\n";    
}

# ... e mySub2(), che oltre alle stringhe vuole che le sia
# passata una ref ad un array:

# Il problema e`, a questo punto, costruire due ref da
# passare a Foo::bar(), a partire dalle due funzioni, che
# come e` stato detto hanno una signature differente...

my $ref1 = \&mySub1;

Foo::bar( $ref1, 'pippo', 'pluto' );

# per la prima funzione non c'e` problema...

# Per la seconda funzione

my $ref2;
{
    my $array_ref = [1, 2, 3];
    $ref2 = sub { 
        mySub2( $array_ref, shift, shift );
    };
}
# $ref2 e` una closure, cioe` una sub anonima che fa
# riferimento a variabili lessicali che erano visibili
# al momento della sua creazione. In questo caso $array_ref.

Foo::bar( $ref2, 'pippo', 'pluto' );

# Non sono ancora sicuro che le cose si facciano cosi`.
# Leggi la doc (e il codice) di Attribute::Curried, oltre
# a perldoc perlref (§"Function Templates")
[download]