Beefy Boxes and Bandwidth Generously Provided by pair Networks vroom
XP is just a number
 
PerlMonks  

runrig's scratchpad

by runrig (Abbot)
on Jun 01, 2004 at 22:22 UTC ( #358702=scratchpad: print w/ replies, xml ) Need Help??

Bizarre copy of ARRAY in list assignment at ...lib/5.18.0/Carp.pm line 165. Perl/Carp bug. Invoke w/at least 2 arguments:
use strict; use warnings; use Carp; use Getopt::Long qw(GetOptions); sub bb { GetOptions( foo => \my $foo, ) or die "Bad option"; carp "Uh oh!"; } bb(@ARGV);
For LA:
# Before loop: my %is_account; $is_account++ for @accounts; ... # In loop: push .... if !$is_account{$username};
For Limbic~Region Split file w/awk (needs to be parameterized):
awk '{ i=i+1 if (i > 5) { i = 1 } filename="file" i ".txt" print >filename }' tmp.txt
For jedikaiti (put the below in file FixStuff.pm):
package FixStuff; use base qw(Exporter); our @EXPORT_OK=qw(FixText FixName); sub FixText { $_[0] =~ s/^\s+//; # this kills any leading whitespace # {insert some other regex nonsense here} #print "$_[0]\n"; # diagnostic print # No need to return...you're modifying @_ #return $_[0]; } sub FixName { ...blahblah } # Alternate FixText { sub FixText { local $_ = shift; # my $_ = shift in 5.9 or later ?? s/^\s+//; ..etc. return $_; } 1; __END__ # Then in DataParser.pl: use FixStuff qw(FixText); #or to use both functions: #use FixStuff qw(FixText FixName); ... FixText(...blahblah...);
Or you don't have to import functions:
use FixStuff; FixStuff::FixText(...blahblah...);
---------------------------
Playing with Release code:
Alternate version w/scalar ref so you don't have to re-bless
#!/users/contrib/bin/perl package Release; use strict; use warnings; sub new { my $class = shift; my ($sub, @args) = @_; bless \sub { $sub->(@args); }, $class; } sub cancel { ${$_[0]} = sub {}; } sub DESTROY { ${$_[0]}->(); } package main; use strict; use warnings; for (1..3) { my $foo = Release->new(sub {my ($num, $msg) = @_; print "Foo $msg\n" +}, $_, "destroyed"); print "$_\n"; $foo->cancel if $_ == 2; print "Release foo\n"; } print "Done\n";
------------------------------------------ Blessed sub ref for ReleaseAction? added 5.6.1 (and prior) nested anonymous sub leak bug
package Release; use strict; use warnings; sub new { my $class = shift; my ($sub, @args) = @_; bless sub { sub { $sub->(@args) }; }, $class; } sub cancel { bless $_[0], 'ReleaseCancel'; } sub DESTROY { $_[0]->()->(); } package ReleaseCancel; sub DESTROY { 1 } package main; use strict; use warnings; my $n = 200; my $v = 'x' x 500_000; # THIS LEAKS 500K ON EVERY ITERATION in 5.6.1 and lower for (1..$n) { my $foo = Release->new(sub {my ($num, $msg) = @_; print "$num: Foo $ +msg\n"}, $_, "destroyed", $v); print "$_\n"; $foo->cancel if $_ == 2; print "Release foo\n"; my $p = scalar(<STDIN>); } print "Done\n";
--------------------------------------------
package Release; use strict; use warnings; sub new { my $class = shift; my ($sub, @args) = @_; bless sub { $sub->(@args); }, $class; } # Can't dereference code ref w/o calling it, # so just re-bless it? sub cancel { bless $_[0], 'ReleaseCancel'; } sub DESTROY { $_[0]->(); } package ReleaseCancel; our @ISA = 'Release'; sub DESTROY { 1 } package main; use strict; use warnings; for (1..3) { my $foo = Release->new(sub {my ($num, $msg) = @_; print "$num: Foo $ +msg\n"}, $_, "destroyed"); print "$_\n"; $foo->cancel if $_ == 2; print "Release foo\n"; } print "Done\n";
----------------------------------------
sub include_file { my $file = shift; open(my $fh, "<", $file) or die "Can't open $file: $!"; my $buffer; while (read($fh, $buffer, 1024*1024) { print $buffer; } close $fh; } #Example: include_file("file.txt");
----------------------
# XML::Rules bug?? # Just want to change some attributes on some tags # Repeated tags, some nested within other handled tags #!/usr/bin/perl use strict; use warnings; use XML::Rules; my @rules = ( B => sub { my $attr = $_[1]; $attr->{FOO} = "HELLO"; return $_[0] => $attr; }, C => sub { my ( $tag, $attr, $context ) = @_; $attr->{BAR} = "GOOD" if exists($attr->{BAR}); $attr->{DEF} = "BOO" if exists($attr->{DEF}); # THIS puts "@" at the front of the unnested tag $tag = '@'.$tag; # THIS works, but is more of a hassle #$tag = '@'.$tag if $context->[-1] eq 'Z'; return $tag => $attr; }, ); my $p = XML::Rules->new( rules => \@rules, style => 'filter', ); my $xml = <<EOT; <A> <B FOO="HEY"> <Z> <C BAR="YOU"/> <C BAZ="SIR"/> </Z> </B> <C ABC="DEF"/> <C DEF="GHI"/> </A> EOT $p->filter($xml, \*STDOUT);
----------------------------
INPUT: while (<>) { chomp; /[^\d\t-]/ and next; my @nums = split /\t/; @nums == 7 or next; ( /^-?\d+/and $_ >= -2**31 and $_ < 2**31 ) or next INPUT for @nums; print "good line: $_"; }
#Fetch into a hash my @columns = $sth->{NAME_lc}; my %row; $sth->bind_columns(\@row{@columns}); while ($sth->fetch) { print "$_ = $row{$_}\n" for @columns; print "\n"; }
our $Kid_Status; use POSIX ":sys_wait_h"; sub REAPER { my $child; while (($child = waitpid(-1,WNOHANG)) > 0) { $Kid_Status = $?; } $SIG{CHLD} = \&REAPER; # still loathe sysV } $SIG{CHLD} = \&REAPER; # do something that forks... if (fork()) { sleep 5; $Kid_Status >>= 8; print "$Kid_Status\n"; } else { exit 43; }
############################################# #!/usr/bin/perl # Attempt to copy registry permissions from one key to another use strict; use warnings; use Win32::TieRegistry qw( Delimiter / KEY_READ KEY_WRITE ); use Win32API::Registry; use Win32 qw( DACL_SECURITY_INFORMATION SACL_SECURITY_INFORMATION ); my $path = 'LMachine/Software/Classes'; my $key1 = 'opendocument.WriterDocument.1'; my $key2 = 'opendocument.WriterGlobalDocument.1'; my $r = $Registry->{"$path/$key1"}; print $r->{"/"},"\n"; my $sec; $r->RegGetKeySecurity( DACL_SECURITY_INFORMATION, $sec, [] ); # Only have read access on this - but can manually run regedit # and change permissions #my $r2 = $Registry->Open("$path/$key2", {Access => KEY_READ(), Delimi +ter=>"/"}); my $r2 = $Registry->{"$path/$key2"}; print $r2->{"/"},"\n"; $r2->RegSetKeySecurity( DACL_SECURITY_INFORMATION, $sec ); ############################################ <code> # Non-Leaky anonymous recursive subs use Scalar::Util qw(weaken); my @arr = (1..100000); for (@arr) { my ($sub, $sub1); $sub1 = $sub = sub { my $num = shift; return $num + $sub->($num-1) if $num >0; return 0; }; weaken($sub); my $num = $sub->(5); print "$num\n"; unless ($_ % 1000) { print "$_: "; <STDIN>; } } # Leaky anonymous recursive subs my @arr = (1..100000); for (@arr) { my $sub; $sub = sub { my $num = shift; return $num + $sub->($num-1) if $num >0; return 0; }; my $num = $sub->(5); unless ($_ % 1000) { print "$_: "; <STDIN>; } } # Anonymous recursive sub my $sub; $sub = sub { my $num = shift; return $num + $sub->($num-1) if $num >0; return 0; }; print $sub->(5),"\n"; ########################### use strict; use warnings; my @arr; foo($arr[$#arr]); sub foo { 1; } ########################### #!/bin/ksh # Feel free to comment/criticize... # # Backup files before removing them. # Before using this script, # you must set environment variable "BAK" # to the directory in which you want to backup your files, # then you can use this script just like the rm command. # I currently have 'rm' aliased to this, and am seeing how # well it goes. [[ -z $BAK ]] && { print "$0: BAK variable not set"; exit 2; } [[ -d $BAK ]] || { print "$0: directory $BAK not found"; exit 2; } bkdir=$BAK/$(date '+%Y-%m-%d-%H:%M:%S') || exit 2 if [[ -d $bkdir ]] then ext=a while [[ -d $bkdir$ext ]] do ext=$(perl -e 'print ++$ARGV[0]' $ext) done bkdir=$bkdir$ext fi mkdir $bkdir || { print "$0: Can't create backup directory"; exit 2; } no_more_opts= for arg in "$@" do [[ $arg = '--' && -z $no_more_opts ]] && { no_more_opts=1; continue; + } [[ $arg = -* && -z $no_more_opts ]] && continue # Check for ".." in path? [[ $arg = ?(*/)..?(/*) ]] && { print "$0: '..' not allowed in file path '$arg'" exit 2 } tmpdir=$bkdir # Do we need to create the directory path [[ $arg = ?*/* ]] && { path=${arg#/} path=${path%/*} tmpdir="$bkdir/$path" mkdir -p "$tmpdir" || { print "$0: Can't create backup directory $tmpdir" exit 2 } } opt="-h" [[ -d $arg ]] && opt="-R" cp $opt -- "$arg" "$tmpdir" done \rm "$@" print "Files backed up in $bkdir" ################################## # Oracle utility... # For a table, if there are any foreign keys # referring to a table's primary keys, then recursively # display the table's primary keys and foreign keys # referring to it. use strict; use warnings; use Getopt::Std; use DBI; my %opts; getopts('t:d:u:p:', \%opts) or die "Bad usage\n"; my $table = $opts{t} or die "No table\n"; my $db = $opts{d} || 'dbname'; my $user = $opts{u} || 'user'; my $passwd = $opts{p} || 'passwd'; $table = uc($table); my $dbh = DBI->connect("dbi:Oracle:$db", $user, $passwd, {RaiseError=> +1}); my $sql = <<EOT; select constraint_name from dba_constraints where table_name = ? and constraint_type = 'P' order by table_name, constraint_name EOT my $name_h = $dbh->prepare($sql); $sql = <<EOT; select constraint_name from dba_constraints where r_constraint_name = ? order by constraint_name EOT my $r_name_h = $dbh->prepare($sql); $sql = <<EOT; select table_name, position, column_name from dba_cons_columns where constraint_name = ? order by position EOT my $column_h = $dbh->prepare($sql); get_pk_info($table, 0); $dbh->disconnect; sub get_pk_info { my ($table, $level) = @_; my $pk_cnames = $dbh->selectcol_arrayref($name_h, {}, $table); for my $pk_cname (@$pk_cnames) { print "\t" x $level, "Table: $table\n" unless $level; my ($pk_table, @p_keys) = get_keys($pk_cname); my $fk_cnames = $dbh->selectcol_arrayref($r_name_h, {}, $pk_cn +ame); my $first = 1; for my $fk_cname (@$fk_cnames) { if ($first) { print "\t" x $level, "Primary keys: @p_keys\n"; $first = 0; } my ($fk_table, @f_keys) = get_keys($fk_cname); print "\t" x $level, "FK table: $fk_table Fkeys: @f_keys\n +"; get_pk_info($fk_table, $level+1); } } } sub get_keys { my $con_name = shift; my ($table, @names); $column_h->execute($con_name); $column_h->bind_columns(\my ($tmp_table, $pos, $col_name)); while ($column_h->fetch) { $table = $tmp_table unless defined $table; push @names, $col_name; } return $table, @names; }
My .vimrc:
set nocp ignorecase smartcase syntax enable function! PerlDoc() normal yy let l:this = @ if match(l:this, '^ *\(use\|require\) ') >= 0 exe ':new' exe ':resize' let l:this = substitute(l:this, '^ *\(use\|require\) *', "", "") let l:this = substitute(l:this, ";.*", "", "") let l:this = substitute(l:this, " .*", "", "") exe ':0r!perldoc -t ' . l:this exe ':0' return endif normal yiw exe ':new' exe ':resize' exe ':0r!perldoc -t -f ' . @ exe ':0' endfunction "Display docs for built-in functions when cursor is on function name "or for modules when cursor is on 'use' or 'require' line. map ,h :call PerlDoc()<CR>:set nomod<CR>:set filetype=man<CR>:echo "pe +rldoc"<CR> "Run program using everything past __END__ as stdin "Output of program replaces everything past __END__ "Makes it easy to undo and start over let @p="L?^#!\r/^__END__\ry''''p!Gperl\rG" "Simplify moving between split windows map <C-J> <C-W>j<C-W>_ map <C-K> <C-W>k<C-W>_ "Make goto file open in a split window map gf <C-W><C-F><C-W>_ "Open next file in a split window map ,n :new<CR>:n<CR><C-W>_ "Default font is too small set guifont=-adobe-courier-medium-r-normal--14-140-75-75-m-90-hp-roman +8 filetype plugin on "This is the only option I like for now set formatoptions=l "Edit vimrc file map ,v :sp ~/.vimrc<CR><C-W>_ "Reload vimrc file map <silent> ,V :source ~/.vimrc<CR>:filetype detect<CR>:exe ":echo 'v +imrc reloaded'"<CR>
Log In?
Username:
Password:

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

How do I use this? | Other CB clients
Other Users?
Others contemplating the Monastery: (5)
As of 2014-04-20 17:23 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    April first is:







    Results (485 votes), past polls