[9903] in Perl-Users-Digest
Perl-Users Digest, Issue: 3496 Volume: 8
daemon@ATHENA.MIT.EDU (Perl-Users Digest)
Thu Aug 20 19:07:18 1998
Date: Thu, 20 Aug 98 16:01:29 -0700
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, 20 Aug 1998 Volume: 8 Number: 3496
Today's topics:
Secure FTP <yves@medianet-usa.com>
Re: Sigh <dan@fearsome.net>
Re: su on NT <work@nospam.idea.co.uk>
Taint Question <upsetter@ziplink.net>
Re: what is 'sub f () {555};' <franzen@pmel.noaa.gov>
Re: wtf is the obsession with "foo" and "bar" (James Stout)
Special: Digest Administrivia (Last modified: 12 Mar 98 (Perl-Users-Digest Admin)
----------------------------------------------------------------------
Date: Thu, 20 Aug 1998 18:28:44 -0400
From: Yves BAILLY <yves@medianet-usa.com>
Subject: Secure FTP
Message-Id: <35DCA31C.B7E78EBF@medianet-usa.com>
This is a multi-part message in MIME format.
--------------5CFCBA86407EF4911200F784
Content-Type: text/plain; charset=us-ascii
Content-Transfer-Encoding: 7bit
Hi !
Here's a (big) Perl script, to be used to handle FTP
problems : each file to be send is put in a waiting
queue, and the script tries to send it when he can.
I'm just a newbies in Perl programming, so if someone
could have a look at my script and give me his
feeling...
--
.~.
/V\ Linux
// \\ Power /^-^\
/( )\ ( @ @ )
^^-^^ -------------oOO (_) OOo-------
Yves BAILLY | yves@medianet-usa.com
1350 Beverly Road | tel home : (703) 847 2324
Suite 324 | tel work : (703) 847 1900
22101 McLean, Virginia | fax work : (703) 847 1901
USA
--------------5CFCBA86407EF4911200F784
Content-Type: application/x-perl; name="queue.pl"
Content-Transfer-Encoding: 7bit
Content-Disposition: inline; filename="queue.pl"
#!/usr/bin/perl
# queue.pl, version 1.0
# Queue structure :
# { rem_host = string (identifiant) ;
# timeout = int ;
# mailto = string ;
# status = string ;
# ftp_PID = int ;
# flagmode = int ;
# files = list
# { src_dir = string ;
# src_file = string ;
# dest_dir = string ;
# dest_file = string ;
# user = string ;
# passwd = string ;
# }
# }
# The timeout is to be in MINUTES !! not seconds, nor hours !!
# Environement variable :
# QUEUES_WAITING = semaphor if concurrent access to the queue
use Getopt::Long ;
require "ftplib.pl" ;
%queues = () ;
$header = "\nFTP Queue Manager -- Yves BAILLY -- August 1998\n" ;
# Installation directory of queue.pl
$INST_PATH="/root/script/" ;
# Flag mode
$FLAG_ADD = 1 ;
$FLAG_REP = 2 ;
$FLAG_NO = 0 ;
# Programme status :
# Defaults values
$DEF_MAILTO = "root\@kafka" ;
$DEF_FLAG = $FLAG_ADD ;
$DEF_TIMEOUT = 3 ;
# Retrieves command line parameters
%param=() ;
&GetOptions(\%param, "send", "list", "config", "add", "timeout",
"del", "stop", "restart", "endftp",
"rh=s", "sf=s", "u=s", "p=s",
"sd=s", "td=s", "tf=s",
"delay=i", "mailto=s", "flag=s",
"ftperror=s", "ftpok=i") ;
print $header ;
&EntryProg() ;
if ( $param{"restart"} )
{ &OrderRestart() ; }
elsif ( $param{"send"} )
{ &OrderSend() ; }
elsif ( $param{"list"} )
{ &OrderList() ; }
elsif ( $param{"config"} )
{ &OrderConfig() ; }
elsif ( $param{"add"} )
{ &OrderAdd() ; }
elsif ( $param{"timeout"} )
{ &OrderTimeOut() ; }
elsif ( $param{"del"} )
{ &OrderDel() ; }
elsif ( $param{"stop"} )
{ &OrderStop() ; }
elsif ( $param{"endftp"} )
{ &OrderEndFTP() ; }
else
{ ExitProg("die", "Unknown order -- exiting.\n") ; }
############################################################################
# EntryProg & ExitProg procedures, for synch purpose
#
sub EntryProg
{ # print "----- EntryProg : $$\n" ;
my($sem) = $ENV{"QUEUES_WAITING"} ;
my($current, $others) = split /;/, $sem ;
# print "current : " . $current . "\n" ;
# print "others : " . $others . "\n" ;
if ( $sem ne "" )
{ print "Others running, waiting...\n" ;
&SetEnv("QUEUES_WAITING", $sem.";".$$) ;
while ($current ne $$)
{ sleep 5 ;
$sem = $ENV{"QUEUES_WAITING"} ;
($current, $others) = split /;/, $sem ;
}
}
else
{ &SetEnv("QUEUES_WAITING", $$) ;
}
&Restore() ;
} # &EntryProg
sub ExitProg
{ # print "----- ExitProg : $$\n" ;
my($exitmode, $mesg) = @_ ;
my($current, $others) = split /;/, $ENV{"QUEUES_WAITING"} ;
# print "current : " . $current . "\n" ;
# print "others : " . $others . "\n" ;
&Save() ;
&SetEnv("QUEUES_WAITING", $others) ;
if ( $exitmode eq "die" )
{ $! = 1 ;
die $mesg . "\n" ;
}
else
{ print $mesg . "\n" ;
exit 0 ;
}
} # &ExitProg
############################################################################
# Order subroutines
#
#---------------------------------------------------------------------------
# When asked to stop a running FTP, or to stop everything
sub OrderStop
{ # print "Stop order... $$\n" ;
my($host) ;
if ( (not defined $param{"rh"}) or ($param{"rh"} eq "") )
{ # Stops everything
foreach $host (keys %queues)
{ if ( $queues{$host}{"status"} eq "sending" )
{ &StopFTP($host) ;
&Wait($host) ;
}
}
&ExitProg("normal", "All queues waiting for time out.\n") ;
}
else
{ # Stops only one queue
$host = $param{"rh"} ;
if ( not defined $queues{$host} )
{ &ExitProg("die", "Host unknown : $host -- exiting.\n") ; }
if ( $queues{$host}{"status"} eq "sending" )
{ &StopFTP($host) ;
&Wait($host) ;
&ExitProg("normal", "Queue for $host waiting time out.\n") ;
}
else
{ &ExitProg("die", "$host not sending -- exiting.\n") ; }
}
} # &OrderStop
#---------------------------------------------------------------------------
# When asked to del a file in a queue, or a queue
sub OrderDel
{ # print "Del order... $$\n" ;
my($host, $str, $num_file, $sf, $sd, $df, $dd, $ftp_env, $relaunch) ;
if ( (not defined $param{"rh"}) or ($param{"rh"} eq "") )
{ ExitProg("die", "Remote host undefined -- exiting.") ; }
$host = $param{"rh"} ;
if ( defined $queues{$host} )
{ if ( (not defined $param{"sf"}) or ($param{"sf"} eq "") )
{ if ( $queues{$host}{"status"} eq "sending" )
{ &StopFTP($host) ; }
undef $queues{$host}{"files"} ;
undef $queues{$host} ;
delete $queues{$host} ;
$str = "Queue for " . $host . " deleted.\n" ;
ExitProg("normal", $str) ;
}
else
{ ($sd, $sf, $dd, $df) = &ValidateFile($param{"sd"}, $param{"sf"},
$param{"td"}, $param{"tf"}) ;
$str = "File $sd/$sf -> $dd/$df in $host " ;
$num_file = &FindFile($host, $sd, $sf, $dd, $df, "", "") ;
if ( $num_file == -1 )
{ &ExitProg("die", "File not found in queue -- exiting.\n") ; }
else
{ $ftp_env = "FTP_QUEUE_" . $queues{$host}{"ftpPID"} ;
$relaunch = 0 ;
if ( ($queues{$host}{"status"} eq "sending") and
( $ENV{$ftp_env} == $num_file ) )
{ &StopFTP($host) ;
$relaunch = 1 ;
}
splice @{$queues{$host}{"files"}}, $num_file, 1 ;
$str .= "deleted.\n" ;
if ( @{$queues{$host}{"files"}} )
{ if ( $relaunch )
{ $str .= "Running FTP stopped and re-launched.\n" ;
&FlushQueue($host) ;
}
}
else
{ $str .= "Empty queue for $host : queue deleted.\n" ;
undef $queues{$host}{"files"} ;
undef $queues{$host} ;
delete $queues{$host} ;
}
}
&ExitProg("normal", $str) ;
}
&ExitProg("die", "Unknown queue -- exiting.\n") ;
}
} # &OrderDel
#---------------------------------------------------------------------------
# When asked to send a file
sub OrderSend
{ # print "Send order... $$\n" ;
# First, checking parameters
if ( (not defined $param{"rh"}) or ($param{"rh"} eq "") )
{ ExitProg("die", "Remote host undefined -- exiting.") ; }
if ( (not defined $param{"sf"}) or ($param{"sf"} eq "") )
{ ExitProg("die", "File to send undefined -- exiting.") ; }
if ( (not defined $param{"u"}) or ($param{"u"} eq "") )
{ ExitProg("die", "User undefined -- exiting.") ; }
if ( (not defined $param{"p"}) or ($param{"p"} eq "") )
{ ExitProg("die", "User's password undefined -- exiting.") ; }
if ( not defined $queues{$param{"rh"}} )
{ &CreateQueue($param{"rh"}) ; }
&AddInQueue($param{"rh"}, $param{"sd"}, $param{"sf"}, $param{"td"},
$param{"tf"}, $param{"u"}, $param{"p"}) ;
if ( $queues{$param{"rh"}}{"status"} eq "created" )
{ &FlushQueue($param{"rh"}) ; }
&ExitProg("normal", "") ;
} # &OrderSend
#---------------------------------------------------------------------------
# When asked to add a file
sub OrderAdd
{ # print "Add order... $$\n" ;
# First, checking parameters
if ( (not defined $param{"rh"}) or ($param{"rh"} eq "") )
{ ExitProg("die", "Remote host undefined -- exiting.") ; }
if ( (not defined $param{"sf"}) or ($param{"sf"} eq "") )
{ ExitProg("die", "File to send undefined -- exiting.") ; }
if ( (not defined $param{"u"}) or ($param{"u"} eq "") )
{ ExitProg("die", "User undefined -- exiting.") ; }
if ( (not defined $param{"p"}) or ($param{"p"} eq "") )
{ ExitProg("die", "User's password undefined -- exiting.") ; }
if ( not defined $queues{$param{"rh"}} )
{ &CreateQueue($param{"rh"}) ; }
&AddInQueue($param{"rh"}, $param{"sd"}, $param{"sf"}, $param{"td"},
$param{"tf"}, $param{"u"}, $param{"p"}) ;
&ExitProg("normal", "") ;
} # &OrderAdd
#---------------------------------------------------------------------------
# When asked to list queues or files
sub OrderList
{ # print "List order... $$\n" ;
if ( (not defined $param{"rh"}) or ($param{"rh"} eq "") )
{ &ListQueues() ; }
elsif ( not defined $queues{$param{"rh"}} )
{ &ExitProg("die", "Unknown queue : ".$param{"rh"}." -- exiting.\n") ; }
else
{ &ListFiles($param{"rh"}) ; }
&ExitProg("normal", "") ;
} # &OrderList
#---------------------------------------------------------------------------
# When asked to list or set config/settings
sub OrderConfig
{ # print "Config order... $$\n" ;
if ( ($param{"delay"} ne "") or
($param{"mailto"} ne "") or
($param{"flag"} ne "") )
{ if ( $param{"rh"} ne "" )
{ if ( defined $queues{$param{"rh"}} )
{ &SetHostSettings($param{"rh"}) ; }
else
{ &ExitProg("die", "Unknown host : ".$param{"rh"}." -- exiting.\n") ; }
}
else
{ &SetDefaults() ; }
}
else
{ if ( $param{"rh"} ne "" )
{ if ( defined $queues{$param{"rh"}} )
{ &ListHostSettings($param{"rh"}) ; }
else
{ &ExitProg("die", "Unknown host : ".$param{"rh"}." -- exiting.\n") ; }
}
else
{ &ListDefaults() ; }
}
&ExitProg("normal", "") ;
} # &OrderConfig
#---------------------------------------------------------------------------
# When we're called after a FTP
sub OrderEndFTP
{ # print "End FTP order...\n" ;
my($host, $nbok, $ftperror, $str) ;
$host = $param{"rh"} ;
$nbok = $param{"ftpok"} ;
$ftperror = $param{"ftperror"} ;
if ( $ftperror eq "ok" )
{ $str = "Sending to $host successfully completed : $nbok files.\n" ;
if ( $nbok > 0 )
{ splice @{$queues{$host}{"files"}}, 0, $nbok ; }
if ( @{$queues{$host}{"files"}} > 0 )
{ $str .= @{$queues{$host}{"files"}} . " files still to send.\n" ;
&Mail("FTP queue : success", $str, $queues{$host}{"mailto"}) ;
&FlushQueue($host) ;
}
else
{ &Mail("FTP queue : success", $str, $queues{$host}{"mailto"}) ;
delete $queues{$host}{"files"} ;
delete $queues{$host} ;
}
&ExitProg("normal", "") ;
}
else
{ if ( $nbok > 0 )
{ splice @{$queues{$host}{"files"}}, 0, $nbok ; }
$str = "Error : " . $ftperror . "\n" ;
$str .= $nbok . " file(s) successfully transfered.\n" ;
&Mail("FTP queue : error on FTP",
&BuildContext($host, $nbok, $str),
$queues{$host}{"mailto"}) ;
&Wait($host) ;
&ExitProg("normal", "") ;
}
} # &OrderEndFTP
#---------------------------------------------------------------------------
# When the time out occures
sub OrderTimeOut
{ # print "Time out order... $$\n" ;
my($host) = $param{"rh"} ;
FlushQueue($host) ;
&ExitProg("normal", "") ;
} # &OrderTimeOut
#---------------------------------------------------------------------------
# Called on a restart : relunches all the FTP, etc.
sub OrderRestart
{ # print "Restart order... $$\n" ;
my($host, $str) ;
$str = "Restarting the FTP queue manager (a crash maybe ?)\n\n" ;
foreach $host (keys %queues)
{ if ( $queues{$host}{"status"} eq "sending" )
{ $str .= "FTP for " . $host . " restart : " ;
$str .= @{$queues{$host}{"files"}} . " files.\n" ;
FlushQueue($host) ;
}
elsif ( $queues{$host}{"status"} eq "waiting" )
{ $str .= "Host " . $host . " (" . @{$queues{$host}{"files"}} ;
$str .= " files) waiting " . $queues{$host}{"timeout"} ;
$str .= " minutes for FTP.\n" ;
Wait($host) ;
}
}
} # &OrderRestart
############################################################################
# Miscel Subroutines
#
#---------------------------------------------------------------------------
# Sets an environnement variable
sub SetEnv
{ my($var, $val) = @_ ;
my($str) ;
$str = $var . "=\"" . $val . "\"; export " . $var ;
system $str ;
} # &SetEnv
#---------------------------------------------------------------------------
# Restores the queues from the file
sub Restore
{ # print "Restoring queues... $$\n" ;
my ($host, $timeout, $mailto, $status, $ftpPID, $flag, @files, $src_dir,
$src_file, $dest_dir, $dest_file, $user, $passwd, $str, $ind, $i,
$setting, $value) ;
open F_IN, "/var/local/FTPqueue.save" ;
while ( $str = <F_IN> )
{ chop($str) ;
if ( ($str ne "") and (substr($str,0,1) ne "#") )
{ if ( $str eq "[defaults]" )
{ $str = <F_IN> ;
while ( $str and ( $str ne "==\n" ) )
{ chop($str) ;
if ( ($str ne "") and (substr($str,0,1) ne "#") )
{ ($setting, $value) = split /=/, $str ;
if ( $setting eq "timeout" )
{ $DEF_TIMEOUT = $value ; }
elsif ( $setting eq "mailto" )
{ $DEF_MAILTO = $value ; }
elsif ( $setting eq "flagmode" )
{ $DEF_FLAG = $value ; }
} # if
$str = <F_IN> ;
} # while
} # if
elsif ( $str eq "[hosts_settings]" )
{ $str = <F_IN> ;
# loop through stored hosts
while ( $str and ( $str ne "==\n") )
{ chop($str) ;
if ( ($str ne "") and (substr($str,0,1) ne "#") )
{ ($host,$timeout,$mailto,$status,$ftpPID,$flag) = split /:/, $str ;
&CreateQueue($host) ;
$queues{$host}{"timeout"} = $timeout ;
$queues{$host}{"mailto"} = $mailto ;
$queues{$host}{"status"} = $status ;
$queues{$host}{"ftpPID"} = $ftpPID ;
$queues{$host}{"flag"} = $flag ;
} # if
$str = <F_IN> ;
} # while
} # elsif
elsif ( $str eq "[hosts_queues]" )
{ $str = <F_IN> ;
# print "Restoring files... \n" ;
# loop through stored hosts
while ( $str and ( $str ne "==\n" ) )
{ chop($str) ; # print $str."\n" ;
if ( ( $str ne "" ) and (substr($str,0,1) ne "#") )
{ $host = $str ; # print $host."\n" ;
# print " Files for " . $host . "\n" ;
$str = <F_IN> ;
# loop through stored files for this host
while ( $str and ( $str ne "--\n" ) )
{ chop($str) ;
if ( ( $str ne "" ) and (substr($str,0,1) ne "#") )
{ ($src_dir, $src_file, $dest_dir, $dest_file, $user, $passwd)
= split /:/, $str ;
push @{$queues{$host}{"files"}}, [($src_dir, $src_file,
$dest_dir, $dest_file, $user, $passwd)] ;
# print "$src_dir $src_file $dest_dir $dest_file $user $passwd"
} # if
$str = <F_IN> ;
} # while (through files)
} # if
$str = <F_IN> ;
} # while (through hosts)
} # elsif
} # if
} # while
close F_IN ;
} # &Restore
#---------------------------------------------------------------------------
# Saves the queues to the file
sub Save
{ # print "Saving file... $$\n" ;
my ($host, $timeout, $mailto, $status, $ftpPID, $flag, @files, $src_dir,
$src_file, $dest_dir, $dest_file, $user, $passwd, $str, $ind, $i) ;
my($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) =
localtime(time) ;
$year += 1900 ;
open F_OUT, "> /var/local/FTPqueue.save" ;
print F_OUT "##########################################################\n" ;
print F_OUT "## File generated by queue.pl ##\n" ;
$str = sprintf("%02d/%02d/%04d - %02d:%02d:%02d",
$mday, $mon, $year, $hour, $min, $sec) ;
print F_OUT "## day/month/year - time = " . $str . " ##\n" ;
print F_OUT "## ##\n" ;
print F_OUT "## DO NOT EDIT THIS FILE ##\n" ;
print F_OUT "## UNLESS YOU KNOW EXACTLY WHAT ##\n" ;
print F_OUT "## YOU'RE DOING ! ##\n" ;
print F_OUT "##########################################################\n" ;
print F_OUT "# ONLY lines beginning by '#' and blank lines are ignored.\n" ;
print F_OUT "\n" ;
print F_OUT "[defaults]\n" ;
print F_OUT "timeout=" . $DEF_TIMEOUT . "\n" ;
print F_OUT "flagmode=" . $DEF_FLAG . "\n" ;
print F_OUT "mailto=" . $DEF_MAILTO . "\n" ;
print F_OUT "==\n" ;
print F_OUT "[hosts_settings]\n" ;
print F_OUT "# host:timeout:mailto:status:ftpPID:flag\n" ;
foreach $host (keys %queues)
{ # print "Saving settings for $host\n" ;
$str = $host . ":" ;
$str .= $queues{$host}{"timeout"} . ":" ;
$str .= $queues{$host}{"mailto"} . ":" ;
$str .= $queues{$host}{"status"} . ":" ;
$str .= $queues{$host}{"ftpPID"} . ":" ;
$str .= $queues{$host}{"flag"} . "\n" ;
print F_OUT $str
}
print F_OUT "==\n" ;
print F_OUT "[hosts_queues]\n" ;
print F_OUT "# First file noted = first (next) file to be send.\n" ;
print F_OUT "# src_dir:src_file:dest_dir:dest_file:user:password\n" ;
foreach $host (keys %queues)
{ print F_OUT $host . "\n" ;
@files = @{$queues{$host}{"files"}} ;
for ($ind = 0 ; $ind < @files ; $ind++)
{ $str = $files[$ind][0] ;
for ($i = 1 ; $i < 6 ; $i++)
{ $str .= ":" . $files[$ind][$i] ; }
$str .= "\n" ;
print F_OUT $str ;
}
print F_OUT "--\n" ;
}
print F_OUT "==\n" ;
close F_OUT ;
} # &Save
#---------------------------------------------------------------------------
# Validates a set of global params for a queue
sub ValidateQueue
{ # print "Validating queue... $$\n" ;
my($mailto, $flag, $timeout) = @_ ;
if ( $mailto eq "" ) { $mailto = $DEF_MAILTO ; }
if ( ($flag > 2) or ($flag < 0) ) { $flag = $DEF_FLAG ; }
if ( $timeout == 0 ) { $timeout = $DEF_TIMEOUT ; }
return ($mailto, $fag, $timeout) ;
} # &ValidateQueue
#---------------------------------------------------------------------------
# Validates a file name to be sent
sub ValidateFile
{ # print "Validating file... $$\n" ;
my($src_dir, $src_file, $dest_dir, $dest_file) = @_ ;
if ( $src_dir eq "" ) { $src_dir = "." ; }
if ( $dest_dir eq "" ) { $dest_dir = "." ; }
if ( $dest_file eq "" ) { $dest_file = $src_file ; }
return ($src_dir, $src_file, $dest_dir, $dest_file) ;
} # &ValidateFile
#---------------------------------------------------------------------------
# Builds the file-flag
# (<file_name>) ==> <file_name_with_flag>
sub BuildFlag
{ # print "Building flag... $$\n" ;
my($host, $file) = @_ ;
if ( $queues{$host}{"flag"} eq $FLAG_ADD )
{ return ( $file . ".flag" ) ; }
elsif ( $queues{$host}{"flag"} eq $FLAG_REP )
{ # print "Flag = replace " ;
my($pos, $pos2) = (0,0) ;
$pos = 0 ;
$pos2 = 0 ;
while ( ($pos2 = index($file, ".", $pos)) > -1 )
{ $pos = $pos2+1 ; }
return ( substr($file, 0, $pos) . "flag" ) ;
}
else
{ return $file ; }
} # &BuildFlag
#---------------------------------------------------------------------------
# Creates a queue : sets defaults, etc.
# (<host>)
sub CreateQueue
{ # print "Creating queue... $$\n" ;
my($host) = @_ ;
$queues{$host}{"timeout"} = $DEF_TIMEOUT ;
$queues{$host}{"mailto"} = $DEF_MAILTO ;
$queues{$host}{"flag"} = $DEF_FLAG ;
$queues{$host}{"status"} = "created" ;
$queues{$host}{"ftpPID"} = 0 ;
@{$queues{$host}{"files"}} = () ;
} # &CreateQueue
#---------------------------------------------------------------------------
# Finds a file in a queue
# (<host>, <src_dir>, <src_file>, <dest_dir>, <dest_file>, <user>, <passwd>)
# -----> <position_in_queue> (-1 if not found)
sub FindFile
{ # print "Finding file... $$ : " ;
my($host, @file) = @_ ;
my($i_files, $i_elem, $found, $nbelem, @files) ;
@files = @{$queues{$host}{"files"}} ;
$i_files = 0 ; $found = 0 ;
if ( $file[4] eq "" )
{ $nbelem = 4 ; }
else
{ $nbelem = 6 ; }
$found = 0 ;
while ( (not $found) and ($i_files < @files) )
{ $found = 1 ;
for ($i_elem = 0 ; $i_elem < $nbelem ; $i_elem++)
{ $found = ($found and ($files[$i_files][$i_elem] eq $file[$i_elem])) ; }
unless ( $found ) { $i_files++ ; }
}
if ( $found )
{ return $i_files ; }
else
{ return -1 ; }
} # &FindFile
#---------------------------------------------------------------------------
# Adds a file in a queue
sub AddInQueue
{ # print "Adding in queue... $$\n" ;
my($host, $src_dir, $src_file, $dest_dir, $dest_file, $user, $passwd)
= @_ ;
my($ftp_env) ;
$ftp_env = "FTP_QUEUE_" . $queues{$host}{"ftpPID"} ;
# Validating
my($numfile) ;
($src_dir, $src_file, $dest_dir, $dest_file) =
&ValidateFile($src_dir, $src_file, $dest_dir, $dest_file) ;
$numfile = &FindFile($host, $src_dir, $src_file, $dest_dir,
$dest_file, "", "") ;
if ( $numfile == -1 )
{ push @{$queues{$host}{"files"}},
[($src_dir, $src_file, $dest_dir, $dest_file, $user, $passwd)] ;
print "File not found : added\n" ;
}
elsif ( ($queues{$host}{"status"} eq "sending") and
($numfile == $ENV{$ftp_env}) )
{ print "File found & sending\n" ;
&StopFTP($host) ;
&FlushQueue($host) ;
}
} # &AddInQueue
#---------------------------------------------------------------------------
# Stops the running FTP of a queue
# (<host>)
sub StopFTP
{ # print "Stopping FTP... $$\n" ;
my($host) = @_ ;
my($ftp_env) ;
if ( defined $queues{$host} )
{ if ( $queues{$host}{"status"} eq "sending" )
{ kill 9, $queues{$host}{"ftpPID"} ;
$ftp_env = "FTP_QUEUE_" . $queues{$host}{"ftpPID"} ;
splice @{$queues{$host}{"files"}}, 0, $ENV{$ftp_env} ;
$queues{$host}{"ftpPID"} = 0 ;
delete $ENV{$ftp_env} ;
$queues{$host}{"status"} = "none" ;
}
}
} # &StopFTP
#---------------------------------------------------------------------------
# Schedules for a new FTP try
# (<host>)
sub Wait
{ # print "Waiting... $$\n" ;
my($host) = @_ ;
$queues{$host}{"status"} = "waiting" ;
open AT, "| at now + " . $queues{$host}{"timeout"} . " minutes " ;
print AT $INST_PATH."queue.pl -timeout -rh=" . $host . "\n" ;
# print "| at now + " . $queues{$host}{"timeout"} . " minutes " ;
# print "queue.pl -timeout -rh=" . $host . "\n" ;
close AT ;
} # &Wait
#---------------------------------------------------------------------------
# Tries to send files in a queue
# (<host>)
sub FlushQueue
{ # print "Flushing queue... $$\n" ;
my($host) = @_ ;
my($env_var, $nbok, $pid, $ind, $error, @files) ;
if ( $pid = fork )
{ # print "Father process : $$\n" ;
$queues{$host}{"ftpPID"} = $pid ;
$queues{$host}{"status"} = "sending" ;
}
elsif (defined $pid)
{ # we're in the child process : proceed the FTP
# print "Child process : $$\n" ;
@files = @{$queues{$host}{"files"}} ;
$env_var = "FTP_QUEUE_" . $$ ;
$nbok = 0 ;
$ind = 0 ;
&SetEnv($env_var, 0) ;
$error = "ok" ;
while ( ($ind < @files) and ($error eq "ok") )
{ $error = &FTPSend($host, @{$files[$ind]}, $queues{$host}{"flag"}) ;
if ( $error eq "ok" ) { $nbok++ ; }
&SetEnv($env_var, $nbok) ;
$ind++ ;
}
exec $INST_PATH .
"queue.pl -endftp -rh='$host' -ftperror='$error' -ftpok=$nbok" ;
# print "./queue.pl -endftp -rh=$host -ftperror='$error' -ftpok=$nbok\n" ;
die "Can't exec queue.pl -- exiting.\n" ;
}
else
{ $error = $! ;
&Mail("FTP queue : fork error", "Unable to fork : " . $error,
$queues{$host}{"mailto"}) ;
&ExitProg("die", "Unable to fork : " . $error) ;
}
} # &FlushQueue
#---------------------------------------------------------------------------
# Lists the queues currently running
sub ListQueues
{ # print "Listing queues... $$\n" ;
my($host) ;
foreach $host (keys %queues)
{ print "==============================================================\n" ;
print "Host $host -- Currently " . $queues{$host}{"status"} . "\n" ;
print @{$queues{$host}{"files"}} . " files -- delay : " ;
print $queues{$host}{"timeout"} . "\n" ;
print "Flag mode : " ;
print "no flag-file\n" if ($queues{$host}{"flag"} == $FLAG_NO) ;
print "add .flag to file name\n" if ($queues{$host}{"flag"} ==
$FLAG_ADD) ;
print "replace last ext with .flag\n" if ($queues{$host}{"flag"} ==
$FLAG_REP) ;
print "Mail to " . $queues{$host}{"mailto"} . " on problem.\n" ;
}
print "=============================================================\n" ;
} # &ListQueues
#---------------------------------------------------------------------------
# Lists the files in a queue
sub ListFiles
{ # print "Listing files... $$\n" ;
my($host) = @_ ;
my($src_dir, $src_file, $dest_dir, $dest_file, $user,
$passwd, $ind, @files) ;
@files = @{$queues{$host}{"files"}} ;
print "================================================================\n" ;
print "Host $host -- Currently " . $queues{$host}{"status"} . "\n" ;
print @files . " files -- delay : " ;
print $queues{$host}{"timeout"} . "\n" ;
print "Mail to " . $queues{$host}{"mailto"} . " on problem.\n" ;
print "Flag mode : " ;
print "no flag-file\n" if ($queues{$host}{"flag"} == $FLAG_NO) ;
print "add .flag to file name\n" if ($queues{$host}{"flag"} ==
$FLAG_ADD) ;
print "replace last ext with .flag\n" if ($queues{$host}{"flag"} ==
$FLAG_REP) ;
for ($ind=0 ; $ind < @files ; $ind++)
{ print "--------------------------------------------------------------\n" ;
print $files[$ind][0] . "/" . $files[$ind][1] . " --> " ;
print $files[$ind][2] . "/" . $files[$ind][3] . "\n" ;
print "User : ".$files[$ind][4]." -- Password : ".$files[$ind][5]."\n" ;
}
print "\n" ;
} # &ListFiles
#---------------------------------------------------------------------------
# List the current default options
sub ListDefaults
{ # print "Listing defaults... $$\n" ;
print "Default settings :\n" ;
print " * delay to wait (minutes) = " . $DEF_TIMEOUT . "\n" ;
print " * flag-file mode : " ;
print " no flag-file\n" if ($DEF_FLAG == $FLAG_NO) ;
print " add .flag to file name\n" if ($DEF_FLAG == $FLAG_ADD) ;
print " replace last ext with .flag\n" if ($DEF_FLAG == $FLAG_REP) ;
print " * mail to " . $DEF_MAILTO . " on problems\n" ;
print "\n" ;
print "Use queue.pl -config -rh=<hostname> to see the settings " ;
print "for a particular host.\n" ;
} # &ListDefaults
#---------------------------------------------------------------------------
# List the settings for a host
sub ListHostSettings
{ # print "Listing host settings... $$\n" ;
my($host) = @_ ;
print "Settings for the host $host :\n" ;
print " * delay to wait (minutes) = " . $queues{$host}{"timeout"} . "\n" ;
print " * flag-file mode : " ;
print " no flag-file\n" if ($queues{$host}{"flag"} == $FLAG_NO) ;
print " add .flag to file name\n" if ($queues{$host}{"flag"} ==
$FLAG_ADD) ;
print " replace last ext with .flag\n" if ($queues{$host}{"flag"} ==
$FLAG_REP) ;
print " * mail to " . $queues{$host}{"mailto"} . " on problems\n" ;
} # &ListHostSettings
#---------------------------------------------------------------------------
# Change the defaults options
sub SetDefaults
{ # print "Setting defaults... $$\n" ;
# Delay parameter
if ( $param{"delay"} ne "" )
{ if ( $param{"delay"} > 0 )
{ $DEF_TIMEOUT = $param{"delay"} ;
print "Delay changed to " . $param{"delay"} . " minutes.\n" ;
}
else
{ print "Delay too short -- unchanged.\n" ; }
}
# Mail to parameter
if ( $param{"mailto"} ne "" )
{ if ( index($param{"mailto"}, "@") > 0 )
{ $DEF_MAILTO = $param{"mailto"} ;
print "Now mail to " . $DEF_MAILTO . " on problems.\n" ;
}
else
{ print "Mail unchanged -- \@ not present.\n" ; }
}
# Flag file parameter
if ( $param{"flag"} ne "" )
{ my($okflag) = 0 ;
if ( lc($param{"flag"}) eq "no" )
{ $DEF_FLAG = $FLAG_NO ;
print "Flag mode changed to : no flag file.\n" ;
$okflag = 1 ;
}
if ( lc($param{"flag"}) eq "add")
{ $DEF_FLAG = $FLAG_ADD ;
print "Flag mode changed to : add .flag to file name.\n" ;
$okflag = 1 ;
}
if ( lc($param{"flag"}) eq "rep")
{ $DEF_FLAG = $FLAG_REP ;
print "Flag mode changed to : replace last ext with .flag.\n" ;
$okflag = 1 ;
}
if ( not $okflag )
{ print "Unknown value (not 'add', 'rep', or 'no') -- " ;
print "flag mode unchanged.\n" ;
}
}
} # &SetDefaults
#---------------------------------------------------------------------------
# Changes the settings for a queue
sub SetHostSettings
{ # print "Setting host settings... $$\n" ;
my($host) = @_ ;
print "Settings for " . $host . " :\n" ;
# Delay parameter
if ( $param{"delay"} ne "" )
{ if ( $param{"delay"} > 1 )
{ $queues{$host}{"timeout"} = $param{"delay"} ;
print "Delay changed to " . $param{"delay"} . " minutes.\n" ;
}
else
{ print "Delay too short -- unchanged.\n" ; }
}
# Mail to parameter
if ( $param{"mailto"} ne "" )
{ if ( index($param{"mailto"}, "@") > 0 )
{ $queues{$host}{"mailto"} = $param{"mailto"} ;
print "Now mail to " . $param{"mailto"} . " on problems.\n" ;
}
else
{ print "Mail unchanged -- \@ not present.\n" ; }
}
# Flag file parameter
if ( $param{"flag"} ne "" )
{ my($okflag) = 0 ;
if ( lc($param{"flag"}) eq "no" )
{ $queues{$host}{"flag"} = $FLAG_NO ;
print "Flag mode changed to : no flag file.\n" ;
$okflag = 1 ;
}
if ( lc($param{"flag"}) eq "add")
{ $queues{$host}{"flag"} = $FLAG_ADD ;
print "Flag mode changed to : add .flag to file name.\n" ;
$okflag = 1 ;
}
if ( lc($param{"flag"}) eq "rep")
{ $queues{$host}{"flag"} = $FLAG_REP ;
print "Flag mode changed to : replace last ext with .flag.\n" ;
$okflag = 1 ;
}
if ( not $okflag )
{ print "Unknown value (not 'add', 'rep', or 'no') -- " ;
print "flag mode unchanged.\n" ;
}
}
} # &SetHostSettings
#---------------------------------------------------------------------------
# Mails a string to someone
# (<subject>, <message>, <recipient>)
sub Mail
{ # print "Mailing... $$\n" ;
my($subject, $mesg, $recip) = @_ ;
my($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) =
localtime(time) ;
$year = $year + 1900 ;
my($datetime) = sprintf("%02d/%02d/%04d - %02d:%02d:%02d",
$mday, $mon, $year, $hour, $min, $sec) ;
open MAIL, "| mail -s '$subject' $recip" ;
print MAIL "\nFTP Queue Manager report START ==========================\n" ;
print MAIL "----- Report send from " . $ENV{"HOSTNAME"} . "\n" ;
print MAIL "----- day/month/year - time = " . $datetime . "\n" ;
print MAIL $mesg ;
print MAIL "\nFTP Queue Manager report END ============================\n" ;
close MAIL ;
} # &Mail
#---------------------------------------------------------------------------
# Builds a string describing the context, with a comment
# (<host>, <file_number>, <comment>) ==> context-string
sub BuildContext
{ # print "Building context... $$\n" ;
my($host, $numfile, $comment) = @_ ;
my($context) = ("") ;
my(@files) = @{$queues{$host}{"files"}} ;
$context = "\n# Remote host implied : " . $host . "\n" ;
$context .= " > TimeOut = " . $queues{$host}{"timeout"} . " minutes\n" ;
$context .= " > MailTo = " . $queues{$host}{"mailto"} . "\n" ;
$context .= " > Flag = " ;
$context .= " no flag-file\n" if ($queues{$host}{"flag"} == $FLAG_NO) ;
$context .= " add .flag to file name\n"
if ($queues{$host}{"flag"} == $FLAG_ADD) ;
$context .= " replace last ext with .flag\n"
if ($queues{$host}{"flag"} == $FLAG_REP) ;
$context .= " > Status = " . $queues{$host}{"status"} . "\n" ;
$context .= " > FTP PID = " . $queues{$host}{"ftpPID"} ;
$context .= " --> if makes sense !\n" ;
$context .= " > NbFiles = " . @files . "\n\n" ;
$context .= "# File implied :\n" ;
$context .= " > SrcDir = " . $files[$numfile][0] . "\n" ;
$context .= " > SrcFile = " . $files[$numfile][1] . "\n" ;
$context .= " > DestDir = " . $files[$numfile][2] . "\n" ;
$context .= " > DestFile = " . $files[$numfile][3] . "\n" ;
$context .= " > User = " . $files[$numfile][4] . "\n" ;
$context .= " > Password = " . $files[$numfile][5] . "\n\n" ;
$context .= "# Comment :\n" ;
$context .= " > " . $comment . "\n" ;
return $context ;
} # &BuildContext
#---------------------------------------------------------------------------
# Does the FTP ; returns an error-string, "ok" on success
sub FTPSend
{ "FTP send... $$\n" ;
my($host, $src_dir, $src_file, $dest_dir, $dest_file, $user, $passwd) = @_ ;
# print $user." ".$passwd."\n" ;
unless ( &ftp::open($host, $user, $passwd) )
{ return "Opening : " . &ftp::error() ; }
unless ( &ftp::binary() )
{ return "Binary : " . &ftp::error() ; }
unless ( &ftp::put($src_dir."/".$src_file, $dest_dir."/".$dest_file) )
{ return "Put : " . &ftp::error() ; }
if ( $queues{$host}{"flag"} ne $FLAG_NO )
{ # print "Creating " . $dest_dir."/".&BuildFlag($host, $dest_file)."\n" ;
unless ( &ftp::create($dest_dir."/".&BuildFlag($host, $dest_file)) )
{ return "Creating : " . &ftp::error() ; }
}
unless ( &ftp::close() )
{ return "Closing : " . &ftp::error() ; }
else
{ return "ok" ; }
} # &FTPSend
--------------5CFCBA86407EF4911200F784--
------------------------------
Date: Thu, 20 Aug 1998 22:08:19 +0100
From: "Daniel Adams" <dan@fearsome.net>
Subject: Re: Sigh
Message-Id: <903648284.20112.0.nnrp-11.c2deb1c5@news.demon.co.uk>
Adam Rabung wrote in message <35DC8D4F.1E222AC1@neweducation.com>...
>I retire from this newsgroup. It seeming consists only of
> 1. Beginning programmers who are too lazy to type "man"
> 2. Seasoned, angry programmers ready to pounce on anyone,
>brandishing references to endless reams of faqs, man pages, and web
>pages.
I think that might be a bit harsh, and you are assuming that everything that
goes on in comp.lang.perl.misc is displayed in the ng, which is slightly
short-sighted. That isn't quite as stupid a statement as you may think it is
(not as stupid as my wholly inadvertant suggestion that
comp.infosystems.www.authoring.cgi is the correct forum for enquiries about
home-grown bananas anyway ;-)
I think you are forgetting that a large amount of traffic is sent via
email - that is, a newbie (or even a fairly accomplished programmer who is
banging his head against the wall over a certain Perl issue) will post a
question and replies will come in via email and ng. There is a reason that
you see flames on the ng - most of the helpful replies are sent by email.
The thing is, people who flame not only want to attack the newbiew in
question, but they want to do so publicly whereas people wishing to help
will often contact the question author via email because that is the most
helpful thing to do. That accounts for at least some of the balance of what
you see - I'd still dispute your suggestion that the group is filled with
only FAQs and flames anyway, thats a slightly paranoid outlook on the
situation.
The ng works, just like most, because everybody wins. Newbies get help.
Experts get jobs and experience. And all the rest of us who are somewhere in
between those two extremes find a useful forum for gaining some combination
of the above.
--
Dan Adams
dan@fearsome.net
------------------------------
Date: Thu, 20 Aug 1998 21:56:05 +0100
From: Kiril <work@nospam.idea.co.uk>
Subject: Re: su on NT
Message-Id: <35DC8D65.D92C3DEB@nospam.idea.co.uk>
You might wan to configure he service itself to run
as a certain user/group - from
Control Panel\Services
Pete Keefe wrote:
>
> In the NT 4.0 server resource kit there is a SU.EXE program that looks like
> it will do what you are want.
> Good luck
> Pete
>
> James O Flynn wrote in message <35D83B78.A54E8CE3@hursley.ibm.com>...
> >New to using perl on NT and I need to be able to start
> >jobs with particular uids and gids.
> >How do I:
> >unless ( fork )
> > {
> > $UID = "user";
> > $GID = "group";
> > exec( "script" );
> > }
> >???
> >With the deamon running as a service set up by administrator?
> >Cheers,
> >James.
> >--
> >4920616d206e6f742061206e756d62657221
------------------------------
Date: 20 Aug 1998 21:46:30 GMT
From: Scratchie <upsetter@ziplink.net>
Subject: Taint Question
Message-Id: <6ri5fm$169@fridge.shore.net>
A Quick question:
Can anyone explain why
$input =~ m|^/?([\w-]+)$|;
$tag_file = $1;
results in an untainted $tag_file, but
($tag_file) = ( $input =~ m|^/?([\w-]+)$| );
doesn't?
TIA,
--Art
--------------------------------------------------------------------------
National Ska & Reggae Calendar
http://www.agitators.com/calendar/
--------------------------------------------------------------------------
------------------------------
Date: Thu, 20 Aug 1998 14:00:18 -0700
From: Nathan Franzen <franzen@pmel.noaa.gov>
Subject: Re: what is 'sub f () {555};'
Message-Id: <Pine.SOL.3.96.980820135659.9004G-100000@corona.pmel.noaa.gov>
On Thu, 20 Aug 1998, Steven Smith wrote:
> I'm trying to understand a lib we pulled off of the net. I've never
> seen this before.
> what would a sub declaration like this do??
>
> sub f () {555};
It's a constant. See perldoc perlsub, in section titled "Constant
Functions". The people who wrote that documentation understand it better
than I do.
The source for the 'constant' pragma (constant.pm) is also interesting
reading.
Regards,
Nathan
------------------------------
Date: Thu, 20 Aug 1998 22:15:50 GMT
From: itxjcs@unix.ccc.nottingham.ac.uk (James Stout)
Subject: Re: wtf is the obsession with "foo" and "bar"
Message-Id: <35de9fe9.19308867@news.nottingham.ac.uk>
Wow
Thanks for answering this question
It has been bugging me for ages, but I thought I would be too stupid
if I asked
Jim
------------------------------
Date: 12 Jul 98 21:33:47 GMT (Last modified)
From: Perl-Request@ruby.oce.orst.edu (Perl-Users-Digest Admin)
Subject: Special: Digest Administrivia (Last modified: 12 Mar 98)
Message-Id: <null>
Administrivia:
Special notice: in a few days, the new group comp.lang.perl.moderated
should be formed. I would rather not support two different groups, and I
know of no other plans to create a digested moderated group. This leaves
me with two options: 1) keep on with this group 2) change to the
moderated one.
If you have opinions on this, send them to
perl-users-request@ruby.oce.orst.edu.
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.misc (and this Digest), send your
article to perl-users@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.
The Meta-FAQ, an article containing information about the FAQ, is
available by requesting "send perl-users meta-faq". The real FAQ, as it
appeared last in the newsgroup, can be retrieved with the request "send
perl-users FAQ". Due to their sizes, neither the Meta-FAQ nor the FAQ
are included in the digest.
The "mini-FAQ", which is an updated version of the Meta-FAQ, is
available by requesting "send perl-users mini-faq". It appears twice
weekly in the group, but is not distributed in the digest.
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 V8 Issue 3496
**************************************
