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