This organizes PIR files into the pir/ directory, which allows it to compile on OS X
[parrot-plumage:kid51-parrot-plumage.git] / pir / Glue.pir
1 =head1 NAME
2
3 Glue.pir - Rakudo "glue" builtins (functions/globals) converted for NQP
4
5 =cut
6
7 .namespace []
8
9 .include 'interpinfo.pasm'
10 .include 'sysinfo.pasm'
11 .include 'iglobals.pasm'
12
13
14 =head1 Functions
15
16 =over 4
17
18 =item $status_code := run($command, $and, $args, ...)
19
20 Spawn the command with the given arguments as a new process; return
21 the spawn status code when the process exits.
22
23 =cut
24
25 .sub 'run'
26     .param pmc command_and_args :slurpy
27     .local int status
28
29     status = spawnw command_and_args
30
31     .return (status)
32 .end
33
34
35 =item $success := do_run($command, $and, $args, ...)
36
37 Print out the command and arguments, then spawn the command with the given
38 arguments as a new process; return 1 if the process exited successfully, or
39 0 if not.
40
41 =cut
42
43 .sub 'do_run'
44     .param pmc command_and_args :slurpy
45
46     .local string cmd
47     cmd = join ' ', command_and_args
48     say cmd
49
50     .local int status
51     status = spawnw command_and_args
52
53     if status goto failed
54     .return (1)
55   failed:
56     .return (0)
57 .end
58
59
60 =item $output := qx($command, $and, $args, ...)
61
62 Spawn the command with the given arguments as a read only pipe;
63 return the output of the command as a single string.
64
65 B<WARNING>: Parrot currently implements this B<INSECURELY>!
66
67 =cut
68
69 .sub 'qx'
70     .param pmc command_and_args :slurpy
71
72     .local string cmd
73     cmd = join ' ', command_and_args
74
75     .local pmc pipe
76     pipe = open cmd, 'rp'
77     unless pipe goto pipe_open_error
78
79     .local pmc output
80     pipe.'encoding'('utf8')
81     output = pipe.'readall'()
82     pipe.'close'()
83     .return (output)
84
85   pipe_open_error:
86     $S0  = 'Unable to execute "'
87     $S0 .= cmd
88     $S0 .= '"'
89     die $S0
90 .end
91
92
93 =item die($message)
94
95 Kill program, reporting error C<$message>.
96
97 =cut
98
99 .sub 'die'
100     .param string message
101
102     die message
103 .end
104
105
106 =item try(&code, @args [, &handler])
107
108 Call C<&code> with flattened C<@args>.  If there are any exceptions, catch
109 them and invoke C<&handler> with the exception, C<&code>, and C<@args>.
110 If C<&handler> is absent, simply return C<0> if an exception is caught.
111 In other words, C<try()> implements the following pseudocode:
112
113     try        { $ret := &code(|@args)                                }
114     catch($ex) { $ret := &handler ?? &handler($ex, &code, @args) !! 0 }
115     return $ret;
116
117 =cut
118
119 .sub 'try'
120     .param pmc code
121     .param pmc args
122     .param pmc handler :optional
123     .param int has_handler :opt_flag
124
125     push_eh do_handler
126     $P0 = code(args :flat)
127     pop_eh
128     .return ($P0)
129
130   do_handler:
131     .local pmc ex
132     .get_results (ex)
133     pop_eh
134     eq has_handler, 0, no_handler
135     $P0 = handler(ex, code, args)
136     .return ($P0)
137
138   no_handler:
139     .return (0)
140 .end
141
142
143 =item @keys := keys(%hash)
144
145 Return an array containing the keys of the C<%hash>.
146
147 =cut
148
149 .sub 'keys'
150     .param pmc hash
151
152     .local pmc key_list, it
153     key_list = root_new ['parrot';'ResizableStringArray']
154     it       = iter hash
155
156   key_loop:
157     unless it goto no_more_keys
158
159     $S0 = shift it
160     push key_list, $S0
161
162     goto key_loop
163   no_more_keys:
164
165     .return(key_list)
166 .end
167
168
169 =item $found := exists(%hash, $key)
170
171 Determine if C<$key> exists in C<%hash>, returning a true value if so, and a
172 false value if not.
173
174 =cut
175
176 .sub 'exists'
177     .param pmc    hash
178     .param string key
179
180     $I0 = exists hash[key]
181
182     .return($I0)
183 .end
184
185
186 =item $does_role := does($object, $role)
187
188 Determine if C<$object> does the C<$role>, returning a true value if so, and a
189 false value if not.
190
191 =cut
192
193 .sub 'does'
194     .param pmc    object
195     .param string role
196
197     $I0 = does object, role
198
199     .return($I0)
200 .end
201
202
203 =item $contents := slurp($filename)
204
205 Read the C<$contents> of a file as a single string.
206
207 =cut
208
209 .sub 'slurp'
210     .param string filename
211     .local string contents
212
213     $P0 = open filename, 'r'
214     contents = $P0.'readall'()
215     close $P0
216     .return(contents)
217 .end
218
219
220 =item spew($filename, $contents)
221
222 Write the string C<$contents> to a file.
223
224 =cut
225
226 .sub 'spew'
227     .param string filename
228     .param string contents
229
230     $P0 = open filename, 'w'
231     $P0.'print'(contents)
232     close $P0
233 .end
234
235
236 =item $edited := subst($original, $regex, $replacement)
237
238 Substitute all matches of the C<$regex> in the C<$original> string with the
239 C<$replacement>, and return the edited string.  The C<$regex> must be a simple
240 string to be compiled using the C<PGE::Perl6Regex> language.
241
242 The C<$replacement> may be either a simple string or a sub that will be called
243 with each match object in turn, and must return the proper replacement string
244 for that match.
245
246 =cut
247
248 .sub 'subst'
249     .param string original
250     .param string regex
251     .param pmc    replacement
252
253     # Compile the string regex into a regex object
254     .local pmc p6regex, matcher
255     p6regex = compreg 'PGE::Perl6Regex'
256     matcher = p6regex(regex)
257
258     # Find all matches in the original string
259     .local pmc matches, match
260     matches = root_new ['parrot';'ResizablePMCArray']
261     match   = matcher(original)
262     unless match goto done_matching
263
264   match_loop:
265     push matches, match
266
267     $I0 = match.'to'()
268     match = matcher(match, 'continue' => $I0)
269
270     unless match goto done_matching
271     goto match_loop
272   done_matching:
273
274     # Do the substitutions on a clone of the original string
275     .local string edited
276     edited = clone original
277
278     # Now replace all the matched substrings
279     .local int offset
280     offset = 0
281   replace_loop:
282     unless matches goto done_replacing
283     match = shift matches
284
285     # Handle either string or sub replacement
286     .local string replace_string
287     $I0 = isa replacement, 'Sub'
288     if $I0 goto call_replacement_sub
289     replace_string = replacement
290     goto have_replace_string
291   call_replacement_sub:
292     replace_string = replacement(match)
293   have_replace_string:
294
295     # Perform the replacement
296     $I0  = match.'from'()
297     $I1  = match.'to'()
298     $I2  = $I1 - $I0
299     $I0 += offset
300     substr edited, $I0, $I2, replace_string
301     $I3  = length replace_string
302     $I3 -= $I2
303     offset += $I3
304     goto replace_loop
305   done_replacing:
306
307     .return(edited)
308 .end
309
310 =item chdir($path)
311
312 Change the current working directory to the specified C<$path>.
313
314 =cut
315
316 .sub 'chdir'
317     .param string path
318
319     .local pmc os
320     os = root_new [ 'parrot' ; 'OS' ]
321     os.'chdir'(path)
322 .end
323
324 =item $path := cwd()
325
326 Return the current working directory.
327
328 =cut
329
330 .sub 'cwd'
331     .local pmc os
332     os = root_new [ 'parrot' ; 'OS' ]
333
334     .local string path
335     path = os.'cwd'()
336
337     .return(path)
338 .end
339
340 =item mkdir($path [, $mode])
341
342 Create a directory specified by C<$path> with mode C<$mode>.  C<$mode> is
343 optional and defaults to octal C<777> (full permissions) if absent.  C<$mode>
344 is modified by the user's current C<umask> as usual.
345
346 =cut
347
348 .sub 'mkdir'
349     .param string path
350     .param int    mode     :optional
351     .param int    has_mode :opt_flag
352
353     if has_mode goto have_mode
354     mode = 0o777
355   have_mode:
356
357     .local pmc os
358     os = root_new [ 'parrot' ; 'OS' ]
359     os.'mkdir'(path, mode)
360 .end
361
362 =item @info := stat($path)
363
364 Returns a 13-item list of information about the given C<$path>, as in Perl 5.
365 (See C<perldoc -f stat> for more details.)
366
367 =cut
368
369 .sub 'stat'
370     .param string path
371
372     .local pmc os, stat_list
373     os = root_new [ 'parrot' ; 'OS' ]
374     stat_list = os.'stat'(path)
375
376     .return (stat_list)
377 .end
378
379 =item $path := fscat(@path_parts [, $filename])
380
381 Join C<@path_parts> and C<$filename> strings together with the appropriate
382 OS separator.  If no C<$filename> is supplied, C<fscat()> will I<not> add a
383 trailing slash (though slashes inside the C<@path_parts> will not be removed,
384 so don't do that).
385
386 =cut
387
388 .sub 'fscat'
389     .param pmc    parts
390     .param string filename     :optional
391     .param int    has_filename :opt_flag
392
393     .local string sep
394     $P0 = getinterp
395     $P1 = $P0[.IGLOBALS_CONFIG_HASH]
396     sep = $P1['slash']
397
398     .local string joined
399     joined = join sep, parts
400
401     unless has_filename goto no_filename
402     joined .= sep
403     joined .= filename
404   no_filename:
405
406     .return (joined)
407 .end
408
409 =item $joined := join($delimiter, @strings)
410
411 Join C<@strings> together with the specified C<$delimiter>.
412
413 =cut
414
415 .sub 'join'
416     .param string delim
417     .param pmc    strings
418
419     .local string joined
420     joined = join delim, strings
421
422     .return (joined)
423 .end
424
425 =item @pieces := split($delimiter, $original)
426
427 Split the C<$original> string with the specified C<$delimiter>, which is not
428 included in the resulting C<@pieces>.
429
430 =cut
431
432 .sub 'split'
433     .param string delim
434     .param string original
435
436     .local pmc pieces
437     pieces = split delim, original
438
439     .return (pieces)
440 .end
441
442
443 =item @array := as_array($list, $of, $items, ...)
444
445 Slurp the list of arguments into an array and return it.
446
447 =cut
448
449 .sub 'as_array'
450      .param pmc items :slurpy
451
452      .return (items)
453 .end
454
455
456 =item $result := call_flattened(&code, $mixed, @args, $list, ...)
457
458 Call C<&code> with flattened arguments.  This is done by first slurping all
459 arguments into an array, then iterating over the array flattening by one level
460 each element that C<does 'array'>.  Finally, the C<&code> is tailcalled with
461 the flattened array using the Parrot C<:flat> flag.
462
463 To avoid flattening an array that should be passed as a single argument, wrap
464 it with C<as_array()> first, like so:
465
466     call_flattened(&code, as_array(@protected), @will_flatten)
467
468 =cut
469
470 .sub 'call_flattened'
471     .param pmc code
472     .param pmc args :slurpy
473
474     .local pmc flattened, args_it, array_it
475     flattened = root_new ['parrot';'ResizablePMCArray']
476     args_it   = iter args
477
478   args_loop:
479     unless args_it goto do_tailcall
480     $P0 = shift args_it
481     $I0 = does $P0, 'array'
482     if $I0 goto flatten_array
483     push flattened, $P0
484     goto args_loop
485   flatten_array:
486     array_it = iter $P0
487   array_loop:
488     unless array_it goto args_loop
489     $P1 = shift array_it
490     push flattened, $P1
491     goto array_loop
492
493   do_tailcall:
494     .tailcall code(flattened :flat)
495 .end
496
497 =back
498
499
500 =head1 Global Variables
501
502 =over 4
503
504 =item $PROGRAM_NAME
505
506 Name of running program (argv[0] in C)
507
508 =item @ARGS
509
510 Program's command line arguments (including options, which are NOT parsed)
511
512 =item %VM
513
514 Parrot configuration
515
516 =item %ENV
517
518 Process-wide environment variables
519
520 =item $OS
521
522 Operating system generic name
523
524 =item $OSVER
525
526 Operating system version
527
528 =back
529
530 =cut
531
532 .sub 'onload' :anon :load :init
533     load_bytecode 'config.pbc'
534     $P0 = getinterp
535     $P1 = $P0[.IGLOBALS_CONFIG_HASH]
536     $P2 = new ['Hash']
537     $P2['config'] = $P1
538     set_hll_global '%VM', $P2
539
540     $P1 = $P0[.IGLOBALS_ARGV_LIST]
541     if $P1 goto have_args
542     unshift $P1, '<anonymous>'
543   have_args:
544     $S0 = shift $P1
545     $P2 = box $S0
546     set_hll_global '$PROGRAM_NAME', $P2
547     set_hll_global '@ARGS', $P1
548
549     $P0 = root_new ['parrot';'Env']
550     set_hll_global '%ENV', $P0
551
552     $S0 = sysinfo .SYSINFO_PARROT_OS
553     $P0 = box $S0
554     set_hll_global '$OS', $P0
555
556     $S0 = sysinfo .SYSINFO_PARROT_OS_VERSION
557     $P0 = box $S0
558     set_hll_global '$OSVER', $P0
559 .end
560
561
562 # Local Variables:
563 #   mode: pir
564 #   fill-column: 100
565 # End:
566 # vim: expandtab shiftwidth=4 ft=pir: