[23061] in Perl-Users-Digest
Perl-Users Digest, Issue: 5282 Volume: 10
daemon@ATHENA.MIT.EDU (Perl-Users Digest)
Mon Jul 28 18:05:46 2003
Date: Mon, 28 Jul 2003 15:05:08 -0700 (PDT)
From: Perl-Users Digest <Perl-Users-Request@ruby.OCE.ORST.EDU>
To: Perl-Users@ruby.OCE.ORST.EDU (Perl-Users Digest)
Perl-Users Digest Mon, 28 Jul 2003 Volume: 10 Number: 5282
Today's topics:
Re: array question (grep -v on array) <skuo@mtwhitney.nsc.com>
Re: array question (grep -v on array) <nobull@mail.com>
Can anyone help with the following code (Aaron Brockhurst)
Re: can this one-liner be squeezed any shorter? <ddunham@redwood.taos.com>
Re: Currying functions <adrian@sixfingeredman.net>
FILE SELECTION DIALOG PROBLEM (Go Perl)
GD.pm index table limitation (julien)
Re: GD.pm index table limitation <NOSPAM@bigpond.com>
Re: GD.pm index table limitation <NOSPAM@bigpond.com>
How do you Call a Perl subroutine with a variable name? (Fred)
Re: How do you Call a Perl subroutine with a variable n <noreply@gunnar.cc>
Re: How do you Call a Perl subroutine with a variable n <krahnj@acm.org>
Re: How do you Call a Perl subroutine with a variable n <skuo@mtwhitney.nsc.com>
Re: How do you Call a Perl subroutine with a variable n <nobull@mail.com>
Re: How do you Call a Perl subroutine with a variable n <noreply@gunnar.cc>
Re: How do you Call a Perl subroutine with a variable n <krahnj@acm.org>
How to do equivalent to Crypt:CBC of Perl in Oracle pl/ <member34391@dbforums.com>
Re: LWP::Request <glex_nospam@qwest.net>
New to Perl (nos)
Re: New to Perl <noreply@gunnar.cc>
pack and unpack question for perl 5.8.0 <twhu@lucent.com>
Re: Perl compiler? error (James E Keenan)
Re: Perl compiler? error <pinyaj@rpi.edu>
Re: Tainting and use lib... (Bryon Bean)
Re: Tainting and use lib... <usenet@expires082003.tinita.de>
Re: <bwalton@rochester.rr.com>
Digest Administrivia (Last modified: 6 Apr 01) (Perl-Users-Digest Admin)
----------------------------------------------------------------------
Date: Mon, 28 Jul 2003 12:38:52 -0700
From: Steven Kuo <skuo@mtwhitney.nsc.com>
Subject: Re: array question (grep -v on array)
Message-Id: <Pine.GSO.4.21.0307281236500.491-100000@mtwhitney.nsc.com>
On Mon, 28 Jul 2003, NetComrade wrote:
> Hi,
>
> I have an output of errors fed into an array, after which I only look
> at things I care about and put them in a different array:
>
> @oracle_errors =
> grep(/ORA-/||/neededarchiving/||/FULL/||/archival/||/Standby/||/deadlock/,@output);
>
> However, I would like to have (yet another array), e.g. @ignore_errors
> which will contain values such as
> ORA-error can be ignored
> ORA-error2 can be ignored
>
> How can I set that up?
>
> Alternatively, (if simpler), i'd like to add some kind of 'grep -v'
> functionality to my grep command (but the array method seems sweeter).
Something like:
my @output = (
'ORA-',
'ORA-error can be ignored',
'FULL',
'XYZ',
'ABC',
'deadlock',
);
my (@a,@b);
for (@output) {
my $aref =
(/ORA-(?!error2? can be ignored)/ ||
/neededarchiving/ ||
/FULL/ ||
/archival/ ||
/Standby/ ||
/deadlock/)? \@a : \@b;
push @$aref, $_;
}
print "oracle_errors: @a\n";
print "ignore_errors: @b\n";
--
Hope this helps,
Steven
------------------------------
Date: 28 Jul 2003 21:02:57 +0100
From: Brian McCauley <nobull@mail.com>
Subject: Re: array question (grep -v on array)
Message-Id: <u9smoqifm6.fsf@wcl-l.bham.ac.uk>
andreyNSPAM@bookexchange.net (NetComrade) writes:
> I have an output of errors fed into an array, after which I only look
> at things I care about and put them in a different array:
>
> @oracle_errors =
> grep(/ORA-/||/neededarchiving/||/FULL/||/archival/||/Standby/||/deadlock/,@output);
>
> However, I would like to have (yet another array), e.g. @ignore_errors
> which will contain values such as
> ORA-error can be ignored
> ORA-error2 can be ignored
What do you mean by that? What would be the desired semantics of
@ingore_errors?
If you are talking about an analogue of gnugrep -vf then I'd assume
@ignore_errors was an array of regex (all of which must be unmatched).
> How can I set that up?
You could combine the patterns into one...
my $ignore_error_pattern = join '|', map "(?:$_)", @ignore_errors;
$ignore_error_pattern = qr/$ignore_error_pattern/;
...and then use...
my @oracle_errors = grep !/$ignore_error_pattern/, @output;
However, whilst this may look elegant, it turns out that it is not
efficient.
You are better off just doing it with explicit nested loops.
That is, unless you really don't need @ignore_errors to be an arbirary
array of regex.
If you can instead make @ignore_errors be a simple array of strings
that are going to looked for in a easily recognied place in the line
(like, say, at the first ocurance of 'ORA-') there's a much more
efficient solution.
my %ignore;
@ignore{@ignore_errors}=();
my @oracle_errors = grep { ! ( /(ORA-\S+)/ && exists $ignore{$1) ) } @output;
> We use Oracle 8.1.7.4 on Solaris 2.7 boxes
I drive a Ford Escort on the LHS of the road :-)
--
\\ ( )
. _\\__[oo
.__/ \\ /\@
. l___\\
# ll l\\
###LL LL\\
------------------------------
Date: 28 Jul 2003 14:58:38 -0700
From: aaron@covenantsolutions.co.uk (Aaron Brockhurst)
Subject: Can anyone help with the following code
Message-Id: <14fc5121.0307281358.3c655be4@posting.google.com>
Hi
I am trying to get the following code to work but am really struggling
to find out why the sub routines getPreviousDetails and
getPreviousEmail dont work. I am trying to use the script on a
charity auction page. I've put the code below
Can anyone provide any solutions
Thanks in advance
Aaron
#!/usr/bin/perl
#!c:\perl\bin\perl
#-----------------------------------------------------------#
#
# script name: placebid.cgi
# description: This script places a bid for the chosen item.
#
#-----------------------------------------------------------#
use Fcntl qw(:flock); # imports LOCK_EX, LOCK_SH, LOCK_NB
use CGI qw( :standard :html3 );
use CGI;
use CGI::Carp 'fatalsToBrowser';
my $loginname = param('username');
my $password = param('password');
my $bid = param('bid');
my $itemcode = param('itemid');
my $itemname = param('itemname');
my $submityet = param('submityet');
my $startamount = param('startamount');
my $maxbid = param('maxbid');
my $SETTINGS;
################## Read in the configuration ########################
open CONFIGFILE, "< configuration.dat" || die "Failed to open
configuration file: $!"; # Open the configuration file
while (<CONFIGFILE>) {
my $line = $_;
next if ($line=~/^#/);
my ($key,$value) = split(/=/,$line);
$value=~s/\n|\r//g;
$value=~s/'//g;
chomp($value);
$SETTINGS{$key}=$value;
}
close(CONFIGFILE);
################### Include the language file ######################
do $SETTINGS{'languagefile'} || die "Failed to include language file:
$!"; # include the language file
####################################################################
#------------------------------------------------------------------#
sub printFile
{
my ($file) = @_;
open FH, "<$file" or return;
print while (<FH>);
close FH; # do not complain if it cannot
}
#------------------------------------------------------------------#
# function that will check to ensure the username are password match
and are ok
sub checkLogin() {
my ($loginname) = @_;
open USERFILE, " $SETTINGS{'userfile'}" || die "Failed to open file:
$!";
if ($^O ne "MSWin32") { flock(USERFILE, LOCK_EX); }
while (<USERFILE>) {
my @fields = split(/\t/,$_); # split $line, using : as delimiter
if (@fields[1]=~m/^$loginname$/) {
if (@fields[2]=~m/^$password$/) {
$matchokay='true'; # login name matches password
}
}
}
close(USERFILE);
if ($matchokay) { return $matchokay; }
else { return ''; }
}
#----------------------------------------------------------#
sub getBidInfo {
my ($itemcode)=@_[0];
my $latestbid = '';
my $i = '';
my $no_bids = '0';
#open the bidfile and find the item
my $bidfile = "$SETTINGS{'bidfiledir'}/$itemcode-bidfile.tab";
#print "<font color=white>$bidfile<br></font>";
open BIDFILE1, " $SETTINGS{'bidfiledir'}/$itemcode-bidfile.tab" ||
die "Failed to open file: $!";
if ($^O ne "MSWin32") {
flock(BIDFILE1, LOCK_EX);
}
while (<BIDFILE1>) {
$$itemcode_bidfile_contents[$i] = $_;
$i++;
}
close(BIDFILE1);
foreach my $record (@$itemcode_bidfile_contents) {
my @fields = split(/\t/,$record); # split $line, using : as
delimiter
if (@fields[0]=~m/^$itemcode$/) {
if (@fields[2] >= $latestbid) { $latestbid=@fields[2];
$no_bids++; }
}
}
$no_bids--; # take 1 off because the first bid isn't a bid, but the
start price
return "$latestbid-$no_bids";
}
#----------------------------------------------------------#
# function that will check to ensure the bid is acceptable
sub checkBid
{
my ($itemcode)=@_[0];
my ($bid)=@_[1];
my $badbid = '';
my $no_bids=0;
open BIDFILE2, " $SETTINGS{'bidfiledir'}/$itemcode-bidfile.tab" ||
die "Failed to open file: $!";
if ($^O ne "MSWin32") {
flock(BIDFILE2, LOCK_EX);
}
while (<BIDFILE2>) {
$bidfile_contents[$no_bids] = $_;
$no_bids++;
}
close(BIDFILE2);
foreach my $record (@bidfile_contents) {
my @fields = split(/\t/,$record);
if (@fields[0]=~m/^$itemcode$/) {
if (@fields[2] >= $bid) {
$realbid = @fields[2];
$badbid = $lang{'placebid error1'};
} elsif ($startamount>$bid) {
$realbid = @fields[2];
$badbid = $lang{'placebid error2'};
}
}
}
if ($badbid) { return ''; }
else { return 'Bid Okay'; }
}
#----------------------------------------------------------#
# function that will check to ensure the bid is acceptable
sub checkMaxBid
{
my ($bid)= shift;
my ($maxbid)= shift;
if ($bid < $maxbid) { return 'ok'; }
else { return ''; }
}
#----------------------------------------------------------#
#function to get todays date
sub todaysDate
{
#get todays date
$time = localtime(4);
@months = ("January","February","March","April","May","June","July","August","September","October","November","December");
($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
localtime(time);
$yr=1900+$year; #just as the perl docs said ( for y2k bug )
# added tdf 17/01/2002
if ($min < 10) { $min='0'.$min; }
if ($hour < 10) { $hour='0'.$hour; }
$date = "$mday-@months[$mon]-$yr-$hour:$min"; # 12:25:30 30 August
2000
return $date;
}
#----------------------------------------------------------#
sub writeBid
{
my ($bid)=@_[0];
my ($loginname)=@_[1];
my ($password)=@_[2];
my ($itemcode)=@_[3];
my ($maxbid)=@_[4];
# get todays date
my $today = &todaysDate();
# now open the file and add the new details.
open BIDFILE4, ">>$SETTINGS{'bidfiledir'}/$itemcode-bidfile.tab" ||
die "Failed to open BidFile: $!";
if ($^O ne "MSWin32") {
flock(BIDFILE4, LOCK_EX);
}
print BIDFILE4 "$itemcode\t$loginname\t$bid\t$today\t$maxbid\n" ||
die "Failed to write to BidFile: $!"; # die added tdf 20/12/2001
close BIDFILE4 || die "Failed to close BidFile: $!"; # die added tdf
20/12/2001
}
#----------------------------------------------------------#
sub getPreviousEmail
{
my $previous_loginname = '';
my $previous_email = '';
# find out the last user to place a bid on this item
#print "Opening file: $bidfiledir/$itemcode-bidfile.tab<br/>";
open BIDFILE5, " $bidfiledir/$itemcode-bidfile.tab" || die "Failed
to open file: $!";
if ($^O ne "MSWin32") {
flock(BIDFILE5, LOCK_EX);
}
while (<BIDFILE5>) {
my @fields = split(/\t/,$_); # split
if (@fields[0]=~m/^$itemcode$/) {
$previous_loginname = @fields[1];
}
#print "Previous loginname: $previous_loginname<br/>";
}
close(BIDFILE5);
if ($previous_loginname eq '') { $previous_loginname = 'Aaron'; }
# match this loginname with one in the user_contents
# get the email address from there
foreach my $record (@user_contents) {
#print "Each record looks like this: $record<br/>";
my @fields = split(/\t/,$record); # split $line, using \t as
delimiter
if (@fields[1]=~m/^$previous_loginname$/) { #print "found matching
name";
$previous_email = @fields[9];
}
#print "Previous Email: $previous_email<br/>";
}
# return the previous email
return $previous_email;
}
#----------------------------------------------------------#
sub informItemWatch {
my $itemcode = shift;
my $email;
my $name;
my $itemwatchfile="$SETTINGS{'itemwatchdir'}/$itemcode-itemwatch.tab";
if (-e $itemwatchfile) {
open ITEMWATCH, " $itemwatchfile";
if ($^O ne "MSWin32") { flock(ITEMWATCH, LOCK_EX); }
while (<ITEMWATCH>) {
my ($itemcode_old,$loginname_old) = split(/\t/,$_);
$loginname_old=~s/\n|\r//g;
chomp($loginname_old);
if ($loginname!~m/^$loginname_old$/ig) {
# get email and send
foreach my $record (@userfile_contents) {
my @fields = split(/\t/,$record); # split $line, using : as
delimiter
if (@fields[1]=~m/^$loginname_old$/ig) {
$email = @fields[9];
$name = @fields[3];
my $message=<<_EOM_;
Dear Auction User\n
This is an auto generated message from $SETTINGS{'auctionname'}
Auction to inform you
that a bid has been placed for $itemname\n
Click on the link below to get back in the game!\n
$SETTINGS{'website'}/$SETTINGS{'auctionroot'}/auction.cgi?searchid=$itemcode\n
Regards,
$SETTINGS{'auctionname'} Auction Management
_EOM_
if ($SETTINGS{'mailprog'}) {
open ( FILE, "|$SETTINGS{'mailprog'}") or die "Failed to
deliver email on open: $!";
# Print Message in _HERE_ string
print FILE <<MSG;
to: $email
from: $SETTINGS{'auctionname'}
reply-to: $SETTINGS{'adminemail'}
subject: $SETTINGS{'auctionname'} - Item Watch
MSG
print FILE $message;
close FILE || die "Failed to deliver message on close:
$!";
}
}
}
}
}
close(ITEMWATCH);
}
return;
}
#----------------------------------------------------------#
sub getPreviousDetails {
my $previous_loginname = '';
my $previous_bid = '';
my $previous_date = '';
my $previous_maxbid = '';
open BIDFILE, "< $SETTINGS{'bidfiledir'}/$itemcode-bidfile.tab" ||
die "Failed to open bidfile for reading:$!";
if ($^O ne "MSWin32") {
flock(BIDFILE, LOCK_EX);
}
while (<BIDFILE>) {
my $prev_details = $_;
$prev_details=~s/\n|\r//g;
chomp($prev_details);
($previous_itemcode,$previous_loginname,$previous_bid,$previous_date,$previous_maxbid)
= split(/\t/,$prev_details);
#print "$previous_itemcode - $previous_maxbid<br/>";
}
close BIDFILE || die "Failed to close BidFile: $!"; # die added tdf
20/12/2001
#print "<font color=red>$previous_maxbid</font><br/>";
#print "<br/>";
return "$previous_loginname|$previous_bid|$previous_date|$previous_maxbid";
#return "$previous_loginname|$previous_bid|$previous_date|120";
}
#----------------------------------------------------------#
sub checkItemcode
{
my ($itemcode)=@_[0];
my ($codestatus)='';
open AUCTION1, " $SETTINGS{'auctionfile'}" || die "Failed to open
file: $!";
if ($^O ne "MSWin32") {
flock(AUCTION1, LOCK_EX);
}
while (<AUCTION1>) {
my @fields = split(/\t/,$_); # split $line, using : as delimiter
if (@fields[0]=~m/^$itemcode$/) { #print "found matching name";
$codestatus = 'true';
}
}
close(AUCTION1);
return $codestatus;
}
#----------------------------------------------------------#
sub getBidIncrement {
my ($itemcode) = shift;
my $bid_inc = '';
open AUCTION1, " $SETTINGS{'auctionfile'}" || die "Failed to open
file: $!";
if ($^O ne "MSWin32") {
flock(AUCTION1, LOCK_EX);
}
while (<AUCTION1>) {
my ($id,$itemname,$description,$startdate,$expiry,$bidincrement,$reserveprice,$photo,$category)
= split(/\t/,$_);
if ($id eq $itemcode) {
$bid_inc = $bidincrement;
}
}
close(AUCTION1);
return $bid_inc;
}
#----------------------------------------------------------#
sub sendEmail
{
my ($address) = shift;
#send an email to the previous bidder to tell them their bid has
been passed
#
#print "Sending Email to Address: $address";
open ( FILE, "|$SETTINGS{'mailprog'}") or die "Failed to deliver
email on open\n";
# Print Message in _HERE_ string
print FILE <<MSG;
to: $address
from: $SETTINGS{'auctionname'}
reply-to: $SETTINGS{'adminemail'}
subject: $SETTINGS{'auctionname'}
MSG
print FILE <<_EOM_;
**********************************************\n
$SETTINGS{'auctionname'}\n
**********************************************\n
This is a courtesy email to let you know that you have been outbid on
the
auction item: $itemname\n
Someone has outbid you but if you are quick you could still win by
placing another bid on this auction!\n
Click on the link below to get back in the game!\n
$SETTINGS{'website'}/$SETTINGS{'auctionroot'}/auction.cgi?searchid=$itemcode\n
Good luck and thanks for Bidding.\n
_EOM_
close FILE; # or die "Failed to deliver message on close\n";
}
#---------------Main Program-----------------------#
my $access = &checkLogin($loginname);
print "Content-type: text/html\n\n";
printFile('header.html');
print "<center>";
my $itemcodeokay = &checkItemcode($itemcode);
#if access is granted then check the bid is greater than the bid
already in the file.
if ($submityet eq 'true') {
if ($itemcodeokay) {
if (($access) and ($submityet eq 'true')) {
my $bidok = &checkBid($itemcode,$bid);
if ($bidok) { # if bid is ok then write the bid to the bid
file.
# check if maxbid is set
if ($maxbid) {
my $maxbidok = &checkMaxBid($bid,$maxbid);
}
($current_loginname,$current_bid,$current_date,$current_maxbid) =
split(/\|/,&getPreviousDetails()); #print
"<p>$previous_loginname,$previous_bid,$previous_date,$previous_maxbid</p>";
my $previous_email = &getPreviousEmail();
&writeBid($bid,$loginname,$password,$itemcode,$maxbid);
#if ($^O ne "MSWin32") { &sendEmail($previous_email); }
my $bid_inc = &getBidIncrement($itemcode);
while ($current_maxbid > $bid) {
$bid = $bid+$bid_inc;
$maxbid = $current_maxbid;
$loginname = $current_loginname;
# ($current_loginname,$current_bid,$current_date,$current_maxbid)
= split(/\|/,&getPreviousDetails());
#if (($bid <= $maxbid) and ($current_loginname ne
$loginname)) {
if ($bid <= $maxbid) {
if ($loginname!~m/Autobid/) {
$loginname.=" (Autobid)";
}
my $previous_email = &getPreviousEmail();
&writeBid($bid,$loginname,$password,$itemcode,$maxbid);
}
}
if ($^O ne "MSWin32") { &sendEmail($previous_email); }
################# Bidding phase is over ###############
# You need to now inform users using itemwatch that a bid has
been made on this item
#if ($^O ne "MSWin32") { &informItemWatch($itemcode); }
##########################################
print "<h3>$lang{'Congratulations Bid Accepted'}</h3>
<p>$lang{'placebid message1'}</p>
<p>$lang{'placebid message6'}</p>
<p><a href=\"auction.cgi\">$lang{'Back to Auction'}</a></p>";
} else {
$error = "<h3>$lang{'Bid not accepted'}</h3>
<p>$lang{'placebid error1'}</p>
<p>$lang{'placebid error2'}</p>
<p>$lang{'placebid error3'}:
<b>$SETTINGS{'currency'}$startamount</b></p>";
print $error;
}
} else {
$error = "<p>$lang{'Login Failed'}</p>
<p>$lang{'placebid message2'}</p>
<p>$lang{'placebid message3'}</p>";
print $error;
}
} else {
$error = "<h3>$lang{'Itemcode Not Recognised'}</h3>";
print $error;
}
} else {
print <<_EOM_;
<center>
<form action="placebid.cgi" method="post" name="placeabid"><a
name="placebidd"></a>
_EOM_
if ($SETTINGS{'privateauction'}=~m/^no$/ig) {
print <<_EOM_;
<p>$lang{'placebid message4'}</p>
_EOM_
} else {
print "<br/>";
}
print <<_EOM_;
<p>$lang{'placebid message5'} $SETTINGS{'currency'}$startamount</p>
<table border="0" width="300" cellspacing="0" cellpadding="0">
<tr>
<td class="bordercolour">
<table border="0" width="100%" cellpadding="5"
cellspacing="1">
<tr>
<td class="headercell">
<table width="100%">
<tr>
<td><img src="images/money1.gif"></td><td><div
class="dialogheader">Place a bid for $itemname</div></td>
</tr>
</table>
</td>
<tr>
<td class="content">
<table cellpadding="5" cellspacing="1" width="300">
<tr>
<td>$lang{'Login Name'}</td><td><input type="text"
name="username" size="11"></td>
</tr><tr>
<td>$lang{'Password'}</td><td><input type="password"
name="password" size="11"></td>
</tr><tr>
<td>$lang{'Bid'} ($SETTINGS{'currency'})</td><td><input
type="text" name="bid" size="6" value="$startamount"><a
href=\"javascript:convert(placeabid.bid.value);\">[$lang{'convert'}]</a></td>
</tr><tr>
<td>$lang{'Max Bid'} ($SETTINGS{'currency'})</td><td><input
type="text" name="maxbid" size="6" value=""><a
href=\"javascript:convert(placeabid.maxbid.value);\">[$lang{'convert'}]</a></td>
</tr><tr>
<td align="center" bgcolor="white" colspan="2"><input
type="submit" value="$lang{'Place your Bid'}" class="headercell"></td>
</tr>
</table><input type="hidden" name="startamount"
value="$startamount">
<input type="hidden" name="submityet" value="true">
</td>
</tr>
</table>
</td>
</tr>
</table>
<script language=javascript>
<!--
// if there's a cookie set drop the username and password value into
the form
if (document.cookie) {
document.placeabid.username.value=cookie_information[\"username\"];
document.placeabid.password.value=cookie_information[\"password\"];
}
//--></script>
<input type="hidden" name="itemid" value="$itemcode">
<input type="hidden" name="itemname" value="$itemname">
</form>
_EOM_
}
print "</center>";
printFile('footer.html');
------------------------------
Date: Mon, 28 Jul 2003 19:49:53 GMT
From: Darren Dunham <ddunham@redwood.taos.com>
Subject: Re: can this one-liner be squeezed any shorter?
Message-Id: <B7fVa.686$Dr5.93@newssvr22.news.prodigy.com>
Dan Jacobson <jidanni@jidanni.org> wrote:
> J> perl -pe 's%\d+%sprintf"%4d",7.2*3600/$&%e'
> Better use s@. By the way are you sure I don't need to do the * in a
> BEGIN lest it get recomputed each input line? You say the compiler or
> whatever takes care of that? (Yes I could write 25920/$& but
> I want the user to see what we did, but do it only once.)
Even if it didn't, are you sure you would care? One extra
multiplication op per line isn't that much of a problem.
You can't optimize everything all the time. It looks like you're trying
to optimize speed, readability, and code size simultaneoulsly.
--
Darren Dunham ddunham@taos.com
Unix System Administrator Taos - The SysAdmin Company
Got some Dr Pepper? San Francisco, CA bay area
< This line left intentionally blank to confuse you. >
------------------------------
Date: Mon, 28 Jul 2003 14:12:21 -0500
From: Adrian Kubala <adrian@sixfingeredman.net>
Subject: Re: Currying functions
Message-Id: <Pine.LNX.4.44.0307281409080.11405-100000@gwen.sixfingeredman.net>
On Mon, 28 Jul 2003, Dave Benjamin wrote:
> other languages like Python and Java use a more OO (and efficient) way
> of caching the pattern than using the method I described.
Why do you say "more efficient" -- can't you implement partial application
with a closure, and why should that less efficient than a full-blown
object? I'd think it'd be more efficient since there's no dynamic
dispatch.
------------------------------
Date: 28 Jul 2003 14:07:00 -0700
From: puissant00@yahoo.com (Go Perl)
Subject: FILE SELECTION DIALOG PROBLEM
Message-Id: <d3825316.0307281307.155601ac@posting.google.com>
I am using the following code to create file selection dialogs..But
apparently the Browse buttons do not seem to work.. i got this from
examples provided by typing widget. I changed a little to remove the
radio buttons and stuff, but i am not able to browse and select the
files. I will be glad if anyone can point the error and throw some
light on this.
Thanks very much.
use Tk;
$mw = MainWindow->new();
foreach my $i (qw(one two three four)) {
my $f = $mw->Frame;
my $lab = $f->Label(-text => "Select $i file to Open: ",
-anchor => 'e');
my $ent = $f->Entry(-width => 20);
my $but = $f->Button(-text => "Browse ...",
-command => sub { fileDialog($mw, $ent, $i)});
$lab->pack(-side => 'left');
$ent->pack(-side => 'left',-expand => 'yes', -fill => 'x');
$but->pack(-side => 'left');
$f->pack(-fill => 'x', -padx => '1c', -pady => 3);
}
sub filebox {
my $demo = shift;
(
-name => $demo,
-text => "Enter a file name in the entry box or click on
the \"Browse\" buttons to select a file name
using the file selection dialog.",
-iconname => 'filebox',
);
}
sub fileDialog {
my $w = shift;
my $ent = shift;
my $operation = shift;
my $types;
my $file;
@types =
(["Text files", '*.txt'],
["All files", '*']
);
if ($operation eq 'open') {
$file = $w->getOpenFile(-filetypes => \@types);
}
}
------------------------------
Date: 28 Jul 2003 12:19:13 -0700
From: jullag@hotmail.com (julien)
Subject: GD.pm index table limitation
Message-Id: <636393c8.0307281119.56375553@posting.google.com>
Hi there,
i have a problem with the GD module: I need to allocate a lot of
colors (and very sharply defined) for one single image. Apparently,
once the image index color table is full (i.e. approx 255 elements),
all subsequently allocated colors will have the same rgb code as the
last element (the 255th one), which looks obviously not exactly as i
would like.
Anybody knows a solution ?
thanks
cheers
julien
------------------------------
Date: Tue, 29 Jul 2003 07:59:24 +1000
From: "Gregory Toomey" <NOSPAM@bigpond.com>
Subject: Re: GD.pm index table limitation
Message-Id: <bg469v$kd3t0$1@ID-202028.news.uni-berlin.de>
"julien" <jullag@hotmail.com> wrote in message
news:636393c8.0307281119.56375553@posting.google.com...
> Hi there,
> i have a problem with the GD module: I need to allocate a lot of
> colors (and very sharply defined) for one single image. Apparently,
> once the image index color table is full (i.e. approx 255 elements),
> all subsequently allocated colors will have the same rgb code as the
> last element (the 255th one), which looks obviously not exactly as i
> would like.
> Anybody knows a solution ?
> thanks
> cheers
> julien
If you are talking gif, then there isn't one. The gif "stnadard" only allows
for 255 colours.
Have a look at png or jpeg instead.
gtoomey
------------------------------
Date: Tue, 29 Jul 2003 08:01:25 +1000
From: "Gregory Toomey" <NOSPAM@bigpond.com>
Subject: Re: GD.pm index table limitation
Message-Id: <bg46dp$knbpr$1@ID-202028.news.uni-berlin.de>
Bu the way, gif is only supported up to Version 1.19 of GD.pm (licencing
issue), and png is supported in later versions.
gtoomey
------------------------------
Date: 28 Jul 2003 11:29:42 -0700
From: fred.illig@lmco.com (Fred)
Subject: How do you Call a Perl subroutine with a variable name?
Message-Id: <8714513c.0307281029.66147c6a@posting.google.com>
Anyone,
I have a Perl module (*.pm).
I have a subroutine declared - sub x($$$);
I have the subroutine in the module - sub x($$$){<process the input
variables and return two variables>};
In another subroutine in this module, I want to call this subroutine
(x) via an array element - @array = (a,b,c,x,y,z);
($outvar1, $outvar2) = &$array[3]($invar1,$invar2,$invar3);
This is not working.
How do I make a call to a subroutine where the name of the subroutine
to be called is being derived from an element in an array? We have a
variable as the subroutine name that we want to use.
We have tried many different combination of referencing and
de-referencing, but we cannot figure it out. A real live example
would be great.
Thanks in advance for any help you can send me.
Fred
------------------------------
Date: Mon, 28 Jul 2003 20:53:36 +0200
From: Gunnar Hjalmarsson <noreply@gunnar.cc>
Subject: Re: How do you Call a Perl subroutine with a variable name?
Message-Id: <bg3rid$kgg45$1@ID-184292.news.uni-berlin.de>
Fred wrote:
> I have a subroutine declared - sub x($$$);
<snip>
> In another subroutine ... I want to call this subroutine
> (x) via an array element - @array = (a,b,c,x,y,z);
> ($outvar1, $outvar2) = &$array[3]($invar1,$invar2,$invar3);
>
> This is not working.
Try this:
($outvar1, $outvar2) = &{\&{$array[3]}}($invar1,$invar2,$invar3);
--
Gunnar Hjalmarsson
Email: http://www.gunnar.cc/cgi-bin/contact.pl
------------------------------
Date: Mon, 28 Jul 2003 19:31:08 GMT
From: "John W. Krahn" <krahnj@acm.org>
Subject: Re: How do you Call a Perl subroutine with a variable name?
Message-Id: <3F257A40.3CFFE1BA@acm.org>
Fred wrote:
>
> Anyone,
>
> I have a Perl module (*.pm).
> I have a subroutine declared - sub x($$$);
> I have the subroutine in the module - sub x($$$){<process the input
> variables and return two variables>};
>
> In another subroutine in this module, I want to call this subroutine
> (x) via an array element - @array = (a,b,c,x,y,z);
> ($outvar1, $outvar2) = &$array[3]($invar1,$invar2,$invar3);
>
> This is not working.
@array = ( 'a', 'b', 'c', &x, 'y', 'z' );
( $outvar1, $outvar2 ) = $array[3]->( $invar1, $invar2, $invar3 );
John
--
use Perl;
program
fulfillment
------------------------------
Date: Mon, 28 Jul 2003 13:11:40 -0700
From: Steven Kuo <skuo@mtwhitney.nsc.com>
Subject: Re: How do you Call a Perl subroutine with a variable name?
Message-Id: <Pine.GSO.4.21.0307281308400.491-100000@mtwhitney.nsc.com>
On Mon, 28 Jul 2003, John W. Krahn wrote:
> Fred wrote:
> >
> > Anyone,
> >
> > I have a Perl module (*.pm).
> > I have a subroutine declared - sub x($$$);
> > I have the subroutine in the module - sub x($$$){<process the input
> > variables and return two variables>};
> >
> > In another subroutine in this module, I want to call this subroutine
> > (x) via an array element - @array = (a,b,c,x,y,z);
> > ($outvar1, $outvar2) = &$array[3]($invar1,$invar2,$invar3);
> >
> > This is not working.
>
>
> @array = ( 'a', 'b', 'c', &x, 'y', 'z' );
^
@array = ( 'a', 'b', 'c', \&x, 'y', 'z' );
Forgot the backslash that makes the fourth array element a code
reference?
> ( $outvar1, $outvar2 ) = $array[3]->( $invar1, $invar2, $invar3 );
>
--
Hope this helps,
Steven
------------------------------
Date: 28 Jul 2003 21:14:55 +0100
From: Brian McCauley <nobull@mail.com>
Subject: Re: How do you Call a Perl subroutine with a variable name?
Message-Id: <u9oezeif28.fsf@wcl-l.bham.ac.uk>
Gunnar Hjalmarsson <noreply@gunnar.cc> writes:
> Fred wrote:
> > I have a subroutine declared - sub x($$$);
>
> <snip>
>
> > In another subroutine ... I want to call this subroutine
> > (x) via an array element - @array = (a,b,c,x,y,z);
You should probably stop wanting that. Wanting to use symbolic
references is usually a bad thing. It is also usually a sign of what
we call an "XY problem". You really want to do "X" (a dispatch table
in this case) and think that "Y" (symbolic references in this case) is
part of the solution of "X" so you ask how do "Y". In fact "X" is
something that is itself simpler than "Y".
> > ($outvar1, $outvar2) = &$array[3]($invar1,$invar2,$invar3);
> > This is not working.
>
> Try this:
>
> ($outvar1, $outvar2) = &{\&{$array[3]}}($invar1,$invar2,$invar3);
Er, why the &{\...}
($outvar1, $outvar2) = &{$array[3]}($invar1,$invar2,$invar3);
Of course the -> syntax is usually preferred.
Note 1: either syntax will cause the protoype to be ignored.
Note 2: Unless you have a _really_ good reason to use a named sub and
a sumbolic reference - don't! (If you don't undertand that statement
then you 99.99% certainly don't have a good reason).
Just put real refs in @array.
my @array = (\&a,\&b,\&c,\&x,\&y,\&z);
You can even skip the symbols competely:
my @array = (
sub {
#....
},
sub {
#....
},
sub {
#....
},
sub {
#....
},
sub {
#....
},
sub {
#....
},
);
--
\\ ( )
. _\\__[oo
.__/ \\ /\@
. l___\\
# ll l\\
###LL LL\\
------------------------------
Date: Mon, 28 Jul 2003 22:59:46 +0200
From: Gunnar Hjalmarsson <noreply@gunnar.cc>
Subject: Re: How do you Call a Perl subroutine with a variable name?
Message-Id: <bg42v3$kjh87$1@ID-184292.news.uni-berlin.de>
Brian McCauley wrote:
> Gunnar Hjalmarsson <noreply@gunnar.cc> writes:
>>Try this:
>>
>> ($outvar1, $outvar2) = &{\&{$array[3]}}($invar1,$invar2,$invar3);
>
> Er, why the &{\...}
>
> ($outvar1, $outvar2) = &{$array[3]}($invar1,$invar2,$invar3);
Well, assuming that strictures are enabled (thought that was 'law'
here), without that creation 'on the fly' of a real reference, and
immediate dereference, Perl complains:
Can't use string ("x") as a subroutine ref
while "strict refs" in use ...
Of course, another way to handle it is a block with
no strict 'refs';
Furthermore, my suggestion makes it _very_ unlikely that you use a
symbolic reference by mistake, which - if I have understood it
correctly - is one of the principal reasons for the general view here
that symrefs is a bad thing.
--
Gunnar Hjalmarsson
Email: http://www.gunnar.cc/cgi-bin/contact.pl
------------------------------
Date: Mon, 28 Jul 2003 21:47:44 GMT
From: "John W. Krahn" <krahnj@acm.org>
Subject: Re: How do you Call a Perl subroutine with a variable name?
Message-Id: <3F259A42.C09CFC56@acm.org>
Steven Kuo wrote:
>
> On Mon, 28 Jul 2003, John W. Krahn wrote:
> >
> > @array = ( 'a', 'b', 'c', &x, 'y', 'z' );
> ^
> @array = ( 'a', 'b', 'c', \&x, 'y', 'z' );
>
> Forgot the backslash that makes the fourth array element a code
> reference?
Oops.
> Hope this helps,
Certainly. :-)
John
--
use Perl;
program
fulfillment
------------------------------
Date: Mon, 28 Jul 2003 18:10:15 +0000
From: nataraj <member34391@dbforums.com>
Subject: How to do equivalent to Crypt:CBC of Perl in Oracle pl/sql
Message-Id: <3157584.1059415815@dbforums.com>
I have been using PERL, Crypt::CBC for encryption and storing the
encrypted password in Oracle database.
Now I want to do the encryption/decryption inside PL/SQL.
How to achieve the same?
i.e.
I should be able to decrypt in pl/sql, something which has been
encrypted in perl and vice versa.
Please suggest.
Thanks in advance.
Nataraj
--
Posted via http://dbforums.com
------------------------------
Date: Mon, 28 Jul 2003 15:16:16 -0500
From: "J. Gleixner" <glex_nospam@qwest.net>
Subject: Re: LWP::Request
Message-Id: <lvfVa.533$Oj3.39084@news.uswest.net>
Kevin Su wrote:
> Can someone show me how to use LWP::request properly? Specifically,
> for authorization. I want to get information from a protected website
> by automating the log in process. I googled it online because someone
> at my company recommended it to me, and I found a site containing:
>
> "-C <username>:<password>
> Provide credentials for documents that are protected by Basic
> Authentication. If the document is protected and you did not specify
> the username and password with this option, then you will be prompted
> to provide these values."
>
> http://toons.cs.ucsb.edu:4080/man?lwp-request
>
> This looks useful to what I am trying to do, though I do not know how
> to use it.
Type the following at your system's prompt
perldoc lwpcook
That'll give you a lot of useful examples for LWP. Specifically:
ACCESS TO PROTECTED DOCUMENTS
Documents protected by basic authorization can easily be
accessed like this:
use LWP::UserAgent;
$ua = LWP::UserAgent->new;
$req = HTTP::Request->new(GET => 'http://www.linpro.no/secret/');
$req->authorization_basic('username', 'thepassword');
print $ua->request($req)->as_string;
The other alternative is to provide a subclass of
LWP::UserAgent that overrides the get_basic_credentials()
method. Study the lwp-request program for an example of
this.
You may need a few additional modules for SSL, see
http://search.cpan.org/ for those.
------------------------------
Date: 28 Jul 2003 13:41:01 -0700
From: nos41@hotmail.com (nos)
Subject: New to Perl
Message-Id: <e06c9226.0307281241.56435230@posting.google.com>
I am looking for a way to look into a file and determine the next
number in a sequence that is not present within a range of numbers.
Example:
File 10000
10001
10003
10004
I want it to find 10002 as the missing number. Any suggestions.
Thanks,
Nos
------------------------------
Date: Mon, 28 Jul 2003 23:33:10 +0200
From: Gunnar Hjalmarsson <noreply@gunnar.cc>
Subject: Re: New to Perl
Message-Id: <bg44to$ki3bq$1@ID-184292.news.uni-berlin.de>
Do you really thing that the subject "New to Perl" accurately
describes the nature of your question?
nos wrote:
> I am looking for a way to look into a file and determine the next
> number in a sequence that is not present within a range of numbers.
> Example:
> File 10000
> 10001
> 10003
> 10004
>
> I want it to find 10002 as the missing number. Any suggestions.
#!/usr/bin/perl
use strict;
use warnings;
my @numbers = sort { $a <=> $b } grep /\d+/, <DATA>;
my $i = 0;
for ($numbers[0]..$numbers[$#numbers]) {
unless ($numbers[$i] == $_) {
print "Missing number: $_\n";
} else {
$i++;
}
}
__DATA__
10000
10001
10003
10004
--
Gunnar Hjalmarsson
Email: http://www.gunnar.cc/cgi-bin/contact.pl
------------------------------
Date: Mon, 28 Jul 2003 16:49:32 -0400
From: "Tulan W. Hu" <twhu@lucent.com>
Subject: pack and unpack question for perl 5.8.0
Message-Id: <bg429f$9p9@netnews.proxy.lucent.com>
My old perl code has the following that works in 5.6.0:
while($line = <STDIN>){
chomp $line;
$aline = $line;
($tline = $aline) =~ tr/\0-\x{ff}//UC;
printf STDERR ("%s\n", $tline);
}
I changed it for perl 5.8.0
while($line = <STDIN>){
chomp $line;
$aline = $line;
$pline = pack("C*", unpack("U*", $line));
printf STDOUT ("%s\n", $pline);
}
Both codes give me the same output if I use perl 5.6.0.
However, if I use perl 5.8.0, then the output is the same
as the input.
The code is converting utf8 to latin1.
I'm wondering which output is correct.
Thanks for your help in advance!
Tulan
------------------------------
Date: 28 Jul 2003 11:16:38 -0700
From: jkeen@concentric.net (James E Keenan)
Subject: Re: Perl compiler? error
Message-Id: <b955da04.0307281016.17c5355d@posting.google.com>
fatted@yahoo.com (fatted) wrote in message news:<4eb7646d.0307280451.1acadb3f@posting.google.com>...
> Lets say a friend of mine :) wrote code which had a bad error in it:
>
> #!/usr/bin/perl
> use warnings;
> use strict;
>
> my $words = ["a", "b", "c"];
> my $num = 612;
>
> if($num == 1)
> {
> print "moo\n";
> }
> elsif (map($_->[0] =~ /\d{6}/, @$words))
> {
> print "Don't give up day job\n";
> }
>
> When run this gives the error:
> Can't use string ("a") as an ARRAY ref while "strict refs" in use at
> ./test.pl line 8.
> After about 1/2 hour of head banging, the problem (which was
> originally in a much larger program) was finally discovered. The code
> problem wasn't on line 8 :). I have fixed that and slapped my "friend"
> around the face for stupidity.
>
> However this leads to my real question:
> Is the error message above, an error in the compiler? For instance if
> the close bracket of an elsif is forgotton, you get an error on the
> line where the close bracket was left out. *Not* on the line where the
> start of the IF THEN ELSE syntax began.
>
There's no compiler error here, but I think you may have a conceptual
error. The 'elsif' clause establishes a Boolean context, i.e., either
a 'true' or 'false' (in Perl's terms) is the only acceptable answer.
Boolean context should be thought of as a subset of scalar context.
'map', however, generates a list by performing an operation on each
element of a source list. Hence, 'map' normally establishes a list
context. However, since that 'map' is itself within the
Boolean/scalar context established by 'elsif', it will impose a scalar
context, i.e., it will ask how many items are in the resulting list.
If there is a nonzero number of items in the source list, the 'elsif'
will register as true.
Now, are you sure that that's what you were aiming for with this code?
(In short, I'm puzzled by your use of 'map' inside an 'elsif'
condition.)
Jim Keenan
------------------------------
Date: Mon, 28 Jul 2003 14:27:17 -0400
From: Jeff 'japhy' Pinyan <pinyaj@rpi.edu>
Subject: Re: Perl compiler? error
Message-Id: <Pine.SGI.3.96.1030728142203.44173A-100000@vcmr-64.server.rpi.edu>
On 28 Jul 2003, James E Keenan wrote:
>fatted@yahoo.com (fatted) wrote in message news:<4eb7646d.0307280451.1acadb3f@posting.google.com>...
>> Lets say a friend of mine :) wrote code which had a bad error in it:
>>
>> #!/usr/bin/perl
>> use warnings;
>> use strict;
>>
>> my $words = ["a", "b", "c"];
>> my $num = 612;
>>
>> if($num == 1)
>> {
>> print "moo\n";
>> }
>> elsif (map($_->[0] =~ /\d{6}/, @$words))
>> {
>> print "Don't give up day job\n";
>> }
>>
>> When run this gives the error:
>> Can't use string ("a") as an ARRAY ref while "strict refs" in use at
>> ./test.pl line 8.
>>
>> However this leads to my real question:
>> Is the error message above, an error in the compiler? For instance if
>> the close bracket of an elsif is forgotton, you get an error on the
>> line where the close bracket was left out. *Not* on the line where the
>> start of the IF THEN ELSE syntax began.
>>
>There's no compiler error here, but I think you may have a conceptual
>error. The 'elsif' clause establishes a Boolean context, i.e., either
>a 'true' or 'false' (in Perl's terms) is the only acceptable answer.
You're not answering the question, though. The OP is curious why the
error is said to stem from line 8, when the expression causing the error
is on line 12. This is because of the way Perl compiles the if-else block
internally.
You can fake it like so:
elsif (map {; $_->[0] =~ /\d{6}/ } @$words) { ... }
or
elsif (do {; map $_->[0] =~ /\d{6}/, @$words) { ... }
Those two lines will make Perl report the "correct" line number with the
error.
--
Jeff Pinyan RPI Acacia Brother #734 2003 Rush Chairman
"And I vos head of Gestapo for ten | Michael Palin (as Heinrich Bimmler)
years. Ah! Five years! Nein! No! | in: The North Minehead Bye-Election
Oh. Was NOT head of Gestapo AT ALL!" | (Monty Python's Flying Circus)
------------------------------
Date: 28 Jul 2003 11:09:55 -0700
From: bryon_bean@msn.com (Bryon Bean)
Subject: Re: Tainting and use lib...
Message-Id: <8daa12a2.0307281009.5895eba4@posting.google.com>
Tina Mueller <usenet@expires082003.tinita.de> wrote in message news:<bg31ua$k4ikc$1@ID-24002.news.uni-berlin.de>...
> Bryon Bean wrote:
> > use lib qw( /var/www/cgi-bin/war/RTG );
> > use RTG::Project;
>
> so this lets us assume that there is a file
> /var/www/cgi-bin/war/RTG/RTG/Project.pm
>
> i think you probably want to write:
> use lib qw( /var/www/cgi-bin/war );
>
Your absolutely right, this does work.
> -T removes the current directory from @INC, so
> before you used -T, it just worked because you had
> "." in @INC, not because of the "use lib".
Is this documented anywhere? I thought that I had looked everywhere
for something that might explain this behavior?
> hth, tina
This does help and thank you very much!
-Bryon
------------------------------
Date: 28 Jul 2003 19:07:16 GMT
From: Tina Mueller <usenet@expires082003.tinita.de>
Subject: Re: Tainting and use lib...
Message-Id: <bg3s94$kanek$1@ID-24002.news.uni-berlin.de>
Bryon Bean wrote:
> Tina Mueller <usenet@expires082003.tinita.de> wrote in message news:<bg31ua$k4ikc$1@ID-24002.news.uni-berlin.de>...
>> -T removes the current directory from @INC, so
>> before you used -T, it just worked because you had
>> "." in @INC, not because of the "use lib".
> Is this documented anywhere? I thought that I had looked everywhere
> for something that might explain this behavior?
uhm, actually I don't know; think I learned this by looking
at @INC =)
(and then it seemed logical to me as the superuser on unix-
systems also does not have "." in $PATH.)
if there's a place I would search for it it's perlsec, but I can't
find it in there...
regards, tina
--
http://www.tinita.de/ \ enter__| |__the___ _ _ ___
http://Movies.tinita.de/ \ / _` / _ \/ _ \ '_(_-< of
http://www.perlquotes.de/ \ \ _,_\ __/\ __/_| /__/ perception
- my mail address expires end of august 2003 -
------------------------------
Date: Sat, 19 Jul 2003 01:59:56 GMT
From: Bob Walton <bwalton@rochester.rr.com>
Subject: Re:
Message-Id: <3F18A600.3040306@rochester.rr.com>
Ron wrote:
> Tried this code get a server 500 error.
>
> Anyone know what's wrong with it?
>
> if $DayName eq "Select a Day" or $RouteName eq "Select A Route") {
(---^
> dienice("Please use the back button on your browser to fill out the Day
> & Route fields.");
> }
...
> Ron
...
--
Bob Walton
------------------------------
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 5282
***************************************
