1. # Proc is a wrapper around Proc::Async, providing a synchronous API atop of
  2. # the asynchronous API.
  3. my class Proc::Async { ... }
  4. my class Proc {
  5. has IO::Pipe $.in;
  6. has IO::Pipe $.out;
  7. has IO::Pipe $.err;
  8. has $.exitcode = -1; # distinguish uninitialized from 0 status
  9. has $.signal;
  10. has @.command;
  11. has Proc::Async $!proc;
  12. has Bool $!w;
  13. has @!pre-spawn;
  14. has @!post-spawn;
  15. has $!active-handles = 0;
  16. has &!start-stdout;
  17. has &!start-stderr;
  18. has $!finished;
  19. submethod BUILD(:$in = '-', :$out = '-', :$err = '-', :$exitcode,
  20. Bool :$bin, Bool :$chomp = True, Bool :$merge, :$command,
  21. Str :$enc, Str:D :$nl = "\n", :$signal --> Nil) {
  22. @!command = |$command if $command;
  23. if nqp::istype($in, IO::Handle) && $in.DEFINITE {
  24. @!pre-spawn.push({ $!proc.bind-stdin($in) });
  25. }
  26. elsif $in === True {
  27. my $cur-promise = Promise.new;
  28. $cur-promise.keep(True);
  29. $!in = IO::Pipe.new(:proc(self), :$chomp, :$enc, :$bin, nl-out => $nl,
  30. :on-write(-> $blob {
  31. $cur-promise .= then({ await $!proc.write($blob) });
  32. }),
  33. :on-close({
  34. $cur-promise .= then({ $!proc.close-stdin; });
  35. self!await-if-last-handle
  36. }));
  37. ++$!active-handles;
  38. $!w := True;
  39. }
  40. elsif nqp::istype($in, Str) && $in eq '-' {
  41. # Inherit; nothing to do
  42. }
  43. else {
  44. $!w := True;
  45. @!post-spawn.push({ $!proc.close-stdin });
  46. }
  47. if $merge {
  48. my $chan = Channel.new;
  49. $!out = IO::Pipe.new(:proc(self), :$chomp, :$enc, :$bin, nl-in => $nl,
  50. :on-read({ (try $chan.receive) // buf8 }),
  51. :on-close({ self!await-if-last-handle }));
  52. ++$!active-handles;
  53. @!pre-spawn.push({
  54. $!proc.stdout(:bin).merge($!proc.stderr(:bin)).act: { $chan.send($_) },
  55. done => { $chan.close },
  56. quit => { $chan.fail($_) }
  57. });
  58. }
  59. else {
  60. if $out === True {
  61. my $chan;
  62. my $stdout-supply;
  63. &!start-stdout = {
  64. $chan = $stdout-supply.Channel;
  65. &!start-stdout = Nil;
  66. }
  67. $!out = IO::Pipe.new(:proc(self), :$chomp, :$enc, :$bin, nl-in => $nl,
  68. :on-read({
  69. &!start-stdout() if &!start-stdout;
  70. (try $chan.receive) // buf8
  71. }),
  72. :on-close({
  73. $chan //= $stdout-supply.Channel; # If we never read
  74. self!await-if-last-handle
  75. }),
  76. :on-native-descriptor({
  77. $!active-handles--;
  78. &!start-stdout = Nil;
  79. await $stdout-supply.native-descriptor
  80. }));
  81. ++$!active-handles;
  82. @!pre-spawn.push({
  83. $stdout-supply = $!proc.stdout(:bin)
  84. });
  85. }
  86. elsif nqp::istype($out, IO::Handle) && $out.DEFINITE {
  87. @!pre-spawn.push({ $!proc.bind-stdout($out) });
  88. }
  89. elsif nqp::istype($out, Str) && $out eq '-' {
  90. # Inherit; nothing to do
  91. }
  92. else {
  93. @!pre-spawn.push({
  94. $!proc.stdout(:bin).tap: -> $ { }, quit => -> $ { }
  95. });
  96. }
  97. if $err === True {
  98. my $chan;
  99. my $stderr-supply;
  100. &!start-stderr = {
  101. $chan = $stderr-supply.Channel;
  102. &!start-stderr = Nil;
  103. }
  104. $!err = IO::Pipe.new(:proc(self), :$chomp, :$enc, :$bin, nl-in => $nl,
  105. :on-read({
  106. &!start-stderr() if &!start-stderr;
  107. (try $chan.receive) // buf8
  108. }),
  109. :on-close({
  110. $chan //= $stderr-supply.Channel; # If we never read
  111. self!await-if-last-handle
  112. }),
  113. :on-native-descriptor({
  114. &!start-stderr = Nil;
  115. $!active-handles--;
  116. await $stderr-supply.native-descriptor
  117. }));
  118. ++$!active-handles;
  119. @!pre-spawn.push({
  120. $stderr-supply = $!proc.stderr(:bin);
  121. });
  122. }
  123. elsif nqp::istype($err, IO::Handle) && $err.DEFINITE {
  124. @!pre-spawn.push({ $!proc.bind-stderr($err) });
  125. }
  126. elsif nqp::istype($err, Str) && $err eq '-' {
  127. # Inherit; nothing to do
  128. }
  129. else {
  130. @!pre-spawn.push({
  131. $!proc.stderr(:bin).tap: -> $ { }, quit => -> $ { }
  132. });
  133. }
  134. }
  135. if nqp::istype($exitcode, Int) && $exitcode.DEFINITE {
  136. $!exitcode = $exitcode;
  137. }
  138. if nqp::istype($signal, Int) && $signal.DEFINITE {
  139. $!signal = $signal;
  140. }
  141. }
  142. method !await-if-last-handle() {
  143. self!wait-for-finish unless --$!active-handles;
  144. self
  145. }
  146. method !wait-for-finish {
  147. CATCH { default { self!set-status(0x100) } }
  148. &!start-stdout() if &!start-stdout;
  149. &!start-stderr() if &!start-stderr;
  150. self!set-status(await($!finished).status) if $!exitcode == -1;
  151. }
  152. method spawn(*@args where .so, :$cwd = $*CWD, :$env --> Bool:D) {
  153. @!command = @args;
  154. self!spawn-internal(@args, $cwd, $env)
  155. }
  156. method shell($cmd, :$cwd = $*CWD, :$env --> Bool:D) {
  157. @!command = $cmd;
  158. my @args := Rakudo::Internals.IS-WIN
  159. ?? (%*ENV<ComSpec>, '/c', $cmd)
  160. !! ('/bin/sh', '-c', $cmd);
  161. self!spawn-internal(@args, $cwd, $env)
  162. }
  163. method !spawn-internal(@args, $cwd, $env --> Bool:D) {
  164. my %ENV := $env ?? $env.hash !! %*ENV;
  165. $!proc := Proc::Async.new(|@args, :$!w);
  166. .() for @!pre-spawn;
  167. $!finished = $!proc.start(:$cwd, :%ENV, scheduler => $PROCESS::SCHEDULER);
  168. my $is-spawned := do {
  169. CATCH { default { self!set-status(0x100) } }
  170. await $!proc.ready;
  171. True
  172. } // False;
  173. .() for @!post-spawn;
  174. self!wait-for-finish unless $!out || $!err || $!in;
  175. $is-spawned
  176. }
  177. method !set-status($new_status) {
  178. $!exitcode = $new_status +> 8;
  179. $!signal = $new_status +& 0xFF;
  180. }
  181. method !status() {
  182. self!wait-for-finish;
  183. ($!exitcode +< 8) +| $!signal
  184. }
  185. # see https://github.com/rakudo/rakudo/issues/1366
  186. # should be deprecated and removed
  187. proto method status(|) {*}
  188. multi method status($new_status) {
  189. $!exitcode = $new_status +> 8;
  190. $!signal = $new_status +& 0xFF;
  191. }
  192. multi method status(Proc:D:) {
  193. self!wait-for-finish;
  194. ($!exitcode +< 8) +| $!signal
  195. }
  196. multi method Numeric(Proc:D:) {
  197. self!wait-for-finish;
  198. $!exitcode
  199. }
  200. multi method Bool(Proc:D:) {
  201. self!wait-for-finish;
  202. $!exitcode == 0
  203. }
  204. method exitcode {
  205. self!wait-for-finish;
  206. $!exitcode
  207. }
  208. method sink(--> Nil) {
  209. self!wait-for-finish;
  210. X::Proc::Unsuccessful.new(:proc(self)).throw if $!exitcode > 0;
  211. }
  212. }
  213. proto sub run(|) {*}
  214. multi sub run(*@args where .so, :$in = '-', :$out = '-', :$err = '-',
  215. Bool :$bin, Bool :$chomp = True, Bool :$merge,
  216. Str :$enc, Str:D :$nl = "\n", :$cwd = $*CWD, :$env) {
  217. my $proc = Proc.new(:$in, :$out, :$err, :$bin, :$chomp, :$merge, :$enc, :$nl);
  218. $proc.spawn(@args, :$cwd, :$env);
  219. $proc
  220. }
  221. proto sub shell(|) {*}
  222. multi sub shell($cmd, :$in = '-', :$out = '-', :$err = '-',
  223. Bool :$bin, Bool :$chomp = True, Bool :$merge,
  224. Str :$enc, Str:D :$nl = "\n", :$cwd = $*CWD, :$env) {
  225. my $proc = Proc.new(:$in, :$out, :$err, :$bin, :$chomp, :$merge, :$enc, :$nl);
  226. $proc.shell($cmd, :$cwd, :$env);
  227. $proc
  228. }
  229. sub QX($cmd, :$cwd = $*CWD, :$env) {
  230. my $proc = Proc.new(:out);
  231. $proc.shell($cmd, :$cwd, :$env);
  232. $proc.out.slurp(:close) // Failure.new("Unable to read from '$cmd'")
  233. }