summaryrefslogtreecommitdiff
path: root/Master/tlpkg/dev/dev.sys_redir.pl
blob: fd3960b67b209298dfdec88c8356bc60996607af (plain)
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
#!/usr/bin/perl

use warnings;
use strict;

# flush an output stream
# argument: a filehandle reference
sub flush {
  my ($fh) = @_;

  my $prev_fh = select($fh);
  my $prev_autoflush = $|;
  $| = 1; # force a flush and turn on autoflush
  $| = $prev_autoflush; # restore the previous autoflush status for this fh
  select($prev_fh);
}

# run a command with (optional) redirections, without a shell
#
# arguments: input filename, output filename, error filename
#   (undef for a filename means no redirection)
# return value: exit status from the child
#
# usage:
#   my $status = sys_redir('foo.tar.xz', 'foo.tar', 'undef', 'xzdec', '-q')
# equivalent to
#   system('xzdec -q <foo.tar.xz >foo.tar');
#   my $status = $? >> 8;
# execpt it never runs a shell and does some additional error checking
sub sys_redir {
  my $in = shift;
  my $out = shift;
  my $err = shift;

  # description for error messages
  my $desc = "@_";
  $desc .= " <$in"  if defined $in;
  $desc .= " <$out" if defined $out;
  $desc .= " <$err" if defined $err;

  # log what we're about to do
  ddebug("Preparing to run: $desc\n");

  # flush stdout and stderr for tydiness
  flush \*STDOUT;
  flush \*STDERR;

  # duplicate file handles
  open(my $stdin,  '<&', \*STDIN)   || die "$desc: failed to dup stdin: $!\n";
  open(my $stdout, '>&', \*STDOUT)  || die "$desc: failed to dup stdout: $!\n";
  open(my $stderr, '>&', \*STDERR)  || die "$desc: failed to dup stderr: $!\n";

  # possibly tweak the file handles
  if (defined $in) {
    open(STDIN,  '<', $in)      || die "$desc: failed to read from $in: $!\n";
  }
  if (defined $out) {
    open(STDOUT, '>', $out)     || die "$desc: failed to write to $out: $!\n"
  }
  if (defined $err) {
    open(STDERR, '>', $err)     || die "$desc: failed to write to $err: $!\n"
  }

  # run the command
  system { $_[0] } @_;

  # check common errors and get actual exit value
  # (taken from perldoc -f system)
  my $ret;
  if ($? == -1) {
    die "failed to execute $desc: $!\n";
  } elsif ($? & 127) {
    die sprintf("child $desc died with signal %d, %s coredump\n",
      ($? & 127), ($? & 128) ? 'with' : 'without');
  } else {
    $ret = $? >> 8;
  }

  # flush stdout and stderr again for tydiness
  flush \*STDOUT;
  flush \*STDERR;

  # restore handles
  open(STDIN,  '<&', $stdin)    || die "$desc: failed to restore stdin: $!\n";
  open(STDOUT, '>&', $stdout)   || die "$desc: failed to restore stdout: $!\n";
  open(STDERR, '>&', $stderr)   || die "$desc: failed to restore stderr: $!\n";

  # log the return value
  ddebug("Child '$desc' returned: $ret\n")

  # done
  return $ret;
}

my $i;

sub test {
  $i++;
  print STDERR "\n";
  print "\n===> BEGIN $i <===\n";
  print "$i Child expects input, please type something\n" if !defined $_[0];
  print "$i Unflushed sdtout from parent"; # no \n
  print STDERR "$i Unflushed sdterr from parent"; # no \n
  my $status = sys_redir @_;
  print "$i Parent writing to stdout (please type something)\n";
  print "$i Parent reading from stdin: ", scalar <>;
  warn "$i Parent writing to stderr\n";
}

test('Cin', 'Cout1', undef, 'perl', '-ne',
    'print "C in-out1 $_"; warn "W in-out1\n"');
test('Cin', undef, undef, 'perl', '-ne',
    'print "C in- $_"; warn "W in-\n"');
test(undef, 'Cout2', undef, 'perl', '-e',
    'print "C -out2 ", scalar <>; warn "W -out2\n"');
test(undef, undef, undef, 'perl', '-e',
    'print "C - ", scalar <>; warn "W -\n"');

# vim: ts=2 sw=2 et