Public Scratchpad

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.

the DSL should be written and executed as perl code
the DSL should work fine with any other valid perl code interspersed within it
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
the functions neccesary for the DSL should not pollute the caller's namespace.
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):

run h2xs -X -A Date::Birth in the directory where you want to setup the dist directory.
This generates stubs for the module. Then cd Date-Birth
copy your Date/Birth/*.pm files to lib/Date/Birth/
edit MANIFEST and add those files
edit README

you may want to modify lib/Date/Birth.pm to include

use Date::Birth::Stone;
use Date::Birth::Flower;
use Date::Birth::DayStone;
use Date::Birth::ZodiacStone;
[download]

and export the symbols it just imported from Date::Birth::*

you may want to modify the t/Date-Birth.t file and add more tests
run perl Makefile.PL
run make test
run make dist

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'