[24252] in Perl-Users-Digest
Perl-Users Digest, Issue: 6443 Volume: 10
daemon@ATHENA.MIT.EDU (Perl-Users Digest)
Thu Apr 22 03:07:13 2004
Date: Thu, 22 Apr 2004 00: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 Thu, 22 Apr 2004 Volume: 10 Number: 6443
Today's topics:
Re: "cloning" perl / CPAN install (Walter Roberson)
Re: Asking for comments on this script <tore@aursand.no>
Re: Creating hash with an array as value. (christie)
Re: Creating hash with an array as value. (Kevin Collins)
Re: Finding all open filehandles and closing them befor <jwillmore@remove.adelphia.net>
free source guestbook (finished) <robin @ infusedlight.net>
Re: free source guestbook (finished) <tassilo.parseval@rwth-aachen.de>
Re: grepping lines above and below a pattern found <bmb@ginger.libs.uga.edu>
Re: Moving Directory using win32api::File <kalinaubears@iinet.net.au>
Operator overloading <kalinaubears@iinet.net.au>
perl -d interfering with program execution? <news**NO_SPAM**@psychogenic.com>
Re: regular expression module? (Walter Roberson)
Re: regular expression module? <uri@stemsystems.com>
Re: regular expression module? (Walter Roberson)
Re: slurp not working? ideas please! <geoffacox@dontspamblueyonder.co.uk>
Re: slurp not working? ideas please! <tassilo.parseval@rwth-aachen.de>
Re: sort numeric lists <uri.guttman@fmr.com>
sorting <bckumari@yahoo.com>
Re: sorting <jurgenex@hotmail.com>
Re: sorting <jwillmore@remove.adelphia.net>
Re: sorting <jtc@shell.dimensional.com>
Re: variable interpolation failed :-( <tadmc@augustmail.com>
Digest Administrivia (Last modified: 6 Apr 01) (Perl-Users-Digest Admin)
----------------------------------------------------------------------
Date: 22 Apr 2004 01:33:02 GMT
From: roberson@ibd.nrc-cnrc.gc.ca (Walter Roberson)
Subject: Re: "cloning" perl / CPAN install
Message-Id: <c677ce$ba0$1@canopus.cc.umanitoba.ca>
In article <utphc.28585$hw5.47672@attbi_s53>,
Joe Smith <Joe.Smith@inwap.com> wrote:
:Walter Roberson wrote:
:> It so happens that I'd scrolled through the entire cpan source already
:> once today, just a short time before, in order to answer another
:> poster's question about where exactly perl -MCPAN -e shell was
:> documented. I saw at that time that the cpan source was long and involved,
:I try to make it a habit of using perldoc on the module before looking
:at the source code. You'll often find important stuff on the first
:page that way.
:If you had done
: perldoc CPAN
:before going to
: less /usr/lib/perl5/5.8.3/CPAN.pm
:you could have saved a lot of wear and tear on your brain.
Actually what I did was perldoc -m CPAN which somehow I had
come to understand was the way one had to ask for documentation
about a module with the given name. I see now looking at the man
page that I did not need the -m to get to the documentation. Oh well,
too late now to worry about how I formed the -m bad habbit.
--
Can a statement be self-referential without knowing it?
------------------------------
Date: Thu, 22 Apr 2004 00:53:38 +0200
From: Tore Aursand <tore@aursand.no>
Subject: Re: Asking for comments on this script
Message-Id: <pan.2004.04.21.22.40.11.298278@aursand.no>
On Wed, 21 Apr 2004 14:26:23 -0500, Rafael Villarroel Flores wrote:
> The following script already does what I want it to do, but I would
> appreciate if the experts here share any comment they may have that
> would help improve my Perl skills
> [...]
One thing you _definitely_ should look into, is how to use templates to
seperate - uhm - ordinary (external) text from Perl code.
Go to <http://www.cpan.org/> and do a search for 'template'. There are
too many to mention.
--
Tore Aursand <tore@aursand.no>
"Then there was the man who drowned crossing a stream with an average
depth of six inches." (W.I.E. Gates)
------------------------------
Date: 21 Apr 2004 15:32:42 -0700
From: kenvin007@yahoo.com (christie)
Subject: Re: Creating hash with an array as value.
Message-Id: <f977ee23.0404211432.4c0996f@posting.google.com>
Anders Christensen <anders_postkasseKEINEJUNK@hotmail.com> wrote in message news:<c65ugh$u2k$1@news.cybercity.dk>...
> Hi, I'm selecting two columns from my database. What I want to do with the
> fetched data is to organize it into a single hash so that each different A
> from the database is used as the hash-key. The hash-value should be an
> array containing every B from the database, where A and B is on the same
> row. An example:
> ----------------
> | A | B |
> ----------------
> | text1 | foo |
> | text2 | bar |
> | text1 |foobar |
> | text3 | oof |
> | text3 | test |
> | text1 | rab |
> ----------------
>
> I want to end up with one hash, where...
> $prods->{text1} is the array (foo, foobar, rab)
Basically, you create a single string hash and push in a stack and use
a perl buid in subroutine to sort it out and throw it into a foreach
loop. that should do it. To be more efficient, you can use the
optimized binary hash to do the job for you. Hope this will help.
> $prods->{text2} is the array (bar)
> $prods->{text3} is the array (oof, test)
>
> I've tried the following code without succes :
> my %hack_hash;
> my $prods = \%hack_hash;
> SendSQL("SELECT A, B FROM table WHERE 1");
> while (MoreSQLData()) {
> my ($value, $costumer) = FetchSQLData();
> push $prods->{$value}, $costumer;
> }
>
> I receive this error: "Type of arg 1 to push must be array (not hash
> element)"
>
> To proof to myself, that it is possible to arrange data as I want, I
> executed the following code succesfully - with the desired result. Heres
> the "proof-code":
>
> my %hack_hash;
> my $prods = \%hack_hash;
> my @tmp1 = ('foo', 'foobar', 'rab');
> $prods->{'text1'} = \@tmp1;
> my @tmp2 = ('bar');
> $prods->{'text2'} = \@tmp2;
> my @tmp3 = ('oof', 'test');
> $prods->{'text3'} = \@tmp3;
>
> Can someone give me a tip? If possible at all, I'd like to do it in one
> single loop...
>
> ./Anders
------------------------------
Date: Wed, 21 Apr 2004 23:22:20 GMT
From: spamtotrash@toomuchfiction.com (Kevin Collins)
Subject: Re: Creating hash with an array as value.
Message-Id: <slrnc8e0h7.s4t.spamtotrash@doom.unix-guy.com>
In article <f977ee23.0404211432.4c0996f@posting.google.com>, christie wrote:
> Anders Christensen <anders_postkasseKEINEJUNK@hotmail.com> wrote in message news:<c65ugh$u2k$1@news.cybercity.dk>...
>> Hi, I'm selecting two columns from my database. What I want to do with the
>> fetched data is to organize it into a single hash so that each different A
>> from the database is used as the hash-key. The hash-value should be an
>> array containing every B from the database, where A and B is on the same
>> row. An example:
>> ----------------
>> | A | B |
>> ----------------
>> | text1 | foo |
>> | text2 | bar |
>> | text1 |foobar |
>> | text3 | oof |
>> | text3 | test |
>> | text1 | rab |
>> ----------------
>>
>> I want to end up with one hash, where...
>> $prods->{text1} is the array (foo, foobar, rab)
> Basically, you create a single string hash and push in a stack and use
> a perl buid in subroutine to sort it out and throw it into a foreach
> loop. that should do it. To be more efficient, you can use the
> optimized binary hash to do the job for you. Hope this will help.
>> $prods->{text2} is the array (bar)
>> $prods->{text3} is the array (oof, test)
>>
>> I've tried the following code without succes :
>> my %hack_hash;
>> my $prods = \%hack_hash;
>> SendSQL("SELECT A, B FROM table WHERE 1");
>> while (MoreSQLData()) {
>> my ($value, $costumer) = FetchSQLData();
>> push $prods->{$value}, $costumer;
Try:
push(@$prods, $value, $costumer);
or:
push(@{$prods}, $value, $costumer);
>> }
>>
>> I receive this error: "Type of arg 1 to push must be array (not hash
>> element)"
>>
>> To proof to myself, that it is possible to arrange data as I want, I
>> executed the following code succesfully - with the desired result. Heres
>> the "proof-code":
>>
>> my %hack_hash;
>> my $prods = \%hack_hash;
>> my @tmp1 = ('foo', 'foobar', 'rab');
>> $prods->{'text1'} = \@tmp1;
>> my @tmp2 = ('bar');
>> $prods->{'text2'} = \@tmp2;
>> my @tmp3 = ('oof', 'test');
>> $prods->{'text3'} = \@tmp3;
>>
>> Can someone give me a tip? If possible at all, I'd like to do it in one
>> single loop...
>>
>> ./Anders
Kevin
------------------------------
Date: Thu, 22 Apr 2004 00:29:04 -0400
From: James Willmore <jwillmore@remove.adelphia.net>
Subject: Re: Finding all open filehandles and closing them before exiting
Message-Id: <pan.2004.04.22.04.28.50.995128@remove.adelphia.net>
On Wed, 21 Apr 2004 12:15:22 -0700, Vilmos Soti wrote:
[ ... ]
> I have a signal handler which tries to unmount the disk in
> the case of a sigint, but it will fail if copy from File::Copy
> has an open filehandle on the mounted disk.
>
> Here is a short program which fully illustrates my problem:
> (I excluded the checking of return values for the sake of keeping
> this short program, well, short)
[ ... ]
> And here are the results after running the program:
>
> #################### results start ####################
>
> [root@cord pts/6 tmp]# ./a.pl
> total 12
> crw-rw-rw- 1 root root 1, 3 Dec 31 1969 devnull
> crw-rw-rw- 1 root root 1, 5 Dec 31 1969 devzero
> drwxr-xr-x 2 root root 12288 Apr 21 11:19 lost+found
> copy starts
> in function bye
> umount: /tmp/mountpoint: device is busy
> [root@cord pts/6 tmp]#
[ ... ]
Try running the script from another directory - other than /tmp.
Usually, when you get the message you have gotten, it's because you're
in the mount you're trying to unmount.
I'm not saying this is the problem, but it is worth looking at. I've done
something similar with an NFS mount and found that if I was in the mount,
I'd get a message stating the resource was busy.
HTH
--
Jim
Copyright notice: all code written by the author in this post is
released under the GPL. http://www.gnu.org/licenses/gpl.txt
for more information.
a fortune quote ...
What you don't know can hurt you, only you won't know it.
------------------------------
Date: Wed, 21 Apr 2004 21:48:36 -0700
From: "Robin" <robin @ infusedlight.net>
Subject: free source guestbook (finished)
Message-Id: <c67k6p$qkg$1@reader2.nmix.net>
#!/usr/bin/perl -wT
use Fcntl qw (:flock);
use strict;
use warnings;
use CGI qw(:all);
$CGI::POST_MAX=1024 * 100; # max 100K posts
$CGI::DISABLE_UPLOADS = 1; # no uploads
$" = '';
$ENV{'PATH'} = '/bin:/usr/bin:/usr/local/bin';
my $homepage = "http://www.infusedlight.net"; #change this to your homepage
my $string = '<--->';
my $string2 = '<---->';
my $version = '1.0.0';
my $bookfile = 'book.txt';
my $headerfile = 'header.txt';
my $footerfile = 'footer.txt';
my $DATE = getdate();
my @head = gethead ($headerfile);
my @foot = getfoot ($footerfile);
if (url_param ('action') eq "sign")
{
sign();
}
elsif (url_param ('action') eq "dosign")
{
dosign();
}
else
{
if (! -e $bookfile)
{
if (open (BOOKFILE, ">$bookfile"))
{
flock (BOOKFILE, LOCK_EX);
print BOOKFILE '';
flock (BOOKFILE, LOCK_UN);
close (BOOKFILE);
}
else
{
print header and print "<center><strong>Viewing Guestbook - Version
$version - No guests</strong><hr><a href=\"$homepage\">To
homepage</a></center>" and exit;
}
}
view (1);
}
sub sign
{
print header;
print (@head);
print <<END;
<div align="center">
<p><strong>GBOOK2 - Sign Guestbook - Version $version</strong></p>
<hr size="1">
<form name="form1" method="post" action="gbook.pl?action=dosign">
<table width="85%" border="1" align="center" cellpadding="3"
cellspacing="0" bordercolor="#660000">
<tr>
<td width="50%" bgcolor="#CCCCCC">Your name:</td>
<td width="50%" bgcolor="#999999">
<div align="center">
<input name="name" type="text" id="name">
</div></td>
</tr>
<tr>
<td bgcolor="#999999">Your email: </td>
<td bgcolor="#CCCCCC"><div align="center">
<input name="email" type="text" id="email">
</div></td>
</tr>
<tr>
<td bgcolor="#CCCCCC">Your web site name (not required):</td>
<td bgcolor="#999999"><div align="center">
<input type="text" name="webname">
</div></td>
</tr>
<tr>
<td bgcolor="#999999">Your web site URL (not required):</td>
<td bgcolor="#CCCCCC"><div align="center">
<input name="url" type="text" id="url">
</div></td>
</tr>
<tr>
<td bgcolor="#CCCCCC">Your message: </td>
<td bgcolor="#999999"><div align="center">
<textarea name="message" cols="35" rows="4"
id="message"></textarea>
</div></td>
</tr>
<tr>
<td bgcolor="#333399">
<div align="right">
<input type="submit" name="Submit" value="Submit">
</div></td>
<td bgcolor="#333399">
<div align="left">
<input type="reset" name="Submit2" value="Reset">
</div></td>
</tr>
</table>
</form>
<hr size="1">
</div>
END
print (@foot);
}
sub dosign
{
if (checkforcookie() eq "true")
{
print header;
print (@head);
print ("<center>You have already signed the guestbook once today.
Please sign it again tommorow.<hr></center>");
print (@foot);
exit;
}
my $name = param ('name');
my $email = param ('email');
my $website = param ('webname') . $string2 . param ('url');
my $message = param ('message');
if (param ('url') !~ /<.*>/ and param ('webname') !~ /<.*>/ and param
('url') !~ /^\s*$/s and param ('webname') !~ /$string2|$string/ and param
('url') !~ /$string2|$string/)
{
my (@url);
@url = split (/$string2/, $website);
if ($url[1] ne '' and $url[0] eq '')
{
$website = <<END;
<a href="$url[1]">$url[1]</a>
END
}
elsif ($url[0] ne '' and $url[1] ne '')
{
$website = <<END;
<a href="$url[1]">$url[0]</a>
END
}
elsif ($url[0] ne '' and $url[1] eq '')
{
$website = 'None';
}
elsif ($url[0] eq '' and $url[1] eq '')
{
$website = 'None';
}
}
else
{
$website = 'None';
}
if ($name !~ /^\s*$/g and $email !~ /^\s*$/g and $message !~ /^\s*$/g and
$email !~ /<.*>/s and param ('webname') !~ /<.*>/g and param ('url') !~
/<.*>/g and $name !~ /<.*>/s and $name !~ /$string/g and $message !~
/$string/g and $website !~ /$string/g and $email !~ /$string/g and $name !~
/$string2/g and $message !~ /$string2/g and $email !~ /$string2/g and param
('webname') !~ /$string2/g and param ('url') !~ /$string2/g)
{
open (BOOKFILE, ">>$bookfile") or print header and print "An error occured
during this operation: <b>$!</b>. Please press the back button on your
browser and try again.<hr>" and exit;
flock (BOOKFILE, LOCK_EX);
print BOOKFILE <<"END";
<div align="center">
<table width="75%" border="1" cellpadding="3" cellspacing="0"
bordercolor="#660000" align="center">
<tr>
<td>Date of message: </td>
<td>$DATE</td>
</tr>
<tr>
<td width="50%">Name:</td>
<td width="50%">$name</td>
</tr>
<tr>
<td width="50%">Email:</td>
<td width="50%">$email</td>
</tr>
<tr>
<td>Website:</td>
<td>$website</td>
</tr>
<tr>
<td>Message:</td>
<td>$message</td>
</tr>
</table>
<hr size="1">
$string
END
flock (BOOKFILE, LOCK_UN);
close (BOOKFILE);
chmod (0770, $bookfile);
setcookie ("gbook.pl");
exit;
}
else
{
printerror1 ();
}
}
sub view
{
my ($header) = @_;
open (BOOKFILE, $bookfile) or print header and print
"<center><strong>Viewing Guestbook - Version $version - No
guests</strong><hr><a href=\"$homepage\">To homepage</a></center>" and exit;
flock (BOOKFILE, LOCK_SH);
my @contentsofbook=<BOOKFILE>;
flock (BOOKFILE, LOCK_UN);
close (BOOKFILE);
my $contentsofbook=join('', @contentsofbook);
@contentsofbook = split (/$string/, $contentsofbook);
@contentsofbook = reverse (@contentsofbook);
my $len = @contentsofbook;
$len -= 1;
$len = "No" if ($len == -1);
my $s;
$s = 's' if ($len > 1 or $len eq "No");
print header if ($header);
print (@head);;
print <<END;
<div align="center">
<strong>GBOOK2 - Viewing Guestbook - Version $version - $len
guest$s</strong>
<hr size="1"><a href="$homepage">To homepage</a><br><br>
END
printpages();
print "<br><br>" if (@contentsofbook);
my $content;
my @contentslen;
@contentslen = @contentsofbook[(url_param ('start') - 1) ..
(url_param('end'))] if (url_param ('start') == 1);
@contentslen = @contentsofbook[(url_param ('start')) .. (url_param('end') -
1)] if (url_param ('start') > 10);
if (! @contentsofbook)
{
print "No guests.";
}
if (url_param ('start') ne '' and url ('end') ne '')
{
print @contentslen;
}
else
{
@contentslen = @contentsofbook[0 .. 10];
print @contentslen;
}
printpages();
print "<br><br>";
print <<END;
<a href="$homepage">To homepage</a></div>
END
print (@foot);
exit;
}
sub printpages
{
my ($counter, $counter2, $tempcount);
open (BOOKFILE, $bookfile) or print "An error occured during this
operation. Please try again.";
flock (BOOKFILE, LOCK_SH);
my @contentstoprint = <BOOKFILE>;
flock (BOOKFILE, LOCK_UN);
close (BOOKFILE);
$counter = 0;
$counter2 =1;
$tempcount = 0;
my $contentstoprint = join ('', @contentstoprint);
@contentstoprint = split (/$string/, $contentstoprint);
@contentstoprint = reverse (@contentstoprint);
my $content1;
print "Pages: [ <a href=\"gbook.pl?start=1&end=10\">1</a> ] " unless (!
@contentstoprint);
foreach $content1 (@contentstoprint)
{
if ($counter == 11)
{
$counter2 += 1;
print "[ <a href=\"gbook.pl?start=$tempcount&end=" , $tempcount + 10 ,
"\">$counter2</a> ] ";
if ($counter2 > 0)
{
$counter = 1;
}
else
{
$counter = 0;
}
}
$tempcount += 1;
$counter += 1;
}
}
sub printerror1
{
print header;
print (@head);
print ("<center>You did not supply the required fields or you used HTML
tags which are not allowed on this guestbook.<hr></center>");
print (@foot);
exit;
}
sub gethead
{
my ($header) = @_;
my @header;
if (-e "$header")
{
open (HEADER, "$header") or print header and print "An error occured
during this operation: <b>$!</b>. Please press the back button on your
browser and try again.<hr>" and exit;
flock (HEADER, LOCK_SH);
@header = <HEADER>;
flock (HEADER, LOCK_UN);
close (HEADER);
}
else
{
open (HEADER, ">$header") or print header and print "An error occured
during this operation: <b>$!</b>. Please press the back button on your
browser and try again.<hr>" and exit;
flock (HEADER, LOCK_EX);
print HEADER <<END;
<html>
<head>
<title>GBOOK2 Version $version</title>
</head>
<body>
END
flock (HEADER, LOCK_UN);
close (HEADER);
open (HEADER, "$header") or print header and print "An error occured
during this operation: <b>$!</b>. Please press the back button on your
browser and try again.<hr>" and exit;
flock (HEADER, LOCK_SH);
@header = <HEADER>;
flock (HEADER, LOCK_UN);
close (HEADER);
}
chmod (0770, $header);
return @header;
}
sub getfoot
{
my ($footer) = @_;
my @footer;
if (-e "$footer")
{
open (FOOTER, "$footer") or print header and print "An error occured
during this operation: <b>$!</b>. Please press the back button on your
browser and try again.<hr>" and exit;
flock (FOOTER, LOCK_SH);
@footer = <FOOTER>;
flock (FOOTER, LOCK_UN);
close (FOOTER);
}
else
{
open (FOOTER, ">$footer") or print header and print "An error occured
during this operation: <b>$!</b>. Please press the back button on your
browser and try again.<hr>" and exit;
flock (FOOTER, LOCK_EX);
print FOOTER <<END;
</body></html>
END
close (FOOTER);
open (FOOTER, "$footer") or print header and print "An error occured
during this operation: <b>$!</b>. Please press the back button on your
browser and try again.<hr>" and exit;
flock (FOOTER, LOCK_SH);
@footer = <FOOTER>;
flock (FOOTER, LOCK_UN);
close (FOOTER);
}
chmod (0770, $footer);
return @footer;
}
sub getdate {
my ($day, $mon, $year)=(localtime)[3,4,5];
$mon++; #month is returned in a 0-11 range
$year +=1900;
my $date = $mon . "/" . $day . "/" . $year;
return $date;
}
sub setcookie
{
my ($redir) = @_;
my $cookie;
$cookie = cookie (-name=>'signed', -value=>"signed", -expires=>'+1d');
print redirect (-url=>"$redir", -cookie=>"$cookie");
}
sub checkforcookie
{
my $cookieflag;
$cookieflag = '';
if (getcookie() eq 'signed')
{
$cookieflag = 'true';
}
return ($cookieflag);
}
sub getcookie
{
my $cookiein;
$cookiein = cookie ('signed');
return $cookiein;
}
-------------
yeah I know the indents suck, but I'm too lazy to clean them up. it's just
my program screws them up.
Later,
-Robin
------------------------------
Date: 22 Apr 2004 07:04:23 GMT
From: "Tassilo v. Parseval" <tassilo.parseval@rwth-aachen.de>
Subject: Re: free source guestbook (finished)
Message-Id: <c67qpm$8f0fh$1@ID-231055.news.uni-berlin.de>
Also sprach Robin:
Only some essential comments and leaving other issues (like the
idiosyncractic indenting aside):
> if (! -e $bookfile)
> {
> if (open (BOOKFILE, ">$bookfile"))
> {
> flock (BOOKFILE, LOCK_EX);
> print BOOKFILE '';
> flock (BOOKFILE, LOCK_UN);
> close (BOOKFILE);
> }
Code like this is almost always wrong. It contains a subtle
race-condition. In theory it's possible that the file does not exist by
the time of the -e check but is created by some other visitor of your
gustbook in between the -e and the open(). Sounds contrived, but it's
possible.
The code above apparently only creates the file if it does not yet
exist. You can drop this checking and creating altogether. You are later
using '>>' for opening. This will create the file for you if it isn't
already there and append otherwise.
> sub dosign
> {
> if (checkforcookie() eq "true")
You made a rather bad choice for checkforcookie()'s return value. "true"
or (in case you use that as well; haven't yet checked) are misleading as
they are both true to perl. Have a function return 1 when you mean true
and 0 (or undef) when you mean false. And then do the check like that:
if (checkforcookie()) {
> {
> print header;
> print (@head);
> print ("<center>You have already signed the guestbook once today.
> Please sign it again tommorow.<hr></center>");
> print (@foot);
> exit;
> }
> my $name = param ('name');
> my $email = param ('email');
> my $website = param ('webname') . $string2 . param ('url');
> my $message = param ('message');
> if (param ('url') !~ /<.*>/ and param ('webname') !~ /<.*>/ and param
> ('url') !~ /^\s*$/s and param ('webname') !~ /$string2|$string/ and param
> ('url') !~ /$string2|$string/)
I hate long lines such as these especially when they are formatted
badly. Line the various conditions up properly:
if (param('url') !~ /<.*>/ and
param('webname') !~ /<.*>/ and
...) {
Also, the /s in '/^\s*$/s' does nothing, so drop that.
> if ($name !~ /^\s*$/g and $email !~ /^\s*$/g and $message !~ /^\s*$/g and
> $email !~ /<.*>/s and param ('webname') !~ /<.*>/g and param ('url') !~
> /<.*>/g and $name !~ /<.*>/s and $name !~ /$string/g and $message !~
> /$string/g and $website !~ /$string/g and $email !~ /$string/g and $name !~
> /$string2/g and $message !~ /$string2/g and $email !~ /$string2/g and param
> ('webname') !~ /$string2/g and param ('url') !~ /$string2/g)
Uggh. Maybe it's time to create a function that does the above check for
you. And again, watch your regex modifiers. What is /g supposed to do in
the above matches?
> {
> open (BOOKFILE, ">>$bookfile") or print header and print "An error occured
> during this operation: <b>$!</b>. Please press the back button on your
> browser and try again.<hr>" and exit;
> flock (BOOKFILE, LOCK_EX);
Note how this will create $bookfile if it doesn't exist. This is the
behaviour you want and why cou should drop the preliminary check for its
existance further above.
> flock (BOOKFILE, LOCK_UN);
> close (BOOKFILE);
An explicit unlock is not necessary as closing the file will unlock it
for you. On older perls this can even be a problem as unlocking did not
flush the file. On recent perls however, it is ok. Just drop the LOCK_UN
stuff.
> sub view
> {
> my ($header) = @_;
> open (BOOKFILE, $bookfile) or print header and print
> "<center><strong>Viewing Guestbook - Version $version - No
> guests</strong><hr><a href=\"$homepage\">To homepage</a></center>" and exit;
> flock (BOOKFILE, LOCK_SH);
> my @contentsofbook=<BOOKFILE>;
This can become a problem one day when the gustbook is large. Also
remember that CGI scripts run concurrently. If you have ten users all
requesting to see the guestbook, you have to read keep it in memory ten
times.
> flock (BOOKFILE, LOCK_UN);
> close (BOOKFILE);
> my $contentsofbook=join('', @contentsofbook);
> @contentsofbook = split (/$string/, $contentsofbook);
> @contentsofbook = reverse (@contentsofbook);
This looks inefficient. You join it and split it again immediately
afterwards. As I recall, $string is the separator you use between
entries or so. That means you can have perl do that work for you
implicitely:
my @contentsofbook = do {
local $/ = $string;
<BOOKFILE>;
};
After that you have one entry in each array element.
> print @contentslen;
> }
> else
> {
> @contentslen = @contentsofbook[0 .. 10];
> print @contentslen;
> }
Bad variable names here. @contentslen does not contains lengths of
something. It apparently contains guastbook entries. Your variable names
should reflect that.
> sub gethead
> {
> my ($header) = @_;
> my @header;
>
> if (-e "$header")
Those quotes are not needed. Anything that is not needed should be
dropped. That's one principle of programming.
> {
> open (HEADER, "$header") or print header and print "An error occured
> during this operation: <b>$!</b>. Please press the back button on your
> browser and try again.<hr>" and exit;
> flock (HEADER, LOCK_SH);
> @header = <HEADER>;
> flock (HEADER, LOCK_UN);
> close (HEADER);
> }
> else
> {
> open (HEADER, ">$header") or print header and print "An error occured
> during this operation: <b>$!</b>. Please press the back button on your
> browser and try again.<hr>" and exit;
> flock (HEADER, LOCK_EX);
> print HEADER <<END;
> <html>
> <head>
> <title>GBOOK2 Version $version</title>
> </head>
> <body>
> END
You do things at runtime that should be done on installation time. Add
to your README that a header file has to exist. It will simplify your
script if it can be sure that certain files are there.
> sub getfoot
> {
> my ($footer) = @_;
> my @footer;
> if (-e "$footer")
> {
> open (FOOTER, "$footer") or print header and print "An error occured
> during this operation: <b>$!</b>. Please press the back button on your
> browser and try again.<hr>" and exit;
> flock (FOOTER, LOCK_SH);
> @footer = <FOOTER>;
> flock (FOOTER, LOCK_UN);
> close (FOOTER);
> }
> else
> {
> open (FOOTER, ">$footer") or print header and print "An error occured
> during this operation: <b>$!</b>. Please press the back button on your
> browser and try again.<hr>" and exit;
> flock (FOOTER, LOCK_EX);
> print FOOTER <<END;
> </body></html>
> END
> close (FOOTER);
> open (FOOTER, "$footer") or print header and print "An error occured
> during this operation: <b>$!</b>. Please press the back button on your
> browser and try again.<hr>" and exit;
> flock (FOOTER, LOCK_SH);
> @footer = <FOOTER>;
> flock (FOOTER, LOCK_UN);
> close (FOOTER);
> }
> chmod (0770, $footer);
> return @footer;
> }
Same for the footer. What you can do is provide an installation script
in your distribution that will first check the integrity and existance
of all files and, in case they aren't there, create them.
> sub getdate {
> my ($day, $mon, $year)=(localtime)[3,4,5];
> $mon++; #month is returned in a 0-11 range
> $year +=1900;
> my $date = $mon . "/" . $day . "/" . $year;
> return $date;
> }
Ah, good, you eventually got rid of the call to 'date'.
> yeah I know the indents suck, but I'm too lazy to clean them up. it's just
> my program screws them up.
Use a better editor. It's no excuse to use bad tools. If you use a sane
editor like vim or emacs, correcting the indentation is just one
key-stroke away. Also, there is
http://perltidy.sf.net/
It can't hurt to let it run over your script.
Tassilo
--
$_=q#",}])!JAPH!qq(tsuJ[{@"tnirp}3..0}_$;//::niam/s~=)]3[))_$-3(rellac(=_$({
pam{rekcahbus})(rekcah{lrePbus})(lreP{rehtonabus})!JAPH!qq(rehtona{tsuJbus#;
$_=reverse,s+(?<=sub).+q#q!'"qq.\t$&."'!#+sexisexiixesixeseg;y~\n~~dddd;eval
------------------------------
Date: Wed, 21 Apr 2004 22:21:23 -0400
From: Brad Baxter <bmb@ginger.libs.uga.edu>
Subject: Re: grepping lines above and below a pattern found
Message-Id: <Pine.A41.4.58.0404212159170.7646@ginger.libs.uga.edu>
On Wed, 21 Apr 2004, mike wrote:
> hi
>
> say i have this in a text file
>
> "Use this form to
> post your messages.
> Remember that
> it can be viewed by
> millions of people worldwide.
> For questions about posting,
> check our FAQ"
>
> what is the most commonly used way to print ,say , 2 lines above and 2
> lines below a certain pattern found such that my output is
>
> "post your messages.
> Remember that
> it can be viewed by
> millions of people worldwide.
> For questions about posting, "
>
> for the matched pattern "viewed" .
>
> thanks...
>
perl
-ne'/viewed/&&($x=$.);push@a,$_;$.>5&&shift@a;$x&&$.-$x>1&&last}{$x&&print@a'
file
Yes, it diverges from spec 2 lines from the end, but I didn't think
anybody would care. :-)
Brad
------------------------------
Date: Thu, 22 Apr 2004 12:57:43 +1000
From: Sisyphus <kalinaubears@iinet.net.au>
Subject: Re: Moving Directory using win32api::File
Message-Id: <408735d3$0$16585$5a62ac22@freenews.iinet.net.au>
Brian wrote:
> I am trying to move a directory that contains numerous other
> subdirectories, e.g. c:\temp\source\temp1, temp2, to a new directory,
> e.d. c:\test. Here is my script:
>
> use Win32API::File qw( :ALL );
> use strict;
>
> my $source = "c:\\temp\\source";
> my $destination = "c:\\test";
> my $mvError = "";
>
> MoveFileEx( $source, $destination, MOVEFILE_REPLACE_EXISTING() )
> or die "Can't move $source to $destination: ",fileLastError(),"\n";
>
> I get the following error:
>
> Can't move c:\temp\source to c:\test\: Access is denied
>
> Any ideas?
>
> When I try: MoveFile( $source, $destination )
>
> I get an error stating that the file already exists
>
>
Just a guess:
You need administrator rights to delete files from C:\temp (which would
not be unusual if that is your $ENV{'TEMP'} directory) - which is why
you get the "Access is denied" message. Creating a copy, however, poses
no problem - so that part of MoveFileEx() succeeds.
I assume that the "file already exists" message (that you subsequently
get) is, in fact, correct ?
Cheers,
Rob
--
To reply by email u have to take out the u in kalinaubears.
------------------------------
Date: Thu, 22 Apr 2004 10:31:46 +1000
From: Sisyphus <kalinaubears@iinet.net.au>
Subject: Operator overloading
Message-Id: <4087139e$0$16587$5a62ac22@freenews.iinet.net.au>
Hi,
I've overloaded the '*' operator and that works as expected - simply
have the overload subroutine return a new object that holds the value of
the multiplication.
But I thought that a '*=' overload subroutine would modify in place the
first argument that the subroutine receives, rather than create a new
object to be returned. Seems that is not the case - I find the overload
subroutine must again create a new object that holds the result of the
multiplication and return that object.
When I do '$obj *= 11;' all that really needs to be done is have $obj
modified in place. Instead I find that 'DESTROY($obj)' is being called
and that the overload function is expected to create and return a
replacement - which strikes me as being inefficient, especially in a
tight loop.
Does it have to be that way, or have I missed something ?
Cheers,
Rob
--
To reply by email u have to take out the u in kalinaubears.
------------------------------
Date: Wed, 21 Apr 2004 20:47:58 -0400
From: "Pat Deegan" <news**NO_SPAM**@psychogenic.com>
Subject: perl -d interfering with program execution?
Message-Id: <pan.2004.04.22.00.47.58.312180@psychogenic.com>
Greetings,
I originally posted this to 'comp.lang.perl' which, apparently, doesn't
exist... brilliant...
I've been having issues while debugging programs. The problems only
appear when using the '-d' switch and I get the impression it has to do
with UTF8 and regex matching but I don't know how to deal with it.
One particular example is a program which uses the DBI to connect to a
database, which will run fine normally but will hang during the call to
DBI->connect() when running under the debugger.
In order to demonstrate the problem, I inserted a couple of bread crumbs
in the DBI.pm file, in the connect() method (at the <=== comments):
1) Just after the DSN is set (around line 460):
$dsn ||= $ENV{DBI_DSN} || $ENV{DBI_DBNAME} || '' unless $old_driver;
print STDERR "DSN: $dsn\n"; # <=== output DSN as passed to connect()
2) Just after the "dbi:driver" prefix is extracted from the DSN (near line
470):
# extract dbi:driver prefix from $dsn into $1
$dsn =~ s/^dbi:(\w*?)(?:\((.*?)\))?://i
or '' =~ /()/; # ensure $1 etc are empty if match
fails
print STDERR "DSN: $dsn\nDriver: '$1'\n"; # <=== output modified DSN
# and extracted driver
Running the program therefore outputs some info on the dsn and driver to
stderr. A normal program run outputs:
$ perl ./myapp.pl
DSN: dbi:mysql:database=mydb;host=localhost
DSN: database=mydb;host=localhost
Driver: 'mysql'
The problem appears when calling the program with -d. Here the program is
loaded in the debugger and simply 'c'ontinued.
$ perl -d ./myapp.pl
Loading DB routines from perl5db.pl version 1.19 Editor support
available.
Enter h or `h h' for help, or `man perldebug' for more help.
main::(./myapp.pl:2): my $numTrials = shift || "1";
DB<1> c
DSN: dbi:mysql:database=mydb;host=localhost
DSN: dbi:mysql:database=mydb;host=localhost
Driver: ''
This is where the program hangs. It seems the (same) dsn did NOT match
the regex this time--the DSN is unchanged and the driver variable is
empty. Hitting ctrl-C will abort the loop and land me somewhere in a
UTF8-related sub, like:
utf8::SWASHGET(/usr/lib/perl5/5.8.0/utf8_heavy.pl:308): 308:
for ($key = $min; $key <= $max; $key++) {
And all this only happens with 'perl -d'. I tried tweaking a few
environment variables, like LANG and SUPPORTED, setting them as
$ export LANG=en_US
$ export SUPPORTED=en_US:en
in a vain attempt to avoid UTF-8 altogether. This had no effect.
Does anyone know how to resolve or work around this problem?
Thanks in advance for any assistance.
In case it's relevant, here's the output of 'perl -V' on this Red Hat
Linux 9 (Shrike) system:
Summary of my perl5 (revision 5.0 version 8 subversion 0) configuration:
Platform:
osname=linux, osvers=2.4.20-2.48smp, archname=i386-linux-thread-multi
uname='linux stripples.devel.redhat.com 2.4.20-2.48smp #1 smp thu feb
13 11:44:55 est 2003 i686 i686 i386 gnulinux ' config_args='-des
-Doptimize=-O2 -march=i386 -mcpu=i686 -g -Dmyhostname=localhost
-Dperladmin=root@localhost -Dcc=gcc -Dcf_by=Red Hat, Inc.
-Dinstallprefix=/usr -Dprefix=/usr -Darchname=i386-linux
-Dvendorprefix=/usr -Dsiteprefix=/usr
-Dotherlibdirs=/usr/lib/perl5/5.8.0 -Duseshrplib -Dusethreads
-Duseithreads -Duselargefiles -Dd_dosuid -Dd_semctl_semun -Di_db
-Ui_ndbm -Di_gdbm -Di_shadow -Di_syslog -Dman3ext=3pm -Duseperlio
-Dinstallusrbinperl -Ubincompat5005 -Uversiononly
-Dpager=/usr/bin/less -isr' hint=recommended, useposix=true,
d_sigaction=define usethreads=define use5005threads=undef
useithreads=define usemultiplicity=define useperlio=define
d_sfio=undef uselargefiles=define usesocks=undef use64bitint=undef
use64bitall=undef uselongdouble=undef usemymalloc=n,
bincompat5005=undef
Compiler:
cc='gcc', ccflags ='-D_REENTRANT -D_GNU_SOURCE -DTHREADS_HAVE_PIDS
-DDEBUGGING -fno-strict-aliasing -I/usr/local/include
-D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64 -I/usr/include/gdbm',
optimize='-O2 -march=i386 -mcpu=i686 -g', cppflags='-D_REENTRANT
-D_GNU_SOURCE -DTHREADS_HAVE_PIDS -DDEBUGGING -fno-strict-aliasing
-I/usr/local/include -I/usr/include/gdbm' ccversion='',
gccversion='3.2.2 20030213 (Red Hat Linux 8.0 3.2.2-1)',
gccosandvers='' intsize=4, longsize=4, ptrsize=4, doublesize=8,
byteorder=1234 d_longlong=define, longlongsize=8, d_longdbl=define,
longdblsize=12 ivtype='long', ivsize=4, nvtype='double', nvsize=8,
Off_t='off_t', lseeksize=8 alignbytes=4, prototype=define
Linker and Libraries:
ld='gcc', ldflags =' -L/usr/local/lib' libpth=/usr/local/lib /lib
/usr/lib
libs=-lnsl -lgdbm -ldb -ldl -lm -lpthread -lc -lcrypt -lutil
perllibs=-lnsl -ldl -lm -lpthread -lc -lcrypt -lutil
libc=/lib/libc-2.3.1.so, so=so, useshrplib=true, libperl=libperl.so
gnulibc_version='2.3.1'
Dynamic Linking:
dlsrc=dl_dlopen.xs, dlext=so, d_dlsymun=undef, ccdlflags='-rdynamic
-Wl,-rpath,/usr/lib/perl5/5.8.0/i386-linux-thread-multi/CORE'
cccdlflags='-fPIC', lddlflags='-shared -L/usr/local/lib'
Characteristics of this binary (from libperl):
Compile-time options: DEBUGGING MULTIPLICITY USE_ITHREADS
USE_LARGE_FILES PERL_IMPLICIT_CONTEXT Locally applied patches:
MAINT18379
Built under linux
Compiled at Feb 18 2003 22:19:53
@INC:
/usr/lib/perl5/5.8.0/i386-linux-thread-multi /usr/lib/perl5/5.8.0
/usr/lib/perl5/site_perl/5.8.0/i386-linux-thread-multi
/usr/lib/perl5/site_perl/5.8.0
/usr/lib/perl5/site_perl
/usr/lib/perl5/vendor_perl/5.8.0/i386-linux-thread-multi
/usr/lib/perl5/vendor_perl/5.8.0
/usr/lib/perl5/vendor_perl
/usr/lib/perl5/5.8.0/i386-linux-thread-multi /usr/lib/perl5/5.8.0
--
Pat Deegan,
http://www.psychogenic.com/
Registered Linux User #128131
------------------------------
Date: 22 Apr 2004 02:27:17 GMT
From: roberson@ibd.nrc-cnrc.gc.ca (Walter Roberson)
Subject: Re: regular expression module?
Message-Id: <c67ai5$fcp$1@canopus.cc.umanitoba.ca>
In article <sisczn965y5k.fsf@tripoli.fmr.com>,
Uri Guttman <uri.guttman@fmr.com> wrote:
:search google for perl-byacc
Thanks for the reference.
When I look around, I see a debian RPM at about the 2.0.5 rev
level, and I see (in a small number of places) the (1993) source for the
1.8.2 rev level. When I look in cpan, I see a distribution which
is named perl5-byacc-patches, but not perl-byacc itself.
Would you happen to have bookmarked for a 2.0.x source that isn't
an RPM?
--
Preposterous!! Where would all the calculators go?!
------------------------------
Date: Thu, 22 Apr 2004 03:09:16 GMT
From: Uri Guttman <uri@stemsystems.com>
Subject: Re: regular expression module?
Message-Id: <x765bsn1yb.fsf@mail.sysarch.com>
>>>>> "WR" == Walter Roberson <roberson@ibd.nrc-cnrc.gc.ca> writes:
WR> In article <sisczn965y5k.fsf@tripoli.fmr.com>,
WR> Uri Guttman <uri.guttman@fmr.com> wrote:
WR> :search google for perl-byacc
WR> Thanks for the reference.
WR> Would you happen to have bookmarked for a 2.0.x source that isn't
WR> an RPM?
i have never used it. i just remembered the name byacc and that it had a
perl output option and googled.
uri
--
Uri Guttman ------ uri@stemsystems.com -------- http://www.stemsystems.com
--Perl Consulting, Stem Development, Systems Architecture, Design and Coding-
Search or Offer Perl Jobs ---------------------------- http://jobs.perl.org
------------------------------
Date: 22 Apr 2004 04:59:13 GMT
From: roberson@ibd.nrc-cnrc.gc.ca (Walter Roberson)
Subject: Re: regular expression module?
Message-Id: <c67jf1$qon$1@canopus.cc.umanitoba.ca>
In article <x765bsn1yb.fsf@mail.sysarch.com>,
Uri Guttman <uri@stemsystems.com> wrote:
:i have never used it. i just remembered the name byacc and that it had a
:perl output option and googled.
Thanks, I was able to find enough pieces to put it together.
I have not compared it to Parse::Yapp as yet, though.
--
Rome was built one paycheck at a time. -- Walter Roberson
------------------------------
Date: Wed, 21 Apr 2004 23:27:51 GMT
From: Geoff Cox <geoffacox@dontspamblueyonder.co.uk>
Subject: Re: slurp not working? ideas please!
Message-Id: <1j0e809k0jhvg12jme8gk94430ahevvk60@4ax.com>
On 21 Apr 2004 15:21:14 GMT, "Tassilo v. Parseval"
<tassilo.parseval@rwth-aachen.de> wrote:
>Also sprach Geoff Cox:
>
>> On 21 Apr 2004 09:26:17 GMT, "Tassilo v. Parseval"
>><tassilo.parseval@rwth-aachen.de> wrote:
>>
>> Tassilo
>>
>> just one more question!?
>>
>> In one of the html files I have for example
>>
>><h2> jkaskdjkla </h2>
>>
>><option values etc
>>
>><p> hsajdj ka </p>
>>
>> The code is giving the data in a different order, ie
>>
>><h2> jkaskdjkla </h2>
>>
>><p> hsajdj ka </p>
>>
>><option values etc
>
>Where is this last line produced? In the snippet you provided, you only
>print text wrapped in <h2> and <p> tags so I can't see where the last
>line would come from.
Tassilo,
The option part comes from the
if ( $tagname eq 'option' ) {
main::choice( $attr->{ value } );
}
The choice sub selects other subs relevant to the path for each
<option etc. The <h2> etc is the heading for each section, followed by
<p> description and then a set of options with associated paths to
full documents...hope this is OK?
Cheers
Geoff
sub start {
my ( $self, $tagname, $attr, undef, $origtext ) = @_;
if ( $tagname eq 'h2' ) {
$in_heading = 1;
return;
}
if ( $tagname eq 'p' ) {
$in_p = 1;
return;
}
if ( $tagname eq 'option' ) {
main::choice( $attr->{ value } );
}
}
sub end {
my ( $self, $tagname, $origtext ) = @_;
if ( $tagname eq 'h2' ) {
$in_heading = 0;
return;
}
if ( $tagname eq 'p' ) {
$in_p = 0;
return;
}
}
sub text {
my ( $self, $origtext ) = @_;
print $fh "<h2>$origtext</h2> \n" if $in_heading;
print $fh "<p>$origtext</p> \n" if $in_p;
}
>Tassilo
------------------------------
Date: 22 Apr 2004 06:20:30 GMT
From: "Tassilo v. Parseval" <tassilo.parseval@rwth-aachen.de>
Subject: Re: slurp not working? ideas please!
Message-Id: <c67o7e$90858$1@ID-231055.news.uni-berlin.de>
Also sprach Geoff Cox:
> On 21 Apr 2004 15:21:14 GMT, "Tassilo v. Parseval"
><tassilo.parseval@rwth-aachen.de> wrote:
>
>>Also sprach Geoff Cox:
>>
>>> On 21 Apr 2004 09:26:17 GMT, "Tassilo v. Parseval"
>>><tassilo.parseval@rwth-aachen.de> wrote:
>>>
>>> Tassilo
>>>
>>> just one more question!?
>>>
>>> In one of the html files I have for example
>>>
>>><h2> jkaskdjkla </h2>
>>>
>>><option values etc
>>>
>>><p> hsajdj ka </p>
>>>
>>> The code is giving the data in a different order, ie
>>>
>>><h2> jkaskdjkla </h2>
>>>
>>><p> hsajdj ka </p>
>>>
>>><option values etc
>>
>>Where is this last line produced? In the snippet you provided, you only
>>print text wrapped in <h2> and <p> tags so I can't see where the last
>>line would come from.
>
> Tassilo,
>
> The option part comes from the
>
> if ( $tagname eq 'option' ) {
>
> main::choice( $attr->{ value } );
>
> }
>
> The choice sub selects other subs relevant to the path for each
><option etc. The <h2> etc is the heading for each section, followed by
><p> description and then a set of options with associated paths to
> full documents...hope this is OK?
Hmmh. When I test it with the following modification:
> sub start {
>
> my ( $self, $tagname, $attr, undef, $origtext ) = @_;
>
> if ( $tagname eq 'h2' ) {
> $in_heading = 1;
> return;
> }
>
> if ( $tagname eq 'p' ) {
> $in_p = 1;
> return;
> }
>
> if ( $tagname eq 'option' ) {
print "$origtext\n";
> }
>
> }
>
> sub end {
> my ( $self, $tagname, $origtext ) = @_;
> if ( $tagname eq 'h2' ) {
> $in_heading = 0;
> return;
> }
>
> if ( $tagname eq 'p' ) {
> $in_p = 0;
> return;
> }
> }
>
> sub text {
> my ( $self, $origtext ) = @_;
> print $fh "<h2>$origtext</h2> \n" if $in_heading;
> print $fh "<p>$origtext</p> \n" if $in_p;
>
> }
and run it on
<h2> jkaskdjkla </h2>
<p> hsajdj ka </p>
<option values="bla">
the output is the same as the input. Likewise, when I swap <h2> and <p>.
I don't see where this parser would change anything about the order of
the tags. It should preserve it.
I remember that main::choice() was this huge 'if/elsif/else' orgy. Can
you take out all but one branch and also post a few lines of HTML input
that exhibits this behaviour? I can't say much more right now because I
cannot reproduce this problem.
Tassilo
--
$_=q#",}])!JAPH!qq(tsuJ[{@"tnirp}3..0}_$;//::niam/s~=)]3[))_$-3(rellac(=_$({
pam{rekcahbus})(rekcah{lrePbus})(lreP{rehtonabus})!JAPH!qq(rehtona{tsuJbus#;
$_=reverse,s+(?<=sub).+q#q!'"qq.\t$&."'!#+sexisexiixesixeseg;y~\n~~dddd;eval
------------------------------
Date: 21 Apr 2004 12:27:12 -0400
From: Uri Guttman <uri.guttman@fmr.com>
Subject: Re: sort numeric lists
Message-Id: <sisc7jw95man.fsf@tripoli.fmr.com>
>>>>> "TKoPaP" == The King of Pots and Pans <King@ask.for.email.invalid> writes:
TKoPaP> On Wed, 21 Apr 2004 at 12:48 GMT, Uri Guttman spoke:
>> this isn't better, it is correct. see my other post where i divined
>> his problem without even seeing any code. :)
TKoPaP> I appreciate your insight in this matter. You appear to have extensive
TKoPaP> education in this area.
TKoPaP> For this problem I can only use the standard modules that come
TKoPaP> with Perl 5.6. Is perl 5.6 up to the task? Or can the solution
TKoPaP> only be had by downloading your module?
you can do a multikey sort with any perl. you can also do the multipass
sort mentioned in this thread. both require you to understand some more
about sorting in general but neither is that complicated. and you have
been given enough code and clues in this thread to solve your
problem. so hack it up in a small script and if you can't get to work,
post that code back here. but you have to do the homework first so study
the examples and ideas posted already.
uri
------------------------------
Date: Wed, 21 Apr 2004 23:23:53 -0400
From: "kums" <bckumari@yahoo.com>
Subject: sorting
Message-Id: <c503f366fec576226849e0dabbc15d8d@localhost.talkaboutprogramming.com>
consider the following numbers
i want to sort the nos as mentioned below
1.1, 1.2, 1.3, 1.4, 1.5, 1.6, 1.7, 1.8, 1.9, 1.10 1.11, 1.12, 1.13, 1.14.
but computer o/p is like
1.1,1.11,1.12,1.13,1.14,1.2,1.3,1.4,1.5,1.6,1.7,1.8,1.9
give any idea to sort
------------------------------
Date: Thu, 22 Apr 2004 04:10:46 GMT
From: "Jürgen Exner" <jurgenex@hotmail.com>
Subject: Re: sorting
Message-Id: <aBHhc.40416$L31.16103@nwrddc01.gnilink.net>
kums wrote:
> consider the following numbers
> i want to sort the nos as mentioned below
> 1.1, 1.2, 1.3, 1.4, 1.5, 1.6, 1.7, 1.8, 1.9, 1.10 1.11, 1.12, 1.13,
> 1.14.
I do not understand. Unless you are using some rather unsual mathematics 1.1
and 1.10 are the same number. Why would they be in different places?
> but computer o/p is like
> 1.1,1.11,1.12,1.13,1.14,1.2,1.3,1.4,1.5,1.6,1.7,1.8,1.9
> give any idea to sort
This looks like a correct numerical sort to me.
Or maybe you are not talking about numbers but about text? But then your
wanted output is not a lexicographical sort, either.
I guess you will have to use custom compare function. Show us what you got
and we may be able to tell you what is wrong.
jue
jue
------------------------------
Date: Thu, 22 Apr 2004 00:36:50 -0400
From: James Willmore <jwillmore@remove.adelphia.net>
Subject: Re: sorting
Message-Id: <pan.2004.04.22.04.36.44.944329@remove.adelphia.net>
On Wed, 21 Apr 2004 23:23:53 -0400, kums wrote:
> consider the following numbers
> i want to sort the nos as mentioned below
> 1.1, 1.2, 1.3, 1.4, 1.5, 1.6, 1.7, 1.8, 1.9, 1.10 1.11, 1.12, 1.13, 1.14.
>
> but computer o/p is like
> 1.1,1.11,1.12,1.13,1.14,1.2,1.3,1.4,1.5,1.6,1.7,1.8,1.9
> give any idea to sort
`perldoc -f sort`
`perldoc -q sort`
:-)
--
Jim
Copyright notice: all code written by the author in this post is
released under the GPL. http://www.gnu.org/licenses/gpl.txt
for more information.
a fortune quote ...
A truly wise man never plays leapfrog with a unicorn.
------------------------------
Date: 21 Apr 2004 23:03:30 -0600
From: Jim Cochrane <jtc@shell.dimensional.com>
Subject: Re: sorting
Message-Id: <slrnc8ekh2.5fm.jtc@shell.dimensional.com>
In article <c503f366fec576226849e0dabbc15d8d@localhost.talkaboutprogramming.com>, kums wrote:
> consider the following numbers
> i want to sort the nos as mentioned below
> 1.1, 1.2, 1.3, 1.4, 1.5, 1.6, 1.7, 1.8, 1.9, 1.10 1.11, 1.12, 1.13, 1.14.
>
> but computer o/p is like
> 1.1,1.11,1.12,1.13,1.14,1.2,1.3,1.4,1.5,1.6,1.7,1.8,1.9
> give any idea to sort
You appear to want each item sorted according to its left, then its right
field (with '.' as the field separator), so the data needs to be treated
this way, as having two fields. I've added some extra data (2.1,
2.2, ...) to do a more complete test.
#!/usr/bin/perl
use strict;
use warnings;
my $data = <<EOM
1.2 1.4 2.13 1.5 2.4 1.14 1.10 1.1 2.5 2.11 2.12 1.7 1.12
2.2 2.1 2.3
1.13 1.3 2.6 2.7 1.8 2.8 1.6 2.9 2.10 1.11 1.9
EOM
;
print "data: $data\n";
my @unsorted = split " ", $data;
print "unsorted:\n", join(", ", @unsorted), "\n";
my @sorted = sort {
my ($a1, $a2) = split /\./, $a;
my ($b1, $b2) = split /\./, $b;
$a1 <=> $b1 || $a2 <=> $b2;
} @unsorted;
print "sorted:\n", join(", ", @sorted), "\n";
--
Jim Cochrane; jtc@dimensional.com
[When responding by email, include the term non-spam in the subject line to
get through my spam filter.]
------------------------------
Date: Wed, 21 Apr 2004 21:21:50 -0500
From: Tad McClellan <tadmc@augustmail.com>
Subject: Re: variable interpolation failed :-(
Message-Id: <slrnc8eb1u.2ag.tadmc@magna.augustmail.com>
fred <fred@no-spam.fr> wrote:
> very elegant solution ;-)
What is?
--
Tad McClellan SGML consulting
tadmc@augustmail.com Perl programming
Fort Worth, Texas
------------------------------
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.
NOTE: due to the current flood of worm email banging on ruby, the smtp
server on ruby has been shut off until further notice.
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 6443
***************************************
