in reply to Re: Attempt to free unreferenced scalar...
in thread Attempt to free unreferenced scalar...

Ok, here it goes...
#!/usr/local/bin/perl -w my $img_server="daniel.dnd.com.pl"; my $pass="qmail"; use strict; my $home; my $folder; my $kt; my $ile; my $ile_starych; my $ktory; my $fol_wzg; my $fol_wzg_cel; my $login; my $domena; my @du; use Socket; use Carp; my $EOL = "\015\012"; sub spawn; # forward declaration sub logmsg { print "$0 $$: @_ at ", scalar localtime, "\n" } sub sep_par { print "\`\@\`"} my $port = shift || 2345; my $proto = getprotobyname('tcp'); $port = $1 if $port =~ /(\d+)/; # untaint port number socket(Server, PF_INET, SOCK_STREAM, $proto) || die "socket: $! +"; setsockopt(Server, SOL_SOCKET, SO_REUSEADDR, pack("l", 1)) || die "setsockopt: $!"; bind(Server, sockaddr_in($port, INADDR_ANY)) || die "bind: $!"; listen(Server,SOMAXCONN) || die "listen: $! +"; logmsg "server started on port $port"; my $waitedpid = 0; my $paddr; sub REAPER { $waitedpid = wait; $SIG{CHLD} = \&REAPER; # loathe sysV #logmsg "reaped $waitedpid" . ($? ? " with exit $?" : ''); } $SIG{CHLD} = \&REAPER; for ( $waitedpid = 0; ($paddr = accept(Client,Server)) || $waitedpid; $waitedpid = 0, close Client) { next if $waitedpid and not $paddr; my($port,$iaddr) = sockaddr_in($paddr); my $name = gethostbyaddr($iaddr,AF_INET); logmsg "connection from $name [", inet_ntoa($iaddr), "] at port $port"; spawn sub { my $line = <STDIN>; chomp $line; my @param = split (/ /,$line); if ($param[0] eq "folders_stat") { my $mail = $param[1]; ($login, $domena) = split ("@", $mail); &folders_stat; } else {print "error\'=\'UNKNOWN ERROR \;)"} }; } sub spawn { my $coderef = shift; unless (@_ == 0 && $coderef && ref($coderef) eq 'CODE') + { confess "usage: spawn CODEREF"; } my $pid; if (!defined($pid = fork)) { logmsg "cannot fork: $!"; return; } elsif ($pid) { #logmsg "begat $pid"; return; # I'm the parent } # else I'm the child -- go spawn open(STDIN, "<&Client") || die "can't dup client to +stdin"; open(STDOUT, ">&Client") || die "can't dup client to +stdout"; ## open(STDERR, ">&STDOUT") || die "can't dup stdout to + stderr"; exit &$coderef(); } sub folders_stat { $home = "/home/platna.dnd.com.pl/m/ms11"; my $quota = 10000; &sep_par; $ktory = 4; open (FOL, "ls -1 $home|") || die "can't exec ls -1: $ +!"; while ($fol_wzg = <FOL>) { chomp $fol_wzg; &napraw_fol_wzg; if ($fol_wzg=~/Maildir/) { $kt = 1;&rob_folder +;next;} elsif ($fol_wzg=~/outbox/) { $kt = 2;&rob_fold +er;next;} elsif ($fol_wzg=~/kosz/) { $kt = 3;&rob_folder +;next;} else {$kt=$ktory;} &rob_folder; $ktory++; } close (FOL); print "koniec\`=\`koniec"; } sub rob_folder { $ile=0; $ile_starych=0; $folder = $home . "/" . $fol_wzg; open (LISTA, "find $folder -type f|") || die "can't exec find: + $!"; while (my $lista = <LISTA>) { $ile++; if ($lista eq "") {print "Folder pusty\n";exit 6;} if ($lista =~ /S/) { $ile_starych++; } } close (LISTA); print "name_f",$kt,"\`=\`",$fol_wzg; &sep_par; print "all_mail",$kt,"\`=\`",$ile; &sep_par; print "new_mail",$kt,"\`=\`",$ile - $ile_starych; &sep_par; print "read_mail",$kt,"\`=\`",$ile_starych; &sep_par; $folder = $home . "/" . $fol_wzg; # open (DU, "du -s $folder|") || die "can't exec du: $!"; my $temp = `du -s $folder`; #<DU>; # close (DU); @du = split (" ",$temp); print "size",$kt,"\`=\`",$du[0] - 16; &sep_par; } sub napraw_fol_wzg { while ($fol_wzg =~ /<B6>/) {$fol_wzg =~ s/<B6>/%B6/;} while ($fol_wzg =~ /<B1>/) {$fol_wzg =~ s/<B1>/%B1/;} while ($fol_wzg =~ /<F3>/) {$fol_wzg =~ s/<F3>/%F3/;} while ($fol_wzg =~ /<A6>/) {$fol_wzg =~ s/<A6>/%A6/;} while ($fol_wzg =~ /<AC>/) {$fol_wzg =~ s/<AC>/%AC/;} while ($fol_wzg =~ /<D3>/) {$fol_wzg =~ s/<D3>/%D3/;} } sub napraw_fol_wzg_cel { while ($fol_wzg_cel =~ /<B6>/) {$fol_wzg_cel =~ s/<B6>/%B6/;} while ($fol_wzg_cel =~ /<B1>/) {$fol_wzg_cel =~ s/<B1>/%B1/;} while ($fol_wzg_cel =~ /<F3>/) {$fol_wzg_cel =~ s/<F3>/%F3/;} while ($fol_wzg_cel =~ /<A6>/) {$fol_wzg_cel =~ s/<A6>/%A6/;} while ($fol_wzg_cel =~ /<AC>/) {$fol_wzg_cel =~ s/<AC>/%AC/;} while ($fol_wzg_cel =~ /<D3>/) {$fol_wzg_cel =~ s/<D3>/%D3/;} } -- Daniellek

Replies are listed 'Best First'.
Re: Attempt to free unreferenced scalar...
by Dominus (Parson) on Nov 30, 2000 at 19:46 UTC
    Do you still get the "attempt to free unreferenced scalar" message if you comment out the line that says $SIG{CHLD} = \&REAPER;?

    If so, you have probably found a real bug in Perl and you should prepare a bug report. Try trimming the code down some more by getting rid of some of the more peripheral subroutines. Use the perlbug program on your system to report the error, including the entire source code of the smallest version of the program you can find that still demonstrates the problem.

    If commenting out the $SIG{CHLD} line makes the problem magically go away, then you've still found a bug in Perl, but it's a well-known bug that people don't know how to fix. In this case you can still solve your problem by avoiding signal handlers and using waitpid to reap the children. If you post about it I will help you fix the program to do this.

    Thanks for taking so much time to investigate this.

      I commented $SIG{CHLD} and the problem really went away!!!

      I would really appreciate if help me to walk around this...

      One thing is really important for me, it has to be still multithreaded.
      Is this possible with waitpid? I read perldoc -f waitpid and there is some example how to use it "non-blocking" way, but i'm not convinced...

      Waiting for Your reply...

      PS. I'm the person to thank You all for guiding me how to find the real problem :)

      -- Daniellek
        > I commented $SIG{CHLD} and the problem really went away!!!
        Good, that's what I thought it was all along.

        >it has to be still multithreaded. Is this possible with waitpid?

        Oh, yes, that's why I suggested it. The key to the multithreadedness of your program is the spawn function. You aren't even going to touch the spawn function.

        The example of what you need to do is in the manual. If you do waitpid(-1, &WNOHANG), then it checks to see if there is a zombie, and if there is one, it cleans it up. Unlike wait, it returns immediately whether there is a zombie or not. If you use:

        do { $kid = waitpid(-1,&WNOHANG); } until $kid == -1;

        then your program will clean up all the outstanding zombies. If there are no zombies, waitpid will return -1 immediately and the loop will execute only once.

        You can stick this code into your program at the top of the main loop, and every time your server accepts a new client, it will try to clean up any outstanding zombies. Get rid of $waitedpid and the signal handler. Leave spawn the way it is. Put the waitpid loop in just before the call to spawn. Don't forget to use POSIX ":sys_wait_h" like it says in perlfunc.

        Hope this helps. Send me email if you can't get it working.

Re: Re: Re: Attempt to free unreferenced scalar...
by Fastolfe (Vicar) on Dec 10, 2000 at 07:35 UTC
    Glad you got your problem fixed, though among other things I noticed that you could probably write this a little clearer:
    while ($fol_wzg_cel =~ /<B6>/) {$fol_wzg_cel =~ s/<B6>/%B6/;} # as: $fol_wzg_cel =~ s/<B6>/%B6/g;
    In addition, you could probably shrink all 6 of those lines into one regexp:
    $fol_wzg_cel =~ /<(B6|B1|F3|A6|AC|D3)>/%$1/g;
      Oh, yes, some day i needed it real FAST and made this in such "ugly" way and the forgot about it, I'll use your suggestion rigth now :)

      Thanks!

      -- Daniellek
      The first one ($fol_wzg_cel =~ s/<B6>/%B6/g;) works great, but the second ($fol_wzg_cel =~ /<(B6|B1|F3|A6|AC|D3)>/%$1/g;) does not because <B6>, <B1> and so on are single polish national letters, not just 4 characters...

      But thanks again for simplifying my code :)

      Q: Is there a possibbility to write someting like this: s/(a|b|c|d)/(1|2|3|4)/ ? It should substitute 1 for a, 2 for b, etc...

      -- Daniellek
        If you're dealing with single characters, you can use tr:
        tr/abcd/1234/;
        Otherwise a more complex way of doing that:
        my %tr = ( a => 1, b => 2, c => 3, d => 4 ); my $tr_keys = join('\E|\Q', keys %tr); s/(\Q$tr_keys\E)/$tr{$1}/g;
        The latter method has the benefit of being able to work with arbitrarily long strings instead of just single characters.