Beefy Boxes and Bandwidth Generously Provided by pair Networks
Don't ask to ask, just ask
 
PerlMonks  

shmem's scratchpad

by shmem (Chancellor)
on Mar 09, 2006 at 10:35 UTC ( [id://535366]=scratchpad: print w/replies, xml ) Need Help??

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)

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)

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 +.)

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;
#!/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;
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;

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):

  • 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;
    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

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>

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; }

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'
Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others scrutinizing the Monastery: (3)
As of 2024-03-19 04:59 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found