p5pRT
commented
24 years ago From bleh@nut.dhs.org
Perl core dumps shortly after I send an interrupt signal to my program.
Output from gdb:
[bleh@nut src]$ gdb perl core GNU gdb 4.18 Copyright 1998 Free Software Foundation\, Inc. GDB is free software\, covered by the GNU General Public License\, and you are welcome to change it and/or distribute copies of it under certain conditions. Type "show copying" to see the conditions. There is absolutely no warranty for GDB. Type "show warranty" for details. This GDB was configured as "i386-redhat-linux"... (no debugging symbols found)...
warning: core file may not match specified executable file.
Core was generated by `perl ./psftp-core ssh://bleh@localhost/'.
Program terminated with signal 11\, Segmentation fault.
Reading symbols from /lib/libnsl.so.1...done.
Reading symbols from /lib/libdl.so.2...done.
Reading symbols from /lib/libm.so.6...done.
Reading symbols from /lib/libc.so.6...done.
Reading symbols from /lib/libcrypt.so.1...done.
Reading symbols from /lib/ld-linux.so.2...done.
#0 chunk_alloc (ar_ptr=0x4013d040\, nb=16) at malloc.c:2804
2804 malloc.c: No such file or directory.
(gdb) bt
#0 chunk_alloc (ar_ptr=0x4013d040\, nb=16) at malloc.c:2804
#1 0x400a840a in __libc_malloc (bytes=4) at malloc.c:2643
#2 0x807a465 in Perl_safemalloc ()
#3 0x8088aea in Perl_sv_grow ()
#4 0x808b271 in Perl_newSV ()
#5 0x8098e8e in Perl_pp_split ()
#6 0x80b155d in Perl_runops_standard ()
#7 0x8059308 in perl_run ()
#8 0x805787f in main ()
#9 0x400681eb in __libc_start_main (main=0x8057810 \
The core occurs when I send an interrupt while the program (attached below) is in ssh_interface. It doesn't occur immeadietly\, but shortly therafter.
psftp.pl
#!/usr/bin/perl
#use Term::ReadLine; #use Term::ReadKey; #use IPC::Open2; use Getopt::Std; use URI::URL; #use strict;
# Configuration
# Location of helper programs (we assume its in path at the moment) my $ssh = "psftp-ssh"; my $scp = "psftp-scp"; my $iprompt = "psftp:"; my $pager = "less"; my $hdir = undef; my $DEBUG = 1; # End configuration
my $version = "0.05"; #my $term = new Term::ReadLine; my $state = 0; my $user = undef; my $pass = undef; my $host = undef; my $port = undef; my $connected = 0; my $pwd = undef; my $prompt = ""; my $auth_mode = undef; local *RFP;
# help related stuff my @commands = (); my %help_hash = ();
my %optctl = (); getopts('hu:c:'\,\%optctl); if ( $optctl{"h"} ) { print "$0 $version\n"; print "by Nadeem Riaz (nads\@bleh.org)\n"; print "Usage $0 [-u user] [-c conf_dir] [host|url]\n"; exit; } $user = $optctl{"u"}; if ( defined($optctl{"c"}) && -d $optctl{"c"} ) { $hdir = $optctl{"c"}; } else { $hdir = "$ENV{HOME}/.psftp"; } if ( ! -d $hdir ) { mkdir($hdir\,0700); } unlink("$hdir/pass"); $SIG{"INT"} = \&do_exit; load_help();
#print "Term Type: " . $term->ReadLine() . "\n" if ( $DEBUG ); #sub test_func { open(FP\,">log.1"); print FP "I was here\n"; close(FP) }; my ($key\,$val); #$my $attrib = $term->Attribs(); # $attrib->{"filename_quote_characters"} = "\\"; # $attrib->{"filename_quoting_function"} = \&test_func; # $attrib->{"pre_input_hook"} = \&test_func; # $attrib->{"display_match_list"} = \&test_func; # $attrib->{"filename_completion_function"} = \&test_func; # $attrib->{"char_is_quoted_p"} = "\\";
#$attrib->{"completion_word"} = [ sort(@commands) ]; #$attrib->{"completion_append_character"} = "\""; #$attrib->{"attempted_completion_function"} = \&do_pick_completion; #$attrib->{"filename_quoting_function"} = sub { print "HEY\n" }; #$attrib->{"filename_dequoting_function"} = sub { print "HEY\n" }; #$attrib->{"filename_quote_characters"} = "b"; #$attrib->{"completer_word_break_characters"} = "\'`\@\$>\<=;|&{( "; #$attrib->{"completion_entry_function"} = undef;
# my $features = $term->Features();
#while ( ($key\,$val) = each ( %{$attrib}) ) {
# print "$key = $val\n";
#}
#print $term->list_completion_function() . "\n";
if ( @ARGV > 0 ) {
open_host($ARGV[0]);
}
my $INT; main_loop();
sub main_loop {
while ( 1 ) {
$prompt = "$iprompt $pwd> ";
my ($line\,$cmd);
print "RIGHT BEFORE NEW TERM!\n";
print "prompt> ";
$line = \
my ($cmd\,$line) = split(/\s+/\,$line\,2);
$cmd = lc($cmd);
if ( $cmd eq "lpwd" ) {
system("pwd");
} elsif ($cmd eq "lcd" ) {
do_local_cd($line);
} elsif ($cmd eq "lls" || $cmd eq "ldir" ) {
do_local_ls($line);
} elsif ( $cmd eq "plls" || $cmd eq "pldir" ) {
do_local_paged_ls($line);
} elsif ( $cmd eq "lmkdir" ) {
do_local_mkdir($line);
} elsif ( $cmd eq "lrmdir" || $cmd eq "lrm" || $cmd eq
"ldel" ) {
do_local_rm($line);
} elsif ( $cmd eq "lchown" ) {
do_local_chown($line);
} elsif ( $cmd eq "lchmod" ) {
do_local_chmod($line);
} elsif ( $cmd eq "put" ) {
do_put($line);
} elsif ( $cmd eq "mput" ) {
do_mput($line)
} elsif ( $cmd eq "get" ) {
do_get($line);
} elsif ( $cmd eq "mget" ) {
do_mget($line);
} elsif ($cmd eq "cd" ) {
do_remote_cd($line);
} elsif ( $cmd eq "pwd" ) {
do_remote_pwd();
} elsif ( $cmd eq "ls" || $cmd eq "dir" ) {
do_remote_ls($line);
} elsif ( $cmd eq "ls" || $cmd eq "dir" ) {
do_remote_paged_ls($line);
} elsif ( $cmd eq "mkdir" ) {
do_remote_mkdir($line);
} elsif ( $cmd eq "rmdir" || $cmd eq "rm" || $cmd eq "del"
) {
do_remote_rm($line);
} elsif ( $cmd eq "chown" ) {
do_remote_chown($line);
} elsif ( $cmd eq "chmod" ) {
do_remote_chmod($line);
} elsif( $cmd eq "open" ) {
open_host($line);
} elsif ( $cmd eq "close" ) {
close_host();
} elsif ( $cmd eq "clear" ) {
system("clear"); # have to replace this later
} elsif ( $cmd eq "help" ) {
do_help($line);
} elsif ( $cmd eq "set" ) {
do_set();
} elsif ($cmd eq "save" ) {
do_save();
} elsif ( $cmd eq "exit" || $cmd eq "quit" ) {
do_exit();
} elsif ( $cmd eq "") {
next;
} else {
print "Bad command: $cmd\n";
}
print "END PF LONG AS ELS/IF\n";
}
exit;
}
sub open_host {
my $line = shift @_;
$host = undef;
$user = undef;
$pass = undef;
$port = undef;
$auth_mode = undef;
$pwd = "";
if ( defined($line) ) {
if ( $line =~ /^ssh\:\/\//i ) {
my $url = new URI::URL $line;
$host = $url->host;
$port = $url->port;
$user = $url->user;
$pass = $url->password;
} else {
$host = $line;
}
}
if ( ! defined($host) || $host eq "" ) {
print "Enter host name: ";
chomp($host = \
sub close_host { if ( ! $connected ) { print "Not connected\n"; return; } $connected =0; $host = undef; $user = undef; $pass = undef; $port = undef; $auth_mode = undef; $pwd = ""; unlink("$hdir/pass"); }
sub get_auth_mode {
my $c = "$ssh $host \"echo no pass ; pwd\" 2>&1";
my $oldint = $SIG{'INT'};
$SIG{'INT'} = \&ssh_interrupt;
open(RFP\,"$c |") || die "Couldn't create pipe: $!";
sleep(1);
my (@lo\,$line);
eval {
$SIG{"ALRM"} = sub {
print "Timeout on auth mode!\n";
if ( ! defined($pass) || $pass eq "") {
print "Enter password: ";
$pass = \
alarm(5);
$line = \
if ( $@ ) {
return undef;
}
alarm 0;
close(RFP) if ( *RFP );
$SIG{"INT"} = $oldint;
my ($gpwd\,$auth);
if ( $line =~ /Bad host name/i ) {
print "Bad host name\n";
return (undef\,undef);
} elsif ($line =~ /password/i ) {
my $o = shift @lo;
if ( $o =~ /Permission denied/ ) {
print "Permission denied\n";
return (undef\,undef);
} elsif ( $o !~ /no pass/ ) {
print "INTERNAL ERROR!: $o \n";
return (undef\,undef);
}
$auth = "password";
} elsif ( $line =~ /no pass/i ) {
$auth = "RSARhost";
} else {
print "ERROR Couldn't determine authentication mode\n";
return (undef\,undef);;
}
$gpwd = shift(@lo);
chomp($gpwd);
return ($auth\,$gpwd);
}
sub write_pass { my $pass = shift @_; local *pFP; open(pFP\,">$hdir/pass") || die "Couldn't open pass file!\n$!\n"; print pFP "$pass\n"; close(pFP); }
sub remote_cd {
my $dir = shift @_;
my $c = "cd $dir 2>&1; pwd";
my @cd_output = execute_remote_cmd($c);
my $cdo = $cd_output[0];
chomp($cdo);
if ( $cdo =~ /No such file or directory/ ) {
return (undef\,"No such file or directory");
} elsif ($cdo =~ /Not a directory/ ) {
return (undef\,"Not a directory");
} elsif ( $cdo =~ /Permission denied/ ) {
return(undef\,"Permission deinied");
} elsif ( ! defined($cdo) ) {
return (undef\,"Internal Error");
}
return $cdo;
}
sub execute_remote_cmd { my ($cmd\,$print) = (@_); my $c = "$ssh $host \"cd $pwd ; $cmd\" 2>&1"; return ssh_interface($c\,$print); }
sub ssh_interface {
my ($c\,$print) = (@_);
print "-- begin ssh interface --\n" if ( $DEBUG );
# open2(\*RFP\,\*WFP\,$c) || die "Couldn't create pipe: $!";
print "current int = $SIG{'INT'}\n";
my $oldint = $SIG{'INT'};
print "old int = $oldint\n";
$SIG{'INT'} = \&ssh_interrupt;
print "new int = $SIG{'INT'}\n";
open(RFP\,"$c |");
sleep(1);
if ( $auth_mode eq "password" ) {
# write_pass($pass);
# print WFP "$pass\n";
\
$| =1; # Flush after every print
while ( read(RFP\,$c\,1) ) {
print $c;
}
$| = 0;
} else {
@output = \
$INT = 0;
return 0;
}
close(RFP);
print "CLOSE SUCCESFUL\n";
$SIG{'INT'} = $oldint;
if ( $print ) {
return 1;
} else {
return @output;
}
}
sub do_remote_cd {
if ( ! $connected ) {
print "Not connected to host!\n";
return;
}
my $dir = shift @_;
my @cd_output = remote_cd($dir);
if ( defined($cd_output[0]) ) {
$pwd = $cd_output[0];
} else {
print "$cd_output[1]\n";
}
}
sub do_remote_mkdir {
if ( ! $connected ) {
print "Not connected to host!\n";
return;
}
my $dir = shift @_;
execute_remote_cmd("mkdir $dir"\,1);
}
sub do_remote_rm {
if ( ! $connected ) {
print "Not connected to host!\n";
return;
}
my $files = shift @_;
execute_remote_cmd("rm -rf $files"\,1);
}
sub do_remote_chown { if ( ! $connected ) { print "Not connected to host!\n"; return; } my $files = shift @_; execute_remote_cmd("chown $files"\,1); }
sub do_remote_chmod { if ( ! $connected ) { print "Not connected to host!\n"; return; } my $files = shift @_; execute_remote_cmd("chmod $files"\,1); }
sub do_remote_pwd { if ( ! $connected ) { print "Not connected to host!\n"; return; } print "$pwd\n"; }
sub do_remote_ls {
if ( ! $connected ) {
print "Not connected to host!\n";
return;
}
my $args = shift @_;
execute_remote_cmd("ls $args"\,1);
print "REMOTE LS RETURN SUCCESSFUL\n";
}
sub do_remote_paged_ls {
if ( ! $connected ) {
print "Not connected to host!\n";
return;
}
local *lFP;
my $args = shift @_;
my @lines = execute_remote_cmd("ls $args");
if ( ! open(lFP\,"| $pager") ) {
print "Couldnt pipe to pager!\n";
return;
}
my $line;
foreach $line (@lines) {
print lFP $line;
}
}
sub do_local_cd { my $dir = shift @_; if ( ! chdir("$dir") ) { print "Couldn't change to dir $dir: $!\n"; return undef; } return 1; }
sub do_local_ls { my $line = shift @_; system("ls $line"); }
sub do_local_paged_ls { my $line = shift @_; system("ls $line | $pager"); }
sub do_local_mkdir { my $dir = shift @_; if ( ! mkdir("$dir"\,0700) ) { print "Couldn't make local dir $dir: $!\n"; return undef; } return 1; }
sub do_local_rm { my $files = shift @_; system("rm -rf $files"); }
sub do_local_chown { my $files = shift @_; system("chown $files"); }
sub do_local_chmod { my $files = shift @_; system("chmod $files"); }
sub do_put {
if ( ! $connected ) {
print "Not connected to host!\n";
return;
}
my $line = shift @_;
if ( ! defined($line) || $line eq "" ) {
print "No file given!\n";
return 0;
}
# Break up args\, and assign them to appropriate var
my ($arg\,$file\,$remote\,@jun) = split_args($line);
my $options = "";
if ( $arg eq "-r" || $arg eq "-R" ) {
$options = "-r";
} else {
$remote = $file;
$file = $arg;
}
# Check file|dir exist
if ( $options ) {
if ( ! -d $file && ! -f $file ) {
print "'$file' is not a file or directory (does it
exist?)\n";
return 0;
}
} else {
if ( ! -f $file ) {
print "'$file' is not a normal file\n";
return 0;
}
}
put_files([ $file ]\,$remote\,$options); return; }
sub do_mput {
if ( ! $connected ) {
print "Not connected to host!\n";
return;
}
my $line = shift @_;
if ( ! defined($line) || $line eq "" ) {
print "No file given!\n";
return 0;
}
# Break up args\, and assign them to appropriate var
my (@files) = split_args($line);
my $options = "";
my $arg = shift(@files);
if ( $arg eq "-r" || $arg eq "-R" ) {
$options = "-r";
} else {
unshift(@files\,$arg);
}
if (@files \< 1 ) {
print "No files given!\n";
return 0;
}
my ($file\,@put_list);
foreach $file (@files) {
next if ( $file eq "" );
print "Trying $file\n" if ( $DEBUG );
my $print_glob_errors = 1;
if ( $options ) {
if ( -d $file || -f $file ) {
push(@put_list\,$file);
$print_glob_errors = 0;
}
} else {
if ( -f $file ) {
push(@put_list\,$file);
$print_glob_errors = 0;
}
}
my ($glob\,@glob_list);
@glob_list = glob($file);
glob_for: foreach $glob (@glob_list) {
print "\tglob'd: $glob\n" if ( $DEBUG );
my $p;
foreach $p (@put_list) {
next glob_for if ( $p eq $glob );
}
# Check file|dir exist
if ( $options ) {
if ( ! -d $glob && ! -f $glob ) {
print "'$glob' is not a file or
directory (does it exist?)\n" if ( $print_glob_errors );
next;
}
} else {
if ( ! -f $glob ) {
print "'$glob' is not a normal
file\n" if ( $print_glob_errors );
next;
}
}
push(@put_list\,$glob)
}
}
put_files(\@put_list\,undef\,$options);
return 1;
}
sub put_files {
my ($local\,$remote\,$options) = (@_);
print "put_file: options = $options Trying to put @{$local} as
$remote\n" if ( $DEBUG );
my $c = "$scp -a -Q ";
if ( defined($options) && $options ne "") {
$c .= " $options ";
}
my @local = @{$local};
my $x;
for ($x=0;$x\<@local;$x++) {
$local[$x] = shell_escape($local[$x]);
}
$remote = shell_escape($remote);
my $f = "$pwd/$remote";
if ( $remote =~ /^\// ) {
$f = $remote;
}
ssh_interface("$c @local $user\@$host:$f 2>&1"\,1);
}
sub do_get {
if ( ! $connected ) {
print "Not connected to host!\n";
return;
}
my $file = shift @_;
if ( ! defined($file) || $file eq "" ) {
print "No file given!\n";
return 0;
}
my ($args\,$nf) = split(/\s+/\,$file\,2);
my $options = "";
if ( defined($nf) && $nf ne "" && ($args eq "-r" || $args eq "-R")
){
$options = "-r";
$file = $nf;
}
get_file($file\,undef\,$options);
return;
}
sub do_mget { if ( ! $connected ) { print "Not connected to host!\n"; return; } print "Feature not done yet\n"; return; }
sub get_file { my ($remote\,$local\,$options) = (@_); print "get_file: options = $options Trying to get $remote as $local\n" if ( $DEBUG ); my $c = "$scp -a -Q "; if ( defined($options) && $options ne "") { $c .= " $options "; } $local = shell_escape($local); $remote = shell_escape($remote); if ( $local eq "" ) { $local = "./"; } my $f = "$pwd/$remote"; if ( $remote =~ /^\// ) { $f = $remote; } ssh_interface("$c $user\@$host:$f $local 2>&1"\,1); }
sub do_help {
if ( @commands \< 1 ) {
load_help();
}
my $cmd = shift @_;
if ( defined($cmd) && $cmd ne "" ) {
if ( exists $help_hash{$cmd} ) {
print "$cmd: $help_hash{$cmd}";
} else {
print "There is no help avaible for $cmd\n";
}
} else {
my @sc = sort(@commands);
my ($x\,$y\,$sc);
for ($x=0;$x\<5;$x++) {
for ($y=0;$y\<6;$y++) {
$sc->[$x]->[$y] = $sc[($x*6)+$y];
}
}
print "Commands available:\n";
# print "commands: @sc\n" if ( $DEBUG );
for ($x=0;$x\<6;$x++) {
print
"$sc->[0]->[$x]\t\t$sc->[1]->[$x]\t\t$sc->[2]->[$x]\t\t$sc->[3]->[$x]\t\t$sc->[4]->[$x]\n";
}
}
}
sub load_help { @commands = qw(lpwd lcd lls plls lmkdir lrm lchown lchmod put mput get mget cd pwd ls pls mkdir rm rmdir chown chmod open close clear exit help set save); $help_hash{"lpwd"} = "display local parent directory\nUsage: lpwd\n"; $help_hash{"lcd"} = "change local directory\nUsage: lcd \
sub do_exit {
if ( $connected ) {
close_host();
}
#ReadMode 0;
unlink("$hdir/pass");
# On interrupts ReadLine might mangle the term\, thus we
# call reset to fix us up
system("reset -Q");
exit;
}
sub ssh_interrupt { $INT = 1; $SIG{"INT"} = \&do_exit; print "SSH INTERRUPT\n" if ( $DEBUG ); close(RFP); return 1; }
sub do_set { print "Feature not done yet\n"; return 0; }
sub do_save { print "Feature not done yet\n"; return 0; }
sub shell_escape {
my $line = shift @_;
$line =~ s/\"/\\"/g;
$line =~ s/\'/\\'/g;
$line =~ s/\s/\\ /g;
$line =~ s/\!/\\!/g;
$line =~ s/\[/\\[/g;
$line =~ s/\]/\\]/g;
$line =~ s/\(/\\(/g;
$line =~ s/\)/\\)/g;
return $line
}
#sub do_pick_completion {
# my ($text\, $line\, $start\, $end) = @_;
# if (substr($line\, 0\, $start) =~ /^\s*$/) {
# return
$term->completion_matches($text\,$attrib->{list_completion_function});
# } else {
# my ($cmd\,$rline) = split(/\s+/\,$line);
# $cmd = lc($cmd);
# if ( ($cmd =~ /^l/ && $cmd ne "ls") || $cmd eq "plls" ||
$cmd eq "put" || $cmd eq "mput") {
# # Local file completion
# my @list =
$term->completion_matches($text\,$attrib->{filename_completion_function});
# $state++;
# my $x;
# for ($x=0;$x\<@list;$x++) {
# $list[$x] = shell_escape($list[$x]);
# }
# open(FP\,">log.1");
# print FP "urmfg: $state: @list\n";
# close(FP);
# return (@list);
# } else {
# $attrib->{"inhibit_completion"} = 1;
# return ();
# }
#
# }
#}
sub split_args {
my $text = shift @_;
my ($space\,$escape\,$open_quote);
my ($warg\,@args);
my ($x);
# Split line into args
for($x=0;$x\<length($text);$x++) {
if ( substr($text\,$x\,1) eq "\\" ) {
if ( $escape ) {
$warg .= "\\";
} else {
$escape = 1;
next;
}
} elsif ( !$escape && substr($text\,$x\,1) eq "\"" ) {
if ( $open_quote ) {
# New Arg
push(@args\,$warg);
$warg ="";
$open_quote = 0;
} else {
$open_quote = 1;
}
next;
} elsif ( ! $escape && ! $open_quote && substr($text\,$x\,1)
eq " " ) {
if ( ! $space ) {
# New Arg
push(@args\,$warg);
$warg ="";
$space = 1;
}
next;
}
if ( $space ) {
$space = 0;
} elsif ( $escape ) {
$escape = 0;
}
$warg .= substr($text\,$x\,1);
}
push(@args\,$warg);
my $y;
for ($y=0;$y\<@args;$y++) {
print "$y. '$args[$y]'\n" if ( $DEBUG );
}
return (@args);
}
# END PSFTP.pl
Migrated from rt.perl.org#1955 (status was 'resolved')
Searchable as RT1955$