Beefy Boxes and Bandwidth Generously Provided by pair Networks
Your skill will accomplish
what the force of many cannot
 
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 musing on the Monastery: (5)
As of 2014-09-17 23:49 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    How do you remember the number of days in each month?











    Results (100 votes), past polls