Path: utzoo!utgpu!jarvis.csri.toronto.edu!mailrus!cs.utexas.edu!uwm.edu!bionet!apple!motcsd!hpda!hpcuhc!hpausla!brian
From: brian@hpausla.aso.hp.com (Brian Coogan)
Newsgroups: comp.lang.perl
Subject: Bugs in perl 3.0 pl 8 -- return statement
Message-ID: <4080004@hpausla.aso.hp.com>
Date: 23 Jan 90 11:33:47 GMT
Organization: HP Australian Software Operation
Lines: 383

I've just been fighting with the return statement of perl 3.0 pl 8 and
losing badly.  There appear to be some bugs, or something rather
non-intuitive, about the way return works.  I'm not sure of the exact
circumstances, but return will fail where simply evaluating an
expression still returns a value.  If it's a programming error on my
part, it's sophisticated, as I've stepped through and verified the
subroutines and they do appear to work.  It's occurred to me that perl
might be getting confused about numeric vs string context vs array
context and I've tried quite a few permutations to get around that, no
luck.  Would be glad of any help from gurus out there - read on
McDuff...  (longish)

This all started when I thought I'd add a binary option to my little
conversion program.  Two hours later I have a working version, which I
had to hack to death to get it to behave!!

The interesting thing is that one of the failing cases works with
perl -d (atob (-bd) works, but btoa still fails).  This is not
encouraging (stack problems?).  I'm running perl on an HP9000/800 (RISC)
(HP-uX 3.1) machine; I get the same symptoms on a HP9000/300 (68030) (HP-UX
6.5) machine, except that perl -d doesn't help either case.

Details:  The program is meant to convert from a given base to another,
including characters.  The failures only occur with binary mode.  Binary
mode involves two extra subroutines, atob and btoa.  Before I added
them, everything else worked fine.  It still does, only binary breaks.
Some examples, the way they should look:

	$ cvt -dx 60 120 10
	3c
	78
	a
	$ cvt -bd 10000
	16
	$ cvt -db 34
	100010

At least, that's what's meant to happen.  In real life,
	$ cvt -bd 10000

	$ cvt -db 34

	$ perl -d cvt -bd 10000
	Loading DB from perldb.pl 3.0.1.1 89/10/26
	main(20):	($myname = $0) =~ s%.*/%%;
	  DB<1> c
	16
	$ perl -d cvt -db 34
	Loading DB from perldb.pl 3.0.1.1 89/10/26
	main(20):	($myname = $0) =~ s%.*/%%;
	  DB<1> c

	$       [ie: no output]

I've included for your perusal two versions of the script, one hacked
to make it work, the other the way I would like it to be.  The working
version is cvt.hack, but it has a lot of debug output.  The failure is
called cvt.

If you can fix this for me, or correct some mistake, I'll be greatly
grateful.  Once this is fixed I hope to post it.

thanks,

Brian Coogan,
Hewlett-Packard Australian Software Operation.

ACSnet:		brian@hpausla.oz		UUCP: hplabs!hpausla!brian
Internet:	brian%hpausla@hplabs.hp.com	Tel: +61 3 871 1648 (TZ=EST-10)

#---------------------------------- cut here ----------------------------------
# This is a shell archive.  Remove anything before this line,
# then unpack it by saving it in a file and typing "sh file".
#
# Wrapped by Brian Coogan <brian@hpausln> on Tue Jan 23 22:23:56 1990
#
# This archive contains:
#	cvt	cvt.dbg	
#
# Error checking via wc(1) will be performed.

unset LANG

echo x - cvt
cat >cvt <<'@EOF'
#! /usr/bin/perl

# cvt
#	Convert between bases
#
#	Usage: cvt -<from><to> [from ...]
#
#	where <from> and <to> are each single letters meaning:
#		o	octal
#		d	decimal
#		x	hex
#		b	binary
#		c	character
#
#		Brian Coogan 6 Jan 90
#
# $Header: cvt,v 1.1.1.1 90/01/23 21:50:44 brian Exp $
# $Locker:  $

($myname = $0) =~ s%.*/%%;
$mode = shift;

die "Usage: $myname -[odbcx][odbcx] [args]\n"
	unless ($mode =~ m|-([odbcx])([odbcx])[^/]*$|);

$from = $1;
$to = $2;


if ($#ARGV >= $[)
{
	while ($val = shift)
	{
		print do cvt($val) . "\n";
	}
	exit(0);
}

while ($val = <>)
{
	print do cvt($val) . "\n";
}
exit(0);

sub cvt
{
	local($val) = @_;

	#
	#	Input
	#	if decimal, its already ok
	#
	$val = oct($val) if $from eq 'o';
	$val = hex($val) if $from eq 'x';
	$val = ord($val) if $from eq 'c';
	$val = &atob($val) if $from eq 'b';

	#
	#	Output
	#
	return(&prettychar($val)) if $to eq 'c';
	return(&btoa($val)) if $to eq 'b';
	return(sprintf("%$to", $val));
}

sub prettychar
{
	local($val) = @_;

	# isprint simulation
	return(sprintf("%c", $val)) if ($val > 32 && $val <= 126);

	# known control chars
	return('\r') if $val == 015;
	return('\n') if $val == 012;
	return('\f') if $val == 014;
	return('\t') if $val == 011;
	return('SP') if $val == 040;

	# misc control chars
	return(sprintf("^%c", ($val + 0100))) if ($val < 32);

	#
	#	If we get this far, it may be a terminal dependent character,
	#	but as we can't portably determine whether it is, we print
	#	it in octal
	#
	return(sprintf("\\%3o", $val));
}

#
#	Ascii binary (aka base 2) to internal
#
sub atob
{
	local($string) = @_;
	local($val, $dig) = 0;

	foreach $dig (split(/ */, $string))
	{
		$val = $val * 2 + $dig;
	}
	return($val);
}

#
#	Internal binary (aka base 2) to ascii.  No particular reason why
#	they're signed; that code can be removed if desired (comment out
#	tagged lines).
#
sub btoa
{
	local($val) = @_;
	local($sign) = '';		# signed
	local(@digits) = ();

	if ($val < 0)			# signed
	{				# signed
		$sign = '-';		# signed
		$val = - $val;		# signed
	}				# signed
	$val = int($val);		# sorry, we're dumb here
	while ($val != 0)
	{
		unshift(@digits, ($val & 1) ? "1" : "0");
		$val = int($val/2);
	}
	return($sign . join('', @digits));
}
@EOF
set `wc -lwc <cvt`
if test $1$2$3 != 1294012229
then
	echo ERROR: wc results of cvt are $* should be 129 401 2229
fi

chmod 555 cvt

echo x - cvt.dbg
cat >cvt.dbg <<'@EOF'
#! /usr/bin/perl

# cvt
#	Convert between bases
#
#	Usage: cvt -<from><to> [from ...]
#
#	where <from> and <to> are each single letters meaning:
#		o	octal
#		d	decimal
#		x	hex
#		b	binary
#		c	character
#
#		Brian Coogan 6 Jan 90
#
# $Header$
# $Locker$

($myname = $0) =~ s%.*/%%;
$mode = shift;

die "Usage: $myname -[odbcx][odbcx] [args]\n"
	unless ($mode =~ m|-([odbcx])([odbcx])[^/]*$|);

$from = $1;
$to = $2;


if ($#ARGV >= $[)
{
	while ($val = shift)
	{
		print do cvt($val) . "\n";
		#$xx = do cvt($val);
		#print "top output $xx\n";
	}
	exit(0);
}

while ($val = <>)
{
	#print do cvt($val) . "\n";
	$xx = do cvt($val);
	print "output $xx\n";
}

sub cvt
{
	local($val) = @_;

	#
	#	Input
	#	if decimal, its already ok
	#
	$val = $val + 0 if $from eq 'd';
	$val = oct($val) if $from eq 'o';
	$val = hex($val) if $from eq 'x';
	$val = ord($val) if $from eq 'c';
	$val = &atob($val) if $from eq 'b';
	printf "cvt  got number in as $val\n";

	#
	#	Output
	#
	return(&prettychar($val)) if $to eq 'c';
	if ($to eq 'b')
	{
		$tmp = &btoa($val);
		print "cvt: retval = $tmp, global = $result\n";
		#$tmp.' '; $tmp; # method 1 - works
		"$tmp";		 # method 2 - works
		#return "$tmp";   # method 3 - fails.
		last;
	}
	#return(&btoa($val)) if $to eq 'b';  # what I really want to do
	sprintf("%$to", $val);
}

sub prettychar
{
	local($val) = @_;

	# isprint simulation
	return(sprintf("%c", $val)) if ($val > 32 && $val <= 126);

	# known control chars
	return('\r') if $val == 015;
	return('\n') if $val == 012;
	return('\f') if $val == 014;
	return('\t') if $val == 011;
	return('SP') if $val == 040;

	# misc control chars
	return(sprintf("^%c", ($val + 0100))) if ($val < 32);

	#
	#	If we get this far, it may be a terminal dependent character,
	#	but as we can't portably determine whether it is, we print
	#	it in octal.
	#
	return(sprintf("\\%3o", $val));
}

#
#	Ascii binary (aka base 2) to internal
#
sub atob
{
	local($string) = @_;
	local($val, $dig) = 0;

	foreach $dig (split(/ */, $string))
	{
		$val = $val * 2 + $dig;
	}
	#return($val); # only works for single digits
	$val;
}

#
#	Internal binary (aka base 2) to ascii.  No particular reason why
#	they're signed; that code can be removed if desired (comment out
#	tagged lines).
#
sub btoa
{
	local($val) = @_;
	local($sign) = '';		# signed
	local(@digits) = ();

	print "btoa: input $val\n";
	if ($val < 0)			# signed
	{				# signed
		$sign = '-';		# signed
		$val = - $val;		# signed
	}				# signed
	$val = int($val);		# sorry, we're dumb here
	while ($val != 0)
	{
		unshift(@digits, ($val & 1) ? "1" : "0");
		$val = int($val/2);
	}
	printf "btoa: ascii output %s\n", $sign . join('', @digits);
	$result = $sign . join('', @digits); # try a global
	#return($sign . join('', @digits)); # returns nothing
	$sign . join('', @digits);
}
@EOF
set `wc -lwc <cvt.dbg`
if test $1$2$3 != 1485062808
then
	echo ERROR: wc results of cvt.dbg are $* should be 148 506 2808
fi

chmod 755 cvt.dbg

exit 0