1. my class Proc {
  2. has IO::Pipe $.in;
  3. has IO::Pipe $.out;
  4. has IO::Pipe $.err;
  5. has $.exitcode = -1; # distinguish uninitialized from 0 status
  6. has $.signal;
  7. has @.command;
  8. has $!in_fh;
  9. has $!out_fh;
  10. has $!err_fh;
  11. has int $!flags;
  12. submethod BUILD(:$in = '-', :$out = '-', :$err = '-', :$exitcode,
  13. Bool :$bin, Bool :$chomp = True, Bool :$merge, :$command,
  14. Str:D :$enc = 'utf8', Str:D :$nl = "\n", :$signal --> Nil) {
  15. if $merge {
  16. die "Executing programs with :merge is known to be broken\n"
  17. ~ "Please see https://rt.perl.org//Public/Bug/Display.html?id=128594 for the bug report.\n";
  18. }
  19. @!command = |$command if $command;
  20. if nqp::istype($in, IO::Handle) && $in.DEFINITE {
  21. $!in_fh := nqp::getattr(nqp::decont($in), IO::Handle, '$!PIO');
  22. $!flags += nqp::const::PIPE_INHERIT_IN;
  23. }
  24. elsif $in === True {
  25. $!in = IO::Pipe.new(:proc(self), :path(''), :$chomp, nl-out => $nl);
  26. $!in_fh := nqp::syncpipe();
  27. $!flags += nqp::const::PIPE_CAPTURE_IN;
  28. Rakudo::Internals.SET_LINE_ENDING_ON_HANDLE($!in_fh, $nl);
  29. nqp::setencoding($!in_fh,Rakudo::Internals.NORMALIZE_ENCODING($enc))
  30. unless $bin;
  31. nqp::bindattr(nqp::decont($!in), IO::Handle, '$!PIO', $!in_fh);
  32. }
  33. elsif nqp::istype($in, Str) && $in eq '-' {
  34. $!in_fh := nqp::null();
  35. $!flags += nqp::const::PIPE_INHERIT_IN;
  36. }
  37. else {
  38. $!in_fh := nqp::null();
  39. $!flags += nqp::const::PIPE_IGNORE_IN;
  40. }
  41. if $out === True || $merge {
  42. $!out = IO::Pipe.new(:proc(self), :path(''), :$chomp, nl-in => $nl);
  43. $!out_fh := nqp::syncpipe();
  44. $!flags += nqp::const::PIPE_CAPTURE_OUT;
  45. Rakudo::Internals.SET_LINE_ENDING_ON_HANDLE($!out_fh, $nl);
  46. nqp::setencoding($!out_fh,Rakudo::Internals.NORMALIZE_ENCODING($enc))
  47. unless $bin;
  48. nqp::bindattr(nqp::decont($!out), IO::Handle, '$!PIO', $!out_fh);
  49. }
  50. elsif nqp::istype($out, IO::Handle) && $out.DEFINITE {
  51. $!out_fh := nqp::getattr(nqp::decont($out), IO::Handle, '$!PIO');
  52. $!flags += nqp::const::PIPE_INHERIT_OUT;
  53. }
  54. elsif nqp::istype($out, Str) && $out eq '-' {
  55. $!out_fh := nqp::null();
  56. $!flags += nqp::const::PIPE_INHERIT_OUT;
  57. }
  58. else {
  59. $!out_fh := nqp::null();
  60. $!flags += nqp::const::PIPE_IGNORE_OUT;
  61. }
  62. if $merge {
  63. $!err := $!out;
  64. $!err_fh := $!out_fh;
  65. $!flags += nqp::const::PIPE_INHERIT_ERR;
  66. }
  67. elsif nqp::istype($err, IO::Handle) && $err.DEFINITE {
  68. $!err_fh := nqp::getattr(nqp::decont($err), IO::Handle, '$!PIO');
  69. $!flags += nqp::const::PIPE_INHERIT_ERR;
  70. }
  71. elsif nqp::istype($err, Str) && $err eq '-' {
  72. $!err_fh := nqp::null();
  73. $!flags += nqp::const::PIPE_INHERIT_ERR;
  74. }
  75. elsif $err === True {
  76. $!err = IO::Pipe.new(:proc(self), :path(''), :$chomp, nl-in => $nl);
  77. $!err_fh := nqp::syncpipe();
  78. $!flags += nqp::const::PIPE_CAPTURE_ERR;
  79. Rakudo::Internals.SET_LINE_ENDING_ON_HANDLE($!err_fh, $nl);
  80. nqp::setencoding($!err_fh,Rakudo::Internals.NORMALIZE_ENCODING($enc))
  81. unless $bin;
  82. nqp::bindattr(nqp::decont($!err), IO::Handle, '$!PIO', $!err_fh);
  83. }
  84. else {
  85. $!err_fh := nqp::null();
  86. $!flags += nqp::const::PIPE_IGNORE_ERR;
  87. }
  88. if nqp::istype($exitcode, Int) && $exitcode.DEFINITE {
  89. $!exitcode = $exitcode;
  90. }
  91. if nqp::istype($signal, Int) && $signal.DEFINITE {
  92. $!signal = $signal;
  93. }
  94. }
  95. method spawn(*@args ($, *@), :$cwd = $*CWD, :$env) {
  96. @!command = @args;
  97. my %env := $env ?? $env.hash !! %*ENV;
  98. self.status(nqp::p6box_i(nqp::spawn(
  99. CLONE-LIST-DECONTAINERIZED(@args),
  100. nqp::unbox_s($cwd.Str),
  101. CLONE-HASH-DECONTAINERIZED(%env),
  102. $!in_fh, $!out_fh, $!err_fh,
  103. $!flags
  104. )));
  105. self.Bool
  106. }
  107. method shell($cmd, :$cwd = $*CWD, :$env) {
  108. @!command = $cmd;
  109. my %env := $env ?? $env.hash !! %*ENV;
  110. self.status(nqp::p6box_i(nqp::shell(
  111. nqp::unbox_s($cmd),
  112. nqp::unbox_s($cwd.Str),
  113. CLONE-HASH-DECONTAINERIZED(%env),
  114. $!in_fh, $!out_fh, $!err_fh,
  115. $!flags
  116. )));
  117. self.Bool
  118. }
  119. proto method status(|) { * }
  120. multi method status($new_status) {
  121. $!exitcode = $new_status +> 8;
  122. $!signal = $new_status +& 0xFF;
  123. }
  124. multi method status(Proc:D:) { ($!exitcode +< 8) +| $!signal }
  125. multi method Numeric(Proc:D:) { $!exitcode }
  126. multi method Bool(Proc:D:) { $!exitcode == 0 }
  127. method sink(--> Nil) {
  128. X::Proc::Unsuccessful.new(:proc(self)).throw unless self;
  129. }
  130. }
  131. sub run(*@args ($, *@), :$in = '-', :$out = '-', :$err = '-',
  132. Bool :$bin, Bool :$chomp = True, Bool :$merge,
  133. Str:D :$enc = 'utf8', Str:D :$nl = "\n", :$cwd = $*CWD, :$env) {
  134. my $proc = Proc.new(:$in, :$out, :$err, :$bin, :$chomp, :$merge, :$enc, :$nl);
  135. $proc.spawn(@args, :$cwd, :$env);
  136. $proc
  137. }
  138. sub shell($cmd, :$in = '-', :$out = '-', :$err = '-',
  139. Bool :$bin, Bool :$chomp = True, Bool :$merge,
  140. Str:D :$enc = 'utf8', Str:D :$nl = "\n", :$cwd = $*CWD, :$env) {
  141. my $proc = Proc.new(:$in, :$out, :$err, :$bin, :$chomp, :$merge, :$enc, :$nl);
  142. $proc.shell($cmd, :$cwd, :$env);
  143. $proc
  144. }
  145. sub QX($cmd, :$cwd = $*CWD, :$env) {
  146. my %env := $env ?? $env.hash !! %*ENV;
  147. my Mu $pio := nqp::syncpipe();
  148. my $status := nqp::shell(
  149. nqp::unbox_s($cmd),
  150. nqp::unbox_s($cwd.Str),
  151. CLONE-HASH-DECONTAINERIZED(%env),
  152. nqp::null(), $pio, nqp::null(),
  153. nqp::const::PIPE_INHERIT_IN + nqp::const::PIPE_CAPTURE_OUT + nqp::const::PIPE_INHERIT_ERR
  154. );
  155. my $result;
  156. try {
  157. $result = nqp::p6box_s(nqp::readallfh($pio));
  158. $status := nqp::closefh_i($pio);
  159. }
  160. $result.DEFINITE
  161. ?? $result
  162. !! Failure.new("Unable to read from '$cmd'")
  163. }