[29957] in Perl-Users-Digest
Perl-Users Digest, Issue: 1200 Volume: 11
daemon@ATHENA.MIT.EDU (Perl-Users Digest)
Tue Jan 15 21:09:39 2008
Date: Tue, 15 Jan 2008 18:09:11 -0800 (PST)
From: Perl-Users Digest <Perl-Users-Request@ruby.OCE.ORST.EDU>
To: Perl-Users@ruby.OCE.ORST.EDU (Perl-Users Digest)
Perl-Users Digest Tue, 15 Jan 2008 Volume: 11 Number: 1200
Today's topics:
Chat client/server print failed <deadpickle@gmail.com>
Re: Converting milliseconds to seconds <abigail@abigail.be>
Re: Converting milliseconds to seconds <joost@zeekat.nl>
Re: Converting milliseconds to seconds <abigail@abigail.be>
Re: Converting milliseconds to seconds <nospam-abuse@ilyaz.org>
Re: USEFUL perl SCRIPT: NTP verifier <john@castleamber.com>
Re: USEFUL perl SCRIPT: NTP verifier <tadmc@seesig.invalid>
Re: Wait for background processes to complete <ben@morrow.me.uk>
Digest Administrivia (Last modified: 6 Apr 01) (Perl-Users-Digest Admin)
----------------------------------------------------------------------
Date: Tue, 15 Jan 2008 16:32:52 -0800 (PST)
From: deadpickle <deadpickle@gmail.com>
Subject: Chat client/server print failed
Message-Id: <80f3c203-d920-4283-9a15-bc34fc7a4c9f@l1g2000hsa.googlegroups.com>
This is a chat client wrote in perl Gtk2. THe problem that I am
running into is that when you type and click send I get a "print() on
closed filehandle GEN0 at chat-client.pl line 332" error. This error
is the print statement in the send_msg_all sub. I cant figure out how
the file handle is closed and am wondering if anyone can see why. I'll
leave the server running for testing purposes.
# the Client:
#!/usr/bin/perl
# Flow of the Program:
# *Send message to the server - send_msg_all
# *Connect to the server - sub connect_server
# -unblock the server - nonblock
# -Login to the server - send_login
# -Timer started to wait for messages - wait_for_msg
# >Handler - handle
# $Process the incoming meswsages - process_incoming
# @Recieve messages and display in textview - rcv_msg
use warnings;
use strict;
use Gtk2 -init;
use Glib qw/TRUE FALSE/;
use IO::Socket::INET;
use Tie::RefHash;
use IO::Select;
#global variables
my $buffer;
my $host = "Deadpickle-hobo";
my $port = 6666;
my $conn_stat = 'idle';
my %inbuffer = ();
my %outbuffer = ();
my %ready = ();
my $select;
my $conn;
my $user;
#the main chat widget
my $main_window = Gtk2::Window->new("toplevel");
$main_window->signal_connect(delete_event => sub {Gtk2->main_quit;});
$main_window->set_default_size(250, 200);
my $table = Gtk2::Table->new(4, 2, FALSE);
$buffer = Gtk2::TextBuffer->new;
my $button = Gtk2::Button->new("Send");
my $entry = Gtk2::Entry->new();
my $label = Gtk2::Label->new("Chat Client Test");
my $textview = Gtk2::TextView->new_with_buffer($buffer);
$textview->set_cursor_visible (FALSE);
my $swindow = Gtk2::ScrolledWindow->new( undef, undef);
$swindow->set_policy( 'automatic', 'automatic');
$swindow->set_shadow_type( 'etched-out');
$swindow->add( $textview);
$table->attach_defaults($label, 0, 1, 0, 1);
$table->attach_defaults($swindow, 0, 2, 1, 3);
$table->attach_defaults($entry, 0, 1, 3, 4);
$table->attach_defaults($button, 1, 2, 3, 4);
$main_window->add($table);
$main_window->show_all();
$button->signal_connect("clicked" => sub { send_msg_all($entry-
>get_text); $entry->set_text('');} );
#run the login dialog
dialog($buffer);
Gtk2->main;
#-------------------Login Dialog-------------------
sub dialog{
my $buffer = shift;
my $dialog_window = Gtk2::Window->new('toplevel');
$dialog_window->signal_connect(delete_event => sub {Gtk2-
>main_quit});
my $dialog_table = Gtk2::Table->new(2, 2, FALSE);
my $dialog_label1 = Gtk2::Label->new('Chat Login:');
my $dialog_label2 = Gtk2::Label->new('User:');
my $dialog_label3 = Gtk2::Label->new('Host:');
my $chat_user = Gtk2::Entry->new();
$chat_user->set_text('');
my $dialog_button1 = Gtk2::Button->new('Connect');
$dialog_table->attach_defaults($dialog_label1, 0, 1, 0, 1);
$dialog_table->attach_defaults($chat_user, 1, 2, 0, 1);
$dialog_table->attach_defaults($dialog_button1, 1, 2, 1, 2);
$dialog_button1->signal_connect("clicked" => sub {$user = $chat_user-
>get_text; $dialog_window->destroy; $buffer->insert(($buffer-
>get_end_iter), "Username: $user...\n"); connect_server()});
$dialog_window->add($dialog_table);
$dialog_window->show_all;
return 1;
}
#------------------Connect to server---------------------
#establishes connection to the server
sub connect_server{
if ($conn_stat ne 'connected') {
$buffer->insert(($buffer->get_end_iter), "Connecting to Server
$host:$port...\n");
$conn = IO::Socket::INET->new(PeerAddr => $host, PeerPort =>
$port, Proto => 'tcp') or popup_err(1);
if ($conn) {
%inbuffer = ();
%outbuffer = ();
%ready = ();
tie %ready, 'Tie::RefHash';
nonblock($conn);
$select = IO::Select->new($conn);
$conn_stat = 'connected';
$buffer->insert(($buffer->get_end_iter), "Connected!\n");
#send login to server
send_login();
#start the timer that monitors incoming messages
my $timer_waiting = Glib::Timeout->add(100, \&wait_for_msg);
print "$conn\n";
}
}
}
#-------------------Error popup-------------------
# pops up an error message
sub popup_err{
my ($error_code) = @_;
my $error;
if ($error_code == 1) {$error = "Cannot create Socket!"}
elsif ($error_code == 2) {$error = "Username to Short!"}
elsif ($error_code == 3) {$error = "No connection Established!"}
elsif ($error_code == 4) {$error = "Already Logged on with This User
Name!"}
elsif ($error_code == 5) {$error = "Not Connected!"}
elsif ($error_code == 6) {$error = "User Successfully Added!"}
elsif ($error_code == 7) {$error = "Error Registering User!"}
elsif ($error_code == 8) {$error = "Already Logged Out!"}
else {$error = "Unkown Error!"}
$buffer->insert(($buffer->get_end_iter), "$error\n");
my $error_dialog = Gtk2::MessageDialog->new($main_window, 'destroy-
with-parent', 'error', 'ok', "$error");
$error_dialog->run;
$error_dialog->destroy;
}
#-------------------blocking-------------------
# nonblock($socket) puts socket into nonblocking mode
sub nonblock {
my $socket = shift;
$socket->blocking(0);
}
#-------------------Message Waiting-------------------
# Wait for incoming messages from the server relayed from clients
sub wait_for_msg {
print "waiting\n";
if ($conn_stat eq 'connected') {
my ($list_size, $msg);
my $server;
my $rv;
my $data;
# check for new information on the connections we have
# anything to read or accept?
foreach $server ($select->can_read(1)) {
# read data
$data = '';
$rv = $server->recv($data, 'POSIX::BUFSIZ', 0);
unless (defined($rv) && length $data) {
# This would be the end of file, so close the client
delete $inbuffer{$server};
delete $outbuffer{$server};
delete $ready{$server};
$select->remove($server);
close $server;
next;
}
$inbuffer{$server} .= $data;
# test whether the data in the buffer or the data we
# just read means there is a complete request waiting
# to be fulfilled. If there is, set $ready{$client}
# to the requests waiting to be fulfilled.
while ($inbuffer{$server} =~ s/(.*\n)//) {
push( @{$ready{$server}}, $1 );
}
}
# Any complete requests to process?
foreach $server (keys %ready) {
handle($server);
}
}
}
#-------------------Handler-------------------
# handle($socket) deals with all pending requests for $client
sub handle {
# requests are in $ready{$server}
# send output to $outbuffer{$server}
my $server = shift;
my $request;
foreach $request (@{$ready{$server}}) {
# $request is the text of the request
# put text of reply into $outbuffer{$client}
chomp $request;
process_incoming($server, $request);
}
delete $ready{$server};
}
#-------------------Process Incoming-------------------
sub process_incoming {
my ($server, $msg) = @_;
my @logged_users;
my @rcvd_msg = split(/::/, $msg);
if ($rcvd_msg[1] eq "1") {
# Login responses
# 12 = already logged on
# 03 = logged in
if($rcvd_msg[2] eq "03") {
print "Successfully Logged in!\n";
} elsif ($rcvd_msg[2] eq "12") {
popup_err(4);
} else {
# Create pop-up for error!
print "Error Logging in ", $msg, "\n";
popup_err(5);
}
} elsif ($rcvd_msg[1] eq "2") {
# register response
if ($rcvd_msg[2] eq "06") {
print "New user successfully registered!\n";
popup_err(6);
} elsif ($rcvd_msg[2] eq "02") {
print "$msg\n";
popup_err(4);
} else {
print "$msg\n";
popup_err(7);
}
} elsif ($rcvd_msg[1] eq "3") {
# quit response
print "$msg\n";
# $exit_cond = 0;
} elsif ($rcvd_msg[1] eq "4") {
# log out response
# 14 = user logged off
# 13 = user not logged in to begin with
print "$msg\n";
if($rcvd_msg[2] == 13) {
popup_err(8); # not logged in
}
# else {
# # clear the buddy list
# $list_size = $buddy_list->size;
# $list_size = $list_size - 1;
# $buddy_list->delete(0,$list_size);
# }
# $menu_file->update;
# } elsif ($rcvd_msg[1] eq "5") {
# # delete existing list of users
# $list_size = $buddy_list->size;
# if($list_size > 0) { $buddy_list->delete(0,$list_size); }
# # get users list response
# # if server response for proto 5 is 17 then Draw in
$buddy_list
# if ($rcvd_msg[2] == 17) {
# @logged_users = split (/ /, $rcvd_msg[3]);
# foreach (@logged_users) {
# $buddy_list->insert('end', "$_");
# }
# } elsif ($rcvd_msg[2] eq 18) {
# # generate error for login
# print "Please Log in to server first!\n";
# print "$msg\n";
# popup_err(51);
# } else {
# print "Unknown error updating buddy list:\n";
# print "$msg\n";
# popup_err(52);
# }
# $menu_file->update;
} elsif ($rcvd_msg[1] eq "6") {
# receive user message
# 13 - user not logged in
# 23 - buddy (target) not logged in
print "$msg\n";
rcv_msg($rcvd_msg[3], $rcvd_msg[4]);
# } elsif ($rcvd_msg[1] eq "7") {
# # receive global message
# print "$msg\n";
# rcv_msg_all($rcvd_msg[3], $rcvd_msg[4]);
# } elsif ($rcvd_msg[1] eq "8") {
# if ($rcvd_msg[2] == 23) {
# popup_err(81);
# } elsif ($rcvd_msg[2] eq "13") {
# popup_err(82);
# } else {
# # receive query information
# print "$msg\n";
# process_query($msg);
# }
# $menu_file->update;
} else {
print "Unrecognized response: $msg\n";
# popup_err(92);
exit(0);
}
# if($err) { print "ERROR: $err\n"; }
}
#-------------------Send message to all-------------------
sub send_msg_all {
my ($msg) = @_;
print "$conn\n";
if(defined $conn) {
# Send a the Message to server
print "Sending\n";
print $conn "7\:\:$user\:\:$msg\n";
} else {
popup_err(3);
}
}
#-------------------Send login-------------------
#logs the user name on the server
sub send_login {
# my ($u) = @_;
if(defined $conn) {
if(length($user) > 0) {
#send login to server
print $conn "1\:\:$user\n";
# update_info();
} else {
popup_err(2);
}
} else {
popup_err(3);
}
}
#-------------------Display Message-------------------
sub rcv_msg {
my ($from, $msg) = @_;
print "Received message from $from\n";
if(defined $conn) {
print "Already Connected: Proceeding with message!\n";
# $status->insert('end',"[$from]: $msg\n");
} else {
print "No connection established!\n";
popup_err(3);
}
}
The Server:
#!/usr/local/bin/perl
#
# SERVER PROTOCOLS
# 01 - Login ....... 1::username::passwd
# 02 - Register New User 2::username::passwd
# 03 - Terminate Program ....... 3::username::passwd
# 04 - Logoff Server 4::username::passwd
# 05 - Get Logged Users ....... 5::username::passwd
# 06 - Message another user
6::username::passwd::rcpt::message
# 07 - Global message ....... 7::username::passwd::message
# 08 - Query buddy 8::username::passwd::rcpt
# 09 - Update Buddy Info .......
9::username::passwd::Name::Email::Quote
use POSIX;
use IO::Socket;
use IO::Select;
use Socket;
use Fcntl;
use Tie::RefHash;
$port = 6666;
my %hosts;
# Create Server
$server = IO::Socket::INET->new(LocalPort => $port,
Listen => 100 )
or die "Can't make server socket: $@\n";
print "Server created. Waiting for events...\n";
# begin with empty buffers
%inbuffer = ();
%outbuffer = ();
%ready = ();
tie %ready, 'Tie::RefHash';
nonblock($server);
$select = IO::Select->new($server);
# Main loop: check reads/accepts, check writes, check ready to process
while (1) {
my $client;
my $rv;
my $data;
# check for new information on the connections we have
# anything to read or accept?
foreach $client ($select->can_read(1)) {
if ($client == $server) {
# accept a new connection
$client = $server->accept();
$select->add($client);
nonblock($client); #subroutine
} else {
# read data
$data = '';
$rv = $client->recv($data, POSIX::BUFSIZ, 0);
unless (defined($rv) && length $data) { #Runs the
bottom statement unless it is true
# This would be the end of file, so close the client
delete $inbuffer{$client};
delete $outbuffer{$client};
delete $ready{$client};
$select->remove($client);
close $client;
next;
}
$inbuffer{$client} .= $data; #add the recieved data
to the inbuffer
# test whether the data in the buffer or the data we
# just read means there is a complete request waiting
# to be fulfilled. If there is, set $ready{$client}
# to the requests waiting to be fulfilled.
# Disceting the matching variable:
# =~: between variable and and regular expression
# s/PATTERN//REPLACEMENT/: searchs the string for the
pattern then replaces it with the replacement text
# (.*\n):
# . match any character except newline
# * match zero or more times
# \n newline
while ($inbuffer{$client} =~ s/(.*\n)//) { #If there is
data in the inbuffer; searches for a string with a newline at the end
push( @{$ready{$client}}, $1 ); # $1 is the matched
string that is added the the hash/array %ready; this must be the
REFHASH
}
}
}
# Any complete requests to process?
foreach $client (keys %ready) { #calls the refhash keys
handle($client); #subroutine
}
# Buffers to flush?
foreach $client ($select->can_write(1)) { #see what clients are
ready to be wrote to
# Skip this client if we have nothing to say
next unless exists $outbuffer{$client}; #run the next
iteration unless the outbuffer exists
$rv = $client->send($outbuffer{$client}, 0);
unless (defined $rv) { #run the statement unless $rv is
defined
# Whine, but move on.
warn "I was told I could write, but I can't.\n";
next;
}
if ($rv == length $outbuffer{$client} ||
$! == POSIX::EWOULDBLOCK) {
substr($outbuffer{$client}, 0, $rv) = '';
delete $outbuffer{$client} unless length
$outbuffer{$client};
} else {
# Couldn't write all the data, and it wasn't because
# it would have blocked. Shutdown and move on.
delete $inbuffer{$client};
delete $outbuffer{$client};
delete $ready{$client};
$select->remove($client);
close($client);
next;
}
}
# Out of band data?
foreach $client ($select->has_exception(0)) { # arg is timeout
# Deal with out-of-band data here, if you want to.
print "DEBUG ME!\n";
}
}
#-------------------Handler-------------------
# handle($socket) deals with all pending requests for $client
sub handle {
# requests are in $ready{$client}
# send output to $outbuffer{$client}
my $client = shift;
my $request;
foreach $request (@{$ready{$client}}) { #cycle through the
clients
# $request is the text of the request
# put text of reply into $outbuffer{$client}
chomp $request;
rcvd_msg_from_client($client, $request); #subroutine
# $outbuffer{$client} .= "$request";
}
delete $ready{$client}; #remove the client from the processes
}
#-------------------Blocking-------------------
# nonblock($socket) puts socket into nonblocking mode
sub nonblock {
my $socket = shift;
$socket->blocking(0);
}
#-------------------Receive Message from Client-------------------
sub rcvd_msg_from_client {
# This sub receives the message from the client and processes
# it.
my ($client, $request) = @_; #drop the passed variables
if (length($request) ne 0) { #if there is a request
chomp $request;
print "CLIENT QUERY: '$request'\n"; #this is used for all
requests into the server
# CLIENT QUERY in the form of ID_NUMBER::USERNAME:: ...
my @msg = split(/::/, $request); #assigned by the client;
runs the requested subs
if($msg[0] eq '1') {logon($client, @msg)}
# } elsif ($msg[0] eq 2) {
# register($client, @msg);
# } elsif ($msg[0] eq 3) {
# quit($client, @msg);
# } elsif ($msg[0] eq 4) {
# logoff($client, @msg);
# } elsif ($msg[0] eq 5) {
# return_logged_users($client, @msg);
# } elsif ($msg[0] eq 6) {
# msg_user($client, @msg);
elsif ($msg[0] eq 7) {msg_all_users($client, @msg)}
# } elsif ($msg[0] eq 8) {
# query_buddy($client, @msg);
# } elsif ($msg[0] eq 9) {
# update_info($client, @msg);
else {
print "Unrecognized ID $msg[0]\n";
$outbuffer{$client} .= "Unrecognized ID $msg[0]\n";
}
}
}
#-------------------login-------------------
sub logon {
# This sub checks the length of the data passed to it,
# if the length is ne 0, then it checks to make sure the
# data authenticates (i.e. login name and password authenticate)
# If this happens then chk_for_login is called else user is
# logged in.
my ($client, @msg) = @_;
my $client_ip = get_hostaddr($client);
if (length($msg[1]) ne 0) {
print "User $msg[1] attempting login...\n";
# if (authorize($msg[1], $msg[2])) {
# check if user is already logged in
if (chk_for_login($msg[1])) { # check if username is already
in use
# user is already logged in
print "SERVER::",time_stamp(),"::03::User $msg[1] $client_ip
logged in.\n";
$outbuffer{$client} .= "SERVER::$msg[0]::03::$msg[1] logged in!
\n";
} else {
# user is not logged in, add to %hosts
my $current_time = time_stamp();
$hosts{$msg[1]}->{'ip'} = $client_ip;
$hosts{$msg[1]}->{'status'} = 'connected';
$hosts{$msg[1]}->{'logged_in'} = 'yes';
$hosts{$msg[1]}->{'user_name'} = $msg[1];
$hosts{$msg[1]}->{'con_time'} = $current_time;
$hosts{$msg[1]}->{'connection'} = $client;
print "SERVER::",time_stamp(),"::03::User $msg[1] $client_ip
logged in.\n";
$outbuffer{$client} .= "SERVER::$msg[0]::03::$msg[1] logged in!
\n";
}
# } else {
# print "SERVER::",time_stamp(),"::00::User $msg[1] NOT logged in.
\n";
# $outbuffer{$client} .= "SERVER::$msg[0]::00::$msg[1] NOT logged
in!\n";
# }
} else {
print "SERVER::",time_stamp(),"::00::Null user not logged in.\n";
print "ERROR::",time_stamp(),"::09::Invalid logon attempt.\n";
$outbuffer{$client} .= "SERVER::$msg[0]::00::Could not login with
that name.\n";
}
}
#-------------------Get host address-------------------
sub get_hostaddr {
my ($client) = @_;
my $sock = $client;
return $sock->peerhost();
}
#-------------------Check current users-------------------
sub chk_for_login {
# chk_for_login() checks the hash of logins for a matching
# key. if one is found then 1 is returned, else 0 is returned
my ($user_name) = @_;
foreach (keys %hosts) {
if($_ eq $user_name) {
return 1;
} else {
return 0;
}
}
}
#-------------------Timestamp-------------------
sub time_stamp {
# This sub returns the time using gmtime();
my ($s, $m, $h, $dy, $mo, $yr, $wd, $dst);
($s, $m, $h, $dy, $mo, $yr, $wd, $dst) = gmtime(); # get the date
$mo++;
$yr = $yr - 100;
if ($mo < 10) { $mo = "0".$mo; }
if ($dy < 10) { $dy = "0".$dy; }
if ($yr < 10) { $yr = "0".$yr; }
if ($h < 10) { $h = "0".$h; }
if ($m < 10) { $m = "0".$m; }
if ($s < 10) { $s = "0".$s; }
return "$mo-$dy-$yr $h:$m:$s";
}
#-------------------Message all users-------------------
sub msg_all_users {
# sends a global message to every user logged in
my ($client, @msg) = @_;
my $rcpt;
print "SERVER::",time_stamp(),"::21::Global message attempt:
$msg[1]\n";
if (chk_for_login($msg[1])) { # check if user is logged in
print "SERVER::",time_stamp(),"::21::$msg[1] cleared for GM\n";
foreach (keys %hosts) { # for each logged in user
$rcpt = get_link($_); # get rcpts connection
$outbuffer{$rcpt} .= "SERVER::$msg[0]::21::$msg[1]::$msg[3]\n";
}
}
}
#-------------------Get the links to the connected
users-------------------
sub get_link {
# This sub gets a connection link to a user
my ($user_name) = @_;
foreach (keys %hosts) {
if($_ eq $user_name) {
return $hosts{$_}->{'connection'};
}
}
}
------------------------------
Date: 15 Jan 2008 23:10:51 GMT
From: Abigail <abigail@abigail.be>
Subject: Re: Converting milliseconds to seconds
Message-Id: <slrnfoqfbr.t74.abigail@alexandra.abigail.be>
_
Joost Diepenmaat (joost@zeekat.nl) wrote on VCCL September MCMXCIII in
<URL:news:87r6giem64.fsf@zeekat.nl>:
|| Abigail <abigail@abigail.be> writes:
||
|| > _
|| > Joost Diepenmaat (joost@zeekat.nl) wrote on VCCL September MCMXCIII in
|| > <URL:news:87k5mbexy5.fsf@zeekat.nl>:
|| > ?? Jim Gibson <jimsgibson@gmail.com> writes:
|| > ??
|| > ?? > What would be a good round() function that "rounds-to-nearest-even"?
|| > ??
|| > ?? sprintf would work, but I'm not 100% sure it rounds to even on every
|| > ?? platform (it uses C's sprintf()). It works on my debian/x86 system though.
|| >
|| > It doesn't, unless you have a really, really old perl. Modern Perls
|| > only use the systems sprintf for floating numbers, when using standard
|| > modifiers. But in this case, we're using "%d".
||
|| Heh. I always use %1.0f :-)
But that doesn't always give the same result as %d:
$ perl -wE 'printf "%d\n" => -0.1'
0
$ perl -wE 'printf "%1.0f\n" => -0.1'
-0
Abigail
--
map{${+chr}=chr}map{$_=>$_^ord$"}$=+$]..3*$=/2;
print "$J$u$s$t $a$n$o$t$h$e$r $P$e$r$l $H$a$c$k$e$r\n";
------------------------------
Date: Wed, 16 Jan 2008 00:12:05 +0100
From: Joost Diepenmaat <joost@zeekat.nl>
Subject: Re: Converting milliseconds to seconds
Message-Id: <87myr6ela2.fsf@zeekat.nl>
Abigail <abigail@abigail.be> writes:
> _
> Joost Diepenmaat (joost@zeekat.nl) wrote on VCCL September MCMXCIII in
> || Heh. I always use %1.0f :-)
>
> But that doesn't always give the same result as %d:
>
> $ perl -wE 'printf "%d\n" => -0.1'
> 0
> $ perl -wE 'printf "%1.0f\n" => -0.1'
> -0
Well, I guess this should be added to the docs :-)
Joost.
------------------------------
Date: 15 Jan 2008 23:20:38 GMT
From: Abigail <abigail@abigail.be>
Subject: Re: Converting milliseconds to seconds
Message-Id: <slrnfoqfu6.t74.abigail@alexandra.abigail.be>
_
Joost Diepenmaat (joost@zeekat.nl) wrote on VCCL September MCMXCIII in
<URL:news:87myr6ela2.fsf@zeekat.nl>:
:) Abigail <abigail@abigail.be> writes:
:)
:) > _
:) > Joost Diepenmaat (joost@zeekat.nl) wrote on VCCL September MCMXCIII in
:) > || Heh. I always use %1.0f :-)
:) >
:) > But that doesn't always give the same result as %d:
:) >
:) > $ perl -wE 'printf "%d\n" => -0.1'
:) > 0
:) > $ perl -wE 'printf "%1.0f\n" => -0.1'
:) > -0
:)
:) Well, I guess this should be added to the docs :-)
Patches welcome.
Abigail
--
perl -le 's[$,][join$,,(split$,,($!=85))[(q[0006143730380126152532042307].
q[41342211132019313505])=~m[..]g]]e and y[yIbp][HJkP] and print'
------------------------------
Date: Wed, 16 Jan 2008 01:05:09 +0000 (UTC)
From: Ilya Zakharevich <nospam-abuse@ilyaz.org>
Subject: Re: Converting milliseconds to seconds
Message-Id: <fmjl85$1rle$1@agate.berkeley.edu>
[A complimentary Cc of this posting was NOT [per weedlist] sent to
Peter J. Holzer
<hjp-usenet2@hjp.at>], who wrote in article <slrnfoph3u.mma.hjp-usenet2@hrunkner.hjp.at>:
> But I think Ilya is a barking up the wrong tree here:
Well, at least it was not the intent. Sorry if my writing lead you to
such a conclusion...
> >>> >This is just a reflection of a sorry state of Perl documentation.
> >>> >There is NO OTHER WAY to round-to-0 but to use int().
I reread what I wrote, and I STILL see no ambiguity in my original
post; what I objected to is "two", not "one", in the following fragment
int Returns the integer portion of EXPR. If EXPR is
omitted, uses $_. You should not use this function
for rounding: one because it truncates towards 0,
and two because machine representations of floating
point numbers can sometimes produce counterintuitive
results.
Yours,
Ilya
------------------------------
Date: 15 Jan 2008 23:39:14 GMT
From: John Bokma <john@castleamber.com>
Subject: Re: USEFUL perl SCRIPT: NTP verifier
Message-Id: <Xns9A26B3951D5CEcastleamber@130.133.1.4>
melsonr@aragorn.rgmhome.net (Robert Melson) wrote:
> And, yet, it's a PERL mantra
You're in the wrong group, this one isn't about PERL.
> that TMTOWTDI (There's More
> Than One Way To Do It). I think the question to ask is
> whether the script/program does what it's intended to do,
> not whether its style meets somebody else's idea of what
> looks good or has better variable names or ...
Which is, like style, just an opinion. Or do you want to say that /your/
opinion is more important?
--
John
http://johnbokma.com/mexit/
------------------------------
Date: Tue, 15 Jan 2008 17:50:34 -0600
From: Tad J McClellan <tadmc@seesig.invalid>
Subject: Re: USEFUL perl SCRIPT: NTP verifier
Message-Id: <slrnfoqhma.efm.tadmc@tadmc30.sbcglobal.net>
Robert Melson <melsonr@aragorn.rgmhome.net> wrote:
> And, yet, it's a PERL mantra that TMTOWTDI
^^^^
Whoever created that PERL thingy stole the Perl mantra!
--
Tad McClellan
email: perl -le "print scalar reverse qq/moc.noitatibaher\100cmdat/"
------------------------------
Date: Tue, 15 Jan 2008 23:49:47 +0000
From: Ben Morrow <ben@morrow.me.uk>
Subject: Re: Wait for background processes to complete
Message-Id: <rdtv55-u7a2.ln1@osiris.mauzo.dyndns.org>
Quoth pgodfrin <pgodfrin@gmail.com>:
> On Jan 14, 2:48 pm, xhos...@gmail.com wrote:
> > pgodfrin <pgodf...@gmail.com> wrote:
> > > On Jan 14, 11:11 am, xhos...@gmail.com wrote:
> >
> > > > $ perl -wle 'use strict; fork or exec "sleep " . $_*3 foreach 1..3 ; \
> > > > my $x; do {$x=wait; print $x} until $x==-1'
<snippage>
> It seems to me that firing off say 5 processes with the '&' character
> to send them to the background is 5 parallel processes, while
> executing them off one at a time is sequential. Your code (fork or
> exec "sleep" ... ) waits for each sleep process to complete - so that
> is what I meant by "waiting sequentially".
No, I think you don't understand how fork works. It *is* rather
confusing until you're used to it. Read the documentation again (both
Perl's and your system's), or find a good Unix programming book.
> Technically speaking you're
> right - but the idea is to have tasks run in parallel versus
> sequentially, which is ostensibly faster.
The tasks do run in parallel with Xho's version.
> To make a long story short, this is how I solved the problem. It seems
> that the PIDs of the commands run via system() and the '&' background
> thing end up belonging to the same Process Group - seen in the ps
> command, plus a little extra:
>
<snip>
> So I wrap the ps command and do some looping:
>
> for (;;)
> {
> open PGRP, "ps -C cp h |" ;
Use lexical filehandles and three-or-more-arg open.
Check the return value.
open my $PGRP, '-|', 'ps', '-C', 'cp', 'h'
or die "couldn't fork ps: $!";
> @pidlist=<PGRP> ;
> if ($#pidlist<0) {die "\nNo more processes\n" ;}
IMHO any use of $#ary is an error; certainly in this case you should be
using @pidlist instead.
@pidlist or die "No more processes\n";
This will run around in a tight loop running probably hundreds of ps
processes per second. This is not a effective use of your system's
resources, to say the least. If you must poll like this you need a sleep
in there somewhere to limit the damage.
> }
>
> It's not pretty but it works...
Yuck. The whole point of the wait syscall is to avoid nastiness like
that. I suggest you learn how it works, or use a module written by
someone who does (you have been given at least two suggestions so far),
or stick to shell.
> But, I believe this is an architectural FLAW with Perl.
No. Firstly, the only flaw here is in your understanding; secondly, if
there was a flaw it would be in Unix, not Perl, since Perl just exposes
the underlying system interfaces.
Ben
------------------------------
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 V11 Issue 1200
***************************************
