Bug -- variable corruption inside sub/foreach 
Author Message
 Bug -- variable corruption inside sub/foreach

I seem to have managed to find another bug in perl.  A variable $file is
corrupted by reading from a filehandle (variable name doesn't seem
to matter, nor does it matter whether $file is local or not, or the
first/most recent variable use beforehand.)  I've worked around this
bug, but it lost me a lot of time.  The variable gets corrupted to
the value of $_.

Unfortunately, I haven't been able to get the bug to appear in reduced
versions of the code, so I'm including the original code below.  To
reproduce the bug, try
        rcslocks -vvv
in a directory containing some RCS files.  If you get any messages
about corruption, you reproduced the bug successfully (or try perl -d with
a breakpoint on line 210, $file should be eq $savefile, a reasonable file
name).

Corrections appreciated.  Perl version 3.0 pl 8 with JMPCLOBBER.

regards,

Brian Coogan,
Hewlett-Packard ASO.

#---------------------------------- 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".
#

#
# This archive contains:
#       rcslocks        rcslocks.1      testit          oldcheck        
#
# Error checking via wc(1) will be performed.

unset LANG

echo x - rcslocks

#! /usr/bin/perl

# $Header: rcslocks,v 1.5 90/02/06 14:25:05 brian Exp $
#
#       Lists names of locked RCS files on stdout.
#       You may give it as arguments RCS file names or directories.
#       If a directory argument is given, the locks in all directories
#       under that directory are recursively reported.
#       The name of either an RCS or working file may be given.
#       By default, only the locks held by the current user are listed.
#
#       Usage: rcslocks [-alv | -u user[,user...]] [directory|file]...
#
#       Options:
#               none            list only locks that current user
#                               holds (by uid) in or under .
#               -u user...      list locks held by user(s)
#               -a              list files with any locks
#               -l              long listing - list who holds the locks
#               -v              verbose (trace find starts) (debug)
#               -vv             trace file names as processed (debug)
#
#       Supports RCS style symbolic links, though not seamlessly -
#       the RCS file name is listed rather than the working file name.
#
#                                       Brian Coogan and others,
#                                       Hewlett-Packard ASO, Jan 90.
#       Examples:
#               ci -u `rcslocks`
#               rcslocks -al
#
# $check_users flag is necessitated by a perl bug where defined(%userlist)
# is always true, even when it hasn't been referenced yet.
#

#
#       findexp: find expression to return names of RCS dirs and *,v
#       findfoll: true if find follows sym links, false if we should
#                 follow the sym link (to one level only) ourselves.
#
$findexp = '\\( -name RCS -o -name "*,v" \\)';
$findfoll = 0;

($me = $0) =~ s%.*/%%;
$USAGE = "Usage: $me [-alv | -u user[,user...]] [directory|file]...";

#
#       Interpret options
#               -u user
#               -a
#               -v
#               -l
#


        ($f,$r) = ($1,$2);
        last if $f eq '-';
        if ($f eq 'v')                  # VERBOSE
        {
                $verbose++;
                $r =~ /^(.)(.*)/,redo if $r ne '';
        }
        elsif ($f eq 'a')               # ALL
        {
                $all++;
                $r =~ /^(.)(.*)/,redo if $r ne '';
        }
        elsif ($f eq 'l')               # LONG listing
        {
                $long++;
                $r =~ /^(.)(.*)/,redo if $r ne '';
        }
        elsif ($f eq 'u')               # USERS
        {

                for $n (split(/,/, $users))
                {
                        $users{$n} = 1;
                }
                $check_users++;
        }
        else{
                # usage error
                print "$USAGE\n";
                exit(1);
        }

Quote:
}

print stderr "$me: Warning: -a given, -u ignored\n" if ($all && $check_users);

if (! $all && ! $check_users)
{

        $myname = $pwline[0];
        $users{$myname} = 1;
        $check_users++;

Quote:
}

push(ARGV, ".") if $#ARGV < $[;            # default to current directory

#
#       Process each argument
#

{
        #
        #       If it is a directory, recurse with a find.
        #
        if (-d $arg)
        {
                print "Running find on directory $arg\n" if $verbose;
                # HP-UX find doesn't return anything across symlinks.
                open(FIND, "find $arg $findexp -print|")
                        || die "$me: can't find $arg: $!\n";
                while (<FIND>)
                {
                        chop;
                        s%^\./%%;  # strip leading ./
                        if (-d $_)
                        {
                                #
                                #       If it's a symlink to a directory,
                                #       and find doesn't follow symlinks,
                                #       follow it ourselves, one level deep.
                                #
                                do checkfiles(<$_/*,v>) if ! $findfoll && -l _;
                        }
                        elsif (m=(^|/)RCS$=)    # RCS pseudo-symlink
                        {
                                unless (open(RCS, "$_"))
                                {
                                        print stderr "$me: cannot open $_\n";
                                        next;
                                }
                                chop($path = <RCS>);
                                close(RCS);
                                next if ! -d $path;
                                do checkfiles(<$path/*,v>);
                        }
                        else
                        {
                                do checkfiles($_);
                        }
                }
                close(FIND);
                next;
        }

        #
        #       If not an RCS file, look for the corresponding
        #       RCS file.
        #
        if ($arg !~ /,v$/)
        {
                #
                #       Add ,v and look for that
                #
                $try = $arg . ",v";
                -f $try && do checkfiles($try) && next;

                #
                #       Add RCS/ and look for that
                #
                $try =~ s%/([^/]+)%/RCS/$1% || $try =~ s%^%RCS/%;
                -f $try && do checkfiles($try) && next;
                if (-f $arg)
                {
                        print stderr "$me: $arg -- no corresponding RCS file\n";
                        next;
                }
        }
        if (! -f $arg)
        {
                print stderr "$me: $arg -- No such file\n";
        }
        do checkfiles($arg);

Quote:
}

sub checkfiles
{
        local($file);


        {
                chop($file) if $file =~ /\n$/;
                print "$file\n" if $verbose >= 2;
                next if ! $file || $file !~ /,v$/; # de-bug
                next if $seen{$file}++;
                $savefile = $file; # perl bug

                unless (open(file, "<$file"))
                {
                        print stderr "$me: cannot read $file: $!\n";
                        next;
                }

                #
                #       Look for the locks line, which appears in the header
                #
                #       PERL BUG: $file gets mangled to be $_ in
                #       the following loop
                #
                while (<file>)
                {
                        last if /^locks\s+/;
                }

                print "\$file corrupted from $savefile to $file\n"
                      if ($file ne $savefile && $verbose >= 3);

                #
                #       Quit unless there are locks
                #
                if (eof(file) || ! /^locks\s+([^;]*);/)
                {
                        print stderr "$file: RCS file may be corrupted\n";
                        next;
                }
                next unless $1;

                #
                #       Delete all the locks we arent interested in
                #
                if ($check_users && defined(%users)) # perl bug
                {


                }
                next unless $#locks >= $[; # no applicable locks

                #
                #       Print out the working file name
                #       and the locks (if requested)
                #       If the file doesn't appear to be from a local
                #       RCS directory, print the RCS file name.
                #
                $file = $savefile;      # perl bug
                ($wfile = $file) =~ s%(^|/)RCS/%$1% &&
                        $file =~ s%,v$%%;
                if ($long)
                {

                }
                else
                {
                        print "$wfile\n";
                }
        }
        close(file);
        return 1;

Quote:
}


set `wc -lwc <rcslocks`
if test $1$2$3 != 2549035262
then
        echo ERROR: wc results of rcslocks are $* should be 254 903 5262
fi

chmod 555 rcslocks

echo x - rcslocks.1

.\" $Header: rcslocks.1,v 1.2 90/02/06 13:58:22 brian Exp $

.if n .ds ' '

.if n .ds ` `
.TH RCSLOCKS 1 "" "" ASO
.SH NAME
rcslocks \- list details of RCS locks
.SH SYNOPSIS
.B rcslocks
[
.B \-alv
|
.B -u
.IR user [ ,user... ]
]
[
.I file
|
.I directory
]
.I ...
.br
.SH DESCRIPTION
.I Rcslocks\^
lists files with RCS locks.
By default,
.I rcslocks\^
lists just the file names of the file locks held by the current user
on standard output.
.PP
If a directory argument is given, RCS directories and
files
are searched for recursively and any locks found are reported.
If no file or directory argument is given,
.I rcslocks
looks in the current directory for looked files.
.SS Options
.TP 8
.BI -u " user"
The
.B -u
option limits the locks reported to those held by
.IR user .
.I user
may be a single user name or a comma separated list of users.
If neither
.B -b
or
.B -a
are given,
.I rcslocks
only reports on locks held by the current user.
.TP 8
.B -a
prints all locks found.
.TP 8
.B -l
lists all locks in long format.
The locked files are listed, along with the locked versions and who
holds the locks.
.TP 5
.B -v
Provides trace output for debugging.
One
.B -v
traces
.I find (1)
commands as they are executed;
.B -vv
prints file names as they are checked.
.SH EXAMPLES
The following command will print all locks under the directory /aso/source:
.PP
.RS
rcslocks -al /aso/source
.RE
.PP
The following command checks in all the files you have locked in the
current directory:
.PP
.RS
ci -u `rcslocks`
.RE
.SH RETURNS
Returns 1 for fatal errors.
Returns 0 for all other situations.
Non-fatal errors are indicated by a message and do not affect
exit status.
.SH NOTES
.I Rcsmerge\^
supports RCS style pseudo-symbolic links.
.SH SEE ALSO

set `wc -lwc <rcslocks.1`
if test $1$2$3 != 943421880
then
        echo ERROR: wc results of rcslocks.1 are $* should be 94 342 1880
fi

chmod 444 rcslocks.1

echo x - testit

: use /bin/sh

if [ ! -d try -o ! -d try/RCS ]
then
        mkdir try try/RCS
        cd try
        cat > file <<!
        To be or not to be, that is the question.
        Whether 'tis noble to suffer the slings and arrows of
        outrageous fortune.
        or to take arms against a sea of troubles, and by opposing,
        conquer 'em
!
        cp file mylock
        cp file hislock
        cp file bothlock
        cp file nowkgfile
        # better than stuffing with whoami/id

        if test -z "$me"
        then
                echo Could not work out name for current user id
                exit 1
        fi

        ci -l nowkgfile < /dev/null
        /bin/rm -f nowkgfile
        ci -l mylock < /dev/null
        ci -l hislock < /dev/null
        ci -l bothlock < /dev/null
        echo A small change >> bothlock
        ci -m'A small change' -l bothlock
        for file in hislock bothlock
        do
                sed -e "s/$me/root/" < RCS/$file,v > RCS/$file,vt
                /bin/rm -f RCS/$file,v
                mv RCS/$file,vt RCS/$file,v
                chmod -w RCS/$file,v
        done
        rcs -l1.1 bothlock
        mv file norcsfile
else
        cd try
fi
set +x

(
        echo '+ ../rcslocks -al `pwd`'
        ../rcslocks -al `pwd` | sed -e "s!^`pwd`!!"
        set -x
        ../rcslocks -a
        ../rcslocks -al
        ../rcslocks -u root -l
        ../rcslocks bothlock
...

read more »



Sat, 25 Jul 1992 11:40:18 GMT  
 Bug -- variable corruption inside sub/foreach
: I seem to have managed to find another bug in perl.  A variable $file is
: corrupted by reading from a filehandle (variable name doesn't seem
: to matter, nor does it matter whether $file is local or not, or the
: first/most recent variable use beforehand.)  I've worked around this
: bug, but it lost me a lot of time.  The variable gets corrupted to
: the value of $_.

Oddly enough, it's not really a perl bug in this case.  What you've got is

        do checkfiles($_);

        sub checkfiles {

                while (<file>) {
                    ...
                }
            }
        }


actual parameters (not copies, as in 2.0), and that foreach iterates over
an array by making the variable ($file, in this case) to be a reference
to the actual array elements.  Hence, when checkfiles is called with $_,
it ends up aliased to $file.  So reading into $_ then clobbers $file too.

That's the fun of passing parameters by reference.  I still think it's
worth it for the efficiency gain.  If it worries you, just be consistent

yourself to worry about aliasing whenever you don't.  Or something like that.

Larry



Mon, 27 Jul 1992 13:57:00 GMT  
 
 [ 2 post ] 

 Relevant Pages 

1. Modifying a variable inside a sub

2. Outer scope of a sub inside a sub

3. Error : calling sub routine inside another sub routine

4. anonymous sub inside anonymous sub?

5. Bug in Net::FTP sub _extract_path (or Net::Cmd sub parse_response)

6. return value from inside foreach

7. Glob inside a foreach loop

8. @$_ causes variable corruption?

9. Evaluating a Variable INSIDE a variable?

10. variable inside variable

11. scalar variable inside of a scalar variable

12. lvalue sub doesn't work inside perl debugger

 

 
Powered by phpBB® Forum Software