[23635] in Perl-Users-Digest
Perl-Users Digest, Issue: 5842 Volume: 10
daemon@ATHENA.MIT.EDU (Perl-Users Digest)
Fri Nov 21 14:10:53 2003
Date: Fri, 21 Nov 2003 11:10:15 -0800 (PST)
From: Perl-Users Digest <Perl-Users-Request@ruby.OCE.ORST.EDU>
To: Perl-Users@ruby.OCE.ORST.EDU (Perl-Users Digest)
Perl-Users Digest Fri, 21 Nov 2003 Volume: 10 Number: 5842
Today's topics:
Re: running a sub inside regex (Greg Bacon)
Re: Sendmail Configuration Problem <noreply@gunnar.cc>
Tied hash for CGI-usage (what about file corruption?) (Dan)
Re: Tied hash for CGI-usage (what about file corruption <usenet@morrow.me.uk>
What is a tied hash? <dan@mathjunkies.com>
Re: What is a tied hash? (Tad McClellan)
Re: What is a tied hash? <kkeller-usenet@wombat.san-francisco.ca.us>
Re: What is a tied hash? <Juha.Laiho@iki.fi>
Re: What is a tied hash? <eddhig22@yahoo.com>
Digest Administrivia (Last modified: 6 Apr 01) (Perl-Users-Digest Admin)
----------------------------------------------------------------------
Date: Fri, 21 Nov 2003 14:19:28 -0000
From: gbacon@hiwaay.net (Greg Bacon)
Subject: Re: running a sub inside regex
Message-Id: <vrs7ngtauk5a66@corp.supernews.com>
In article <isen-1711031631500001@ruvkung4pb3.mgh.harvard.edu>,
Thomas Isenbarger <isen@molbio.mgh.harvard.edu> wrote:
: [...]
: for molecular biologists out there, I am trying to find the reverse
: complement on the fly inside the regex. the @pairing array is something
: like @pairing = (AU, CG, GC, UA) and defines the substitutions to be made
: in order to build a reverse complement.
Well, Abigail hasn't posted a Single Spiffy Regular Expression to
do it, so I feel better about not having found one.
Included below is a solution I developed in test-driven fashion. I
believe it implements everything but on-the-fly pairing rules.
[...]
Enjoy,
Greg
-----
#! /usr/local/bin/perl
use warnings;
use strict;
use Data::Dumper;
sub revcomp {
local $_ = reverse shift;
tr[AGCUN]
[UCGAN];
$_;
}
sub cmp_pairs {
my $l1 = shift;
my $l2 = shift;
my $pass = @$l1 == @$l2;
if ($pass) {
foreach my $i (0 .. $#$l1) {
my $a = $l1->[$i];
my $b = $l2->[$i];
if (@$a != @$b || grep $a->[$_] ne $b->[$_], 0 .. $#$a) {
$pass = 0;
last;
}
}
}
unless ($pass) {
local $Data::Dumper::Indent = 1;
my $want = Dumper $l1;
my $got = Dumper $l2;
chomp $got;
die "bad result:\n" .
" - want:\n" .
$want .
" - got:\n" .
$got;
}
1;
}
sub cmp_lstpairs {
my $want = shift;
my $got = shift;
my $tag = shift || "";
$tag = $tag . ": " if $tag;
die "${tag}bad results (" . scalar @$got . ")\n"
unless @$got == @$want;
cmp_pairs $want->[$_], $got->[$_] for 0 .. $#$want;
1;
}
sub mkspec {
my @spec;
my %search = (
# a specific sequence element to remember
literal => qr/^(\w+-)?S=([ACGUBDHKMNRSVWY]+)\z/s,
# replay something we remembered
replay => qr/^(\w+-)?S-(\w+)\z/s,
# a reverse complement of an earlier saved element
revcomp => qr/^(\w+-)?R-(\w+)\z/s,
# a palindrome of an earlier saved element
palindrome => qr/^(\w+-)?P-(\w+)\z/s,
# a range; becomes [ACGU]{$m,$n}
range => qr/^(\w+-)?S=(\d+-\d+)\z/s,
);
PART:
for (@_) {
while (my($type,$pat) = each %search) {
if (/$pat/) {
my @name = defined $1 ? substr($1,0,-1) : ();
push @spec => [ $type => $2, @name ];
keys %search; # reset each
next PART;
}
}
# unrecognized
die "$0: unrecognized spec: [$_]\n";
}
\@spec;
}
sub pattern {
my $pair = shift;
my $got = shift || {};
my($type,$what,$name) = @$pair;
my %mkpat = (
literal => sub { qr/($what)/ },
revcomp => sub {
if (exists $got->{$what}) {
my $revc = revcomp $got->{$what};
qr/($revc)/;
}
},
replay => sub {
if (exists $got->{$what}) {
my $str = $got->{$what};
qr/($str)/;
}
},
palindrome => sub {
if (exists $got->{$what}) {
my $str = reverse $got->{$what};
qr/($str)/;
}
},
range => sub {
my($m,$n) = split /-/, $what;
qr/([ACGU]{$m,$n})/;
},
);
my $pat = exists $mkpat{$type}
? $mkpat{$type}->() || qr/(?!)/
: qr/(?!)/;
($name, $pat);
}
sub find {
my $targ = shift;
my $spec = shift;
return unless @$spec;
my @hits;
my($name,$pat) = pattern $spec->[0];
ATTEMPT:
while ($targ =~ /$pat/g) {
my $got = {};
$got->{$name} = $1 if defined $name;
my @maybe = [ $1, pos($targ) - length $1 ];
if (@$spec > 1) {
foreach my $part (@{$spec}[1 .. $#$spec]) {
my($name,$pat) = pattern $part, $got;
# need /gc to adjust pos
if ($targ =~ /\G$pat/gc) {
push @maybe => [ $1, pos($targ) - length $1 ];
}
else {
next ATTEMPT;
}
}
}
push @hits => \@maybe;
}
@hits;
}
## tests
my $TEST_TAG = qr/^test_/;
sub test_cmp_pairs {
die "should have passed" unless eval {
cmp_pairs [[ a => 1 ], [ b => 2 ]],
[[ a => 1 ], [ b => 2 ]]
};
die "should have failed" if eval {
cmp_pairs [[ a => 1 ], [ b => 2 ]],
[[ a => 1 ], [ b => 2 ], [ c => 3 ]]
};
die "should have failed" if eval {
cmp_pairs [[ a => 1 ], [ b => 2 ]],
[[ a => 1 ], [ c => 2 ]]
};
}
sub test_cmp_lstpairs {
my @base;
my @chk;
@base = ([[ a => 1 ], [ b => 2 ]]);
@chk = ([[ a => 1 ], [ b => 2 ]]);
die "should have passed" unless eval { cmp_lstpairs \@base, \@chk };
@base = ([[ a => 1 ], [ b => 2 ]], [[ c => 3 ]]);
@chk = ([[ a => 1 ], [ b => 2 ]], [[ c => 3 ]]);
die "should have passed" unless eval { cmp_lstpairs \@base, \@chk };
@base = ([[ a => 1 ], [ b => 2 ]], [[ c => 3 ]]);
@chk = ([[ a => 1 ], [ b => 2 ]], [[ c => 4 ]]);
die "should have failed" if eval { cmp_lstpairs \@base, \@chk };
}
sub test_mkspec_lit_AC {
my $want = [[ literal => 'AC', 'str' ]];
my $got = mkspec 'str-S=AC';
cmp_pairs $want, $got;
}
sub test_mkspec_lit_AC_rev_1 {
my $want = [[ literal => 'AC', 'one' ], [ revcomp => 'one' ]];
my $got = mkspec 'one-S=AC', 'R-one';
cmp_pairs $want, $got;
}
sub test_find_lit_AC {
my @want = ([[ AC => 0 ]]);
my $spec = mkspec 'S=AC';
my @got = find 'AC' => $spec;
cmp_lstpairs \@want, \@got;
}
sub test_find_lit_AC_offset {
my @want = ([[ AC => 3 ]]);
my $spec = mkspec 'str-S=AC';
my @got = find 'XXXAC' => $spec;
cmp_lstpairs \@want, \@got, "str-S=AC";
$spec = mkspec 'S=AC';
@got = find 'XXXAC' => $spec;
cmp_lstpairs \@want, \@got, "S=AC";
}
sub test_find_multi_lit_AC {
my @want = ([[ AC => 0 ]], [[ AC => 3 ]]);
my $spec = mkspec 'S=AC';
my @got = find 'ACXAC' => $spec;
cmp_lstpairs \@want, \@got;
}
sub test_find_adjacent_lit {
my @want;
my $spec;
my @got;
@want = ([[ UNAANU => 0 ], [ GC => 6 ]]);
$spec = mkspec qw/ S=UNAANU S=GC /;
@got = find 'UNAANUGC' => $spec;
cmp_lstpairs \@want, \@got;
#####
@want = ();
$spec = mkspec qw/ S=UNAANU S=GC /;
@got = find 'UNAANU#GC' => $spec;
cmp_lstpairs \@want, \@got, "expect no match";
}
sub test_find_lit_rev {
my @want = ([[ AC => 0 ], [ GU => 2 ]]);
my $spec = mkspec 'foo-S=AC', 'R-foo';
my @got = find 'ACGU' => $spec;
cmp_lstpairs \@want, \@got;
}
sub test_find_lit_rev_lit {
my @want = ([[ AC => 0 ], [ GU => 2 ], [ NN => 4 ]]);
my $spec = mkspec 'a-S=AC', 'R-a', 'b-S=NN';
my @got = find 'ACGUNN' => $spec;
cmp_lstpairs \@want, \@got;
}
sub test_mkspec_separated {
my $want = [
[ literal => 'NN', 'foo' ],
[ literal => 'AC' ],
[ replay => 'foo' ],
];
my $got = mkspec 'foo-S=NN', 'S=AC', 'S-foo';
cmp_pairs $want, $got;
}
sub test_find_separated {
my @want = ([[ NN => 0 ], [ AC => 2 ], [ NN => 4 ]]);
my $spec = mkspec 'foo-S=NN', 'S=AC', 'S-foo';
my @got = find 'NNACNN' => $spec;
cmp_lstpairs \@want, \@got;
}
sub test_mkspec_palindrome {
my $want = [
[ literal => 'ACGU', 'abc' ],
[ palindrome => 'abc' ],
];
my $got = mkspec 'abc-S=ACGU', 'P-abc';
cmp_pairs $want, $got;
}
sub test_find_palindrome {
my @want = ([[ ACGU => 0 ], [ UGCA => 4 ]]);
my $spec = mkspec 'abc-S=ACGU', 'P-abc';
my @got = find 'ACGUUGCA' => $spec;
cmp_lstpairs \@want, \@got;
}
sub test_mkspec_range {
my $want = [[ range => '3-5' ]];
my $got = mkspec 'S=3-5';
cmp_pairs $want, $got;
#####
$want = [[ range => '1-3', 'quux' ]];
$got = mkspec 'quux-S=1-3';
cmp_pairs $want, $got;
}
sub test_find_range {
my @want;
my $spec;
my @got;
@want = ([[ ACG => 0 ]]);
$spec = mkspec 'S=1-3';
@got = find 'ACG' => $spec;
cmp_lstpairs \@want, \@got;
#######
@want = ([[ AC => 0 ]]);
$spec = mkspec 'S=1-3';
@got = find 'AC' => $spec;
cmp_lstpairs \@want, \@got;
#######
@want = ([[ U => 0 ]]);
$spec = mkspec 'S=1-3';
@got = find 'UXXX' => $spec;
cmp_lstpairs \@want, \@got;
#####
@want = ([[ UUU => 2 ]]);
$spec = mkspec 'S=1-3';
@got = find 'XXUUU' => $spec;
cmp_lstpairs \@want, \@got, "UUU => 2";
}
sub test_find_dangling_backref {
my @want;
my $spec;
my @got;
@want = ();
$spec = mkspec 'S-foobar';
@got = find 'ACGUUGCA' => $spec;
cmp_lstpairs \@want, \@got;
#####
@want = ();
$spec = mkspec 'R-notthere';
@got = find 'ACGUUGCA' => $spec;
cmp_lstpairs \@want, \@got;
}
sub subname {
my $sub = (caller 1)[3];
$sub =~ s/^main:://;
$sub;
}
sub find_tests {
my $caller = shift;
my $test = {};
foreach my $sym (keys %main::) {
no strict 'refs';
next unless $sym =~ /$TEST_TAG/;
$test->{$sym} = \&$sym if exists &$sym;
}
$test;
}
sub run_tests {
my $total = 0;
my $pass = 0;
my $fail = 0;
my $test = find_tests;
local $| = 1;
local $@;
foreach my $name (sort keys %$test) {
++$total;
my $label = $name;
$label =~ s/$TEST_TAG//;
print "$label... ";
$@ = "";
eval { $test->{$name}->() };
if ($@) {
++$fail;
print "FAIL: $@";
}
else {
++$pass;
print "ok\n";
}
}
($total, $pass, $fail);
}
sub supertest {
my $name = subname;
die "$0: name = [$name]\n" unless $name eq 'supertest';
die "$0: bad supertest name: $name\n" if $name =~ /$TEST_TAG/;
my($total, $pass, $fail) = run_tests;
if ($total != $pass + $fail) {
print "pass ($pass) + fail ($fail) != total ($total)\n";
}
else {
if ($total) {
my $result = $fail ? "FAIL" : "PASS";
my $score = sprintf "%.1f", $pass / $total * 100;
print "\n",
"$result: $pass/$total ($score%)\n";
}
else {
print "No tests.\n";
}
}
not $fail == 0;
}
## main
while (@ARGV && $ARGV[0] =~ /^-/) {
my $arg = shift;
last if $arg eq '--';
if ($arg eq '--test') {
exit supertest;
}
else {
die "$0: unknown option '$arg'\n";
}
}
my @search = qw/ 1-S=AC R-1 /;
my $str = 'ACGUXYZACGU';
print "Searching for [@search] in $str:\n";
my @matches = find $str => mkspec qw/ 1-S=AC R-1 /;
if (@matches) {
for (@matches) {
print " - match:\n";
foreach my $match (@$_) {
my($str,$pos) = @$match;
print " - [$str] => $pos\n";
}
}
}
else {
print " - no matches.\n";
}
__END__
--
If credit expansion, protectionism, and government spending were a path
to prosperity, mankind would have long ago created heaven on earth.
-- Lew Rockwell
------------------------------
Date: Fri, 21 Nov 2003 15:00:39 +0100
From: Gunnar Hjalmarsson <noreply@gunnar.cc>
Subject: Re: Sendmail Configuration Problem
Message-Id: <bpl6ft$1kvf6k$1@ID-184292.news.uni-berlin.de>
news@roaima.freeserve.co.uk wrote:
> Gunnar Hjalmarsson wrote:
>> You may also want to ask your ISP why their sendmail program or
>> mail server is configured to add that "Sender:" header.
>
> Because that's the (arguably) correct behaviour for a mailer when
> someone tries to send an email whilst pretending to be someone
> else. To do that without having sendmail add the Sender: header you
> need to be in the list of "trusted users".
I see. I just got the impression that the added "Sender:" header in
this case was some administrator of a web hosting service or ISP. If
that's actually the case, it makes no sense to me. But maybe that's
what you meant by arguably...
--
Gunnar Hjalmarsson
Email: http://www.gunnar.cc/cgi-bin/contact.pl
------------------------------
Date: Fri, 21 Nov 2003 15:44:35 GMT
From: Dan.Schneider@web.de (Dan)
Subject: Tied hash for CGI-usage (what about file corruption?)
Message-Id: <3fbf3156.756359@news.rz.uni-duesseldorf.de>
Has anyone knwoledge to share about tied hashes as database backend in
cgi-scripts?
I'm running a CGI that will acess a DBM file (DB_File) as a tied hash
like this:
sub pseudo-code{
tie %hash
read(!) something
untied %hash
}
Do I have to use a file lock algorithm wrapped around when I am just
goint to READ from the file?
Will file corruption over time be a problem? (the script will be
running on a heavy load website, multiple processes, maybe sometimes
to read all at once)
As I udnerstand it I'll have to lock the DB_File only for
write/read-write access, but for reading only??
------------------------------
Date: Fri, 21 Nov 2003 16:26:39 +0000 (UTC)
From: Ben Morrow <usenet@morrow.me.uk>
Subject: Re: Tied hash for CGI-usage (what about file corruption?)
Message-Id: <bplebv$jin$2@wisteria.csv.warwick.ac.uk>
Dan.Schneider@web.de (Dan) wrote:
> Do I have to use a file lock algorithm wrapped around when I am just
> goint to READ from the file?
>
> Will file corruption over time be a problem? (the script will be
> running on a heavy load website, multiple processes, maybe sometimes
> to read all at once)
>
> As I udnerstand it I'll have to lock the DB_File only for
> write/read-write access, but for reading only??
[this applies much more generally than tied hashes]
If anyone is going to be writing, then *everyone* has to lock. Readers
lock with LOCK_SH, writers with LOCK_EX. See the documentation for
DB_File for some important caveats when locking. If you have control
of every program accessing this database, it is probably a better idea
to use a lockfile: lock the file before you tie, and untie before you
unlock.
Ben
--
I've seen things you people wouldn't believe: attack ships on fire off the
shoulder of Orion; I've watched C-beams glitter in the darkness near the
Tannhauser Gate. All these moments will be lost, in time, like tears in rain.
Time to die. |-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-| ben@morrow.me.uk
------------------------------
Date: Fri, 21 Nov 2003 17:34:48 GMT
From: Dan Anderson <dan@mathjunkies.com>
Subject: What is a tied hash?
Message-Id: <m2y8u9zkuf.fsf@syr-24-59-76-83.twcny.rr.com>
I'm just curious, what is the difference between a tied hash
and regular hash? I've seen the term come up quite often but never
quite knew what it meant. Does it have something to do with whether
you use a {} to create a reference to a hash or a list to create it,
and whether or not you need to use a ->?
Thanks in advance,
Dan
------------------------------
Date: Fri, 21 Nov 2003 11:57:22 -0600
From: tadmc@augustmail.com (Tad McClellan)
Subject: Re: What is a tied hash?
Message-Id: <slrnbrskg2.6he.tadmc@magna.augustmail.com>
Dan Anderson <dan@mathjunkies.com> wrote:
>
> I'm just curious, what is the difference between a tied hash
> and regular hash?
A regular hash does only regular things when it is accessed,
a tied hash allows you to do whatever you want each time
it is accessed (eg: read/write values in a disk file instead
of in RAM).
> I've seen the term come up quite often but never
> quite knew what it meant.
Then your first step should be to read the applicable docs:
perldoc -f tie
perldoc perltie
> Does it have something to do with whether
> you use a {} to create a reference to a hash or a list to create it,
> and whether or not you need to use a ->?
No.
--
Tad McClellan SGML consulting
tadmc@augustmail.com Perl programming
Fort Worth, Texas
------------------------------
Date: Fri, 21 Nov 2003 09:57:41 -0800
From: Keith Keller <kkeller-usenet@wombat.san-francisco.ca.us>
Subject: Re: What is a tied hash?
Message-Id: <lmjlpb.n65.ln@goaway.wombat.san-francisco.ca.us>
-----BEGIN xxx SIGNED MESSAGE-----
Hash: SHA1
On 2003-11-21, Dan Anderson <dan@mathjunkies.com> wrote:
>
> I'm just curious, what is the difference between a tied hash
> and regular hash?
- From perldoc -f tie:
This function binds a variable to a package class
that will provide the implementation for the variable.
So instead of Perl handling the hash in the default manner, tie
tells Perl to handle it differently, where ''differently'' is
definied by the particular tie implementation.
> Does it have something to do with whether
> you use a {} to create a reference to a hash or a list to create it,
> and whether or not you need to use a ->?
No.
Read
perldoc -f tie
perldoc Tie::Hash
perldoc perltie
for much more.
- --keith
- --
kkeller-usenet@wombat.san-francisco.ca.us
(try just my userid to email me)
AOLSFAQ=http://wombat.san-francisco.ca.us/cgi-bin/fom
-----BEGIN xxx SIGNATURE-----
Version: GnuPG v1.2.3 (GNU/Linux)
iD8DBQE/vlIRhVcNCxZ5ID8RAptRAJ0Wc11ZavN1ibK8z6ayn50MnhFv7gCfdae/
0pxoYGtDt7OpmWcM3p8pJJQ=
=Ry7V
-----END PGP SIGNATURE-----
------------------------------
Date: Fri, 21 Nov 2003 18:17:00 GMT
From: Juha Laiho <Juha.Laiho@iki.fi>
Subject: Re: What is a tied hash?
Message-Id: <bplkhl$ta6$1@ichaos.ichaos-int>
Dan Anderson <dan@mathjunkies.com> said:
> I'm just curious, what is the difference between a tied hash
>and regular hash? I've seen the term come up quite often but never
>quite knew what it meant. Does it have something to do with whether
>you use a {} to create a reference to a hash or a list to create it,
>and whether or not you need to use a ->?
"perldoc -f tie", "perldoc tie"
... and to summarize. Tieing (tying?) lets you hide code behind something
that looks like a variable. And the code may then do "anything".
Commonly this would be used so that you have what you access as a hash,
but behind the scenes, all changes to the hash are stored into a file
(often into some kind of database format, where the db access is done
based on the hash keys).
It's not just hashes that can be tied, but also arrays, scalars and file
handles.
--
Wolf a.k.a. Juha Laiho Espoo, Finland
(GC 3.0) GIT d- s+: a C++ ULSH++++$ P++@ L+++ E- W+$@ N++ !K w !O !M V
PS(+) PE Y+ PGP(+) t- 5 !X R !tv b+ !DI D G e+ h---- r+++ y++++
"...cancel my subscription to the resurrection!" (Jim Morrison)
------------------------------
Date: Sat, 22 Nov 2003 06:06:43 +1100
From: Edo <eddhig22@yahoo.com>
Subject: Re: What is a tied hash?
Message-Id: <3FBE6243.3010500@yahoo.com>
Dan Anderson wrote:
> I'm just curious, what is the difference between a tied hash
> and regular hash? I've seen the term come up quite often but never
> quite knew what it meant. Does it have something to do with whether
> you use a {} to create a reference to a hash or a list to create it,
> and whether or not you need to use a ->?
>
> Thanks in advance,
>
> Dan
perldoc -f tie
has to do with keeping the hash sorted
------------------------------
Date: 6 Apr 2001 21:33:47 GMT (Last modified)
From: Perl-Users-Request@ruby.oce.orst.edu (Perl-Users-Digest Admin)
Subject: Digest Administrivia (Last modified: 6 Apr 01)
Message-Id: <null>
Administrivia:
The Perl-Users Digest is a retransmission of the USENET newsgroup
comp.lang.perl.misc. For subscription or unsubscription requests, send
the single line:
subscribe perl-users
or:
unsubscribe perl-users
to almanac@ruby.oce.orst.edu.
To submit articles to comp.lang.perl.announce, send your article to
clpa@perl.com.
To request back copies (available for a week or so), send your request
to almanac@ruby.oce.orst.edu with the command "send perl-users x.y",
where x is the volume number and y is the issue number.
For other requests pertaining to the digest, send mail to
perl-users-request@ruby.oce.orst.edu. Do not waste your time or mine
sending perl questions to the -request address, I don't have time to
answer them even if I did know the answer.
------------------------------
End of Perl-Users Digest V10 Issue 5842
***************************************
