destructive grep

grep something off an array, i.e. if something is found, it is weeded out from the array.
sub dgrep (&+) { my $code = shift; my $array = shift; my @return; for my $i ( -$#$array .. 0 ){ local $_ = $array->[-$i]; if(&$code){ unshift @return, $array->[-$i]; splice @$array, -$i, 1; } } @return; } my @array = qw(moon fruit address buddy geese join say gone); my @goners = dgrep { /(.)\1/ } @array; warn "goners: (@goners)\n"; warn "array: (@array)\n"; __END__ goners: (moon address buddy geese) array: (fruit join say gone)
[download]

python sucks.

for server in serverList: # Required parameters try: ldapConnection = server['connection'] ldapVersion = server['version'] ldapUseTls = server['tls'] ldapBindDn = server['binddn'] ldapBindPassword = server['bindpassword'] groupList = server['groups'] if 'memberAttr' in config: _memberAttr = config['memberAttr'] except Exception as error: print("[LdapUserList::Run] Module LastLogin misses som +e parameters: " + str(error.message)) exit() # # LDAP connection # con = ldap.initialize(ldapConnection); con.set_option(ldap.OPT_PROTOCOL_VERSION, ldapVersion) con.set_option(ldap.OPT_DEREF, ldap.DEREF_ALWAYS) if ldapUseTls: con.set_option(ldap.OPT_X_TLS_DEMAND, True) try: con.simple_bind_s(ldapBindDn, ldapBindPassword) except Exception as error: print("[LdapUserList::Run] LDAP connection failed: " + + str(error.message)) exit() if (verbose): print "[LdapUserList::Run] LDAP connected to + " + ldapConnection + " as: " + con.whoami_s() # # Query for entries # userDict = {} # <========== this for group in groupList: if(verbose): print("[LdapUserList::Run] Searching grou +p " + group) result = con.search_s(group, ldap.SCOPE_SUBTREE, "obje +ctClass=*", [_memberAttr]) for g in result: groupname = g[0] # Check if we have some members if not _memberAttr in g[1]: continue userlist = g[1][_memberAttr] userDict[groupname] = userlist # # Print entries # _result.append("groupdn;userdn") for (k,v) in userDict.iteritems(): # <========= this for user in v: _result.append(k + ";" + user)
[download]

a .signature

$::Given.Surname (m?!\)Oo. M z ___ cel +49.123.456.7890: +:$ $::Street #11 G\ \ / / mail ----> me@foo.tld: +:$ $::12345 Some Town /\_/(q / / ^[ - immer weg vom Haufen: +:$ $::--------------------- \__(m.===== -)--])?);sub AUTOLOAD{map{print +&& select($,,$,,$,,$|/++$-)}map{pack c,($|++?1:13)+ord}split//,shift||ESE +L} alarm if$Herl.Pack("\cG"x4 ."Itrs\c_`mnsgdq\c_Gdbj\c_O`qk"),er(qq.dq\t +.)
[download]

pragmatic pragma

Draft of a meditation. Make arbitrary modules pragmatic, i.e. lexically scoped.
Example:

package Foo; require Exporter; @Foo::ISA = qw(Exporter); our @EXPORT = qw(foo); sub foo { print "Foo::foo\n" } 1;
[download]
#!/usr/bin/perl # sub foo { print "main::foo\n"; } use pragmatic Foo; foo; no pragmatic Foo; foo; use pragmatic Foo; foo; no pragmatic; foo; use pragmatic Foo; foo;
[download]
package pragmatic; our $VERSION = 0.01; our %pragmas; # pragmas currently in effect our %masked; # masked symbols while pragma on our %symbols; # our $AUTOLOAD; sub import { shift; # discard package return unless @_; # nothing to do my ($mod,@args) = split " ", shift; my @caller = caller(1); # see if $mod is defined in $caller my $callpkg = $caller[0]; unless (exists $symbols{$callpkg} && exists $symbols{$callpkg}->{$ +mod}) { package pragmatic::import { die $@ unless eval "use $mod @args;1"; my $stash = "$callpkg\::"; for my $symbol (keys %pragmatic::import::) { if (my $code = *{$pragmatic::import::{$symbol}}{CODE}) +{ next unless *{${$stash}{$symbol}}; if (*{${$stash}{$symbol}}{CODE}) { $masked{$callpkg}->{$symbol} = *{${$stash}{$symbol}}{CODE}; } $symbols{$callpkg}->{$mod}->{$symbol} = $code; *{"$caller\::$symbol"} = \&{"pragmatic::$symbol"}; } delete $pragmatic::import::{$symbol}; } } } push @{$pragmas{$callpkg}}, $mod unless grep {/^$mod$/} @{$pragmas{$callpkg}}; $^H{"$callpkg/pragma/in_effect"} = 1; $^H{"$callpkg/$mod/in_effect"} = 1; } sub unimport { shift; my $mod = shift; my $callpkg = (caller)[0]; if($mod) { $^H{"$callpkg/$mod/in_effect"} = 0; } else { $^H{"$callpkg/pragma/in_effect"} = 0; } } sub AUTOLOAD { $AUTOLOAD =~ s/.*:://; my ($callpkg,$file,$line,$hinthash) = (caller(0))[0..2,10]; if ($hinthash->{"$callpkg/pragma/in_effect"}) { # look up symbol in reverse pragma chain for this package for my $mod ( reverse @{$pragmas{$callpkg}} ) { if (exists $symbols{$callpkg}->{$mod}) { if (exists $symbols{$callpkg}->{$mod}->{$AUTOLOAD}) { if ($hinthash->{"$callpkg/$mod/in_effect"}) { goto &{$symbols{$callpkg}->{$mod}->{$AUTOLOAD} +}; } else { goto &{$masked{$callpkg}->{$AUTOLOAD}}; } } } } die "Undefined subroutine &$callpkg::$AUTOLOAD called at $file + line $line\n"; } else { goto &{$masked{$callpkg}->{$AUTOLOAD}}; } } 1;
[download]

for LanX about internal DSL

Some thoughts, using the very neat tmoertel meditation, and my derived module.

  1. the DSL should be written and executed as perl code
  2. the DSL should work fine with any other valid perl code interspersed within it
  3. the scope of the DSL code should be delimited. In this case, it is included in a block provided to the render() funtion, which is fine
  4. the functions neccesary for the DSL should not pollute the caller's namespace.
  5. the DSL should be performant

Point 4 is the biggest thing here. The DSL scope is already confined via the block as argument to render, which happens to be compiled into the scope of the code using it. This call could be wrapped into a package proper, but maybe it is feasible to use lexical subs inside the block render() consumes. I'll give that a try.


Basic steps to make a distribution from a bunch of module files (say, Date/Birth/*.pm):

Done. You will find a Date-Birth-0.01.tar.gz in your current directory.


Why does this yup?

#!/usr/bin/perl use Encode; use strict; use warnings; # avoid being beaten to death no warnings "experimental::regex_sets"; my $european_chars_iso8859 = join '', map { chr $_ } (191..207,209..21 +4,216,217..221,223..239,241..246,248..253); my $european_chars_utf8 = encode_utf8(decode('latin1',$european_cha +rs_iso8859)); my $european_chars = "[$european_chars_iso8859] + [$european_chars_utf +8]"; my $valid = "[:print:] + $european_chars"; print "yup\n" if chr(0x82) =~ /^(?[$valid])+$/; __END__ yup
[download]

XP in hex, Free Nodelet Settings

<script type="text/javascript"> item = document.evaluate("//center/table/tbody/tr/td`[1]/table`[1]/tbo +dy/tr/td`[2]/table/tbody/tr`[4]/td`[2]/b",document, null, XPathResult +.ORDERED_NODE_SNAPSHOT_TYPE,null).snapshotItem(0); if(item) item.innerHTML = "0x" + parseInt(item.innerHTML).toString(16) +; </script>
[download]

fusselkerl

#!/usr/bin/perl # file fusselkerl use strict; my $pat = shift; my $p; { my (%s, %i); my $d = my $c = 1; # our regexp will be inside parens, so first back +ref is 2 $p = join ( "", map { if($s{$_}++){ "\\".$i{$_} } else{ $i{$_}=++$c; $c>$d+1 ? '(?!'.join('|',map{"\\".abs}-$c+1..-$d-1).")(\\w)" : + "(\\w)"; } } split//,$pat ); } print '(',$p,")\n"; open my $fh, '<', shift; my %s; while (<$fh>) { my @l = (); while (/\b($p)\b/g) { push @l, $1 unless $s{$1}++; } print join (", ",@l), $/ if @l; }
[download]

try: perl fusselkerl fusselkerl /usr/share/dict/words


For Lady Aleena

The name attribute is to be used on button, fieldset, form, iframe, input, keygen, map, meta, object, output, param , select, and textarea. Using the name attribute on anything else will lead to poor HTML.

You forgot a which is the most common tag for which the name attribute is valid. <a></a> is anchor and it is used as <a href="$url">link text</a> and <a name="anchor_name">anchor in text</a> to mark an anchor in a page whose href would then be <a href="$url#anchor_name">target text</a>.

So, For Lady_Aleena ([href://?node_id=535366#Lady_Aleena|For Lady_Aleena]) links to the copy of this node marked as <a name="Lady_Aleena">For Lady Aleena</a> on my scratchpad. This is described on What shortcuts can I use for linking to other information?.

You cannot link to a id or to any tag for which the name attribute is valid and set, only to an anchor (<a name="foo">foo</a>).

Sorry for the impromptu lesson on HTML and PerlMonks markup. :-D

perl -le'print map{pack c,($-++?1:13)+ord}split//,ESEL'