From 0fd0d0bc1b53ba2c9796106efdea13157c3f593e Mon Sep 17 00:00:00 2001 From: Manuel Pégourié-Gonnard Date: Sun, 12 Jun 2011 11:25:52 +0000 Subject: add dev.sys_redir.pl (see README for details) git-svn-id: svn://tug.org/texlive/trunk@22936 c570f23f-e606-0410-a88d-b1316a301751 --- Master/tlpkg/dev/dev.sys_redir.README | 16 +++++ Master/tlpkg/dev/dev.sys_redir.pl | 119 ++++++++++++++++++++++++++++++++++ 2 files changed, 135 insertions(+) create mode 100644 Master/tlpkg/dev/dev.sys_redir.README create mode 100644 Master/tlpkg/dev/dev.sys_redir.pl (limited to 'Master/tlpkg/dev') diff --git a/Master/tlpkg/dev/dev.sys_redir.README b/Master/tlpkg/dev/dev.sys_redir.README new file mode 100644 index 00000000000..860d859a458 --- /dev/null +++ b/Master/tlpkg/dev/dev.sys_redir.README @@ -0,0 +1,16 @@ +Replacement for system('foo bar') without using a shell. +Would solve quoting problems once and for all. + +includes a test routine with a few tests, lacking tests for stderr redirection +right now + +needs to be tested on windows too! + +Ideas for running tests (Unix): + +# echo abc > Cin; echo 123 >> Cin +perl redir.pl # interactive, just keep typing 'y' +yes | perl redir.pl +yes | perl redir.pl >Pout 2>Perr +yes | perl redir.pl >Pcomb 2>&1 + diff --git a/Master/tlpkg/dev/dev.sys_redir.pl b/Master/tlpkg/dev/dev.sys_redir.pl new file mode 100644 index 00000000000..fd3960b67b2 --- /dev/null +++ b/Master/tlpkg/dev/dev.sys_redir.pl @@ -0,0 +1,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'); +# 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 -- cgit v1.2.3