Article 3414 of comp.lang.perl:
Xref: feenix.metronet.com alt.sources:1421 comp.lang.perl:3414 news.software.readers:1868
Path: feenix.metronet.com!news.ecn.bgu.edu!psuvax1!uwm.edu!cs.utexas.edu!usc!elroy.jpl.nasa.gov!ames!skates.gsfc.nasa.gov!usenet
From: pat@jaameri.gsfc.nasa.gov (patrick m. ryan)
Newsgroups: alt.sources,comp.lang.perl,news.software.readers
Subject: pInews (beta), a Perl NNTP posting program
Date: 14 Jun 1993 11:29:26 EDT
Organization: Oceans & Ice Branch, Code 971, NASA/GSFC/Hughes STX
Lines: 734
Message-ID: <1vi5jt$1ne@skates.gsfc.nasa.gov>
Reply-To: pat@jaameri.gsfc.nasa.gov (patrick m. ryan)
NNTP-Posting-Host: jaameri.gsfc.nasa.gov
Mime-Version: 1.0
Content-Type: text/plain; charset=US-ASCII
Content-Transfer-Encoding: 7bit
X-Posting-Version: pInews [v. 0.2]


	Included below is the beta version of my Perl NNTP posting
program, pInews. Please let me know if it works for you.


#!/bin/sh
# This is a shell archive (produced by shar 3.49)
# To extract the files from this archive, save it to a file, remove
# everything above the "!/bin/sh" line above, and type "sh file_name".
#
# made 06/14/1993 15:28 UTC by pat@jaameri
# Source directory /home/pat/perl
#
# existing files will NOT be overwritten unless -c is specified
#
# This shar contains:
# length  mode       name
# ------ ---------- ------------------------------------------
#   6811 -rwxr-xr-x pInews
#   2096 -rw-r--r-- README.pInews
#   8535 -r--r--r-- date.pl
#
# ============= pInews ==============
if test -f 'pInews' -a X"$1" != X"-c"; then
	echo 'x - skipping pInews (File already exists)'
else
echo 'x - extracting pInews (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'pInews' &&
#!/usr/local/bin/perl -- -*- Perl -*-
#
# $Header: /home/pat/perl/RCS/pInews,v 0.2 1993/06/14 14:41:31 pat Exp pat $
#
#  pInews   - Perl Inews (or maybe Pat's Inews)
#       a simple NNTP news posting client
#
# references:
#    RFC 850
#    RFC 977
#
#
#
# server connection code taken from pgnews written by
#    Jeffrey B. McGough  mcgough@wrdis01.af.mil
#
#
# bug reports, fixes, fan mail, cash donations to:
#     pat@jaameri.gsfc.nasa.gov (patrick m. ryan)
#
X
require 'getopts.pl';
require 'date.pl';
X
&Getopts('h:vd');
X
$rcsid = q!$Id: pInews,v 0.2 1993/06/14 14:41:31 pat Exp pat $!;
$v = (split(/\s+/,$rcsid))[2];
$version = "pInews [v. $v]";
X
# host and domain *must* be set!!
chop($host = `hostname`); 
if (!$host) { die "could not determine hostname\n"; }
X
$domain = "gsfc.nasa.gov";
if (!$domain) { die "no domain set\n"; }
X
$fullname = (getpwuid($<))[6];
if ($fullname =~ /,/)		# strip out the extra gcos stuff
{
X    @f = split(/,/,$fullname);
X    $fullname=$f[0];
}
X
# get user name
$user = getlogin() || (getpwuid($<))[0] ||
X    $ENV{USER} || $ENV{LOGNAME} ||
X    die "who are you?\n";
# get user's home directory  
$home = $ENV{HOME} || (getpwuid($<))[7] ||
X    die "you are homeless!\n";
X
$pIrc = $home . "/.pIrc";
X
$port = 119; # for NNTP
$nntpserver = $opt_h || $ENV{NNTPSERVER};
if (!$nntpserver && -f '/etc/nntpserver')
{
X    chop ($nntpserver = `cat /etc/nntpserver`);
}
if (!$nntpserver) { $nntpserver='localhost'; } # last resort
X
# Pack format...
$sockaddr = 'S n a4 x8';
X
$DOMAIN = 2;
$STYLE = 1;
X
$rin = $rout = '';
X
($name, $aliases, $proto) = getprotobyname('tcp');
($name, $aliases, $type, $len, $hostaddr) = gethostbyname($nntpserver);
X
$sock = pack($sockaddr, $DOMAIN, $port, $hostaddr);
X
$SIG{'ALRM'} = 'handler';
alarm(60);
X
print "connecting to $nntpserver...";
socket(S, $DOMAIN, $STYLE, $proto) || die $!;
connect(S, $sock) || die $!;
select(S); $| = 1; select(STDOUT);
alarm(0);
print "\n";
X
# set up for select
vec($rin, fileno(S), 1) = 1;
# this select will block until the server gives us something.
$nfound = select($rout=$rin, undef, undef, 900);
if ($nfound == 0)
{
X	print "Socket timed out...";
X	exit 1;
}
$_ = <S>; # read one line to see if we got a good connection.
if ($opt_d) { print $_; }
if ($_ !~ /^200/)
{
X	print;
X	print S 'quit\n';
X	print $_,"\n";
X	die "Service unavailable";
}
X
$tmpdir = $ENV{TMPDIR} || '/tmp';
$tmp = $tmpdir . '/.pinews.'.$$;
$editor = $ENV{VISUAL} || $ENV{EDITOR} || "vi";
$dead = $home."/dead.article";
X
# list of required headers from RFC850
%header = (
X	   'From','',
X	   'Date','',
##	   'Relay-Version','',
##	   'X-Newsreader','',
X	   'X-Posting-Version',$version,
X	   'Newsgroups','',
X	   'Subject','',
X	   'Message-ID','',
X	   'Path',''
X	   );
X
###$header{'NNTP-Posting-Host'} = $host;
$header{From} = "$user@$host.$domain";
if ($fullname)
{ $header{From} .= " ($fullname)"; }
X
# grab user's personal headers, if any
%myheaders=();
if ( -f $pIrc )
{
X    (%myheaders) = &split_headers($pIrc);
X    if ($opt_d)
X    {
X	print "user headers:\n";
X	while (($key,$value) = each %myheaders)
X	{
X	    printf "%3d\t%s: %s",$i++,$key,$value;
X	}
X    }
}
X
# now ask the user for a few headers  
@ask_headers = ('Newsgroups','Subject');
X
foreach (@ask_headers)
{
X    print "$_: ";
X    $r="";
X    until ($r)
X    {
X	$r = <STDIN>;
X	chop $r;
X    }
X    $header{$_} = $r;
}
X
$header{Newsgroups} =~ s/\s//g;
##$header{"Message-ID"} = "<$$.$<@$host>";
##$fmt = "%a, %d-%b-%Y %T %Z";
$fmt = "%d %h %Y %T %Z";
$header{Date} = &date(time(),$fmt);
X
if ($opt_d)
{
X    print "\nheaders:\n";
X    while (($key,$value) = each %header)
X    {
X	print "\t$key: $value\n";
X    }
}
X
# construct header
X
@req_headers = (From,Newsgroups,Subject,Date,'X-Posting-Version');
$head = '';
foreach (@req_headers)
{
X    if ($header{$_})
X    {
X	$head .= "$_: $header{$_}\n";
X    }
X    # should probably be an error of one of these is missing
}
X
# send user header lines, if any
if (%myheaders)
{
X    while (($key,$value) = each %myheaders)
X    {
X	unless (defined($header{$key})) # don't overwrite reserved headers
X	{
X	    $head .= "$key: $value";
X	}
X    }
}
X
# touch the file so that it is not world readable
open(TMP,">$tmp");
chmod(0600,$tmp);
close TMP;
X
# invoke the editor for create the article
X
$cmd = "$editor $tmp";
if ($opt_d) { print $cmd,"\n"; }
system $cmd;
if ($?>>8)			# error from system()
{
X    print STDERR "error executing \"$cmd\"\n";
X    if ( -s $tmp )
X    {
X	&save_article($head,$tmp,$dead);
X    }
X    unlink $tmp;
X    print S "quit\n";
X    exit 1;
}
X
X
print "post article? ";
chop ($r = <STDIN>);
X
if ($r !~ /^\s*y/i)
{
X    print "ok. not posting\n";
X    &save_article($head,$tmp,$dead);
X    unlink $tmp;
X    print S 'quit\n';
X    exit 0;
}
X
# now try to send the article
X
print "posting article...\n";
X
print S "post\n";
$_ = <S>;
if ($opt_d) { print $_; }
# check reply value
X
X
if ($opt_d)
{
X    print "sending headers:\n";
X    print $head;
}
X
print S $head;
print S "\n";		# blank line after header
X
open(TMP,"<$tmp") || die;
while (<TMP>)
{
X    if ($_ eq ".\n")
X    { print S "..\n"; }	# this looks like an EOT marker
X    else
X    { print S $_; }
}
print S ".\n";
close TMP;
$_ = <S>;
###    if ($opt_d) { print $_; }
if ($_ !~ /^240/)
{
X    print STDERR $_;
X    &save_article($head,$tmp,$dead);
}
else
{
X    print "article posted\n";
}
X
print S "quit\n";
unlink $tmp;
X
Xexit 0;
X
X
sub handler
{
X    local($sig) = @_;
X    print "Caught a SIG$sig--aborting\n";
X    unlink $tmp;
X    exit(0);
}
X
sub split_headers
{
X    
# generates an associative array containing all of the header
# information from a mail message.
#    
# bugs:
#   doesn't handle mutiple instances of the same field.
#   right now, it just concatenates them.
#   usually, this doesn't matter.
X    
X    local($file)=@_;
X
X    # swallow the entire header file.  yum, yum...
X    open(HEADER,"<$file");
X    local(@lines)=<HEADER>;
X    close(HEADER);
X    
X    local(%headers,$tmp);
X
X    %headers=();
X    while (@lines)
X    {
X	$_ = shift(@lines);
X
X	if (/^\s*\n$/o) { last; } # this is an empty line
X
X	# split header line as "field: value"
##	($field,$value) = /^([^:]+):\s*(.*\n)/o ;
X	($field,$value) = split(/\s*:\s*/,$_,2);
X	
X	if (( !$field ) || (!$value)) { next; } # unrecognized header
X
X	$tmp='';
# need to change field to all same case?
# append multiply defined headers
X	$headers{$field} .= $value;
X	
X	# append any continuation lines
X	while ($lines[0] =~ /^\s+/o)
X	{
X	    $headers{$field} .= shift(@lines);
X	}
X    }
X
X    # 
X    return (%headers);
X
}
X
sub save_article
{
X    local($head,$tmp,$dead) = @_;
X
X    $ok=1;
X
X    open(DEAD,">$dead") || die "couldn't save article\n";
X    print DEAD $head;
X    print DEAD "\n";
X
X    open(TMP,"<$tmp");
X    while (<TMP>)
X    {
X	print DEAD $_;
X    }
X    close TMP;
X    close DEAD;
X    
X    print STDERR "saved article in $dead\n";
X    return;
}
SHAR_EOF
chmod 0755 pInews ||
echo 'restore of pInews failed'
Wc_c="`wc -c < 'pInews'`"
test 6811 -eq "$Wc_c" ||
	echo 'pInews: original size 6811, current size' "$Wc_c"
fi
# ============= README.pInews ==============
if test -f 'README.pInews' -a X"$1" != X"-c"; then
	echo 'x - skipping README.pInews (File already exists)'
else
echo 'x - extracting README.pInews (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'README.pInews' &&
X
pInews - v.0.2
X
X	This is a beta release of pInews, my quick & dirty NNTP posting
program written in Perl.  I wrote it because I don't have a standalone
posting program like Pnews and because I wanted to learn a little about
networking.
X
X	I'd appreciate it if someone who knows a lot about posting software
could take a look at this program, specifically at the headers I set up for
articles.  I sat down with RFC850 and RFC977 and made my best guess as to
which headers my program is required to send.
X
X	*Please* let me know if this program causes anyone any problems.
I'd rather not crash anyone's NNTP server.  I strongly recommend that you
try posting to your local *.test newsgroup before posting to the rest of
the world.  The program is pretty simple so it shouldn't be hard to track
down any fatal errors.  Bug reports and enhancement ideas are welcome.
X
X
INSTALLATION
X
1. Make sure you have 'date.pl' available somewhere.  I've included it with
X   this distribution in case you don't have it.
X
2. Edit the line which says "$domain = " and set it for your system.
X
3. Put pInews /usr/local/bin or wherever you keep local software.
X
4. Post away!
X
OPTIONS
X	-h hostname	specify NNTP server machine
X	-d		debug this program
X
NOTES
X	The identity of the NNTP server machine can be specified in several
places.  They are listed here in decreasing order of precedence:
X
X	1. command line  -  -h hostname
X	2. environment   -  $NNTPSERVER
X	3. file          -  /etc/nntpserver
X	4. default       -  "localhost"
X
X
X	There is NO WARRANTY associated with this program.  The author is
not responsible for any loss which may occur as a result of using this
program.
X
CREDITS
X	The server connection code taken from pgnews written by
Jeffrey B. McGough mcgough@wrdis01.af.mil
X
X
The address for bug reports is pat@jaameri.gsfc.nasa.gov.
X
--
"I have a cunning plan." -- Baldrick
X                                                             patrick m. ryan
X     nasa / goddard space flight center / oceans and ice branch / hughes stx
X               pat@jaameri.gsfc.nasa.gov / patrick.m.ryan@x500.gsfc.nasa.gov
X
SHAR_EOF
chmod 0644 README.pInews ||
echo 'restore of README.pInews failed'
Wc_c="`wc -c < 'README.pInews'`"
test 2096 -eq "$Wc_c" ||
	echo 'README.pInews: original size 2096, current size' "$Wc_c"
fi
# ============= date.pl ==============
if test -f 'date.pl' -a X"$1" != X"-c"; then
	echo 'x - skipping date.pl (File already exists)'
else
echo 'x - extracting date.pl (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'date.pl' &&
;#
;# Name
;#	date.pl - Perl emulation of (the output side of) date(1)
;#
;# Synopsis
;#	requirelude "date.pl";
;#	$Date = &date(time);
;#	$Date = &date(time, $format);
;#
;# Description
;#	This package implements the output formatting functions of date(1) in
;#	Perl.  The format options are based on those supported by Ultrix 4.0
;#	plus a couple of additions:
;#
;#		%a		abbreviated weekday name - Sun to Sat
;#		%A		full weekday name - Sunday to Saturday
;#		%b		abbreviated month name - Jan to Dec
;#		%B		full month name - January to December
;#		%c		date and time in local format [+]
;#		%d		day of month - 01 to 31
;#		%D		date as mm/dd/yy
;#		%e		day of month (space padded) - ` 1' to `31'
;#		%h		abbreviated month name - Jan to Dec
;#		%H		hour - 00 to 23
;#		%I		hour - 01 to 12
;#		%j		day of the year (Julian date) - 001 to 366
;#		%m		month of year - 01 to 12
;#		%M		minute - 00 to 59
;#		%n		insert a newline character
;#		%p		AM or PM
;#		%r		time in AM/PM notation
;#		%R		time as HH:MM
;#		%S		second - 00 to 59
;#		%t		insert a tab character
;#		%T		time as HH:MM:SS
;#		%U		week number, Sunday as first day of week - 00 to 53
;#		%w		day of week - 0 (Sunday) to 6
;#		%W		week number, Monday as first day of week - 00 to 53
;#		%x		date in local format [+]
;#		%X		time in local format [+]
;#		%y		last 2 digits of year - 00 to 99
;#		%Y		all 4 digits of year ~ 1700 to 2000 odd ?
;#		%z		time zone from TZ environment variable w/ a trailing space [*]
;#		%Z		time zone from TZ environment variable
;#		%%		insert a `%' character
;#		%+		insert a `+' character [*]
;#
;#	[*]:  Not supported by date(1) but I wanted 'em.
;#	[+]:  These may need adjustment to fit local conventions, see below.
;#
;#	For the sake of compatibility, a leading `+' in the format
;#	specificaiton is removed if present.
;#
;# Remarks
;#	An extension of `ctime.pl' by Waldemar Kebsch (kebsch.pad@nixpbe.UUCP),
;#	as modified by Marion Hakanson (hakanson@ogicse.ogi.edu).
;#
;#  Unlike date(1), unknown format tags are silently replaced by "".
;#
;#  defaultTZ is a blatant hack, but I wanted to be able to get date(1)
;#	like behaviour by default and there does'nt seem to be an easy (read
;#	portable) way to get the local TZ name back...
;#
;#	For a cheap date, try...
;#
;#		#!/usr/local/bin/perl
;#		require "date.pl";
;#		exit print (&date(time, shift @ARGV) . "\n") ? 0 : 1;
;#
;#	This package is redistributable under the same terms as apply to
;#	the Perl 3.0 release.  See the COPYING file in your Perl kit for
;#	more information.
;#
;#	Please send any bug reports or comments to tmcgonigal@gvc.com
;#
;# Modification History
;#	Nmemonic	Version	Date		Who
;#
;#	NONE		none	02feb91		Terry McGonigal (tmcgonigal@gvc.com)
;#		Created from ctime.pl
;#
;#	NONE		none	07feb91		tmcgonigal
;#		Added some of Marion Hakanson (hakanson@ogicse.ogi.edu)'s ctime.pl
;#		TZ handling changes.
;#
;#	NONE		none	09feb91		tmcgonigal
;#		Corrected week number calculations.
;#
;# SccsId = "%W% %E%"
;#
package date;
X
# Months of the year
@MoY = ('January',	'Febuary',	'March',	'April',	'May',		'June',
X		'July',		'August',	'September','October',	'November', 'December');
X
# days of the week
@DoW = ('Sunday',	'Monday',	'Tuesday',	'Wednesday',
X		'Thursday',	'Friday',	'Saturday');
X
# defaults
$defaultTZ = 'EST';					# time zone (hack!)
$defaultFMT = '%a %h %e %T %z%Y';	# format (ala date(1))
X
# `local' formats
$locTF = '%T';						# time (as HH:MM:SS)
$locDF = '%D';						# date (as mm/dd/yy)
$locDTF = '%a %b %d %T %Y';			# date/time (as dow mon dd HH:MM:SS yyy)
X
# Time zone info
$TZ;								# wkno needs this info too
X
# define the known format tags as associative keys with their associated
# replacement strings as values.  Each replacement string should be
# an eval-able expresion assigning a value to $rep.  These expressions are
# eval-ed, then the value of $rep is substituted into the supplied
# format (if any).
%Tags = ( '%a', '($rep = $DoW[$wday])=~ s/^(...).*/\1/',# abbr. weekday name - Sun to Sat
X		  '%A', '$rep = $DoW[$wday]',					# full weekday name - Sunday to Saturday
X		  '%b', '($rep = $MoY[$mon]) =~ s/^(...).*/\1/',# abbr. month name - Jan to Dec
X		  '%B', '$rep = $MoY[$mon]',					# full month name - January to December
X		  '%c', '$rep = $locDTF; 1',					# date/time in local format
X		  '%d',	'$rep = &date\'pad($mday, 2, "0")',		# day of month - 01 to 31
X		  '%D',	'$rep = \'%m/%d/%y\'',					# date as mm/dd/yy
X		  '%e', '$rep = &date\'pad($mday, 2, " ")',		# day of month (space padded) ` 1' to `31'
X		  '%h', '$rep = \'%b\'',						# abbr. month name (same as %b)
X		  '%H',	'$rep = &date\'pad($hour, 2, "0")',		# hour - 00 to 23
X		  '%I', '$rep = &date\'ampmH($hour)',			# hour - 01 to 12
X		  '%j', '$rep = &date\'pad($yday+1, 3, "0")',	# Julian date 001 - 366
X		  '%m',	'$rep = &date\'pad($mon+1, 2, "0")',	# month of year - 01 to 12
X		  '%M', '$rep = &date\'pad($min, 2, "0")',		# minute - 00 to 59
X		  '%n',	'$rep = "\n"',							# insert a newline
X		  '%p', '$rep = &date\'ampmD($hour)',			# insert `AM' or `PM'
X		  '%r', '$rep = \'%I:%M:%S %p\'',				# time in AM/PM notation
X		  '%R', '$rep = \'%H:%M\'',						# time as HH:MM
X		  '%S', '$rep = &date\'pad($sec, 2, "0")',		# second - 00 to 59
X		  '%t',	'$rep = "\t"',							# insert a tab
X		  '%T',	'$rep = \'%H:%M:%S\'',					# time as HH:MM:SS
X		  '%U',	'$rep = &date\'wkno($yday, 0)',			# week number (weeks start on Sun) - 00 to 53
X		  '%w', '$rep = $wday; 1',						# day of week - Sunday = 0
X		  '%W', '$rep = &date\'wkno($yday, 1)',			# week number (weeks start on Mon) - 00 to 53
X		  '%x', '$rep = $locDF; 1',						# date in local format
X		  '%X', '$rep = $locTF; 1',						# time in local format
X		  '%y', '($rep = "$year") =~ s/..(..)/\1/',		# last 2 digits of year - 00 to 99
X		  '%Y', '$rep = "$year"',						# full year ~ 1700 to 2000 odd
X		  '%z', '$rep = $TZ eq "" ? "" : "$TZ "',		# time zone from TZ env var (w/trail. space)
X		  '%Z', '$rep = $TZ; 1',						# time zone from TZ env. var.
X		  '%%', '$rep = \'%\'; $adv=1',					# insert a `%'
X		  '%+', '$rep = \'+\''							# insert a `+'
);
X	
sub main'date {
X	local($time, $format) = @_;
X	local($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst);
X	local($pos, $tag, $rep, $adv) = (0, "", "", 0);
X
X
X	# default to date/ctime format or strip leading `+'...
X	if ($format eq "") {
X		$format = $defaultFMT;
X	} elsif ($format =~ /^\+/) {
X		$format = $';
X	}
X
X	# Use local time if can't find a TZ in the environment
X	$TZ = defined($ENV{'TZ'}) ? $ENV{'TZ'} : $defaultTZ;
X	($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) = 
X		&gettime ($TZ, $time);
X
X	# Hack to deal with 'PST8PDT' format of TZ
X	# Note that this can't deal with all the esoteric forms, but it
X	# does recognize the most common: [:]STDoff[DST[off][,rule]]
X	if ($TZ =~ /^([^:\d+\-,]{3,})([+-]?\d{1,2}(:\d{1,2}){0,2})([^\d+\-,]{3,})?/) {
X		$TZ = $isdst ? $4 : $1;
X	}
X
X	# watch out in 2070...
X	$year += ($year < 70) ? 2000 : 1900;
X
X	# now loop throught the supplied format looking for tags...
X	while (($pos = index ($format, '%')) != -1) {
X
X		# grab the format tag
X		$tag = substr($format, $pos, 2);
X		$adv = 0;							# for `%%' processing
X
X		# do we have a replacement string?
X		if (defined $Tags{$tag}) {
X
X			# trap dead evals...
X			if (! eval $Tags{$tag}) {
X				print STDERR "date.pl: internal error: eval for $tag failed.\n";
X				return "";
X			}
X		} else {
X			$rep = "";
X		}
X			
X		# do the substitution
X		substr ($format, $pos, 2) =~ s/$tag/$rep/;
X		$pos++ if ($adv);
X	}
X
X	$format;
}
X
# weekno - figure out week number
sub wkno {
X	local ($yday, $firstweekday) = @_;   
X	local ($jan1, @jan1, $wks);
X	local ($now) = time;
X
X	# figure out the `time' value for January 1
X	$jan1 = $now - ((&gettime ($TZ, $now))[7] * 86400);		# 86400 sec/day
X
X	# figure out what day of the week January 1 was
X	@jan1= &gettime ($TZ, $jan1);
X	
X	# and calculate the week number
X	$wks = (($yday + ($jan1[6] - $firstweekday)) + 1)/ 7;
X	$wks += (($wks - int($wks) > 0.0) ? 1 : 0);
X
X	# supply zero padding
X	&pad (int($wks), 2, "0");
}
X
# ampmH - figure out am/pm (1 - 12) mode hour value.
sub ampmH { local ($h) = @_;  &pad($h>12 ? $h-12 : $h, 2, "0"); }
X
# ampmD - figure out am/pm designator
sub ampmD { shift @_ > 12 ? "PM" : "AM"; }
X
# gettime - get the time via {local,gmt}time
sub gettime { ((shift @_) eq 'GMT') ? gmtime(shift @_) : localtime(shift @_); }
X
# pad - pad $in with leading $pad until lenght $len
sub pad {
X	local ($in, $len, $pad) = @_;
X	local ($out) = "$in";
X
X	$out = $pad . $out until (length ($out) == $len);
X	return $out;
}
X
1;
SHAR_EOF
chmod 0444 date.pl ||
echo 'restore of date.pl failed'
Wc_c="`wc -c < 'date.pl'`"
test 8535 -eq "$Wc_c" ||
	echo 'date.pl: original size 8535, current size' "$Wc_c"
fi
exit 0

--
"I have a cunning plan." -- Baldrick
                                                             patrick m. ryan
     nasa / goddard space flight center / oceans and ice branch / hughes stx
               pat@jaameri.gsfc.nasa.gov / patrick.m.ryan@x500.gsfc.nasa.gov