perl-install/run_program.pm


1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129

package run_program; # $Id$

use diagnostics;
use strict;
use c;

use MDK::Common;
use log;

1;

sub run_or_die {
    my ($name, @args) = @_;
    run($name, @args) or die "$name failed\n";
}
sub rooted_or_die {
    my ($root, $name, @args) = @_;
    rooted($root, $name, @args) or die "$name failed\n";
}

sub get_stdout {
    my ($name, @args) = @_;
    my @r;
    run($name, '>', \@r, @args) or return;
    wantarray() ? @r : join('', @r);
}
sub rooted_get_stdout {
    my ($root, $name, @args) = @_;
    my @r;
    rooted($root, $name, '>', \@r, @args) or return;
    wantarray() ? @r : join('', @r);
}

sub run { raw({}, @_) }

sub rooted {
    my ($root, $name, @args) = @_;
    raw({ root => $root }, $name, @args);
}

sub raw {
    my ($options, $name, @args) = @_;
    my $root = $options->{root} || '';
    my $str = ref($name) ? $name->[0] : $name;
    log::l("running: $str @args" . ($root ? " with root $root" : ""));

    return 1 if $root && $<;

    $root ? ($root .= '/') : ($root = '');
    install_any::check_prog(ref($name) ? $name->[0] : $name) if !$root && $::isInstall;


    my ($stdout_raw, $stdout_mode, $stderr_raw, $stderr_mode);
    ($stdout_mode, $stdout_raw, @args) = @args if $args[0] =~ /^>>?$/;
    ($stderr_mode, $stderr_raw, @args) = @args if $args[0] =~ /^2>>?$/;
    
    $ENV{HOME} || $::isInstall or $ENV{HOME} = '/root';
    my $stdout = $stdout_raw && (ref($stdout_raw) ? "$ENV{HOME}/tmp/.drakx-stdout.$$" : "$root$stdout_raw");
    my $stderr = $stderr_raw && (ref($stderr_raw) ? "$ENV{HOME}/tmp/.drakx-stderr.$$" : "$root$stderr_raw");

    if (my $pid = fork()) {
	if ($options->{detach}) {
	    $pid;
	} else {
	    my $ok;
	    eval {
		local $SIG{ALRM} = sub { die "ALARM" };
		alarm($options->{timeout} || 10 * 60);
		waitpid $pid, 0;
		$ok = $? == 0;
		alarm 0;
	    };
	    if ($@) {
		log::l("ERROR: killing runaway process (process=$str, pid=$pid, args=@args, error=$@)");
		kill 9, $pid;
		return;
	    }

	    if ($stdout_raw && ref($stdout_raw)) {	    
		if (ref($stdout_raw) eq 'ARRAY') { 
		    @$stdout_raw = cat_($stdout);
		} else { 
		    $$stdout_raw = cat_($stdout);
		}
		unlink $stdout;
	    }
	    if ($stderr_raw && ref($stderr_raw)) {
		if (ref($stderr_raw) eq 'ARRAY') { 
		    @$stderr_raw = cat_($stderr);
		} else { 
		    $$stderr_raw = cat_($stderr);
		}
		unlink $stderr;
	    }
	    $ok;
	}
    } else {
	if ($stderr && $stderr eq 'STDERR') {
	} elsif ($stderr) {
	    $stderr_mode =~ s/2//;
	    open STDERR, "$stderr_mode $stderr" or die "run_program can't output in $stderr (mode `$stderr_mode')";
	} elsif ($::isInstall) {
	    open STDERR, ">> /tmp/ddebug.log" or open STDOUT, ">> /dev/tty7" or die "run_program can't log, give me access to /tmp/ddebug.log";
	}
	if ($stdout && $stdout eq 'STDOUT') {
	} elsif ($stdout) {
	    open STDOUT, "$stdout_mode $stdout" or die "run_program can't output in $stdout (mode `$stdout_mode')";
	} elsif ($::isInstall) {
	    open STDOUT, ">> /tmp/ddebug.log" or open STDOUT, ">> /dev/tty7" or die "run_program can't log, give me access to /tmp/ddebug.log";
	}