runrig's scratchpad

Public Scratchpad

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);
[download]

For LA:

# Before loop:
my %is_account;
$is_account++ for @accounts;
...
# In loop:
push .... if !$is_account{$username};
[download]

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
[download]

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...);
[download]

Or you don't have to import functions:

use FixStuff;

FixStuff::FixText(...blahblah...);
[download]

---------------------------
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";
[download]

------------------------------------------ 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";
[download]

--------------------------------------------

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";
[download]

----------------------------------------

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");
[download]

----------------------

# 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);
[download]

----------------------------


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: $_";
}
[download]

#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";
}
[download]

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;
}
[download]

#############################################
#!/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;
}
[download]

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>
[download]

Domain Nodelet^?

www.com | www.net | www.org

Chatterbox^?

How do I use this? • Last hour • Other CB clients

Other Users^?

Others making s'mores by the fire in the courtyard of the Monastery: (2)

As of 2025-05-17 12:22 GMT

Sections^?

Information^?

Find Nodes^?

Leftovers^?

Voting Booth^?

No recent polls found

Notices^?

	• erzuuli	‥ Anonymous Monks are no longer allowed to use Super Search, due to an excessive use of this resource by robots.


Perl-Sensitive Sunglasses
	PerlMonks