root/lang/perl/FreeBSD-i386-Ptrace/trunk/t/rperl.pl @ 31281

Revision 31281, 1.9 kB (checked in by dankogai, 5 years ago)

typo fixes

Line 
1#!/usr/local/bin/perl
2#
3# $Id: rperl.pl,v 0.1 2009/03/14 12:45:27 dankogai Exp dankogai $
4#
5use strict;
6use warnings;
7use FreeBSD::i386::Ptrace;
8use FreeBSD::i386::Ptrace::Syscall;
9use File::Temp;
10
11our $DEBUG = 0;
12my %banned = map { $_ => 1 } qw/ptrace fork vfork rfork bind listen accept/;
13my $timeout = 1;
14
15my $src    = slurp();
16
17my $pfh = File::Temp->new() or die $!;
18$pfh->print($src);
19$pfh->close;
20
21my $coh = File::Temp->new() or die $!;
22$coh->autoflush(1);
23my $ceh = File::Temp->new() or die $!;
24$ceh->autoflush(1);
25
26defined( my $pid = fork() ) or die "fork failed:$!";
27
28if ( $pid == 0 ) {    # son
29    no warnings;
30    close STDIN;
31    open STDOUT, '>&', $coh;
32    open STDERR, '>&', $ceh;
33    # showtime!
34    pt_trace_me;
35    exec qw/perl -Tw/, $pfh->filename;
36}
37else {                # mother
38    wait;             # for exec;
39    eval {
40        local $SIG{ALRM} = sub { die "timed out\n" };    # NB: \n required
41        alarm $timeout;
42        my $count = 0;    # odd on enter, even on leave
43        while ( pt_syscall($pid) == 0 ) {
44            last if wait == -1;
45            next unless ++$count & 1;    # enter only
46            my $call = pt_getcall($pid);
47            warn $SYS{$call} if $DEBUG;
48            next if !$banned{ $SYS{$call} };
49            pt_kill($pid);
50            print "# $pid killed: SYS_$SYS{$call} banned.\n";
51            last;
52        }
53        alarm 0;
54    };
55    if ($@) {
56        pt_kill($pid);
57        print "# $pid killed: $@";
58    }
59    #close $coh;
60    #close $ceh;
61    #unlink $csrcfn;
62    my $cout = slurp($coh->filename);
63    #unlink $coutfn;
64    my $cerr = slurp($ceh->filename);
65    #unlink $cerrfn;
66    print "# stdout\n", $cout, "\n", "# stderr\n", $cerr, "\n";
67}
68
69sub slurp {
70    my $ret;
71    local $/;
72    if (@_) {
73        my $fn = shift;
74        open my $fh, "<", $fn or die "$fn:$!";
75        $ret = <$fh>;
76        close $fh;
77    }
78    else {
79        $ret = <>;
80    }
81    $ret;
82}
Note: See TracBrowser for help on using the browser.