[23440] in Perl-Users-Digest
Perl-Users Digest, Issue: 5655 Volume: 10
daemon@ATHENA.MIT.EDU (Perl-Users Digest)
Tue Oct 14 06:06:13 2003
Date: Tue, 14 Oct 2003 03: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 Tue, 14 Oct 2003 Volume: 10 Number: 5655
Today's topics:
Action Based on File's Last Modification Time: Is One <nospam_for_jkeen@concentric.net>
Re: Action Based on File's Last Modification Time: Is <grazz@pobox.com>
Re: App getting bigger and bigger <nobody@nowhere.com>
cannot use bitwise AND-Operator on hex-scalars from ARG <r.reichenberg@gmx.de>
Re: cannot use bitwise AND-Operator on hex-scalars from <josef.moellers@fujitsu-siemens.com>
Re: cannot use bitwise AND-Operator on hex-scalars from <kalinaubears@iinet.net.au>
Re: cannot use bitwise AND-Operator on hex-scalars from <kuujinbo@hotmail.com>
Re: CGI.pm File Upload doesn't work (blocks) on my Serv <bjoern_p1@gmx.net>
Re: help: need suggestion on an IDE for learning perl.. <usenet@dwall.fastmail.fm>
Re: How To activate command line history in debugger? <k.kronschnabl-nospam@ica-intercom-akademie.de>
How to update entries in a file <no@spam.here>
Re: How to update entries in a file <r.reichenberg@gmx.de>
Re: Named Pipe Permissions Question <flavell@mail.cern.ch>
Net::IRC::DCC <asdf@asdf.com>
Digest Administrivia (Last modified: 6 Apr 01) (Perl-Users-Digest Admin)
----------------------------------------------------------------------
Date: 14 Oct 2003 01:58:50 GMT
From: "James E Keenan" <nospam_for_jkeen@concentric.net>
Subject: Action Based on File's Last Modification Time: Is One Approach Better?
Message-Id: <bmfl8q$t7@dispatch.concentric.net>
Let's say that I wish to process every file in a given directory that was
last modified more than 14 days ago. From various parts of the Camel book,
it appears I could test the age of the file in 1 of 2 ways.
### approach using 'stat' ### Camel pp 800-801
my ($file, $days_ago, $DAY, $earlier);
$DAY = 60 * 60 * 24;
$days_ago = 14;
$earlier = time() - ($days_ago * $DAY);
...
if ( (stat($file))[9] < $earlier ) {
# process $file
}
### approach using file test operator '-M' ### Camel pp 98-100
if (-M $file > 14) {
# process $file
}
### [end code samples] ###
For the purpose of argument, let's assume that the "at the point the Perl
script started running" proviso for the file test operator is not meaningful
from the current time. Given that assumption, is there any particular
reason to prefer the more verbose approach using 'stat' to the simple one
using the '-M'?
jimk
------------------------------
Date: Tue, 14 Oct 2003 02:24:04 GMT
From: Steve Grazzini <grazz@pobox.com>
Subject: Re: Action Based on File's Last Modification Time: Is One Approach Better?
Message-Id: <87Jib.19026$0I6.7665@nwrdny03.gnilink.net>
James E Keenan <nospam_for_jkeen@concentric.net> wrote:
> Let's say that I wish to process every file in a given directory
> that was last modified more than 14 days ago. From various parts
> of the Camel book, it appears I could test the age of the file in
> 1 of 2 ways.
[ using stat() and -M ]
> For the purpose of argument, let's assume that the "at the point
> the Perl script started running" proviso for the file test operator
> is not meaningful from the current time.
This is what trips people, though, when they use it in long-running
daemons, mod_perl handlers, etc.
> Given that assumption, is there any particular reason to prefer the
> more verbose approach using 'stat' to the simple one using the '-M'?
No. -M is simpler, easier to read, and probably a bit faster.
--
Steve
------------------------------
Date: Tue, 14 Oct 2003 00:47:55 -0400
From: "Yannick Turgeon" <nobody@nowhere.com>
Subject: Re: App getting bigger and bigger
Message-Id: <pan.2003.10.14.04.47.49.690130@nowhere.com>
Forget about this.
One of the package I use was storing EVERY webpage I was downloading to
provide some other functionality. You can imagine!
Yannick
Le Mon, 13 Oct 2003 15:23:09 -0400, Yannick Turgeon a écrit :
> Hello all,
>
> I just make a program in perl. My first one in fact. Which use some WWW
> packages to start a http session, log to a site, download some pages and treat
> these data.
>
> The problem I have now it's that while executing, my program is taking
> more and more memory. What should I look for to solve this? Perl has a
> garbagge collector so I did not worry freing anything. Should I?
>
> The program is a endless loop (while(1)...). At each iteration it creates
> objects inside the only function called:
>
> Create my objects Obj
> while(1){
> Obj->CallMyFunction();
> sleep(60);
> }
>
> I supposed every object and variable created inside CallMyFunction() were
> freed from memory after quiting the function. Inside this function, I
> create another type of object which has "Obj" has member variable. Could it
> cause a problem. I do not store anything in Obj at each iteration. It has
> its initial variables and they don't change.
>
> Hope it's clear and thanks for your help.
>
> Yannick
------------------------------
Date: Tue, 14 Oct 2003 10:51:44 +0200
From: "Roland Reichenberg" <r.reichenberg@gmx.de>
Subject: cannot use bitwise AND-Operator on hex-scalars from ARGV[0]
Message-Id: <bmgebo$jcm$1@news.nrw.net>
Hi NG,
here is my littel perl scirpt:
===========================
#!/usr/bin/perl
$var1 = $ARGV[0];
$var2 = 0xaffe;
$res = $var1 & $var2;
print $res;
===========================
if I start this script from command line like this:
user@host > ./my.perl.test.pl 0xcafe
I get an error message that says: "Argument "0xcafe" isn't numeric in
bitwise and (&) in line...
What's going wrong? We have perl V5.8.0 installed on a linux box.
Thank you for your answers!
Regards,
Roland
------------------------------
Date: Tue, 14 Oct 2003 11:44:29 +0200
From: Josef =?iso-8859-1?Q?M=F6llers?= <josef.moellers@fujitsu-siemens.com>
Subject: Re: cannot use bitwise AND-Operator on hex-scalars from ARGV[0]
Message-Id: <3F8BC57D.F4460007@fujitsu-siemens.com>
Roland Reichenberg wrote:
> =
> Hi NG,
> =
> here is my littel perl scirpt:
> =
> =3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
> #!/usr/bin/perl
> =
> $var1 =3D $ARGV[0];
> =
> $var2 =3D 0xaffe;
> =
> $res =3D $var1 & $var2;
> =
> print $res;
> =3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
> =
> if I start this script from command line like this:
> =
> user@host > ./my.perl.test.pl 0xcafe
> =
> I get an error message that says: "Argument "0xcafe" isn't numeric in
> bitwise and (&) in line...
> =
> What's going wrong? We have perl V5.8.0 installed on a linux box.
You have a string, not an integer.
Use eval($ARGV[0]);
You can use eval to check for invalid numbers, too.
-- =
Josef M=F6llers (Pinguinpfleger bei FSC)
If failure had no penalty success would not be a prize
-- T. Pratchett
------------------------------
Date: Tue, 14 Oct 2003 19:43:51 +1000
From: Sisyphus <kalinaubears@iinet.net.au>
Subject: Re: cannot use bitwise AND-Operator on hex-scalars from ARGV[0]
Message-Id: <3f8bc60c$0$23599$5a62ac22@freenews.iinet.net.au>
Roland Reichenberg wrote:
> Hi NG,
>
> here is my littel perl scirpt:
>
> ===========================
> #!/usr/bin/perl
>
> $var1 = $ARGV[0];
That's effectively the same as:
$var1 = '0xcafe';
(given that the command line arg is, in fact, 0xcafe), which produces
the same error.
Try, instead:
$var1 = hex($ARGV[0]);
It should then work, irrespective of whether the command line arg is
given as 0xcafe or simply cafe.
Hth.
Cheers,
Rob
--
To reply by email u have to take out the u in kalinaubears.
------------------------------
Date: Tue, 14 Oct 2003 18:41:32 +0900
From: ko <kuujinbo@hotmail.com>
Subject: Re: cannot use bitwise AND-Operator on hex-scalars from ARGV[0]
Message-Id: <bmgggg$jer$1@pin3.tky.plala.or.jp>
Roland Reichenberg wrote:
> Hi NG,
>
> here is my littel perl scirpt:
>
> ===========================
> #!/usr/bin/perl
>
> $var1 = $ARGV[0];
>
> $var2 = 0xaffe;
>
> $res = $var1 & $var2;
>
> print $res;
> ===========================
>
> if I start this script from command line like this:
>
> user@host > ./my.perl.test.pl 0xcafe
>
> I get an error message that says: "Argument "0xcafe" isn't numeric in
> bitwise and (&) in line...
>
> What's going wrong? We have perl V5.8.0 installed on a linux box.
>
> Thank you for your answers!
>
> Regards,
>
> Roland
>
>
>
Try using oct():
$var1 = oct($var1) if $var1 =~ /^0/;
HTH - keith
------------------------------
Date: Tue, 14 Oct 2003 08:55:58 +0200
From: Bjoern <bjoern_p1@gmx.net>
Subject: Re: CGI.pm File Upload doesn't work (blocks) on my Server (but works on my Desktop)
Message-Id: <bmg6ic$kbpf9$1@ID-142197.news.uni-berlin.de>
Alan J. Flavell wrote:
> On Mon, 13 Oct 2003, Bjoern wrote:
>
>
>>OK, made a short version now, and it seems as if CGI.pm is not at fault.
>>I don't think the script is even ever called, as even if I point the
>>upload form to a non-existant script, it still blocks forever.
>>
>>So you'll probably tell me to go away.
[...]
OK, the problem cause is really embarrassing: apparently my desktop
computers firewall (Kerio) was blocking the file uploads. I still don't
know why, because it let's other http requests pass, but at least I can
test my script by temporarily disabling the firewall.
So it wasn't perl-related after all. But for completeness sake I wanted
to post the solution here anyway, in case somebody with a similiar
problem is searching the archives.
[...]
>>----------- Script -----------
>>
>>#!/usr/bin/perl
>
>
> Guess who isn't paying proper attention to this group's posting
> guidelines? The regulars hate that. It's demeaning for a human being
> to be asked to do the job of a machine.
I am not sure what I did wrong here? I was asked to post code, and in
the guidelines I just found: "First make a short (less than 20-30 lines)
and complete program that illustrates the problem you are having. People
should be able to run your program by copy/pasting the code from your
article.". Or is it that the #!/usr/bin/perl doesn't belong into the script?
Just trying to understand? Sorry I didn't read the guidelines
beforehand, but it isn't obvious to look for 'guidelines', I only
searched for the faq.
Thanks for all the helpful replies!
Bjoern
--
Let's not weep for their evil deeds,
but for their lack of imagination
(Nick Cave)
------------------------------
Date: Tue, 14 Oct 2003 04:45:24 GMT
From: "David K. Wall" <usenet@dwall.fastmail.fm>
Subject: Re: help: need suggestion on an IDE for learning perl...
Message-Id: <Xns94147B0EA8B3dkwwashere@63.240.76.16>
[top-posting rearranged]
<orbii@hotmail.com> wrote:
> "David K. Wall" <usenet@dwall.fastmail.fm> wrote in message
> news:Xns9413BD9FA9694dkwwashere@63.240.76.16...
>> <orbii@hotmail.com> wrote:
>>
[snip]
>> > please be generous and point me a direction on which ide you're
>> > using and how to add extension to that ide for a proper color syntax
>> > of perl? or is that even possible?
>> perldoc -q editor
> woah, it is a big list, THX MATE!!!!
You're welcome.
Something else you should know: top-posting is frowned upon in this
newsgroup. See http://web.presby.edu/~nnqadmin/nnq/nquote.html for some
reasons why. The practical reason for not top-posting is because folks here
don't like it. They're more likely to help if you follow the accepted
practice.
------------------------------
Date: Tue, 14 Oct 2003 08:05:24 +0200
From: Kurt Kronschnabl <k.kronschnabl-nospam@ica-intercom-akademie.de>
Subject: Re: How To activate command line history in debugger?
Message-Id: <bmg588$j5t$07$1@news.t-online.com>
Peter Scott wrote:
> I just wasted a bunch of time replying to your
> posted address, reading the bounce, resending without the "-nospam", and
> reading the bounce from that.
It's indeed my fault. i just saw my miswritten address. I am very sorry
about that, because you are so engaged to help me. I corrected it now.
But I must include the nospam string in it. I hope you understand this.
> Maybe it's something wrong with your terminal settings. Write a small
> application that uses Term::ReadKey and run it fom the same shell that
> you're running the debugger to see if it works properly.
I'll do this.
> Also, see whether the debugger loaded the module properly. Do
>
> perl -de 0
>
> and type
>
> x \%INC
That's really interesting: The result is:
DB<3> x \$INC
0 SCALAR(0x813a9f0)
-> undef
BUT: $INC has a content with perl -V:
/etc/perl
/usr/local/lib/perl/5.8.0
/usr/local/share/perl/5.8.0
/usr/lib/perl5
/usr/share/perl5
/usr/lib/perl/5.8.0
/usr/share/perl/5.8.0
/usr/local/lib/site_perl
> Hardly guaranteed, unless you know of other Knoppix users with the same
> problem, in which case you should file a bug report.
It's a bug report worth in every case.
In the case of Java the environment variable JAVA_HOME has been missing
set. Does perl need a certain one as well? I did'nt discover any under Suse.
Regards, Kurt
------------------------------
Date: Tue, 14 Oct 2003 09:20:56 GMT
From: "John" <no@spam.here>
Subject: How to update entries in a file
Message-Id: <YdPib.150444$bo1.70104@news-server.bigpond.net.au>
Hi,
I have a file entry in the following format:
<Employee number="111222">
<Department>Sales</Department>
<Surname>Jones</Surname>
<Name>Tom</Name>
</Employee number>
Then, I'd like to update another file with the above entry. What I need
though is to first check whether this entry already exists in the file to be
updated.
If the entry does not exist then I just append the above record to the file.
But if the entry exists then I need to delete the old entry first and
replace it with the new one [by just appending it to the file's end - no
need to put it back in the same spot].
I recognise that I will probably need to read the old file into a temporary
one, do my editing there and save the results to a new file. The new file
will then be renamed to the old file. Is each line in the file entry meant
to become a hash element?
Can someone give me some pointers as to where I should start looking?
Thanks.
------------------------------
Date: Tue, 14 Oct 2003 11:24:59 +0200
From: "Roland Reichenberg" <r.reichenberg@gmx.de>
Subject: Re: How to update entries in a file
Message-Id: <bmgga2$l4i$1@news.nrw.net>
Hi John,
> I have a file entry in the following format:
> <Employee number="111222">
> <Department>Sales</Department>
> <Surname>Jones</Surname>
> <Name>Tom</Name>
> </Employee number>
This looks like XML-formated data
> Can someone give me some pointers as to where I should start looking?
Have you tried the perl xml module?
Maybe this module includes the methods that you need.
Look at www.cpan.org for more information about perl and xml.
Regards,
Roland
------------------------------
Date: Tue, 14 Oct 2003 02:49:57 +0200
From: "Alan J. Flavell" <flavell@mail.cern.ch>
Subject: Re: Named Pipe Permissions Question
Message-Id: <Pine.LNX.4.53.0310140246340.8208@lxplus091.cern.ch>
On Mon, Oct 13, mooseshoes inscribed on the eternal scroll:
[unattributed quote]
> > So it wasn't a perl problem at all then. Steve G. was
> > correct in that assessment.
good advice...
> <<< Due to the fact the code is a Perl script, it, by definition, includes
> the possibility that the trouble was Perl-related,
Your attitude gets its just desserts. Please don't change your
posting alias.
------------------------------
Date: Tue, 14 Oct 2003 08:53:40 GMT
From: "n1zerd" <asdf@asdf.com>
Subject: Net::IRC::DCC
Message-Id: <oQOib.11492$ZH4.8183@twister.socal.rr.com>
Does anyone know what the code should look like under Net::IRC::DCC::CHAT to add a close sub, so that I can allow a program to close a dcc chat session when it wants to?
This is what Net::IRC::DCC::GET has, but I don't think it works for CHAT...if it does, I can't figure out the syntax in the program that calls it then...so far the whole program quits when trying to call this when pasted under CHAT...
sub close {
my ($self, $sock) = @_;
$self->{_fh}->close;
$self->{_parent}->parent->removeconn($self);
$self->{_parent}->handler(Net::IRC::Event->new('dcc_close',
$self->{_nick},
$self->{_socket},
$self->{_type}));
$self->{_socket}->close;
return;
}
here's the whole module DCC module:
#####################################################################
# #
# Net::IRC -- Object-oriented Perl interface to an IRC server #
# #
# DCC.pm: An object for Direct Client-to-Client connections. #
# #
# Copyright (c) 1997 Greg Bacon & Dennis Taylor. #
# All rights reserved. #
# #
# This module is free software; you can redistribute or #
# modify it under the terms of Perl's Artistic License. #
# #
#####################################################################
# $Id: DCC.pm,v 1.1.1.1 2002/11/14 17:32:15 jmuhlich Exp $
package Net::IRC::DCC;
use strict;
# --- #perl was here! ---
#
# The comments scattered throughout this module are excerpts from a
# log saved from one particularly surreal night on #perl. Ahh, the
# trials of being young, single, and drunk...
#
# ---------------------
# \merlyn has offered the shower to a randon guy he met in a bar.
# fimmtiu: Shower?
# \petey raises an eyebrow at \merlyn
# \merlyn: but he seems like a nice trucker guy...
# archon: you offered to shower with a random guy?
# Methods that can be shared between the various DCC classes.
package Net::IRC::DCC::Connection;
use Carp;
use Socket; # need inet_ntoa...
use strict;
sub fixaddr {
my ($address) = @_;
chomp $address; # just in case, sigh.
if ($address =~ /^\d+$/) {
return inet_ntoa(pack "N", $address);
} elsif ($address =~ /^[12]?\d{1,2}\.[12]?\d{1,2}\.[12]?\d{1,2}\.[12]?\d{1,2}$/) {
return $address;
} elsif ($address =~ tr/a-zA-Z//) { # Whee! Obfuscation!
return inet_ntoa(((gethostbyname($address))[4])[0]);
} else {
return;
}
}
sub bytes_in {
return shift->{_bin};
}
sub bytes_out {
return shift->{_bout};
}
sub nick {
return shift->{_nick};
}
sub socket {
return shift->{_socket};
}
sub time {
return time - shift->{_time};
}
sub debug {
return shift->{_debug};
}
# Changes here 1998-04-01 by MJD
# Optional third argument `$block'.
# If true, don't break the input into lines... just process it in blocks.
sub _getline {
my ($self, $sock, $block) = @_;
my ($input, $line);
my $frag = $self->{_frag};
if (defined $sock->recv($input, 10240)) {
$frag .= $input;
if (length($frag) > 0) {
warn "Got ". length($frag) ." bytes from $sock\n"
if $self->{_debug};
if ($block) { # Block mode (GET)
return $input;
} else { # Line mode (CHAT)
# We're returning \n's 'cause DCC's need 'em
my @lines = split /\012/, $frag, -1;
$lines[-1] .= "\012";
$self->{_frag} = ($frag !~ /\012$/) ? pop @lines : '';
return (@lines);
}
}
else {
# um, if we can read, i say we should read more than 0
# besides, recv isn't returning undef on closed
# sockets. getting rid of this connection...
warn "recv() received 0 bytes in _getline, closing connection.\n"
if $self->{_debug};
$self->{_parent}->handler(Net::IRC::Event->new('dcc_close',
$self->{_nick},
$self->{_socket},
$self->{_type}));
$self->{_parent}->parent->removefh($sock);
$self->{_socket}->close;
$self->{_fh}->close if $self->{_fh};
return;
}
} else {
# Error, lets scrap this connection
warn "recv() returned undef, socket error in _getline()\n"
if $self->{_debug};
$self->{_parent}->handler(Net::IRC::Event->new('dcc_close',
$self->{_nick},
$self->{_socket},
$self->{_type}));
$self->{_parent}->parent->removefh($sock);
$self->{_socket}->close;
$self->{_fh}->close if $self->{_fh};
return;
}
}
sub DESTROY {
my $self = shift;
# Only do the Disconnection Dance of Death if the socket is still
# live. Duplicate dcc_close events would be a Bad Thing.
if ($self->{_socket}->opened) {
$self->{_parent}->handler(Net::IRC::Event->new('dcc_close',
$self->{_nick},
$self->{_socket},
$self->{_type}));
$self->{_socket}->close;
close $self->{_fh} if $self->{_fh};
$self->{_parent}->{_parent}->parent->removeconn($self);
}
}
sub peer {
return ( $_[0]->{_nick}, "DCC " . $_[0]->{_type} );
}
# -- #perl was here! --
# orev: hehe...
# Silmaril: to, not with.
# archon: heheh
# tmtowtdi: \merlyn will be hacked to death by a psycho
# archon: yeah, but with is much more amusing
# Connection handling GETs
package Net::IRC::DCC::GET;
use IO::Socket;
use Carp;
use strict;
@Net::IRC::DCC::GET::ISA = qw(Net::IRC::DCC::Connection);
sub new {
my ($class, $container, $nick, $address,
$port, $size, $filename, $handle, $offset) = @_;
my ($sock, $fh);
# get the address into a dotted quad
$address = &Net::IRC::DCC::Connection::fixaddr($address);
return if $port < 1024 or not defined $address or $size < 1;
$fh = defined $handle ? $handle : IO::File->new(">$filename");
unless(defined $fh) {
carp "Can't open $filename for writing: $!";
$sock = new IO::Socket::INET( Proto => "tcp",
PeerAddr => "$address:$port" ) and
$sock->close();
return;
}
binmode $fh; # I love this next line. :-)
ref $fh eq 'GLOB' ? select((select($fh), $|++)[0]) : $fh->autoflush(1);
$sock = new IO::Socket::INET( Proto => "tcp",
PeerAddr => "$address:$port" );
if (defined $sock) {
$container->handler(Net::IRC::Event->new('dcc_open',
$nick,
$sock,
'get',
'get', $sock));
} else {
carp "Can't connect to $address: $!";
close $fh;
return;
}
$sock->autoflush(1);
my $self = {
_bin => defined $offset ? $offset : 0, # bytes recieved so far
_bout => 0, # Bytes we've sent
_connected => 1,
_debug => $container->debug,
_fh => $fh, # FileHandle we will be writing to.
_filename => $filename,
_frag => '',
_nick => $nick, # Nick of person on other end
_parent => $container,
_size => $size, # Expected size of file
_socket => $sock, # Socket we're reading from
_time => time,
_type => 'GET',
};
bless $self, $class;
return $self;
}
# -- #perl was here! --
# \merlyn: we were both ogling a bartender named arley
# \merlyn: I mean carle
# \merlyn: carly
# Silmaril: man merlyn
# Silmaril: you should have offered HER the shower.
# \petey: all three of them?
sub parse {
my ($self) = shift;
my $line = $self->_getline($_[0], 'BLOCKS');
next unless defined $line;
unless(print {$self->{_fh}} $line) {
carp ("Error writing to " . $self->{_filename} . ": $!");
close $self->{_fh};
$self->{_parent}->parent->removeconn($self);
$self->{_parent}->handler(Net::IRC::Event->new('dcc_close',
$self->{_nick},
$self->{_socket},
$self->{_type}));
$self->{_socket}->close;
return;
}
$self->{_bin} += length($line);
# confirm the packet we've just recieved
unless ( $self->{_socket}->send( pack("N", $self->{_bin}) ) ) {
carp "Error writing to DCC GET socket: $!";
close $self->{_fh};
$self->{_parent}->parent->removeconn($self);
$self->{_parent}->handler(Net::IRC::Event->new('dcc_close',
$self->{_nick},
$self->{_socket},
$self->{_type}));
$self->{_socket}->close;
return;
}
$self->{_bout} += 4;
# The file is done.
# If we close the socket, the select loop gets screwy because
# it won't remove its reference to the socket.
if ( $self->{_size} and $self->{_size} <= $self->{_bin} ) {
close $self->{_fh};
$self->{_parent}->parent->removeconn($self);
$self->{_parent}->handler(Net::IRC::Event->new('dcc_close',
$self->{_nick},
$self->{_socket},
$self->{_type}));
$self->{_socket}->close;
return;
}
$self->{_parent}->handler(Net::IRC::Event->new('dcc_update',
$self->{_nick},
$self,
$self->{_type},
$self ));
}
sub filename {
return shift->{_filename};
}
sub size {
return shift->{_size};
}
sub close {
my ($self, $sock) = @_;
$self->{_fh}->close;
$self->{_parent}->parent->removeconn($self);
$self->{_parent}->handler(Net::IRC::Event->new('dcc_close',
$self->{_nick},
$self->{_socket},
$self->{_type}));
$self->{_socket}->close;
return;
}
# -- #perl was here! --
# \merlyn: I can't type... she created a numbner of very good drinks
# \merlyn: She's still at work
# \petey resists mentioning that there's "No manual entry
# for merlyn."
# Silmaril: Haven't you ever seen swingers?
# \merlyn: she's off tomorrow... will meet me at the bar at 9:30
# Silmaril: AWWWWwwww yeeeaAAHH.
# archon: waka chica waka chica
# Connection handling SENDs
package Net::IRC::DCC::SEND;
@Net::IRC::DCC::SEND::ISA = qw(Net::IRC::DCC::Connection);
use IO::File;
use IO::Socket;
use Carp;
use strict;
sub new {
my ($class, $container, $nick, $filename, $blocksize) = @_;
my ($size, $port, $fh, $sock, $select);
$blocksize ||= 1024;
# Shell-safe DCC filename stuff. Trying to prank-proof this
# module is rather difficult.
$filename =~ tr/a-zA-Z.+0-9=&()[]%\-\\\/:,/_/c;
$fh = new IO::File $filename;
unless (defined $fh) {
carp "Couldn't open $filename for reading: $!";
return;
}
binmode $fh;
$fh->seek(0, SEEK_END);
$size = $fh->tell;
$fh->seek(0, SEEK_SET);
$sock = new IO::Socket::INET( Proto => "tcp",
Listen => 1);
unless (defined $sock) {
carp "Couldn't open DCC SEND socket: $!";
$fh->close;
return;
}
$container->ctcp('DCC SEND', $nick, $filename,
unpack("N",inet_aton($container->hostname())),
$sock->sockport(), $size);
$sock->autoflush(1);
my $self = {
_bin => 0, # Bytes we've recieved thus far
_blocksize => $blocksize,
_bout => 0, # Bytes we've sent
_debug => $container->debug,
_fh => $fh, # FileHandle we will be reading from.
_filename => $filename,
_frag => '',
_nick => $nick,
_parent => $container,
_size => $size, # Size of file
_socket => $sock, # Socket we're writing to
_time => 0, # This gets set by Accept->parse()
_type => 'SEND',
};
bless $self, $class;
$sock = Net::IRC::DCC::Accept->new($sock, $self);
unless (defined $sock) {
carp "Error in accept: $!";
$fh->close;
return;
}
return $self;
}
# -- #perl was here! --
# fimmtiu: So a total stranger is using your shower?
# \merlyn: yes... a total stranger is using my hotel shower
# Stupid coulda sworn \merlyn was married...
# \petey: and you have a date.
# fimmtiu: merlyn isn't married.
# \petey: not a bad combo......
# \merlyn: perhaps a adate
# \merlyn: not maerried
# \merlyn: not even sober. --)
sub parse {
my ($self, $sock) = @_;
my $size = ($self->_getline($sock, 1))[0];
my $buf;
# i don't know how useful this is, but let's stay consistent
$self->{_bin} += 4;
unless (defined $size) {
# Dang! The other end unexpectedly canceled.
carp (($self->peer)[1] . " connection to " .
($self->peer)[0] . " lost");
$self->{_fh}->close;
$self->{_parent}->parent->removefh($sock);
$self->{_parent}->handler(Net::IRC::Event->new('dcc_close',
$self->{_nick},
$self->{_socket},
$self->{_type}));
$self->{_socket}->close;
return;
}
$size = unpack("N", $size);
if ($size >= $self->{_size}) {
if ($self->{_debug}) {
warn "Other end acknowledged entire file ($size >= ",
$self->{_size}, ")";
}
# they've acknowledged the whole file, we outtie
$self->{_fh}->close;
$self->{_parent}->parent->removeconn($self);
$self->{_parent}->handler(Net::IRC::Event->new('dcc_close',
$self->{_nick},
$self->{_socket},
$self->{_type}));
$self->{_socket}->close;
return;
}
# we're still waiting for acknowledgement,
# better not send any more
return if $size < $self->{_bout};
unless (defined $self->{_fh}->read($buf,$self->{_blocksize})) {
if ($self->{_debug}) {
warn "Failed to read from source file in DCC SEND!";
}
$self->{_fh}->close;
$self->{_parent}->parent->removeconn($self);
$self->{_parent}->handler(Net::IRC::Event->new('dcc_close',
$self->{_nick},
$self->{_socket},
$self->{_type}));
$self->{_socket}->close;
return;
}
unless($self->{_socket}->send($buf)) {
if ($self->{_debug}) {
warn "send() failed horribly in DCC SEND"
}
$self->{_fh}->close;
$self->{_parent}->parent->removeconn($self);
$self->{_parent}->handler(Net::IRC::Event->new('dcc_close',
$self->{_nick},
$self->{_socket},
$self->{_type}));
$self->{_socket}->close;
return;
}
$self->{_bout} += length($buf);
$self->{_parent}->handler(Net::IRC::Event->new('dcc_update',
$self->{_nick},
$self,
$self->{_type},
$self ));
return 1;
}
# -- #perl was here! --
# fimmtiu: Man, merlyn, you must be drunk to type like that. :)
# \merlyn: too many longislands.
# \merlyn: she made them strong
# archon: it's a plot
# \merlyn: not even a good amoun tof coke
# archon: she's in league with the guy in your shower
# archon: she gets you drunk and he takes your wallet!
# handles CHAT connections
package Net::IRC::DCC::CHAT;
@Net::IRC::DCC::CHAT::ISA = qw(Net::IRC::DCC::Connection);
use IO::Socket;
use Carp;
use strict;
sub new {
my ($class, $container, $type, $nick, $address, $port) = @_;
my ($sock, $self);
if ($type) {
# we're initiating
$sock = new IO::Socket::INET( Proto => "tcp",
Listen => 1);
unless (defined $sock) {
carp "Couldn't open DCC CHAT socket: $!";
return;
}
$sock->autoflush(1);
$container->ctcp('DCC CHAT', $nick, 'chat',
unpack("N",inet_aton($container->hostname)),
$sock->sockport());
$self = {
_bin => 0, # Bytes we've recieved thus far
_bout => 0, # Bytes we've sent
_connected => 1,
_debug => $container->debug,
_frag => '',
_nick => $nick, # Nick of the client on the other end
_parent => $container,
_socket => $sock, # Socket we're reading from
_time => 0, # This gets set by Accept->parse()
_type => 'CHAT',
};
bless $self, $class;
$sock = Net::IRC::DCC::Accept->new($sock, $self);
unless (defined $sock) {
carp "Error in DCC CHAT connect: $!";
return;
}
} else { # we're connecting
$address = &Net::IRC::DCC::Connection::fixaddr($address);
return if $port < 1024 or not defined $address;
$sock = new IO::Socket::INET( Proto => "tcp",
PeerAddr => "$address:$port");
if (defined $sock) {
$container->handler(Net::IRC::Event->new('dcc_open',
$nick,
$sock,
'chat',
'chat', $sock));
} else {
carp "Error in DCC CHAT connect: $!";
return;
}
$sock->autoflush(1);
$self = {
_bin => 0, # Bytes we've recieved thus far
_bout => 0, # Bytes we've sent
_connected => 1,
_nick => $nick, # Nick of the client on the other end
_parent => $container,
_socket => $sock, # Socket we're reading from
_time => time,
_type => 'CHAT',
};
bless $self, $class;
$self->{_parent}->parent->addfh($self->socket,
$self->can('parse'), 'r', $self);
}
return $self;
}
# -- #perl was here! --
# \merlyn: tahtd be coole
# KTurner bought the camel today, so somebody can afford one
# more drink... ;)
# tmtowtdi: I've heard of things like this...
# \merlyn: as an experience. that is.
# archon: i can think of cooler things (;
# \merlyn: I don't realiy have that mch in my wallet.
sub parse {
my ($self, $sock) = @_;
foreach my $line ($self->_getline($sock)) {
return unless defined $line;
$self->{_bin} += length($line);
return undef if $line eq "\012";
$self->{_bout} += length($line);
$self->{_parent}->handler(Net::IRC::Event->new('chat',
$self->{_nick},
$self->{_socket},
'chat',
$line));
$self->{_parent}->handler(Net::IRC::Event->new('dcc_update',
$self->{_nick},
$self,
$self->{_type},
$self ));
}
}
# Sends a message to a channel or person.
# Takes 2 args: the target of the message (channel or nick)
# the text of the message to send
sub privmsg {
my ($self) = shift;
unless (@_) {
croak 'Not enough arguments to privmsg()';
}
# Don't send a CR over DCC CHAT -- it's not wanted.
$self->socket->send(join('', @_) . "\012");
}
# -- #perl was here! --
# \merlyn: this girl carly at the bar is aBABE
# archon: are you sure? you don't sound like you're in a condition to
# judge such things (;
# *** Stupid has set the topic on channel #perl to \merlyn is shit-faced
# with a trucker in the shower.
# tmtowtdi: uh, yeah...
# \merlyn: good topic
# Sockets waiting for accept() use this to shoehorn into the select loop.
package Net::IRC::DCC::Accept;
@Net::IRC::DCC::Accept::ISA = qw(Net::IRC::DCC::Connection);
use Carp;
use Socket; # we use a lot of Socket functions in parse()
use strict;
sub new {
my ($class, $sock, $parent) = @_;
my ($self);
$self = { _debug => $parent->debug,
_nonblock => 1,
_socket => $sock,
_parent => $parent,
_type => 'accept',
};
bless $self, $class;
# Tkil's gonna love this one. :-) But what the hell... it's safe to
# assume that the only thing initiating DCCs will be Connections, right?
# Boy, we're not built for extensibility, I guess. Someday, I'll clean
# all of the things like this up.
$self->{_parent}->{_parent}->parent->addconn($self);
return $self;
}
sub parse {
my ($self) = shift;
my ($sock);
$sock = $self->{_socket}->accept;
$self->{_parent}->{_socket} = $sock;
$self->{_parent}->{_time} = time;
if ($self->{_parent}->{_type} eq 'SEND') {
# ok, to get the ball rolling, we send them the first packet.
my $buf;
unless (defined $self->{_parent}->{_fh}->
read($buf, $self->{_parent}->{_blocksize})) {
return;
}
unless (defined $sock->send($buf)) {
$sock->close;
$self->{_parent}->{_fh}->close;
$self->{_parent}->{_parent}->parent->removefh($sock);
$self->{_parent}->handler(Net::IRC::Event->new('dcc_close',
$self->{_nick},
$self->{_socket},
$self->{_type}));
$self->{_socket}->close;
return;
}
}
$self->{_parent}->{_parent}->parent->addconn($self->{_parent});
$self->{_parent}->{_parent}->parent->removeconn($self);
$self->{_parent}->{_parent}->handler(Net::IRC::Event->
new('dcc_open',
$self->{_parent}->{_nick},
$self->{_parent}->{_socket},
$self->{_parent}->{_type},
$self->{_parent}->{_type},
$self->{_parent}->{_socket})
);
}
1;
__END__
=head1 NAME
Net::IRC::DCC - Object-oriented interface to a single DCC connection
=head1 SYNOPSIS
Hard hat area: This section under construction.
=head1 DESCRIPTION
This documentation is a subset of the main Net::IRC documentation. If
you haven't already, please "perldoc Net::IRC" before continuing.
Net::IRC::DCC defines a few subclasses that handle DCC CHAT, GET, and SEND
requests for inter-client communication. DCC objects are created by
C<Connection-E<gt>new_{chat,get,send}()> in much the same way that
C<IRC-E<gt>newconn()> creates a new connection object.
=head1 METHOD DESCRIPTIONS
This section is under construction, but hopefully will be finally written up
by the next release. Please see the C<irctest> script and the source for
details about this module.
=head1 AUTHORS
Conceived and initially developed by Greg Bacon E<lt>gbacon@adtran.comE<gt> and
Dennis Taylor E<lt>dennis@funkplanet.comE<gt>.
Ideas and large amounts of code donated by Nat "King" Torkington E<lt>gnat@frii.comE<gt>.
Currently being hacked on, hacked up, and worked over by the members of the
Net::IRC developers mailing list. For details, see
http://www.execpc.com/~corbeau/irc/list.html .
=head1 URL
Up-to-date source and information about the Net::IRC project can be found at
http://netirc.betterbox.net/ .
=head1 SEE ALSO
=over
=item *
perl(1).
=item *
RFC 1459: The Internet Relay Chat Protocol
=item *
http://www.irchelp.org/, home of fine IRC resources.
=back
=cut
------------------------------
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 5655
***************************************
