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' ) ); #### \$_ = 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 13 Re6 g6 14 Nb5 Ne8 15 Be2 a6 16 Qa3 g5 17 Na7+!! Qxa7 18 Rxc6+! bxc\ 6 19 Bxa6+ Qb7 20 Qa5 |; s{\b(\d+)\b}{\1.}g; print; #### 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 "

List mode

\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 "

Item mode

\n"; } sub fetch_image { print "

Fetch_image mode

\n"; } ##
## # Modified by larsen - Nov 17 2001 [% 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( ); %]
[% use Everything::Experience; if (\$NODE->{imgsrc} and getLevel(\$NODE)<5 and !isGod(\$NODE)) return linkNodeTitle("I want my picture back|*"); return ""; %]
 User since: [{parsetime:createtime}] Last here: [{parsetime:lasttime}] ([{timesince:\$NODE->{lasttime}}]) Experience: [% \$NODE->{experience} || "none yet" %] Level: [% 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)"; %] Writeups: [% my \$count = htmlcode('displaySingleVar', 'numwriteups'); \$count ||= 0; my \$title = \$NODE->{title}; \$title =~ s/ /\+/g; "\$count"; %] Location: [{displaySingleVar:location}] User's localtime: [% my \$USERVARS = getVars(\$NODE); htmlcode('userlocaltime', \$USERVARS->{timezone}); %] User's scratchpad: [% # crazyinsomniac Sat Nov 3 00:39:08 2001 GMT my \$USERVARS = getVars(\$NODE); if(\$\$USERVARS{scratchpublic}) { return qq( this pad be public, scratch it); } else { return "not public"; } %]

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

[% if(getId(\$USER) == getId(\$NODE) and getId(\$USER) != \$HTMLVARS{default_user}){ my \$str .= "Change your " . linkNodeTitle("user settings") . "
"; \$str .= linkNode(\$NODE, 'Edit', {displaytype => 'edit'}) . " your user information"; } %] ##
## #!/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")