Convert to native NQP-rx regex; move last bits of Glue functionality to Util; kill...
[parrot-plumage:parrot-plumage.git] / src / lib / Util.nqp
1 =begin
2
3 =head1 NAME
4
5 Util.nqp - Utility functions for NQP and Plumage
6
7 =head1 SYNOPSIS
8
9     # Load this library
10     pir::load_bytecode('src/lib/Util.pbc');
11
12     # Hash methods
13     $found     := %hash.exists($key);
14     @keys      := %hash.keys;
15     @values    := %hash.values;
16     @flattened := %hash.kv;
17
18     # Array methods
19     @reversed := @array.reverse;
20
21     # Basics
22     @mapped  := map(   &code, @originals);
23     @matches := grep(  &code, @all);
24     $result  := reduce(&code, @array, $initial?);
25
26     # Containers
27     %hash := hash(:key1(value1), :key2(value2), ...);
28     %set  := set_from_array(@array);
29
30     # Regular expressions
31     @matches := all_matches($regex, $text);
32     $edited  := subst($original, $regex, $replacement);
33
34     # I/O
35     print('things', ' to ', 'print', ...);
36     say(  'things', ' to ', 'say',   ...);
37     $contents := slurp($filename);
38     spew(  $filename, $contents);
39     append($filename, $contents);
40
41     # Filesystems and paths
42     $path        := fscat(@path_parts [, $filename]);
43     $home        := user_home_dir();
44     $found       := path_exists($path);
45     $is_dir      := is_dir($path);
46     $writable    := test_dir_writable($directory_path);
47     $binary_path := find_program($program);
48     mkpath($directory_path);
49
50     # External programs
51     $status_code := run(   $command, $and, $args, ...);
52     $success     := do_run($command, $and, $args, ...);
53     $output      := qx(    $command, $and, $args, ...);
54
55     # HLL Interop
56     $result := eval($source_code, $language);
57
58     # Deep Magic
59     store_dynlex_safely($var_name, $value);
60
61     # Global variables
62     my $*EXECUTABLE_NAME;
63     my $*PROGRAM_NAME;
64     my $*OSNAME;
65     my $*OSVER;
66     my @*ARGS;
67     my %*ENV;
68     my %*VM;
69     my $*OS;
70
71     # Plumage-specific
72     $replaced := replace_config_strings($original);
73
74
75 =head1 DESCRIPTION
76
77 =head2 Hash Methods
78
79 These methods extend the native NQP Hash class to support more of the basic
80 functionality expected for Perl 6 Hashes.
81
82 =end
83
84 module Hash {
85
86
87 =begin
88
89 =over 4
90
91 =item $found := %hash.exists($key)
92
93 Return a true value if C<$key> exists in C<%hash>, or a false value otherwise.
94
95 =end
96
97     method exists ($key) {
98         return Q:PIR{
99             $P1 = find_lex '$key'
100             $I0 = exists self[$P1]
101             %r  = box $I0
102         };
103     }
104
105
106 =begin
107
108 =item @keys := %hash.keys
109
110 Return all the C<@keys> in the C<%hash> as an unordered array.
111
112 =end
113
114     method keys () {
115         my @keys;
116         for self { @keys.push($_.key); }
117         @keys;
118     }
119
120
121 =begin
122
123 =item @values := %hash.values
124
125 Return all the C<@values> in the C<%hash> as an unordered array.
126
127 =end
128
129     method values () {
130         my @values;
131         for self { @values.push($_.value); }
132         @values;
133     }
134
135
136 =begin
137
138 =item @flattened := %hash.kv
139
140 Flatten C<%hash> into an array, alternating key and value.  This is useful
141 when iterating over key and value simultaneously:
142
143     for %hash.kv -> $k, $v { ... }
144
145 =end
146
147     method kv () {
148         my @kv;
149         for self { @kv.push($_.key); @kv.push($_.value); }
150         @kv;
151     }
152
153
154 =begin
155
156 =back
157
158 =end
159
160 }
161
162
163 =begin
164
165 =head2 Array Methods
166
167 These methods extend the native NQP Array class to support more of the basic
168 functionality expected for Perl 6 Hashes.
169
170 =end
171
172 module Array {
173
174
175 =begin
176
177 =over 4
178
179 =item @reversed := @array.reverse
180
181 Return a C<@reversed> copy of the C<@array>.
182
183 =end
184
185     method reverse () {
186         my @reversed;
187         for self { @reversed.unshift($_); }
188         @reversed;
189     }
190
191
192 =begin
193
194 =back
195
196 =end
197
198 }
199
200
201 =begin
202
203 =head2 Basic Functions
204
205 These functions provide basic functionality that would be part of the standard
206 setting in Perl 6, but are not provided with NQP by default.
207
208 =over 4
209
210 =item @mapped := map(&code, @originals)
211
212 Pretty much as you would expect, except there is no flattening or other
213 coersion, due to the current semantics of NQP.  This means that every
214 application of C<&code> to an item in the C<@originals> produces exactly
215 one entry in the C<@mapped> output.
216
217 =end
218
219 sub map (&code, @originals) {
220     my @mapped;
221
222     for @originals {
223         @mapped.push(&code($_));
224     }
225
226     return @mapped;
227 }
228
229
230 =begin
231
232 =item @matches := grep(&code, @all)
233
234 Select all members of C<@all> for which C<&code($member)> returns true.
235 Order is retained, and duplicates are handled independently.
236
237 =end
238
239 sub grep (&code, @all) {
240     my @matches;
241
242     for @all {
243         @matches.push($_) if &code($_);
244     }
245
246     return @matches;
247 }
248
249
250 =begin
251
252 =item $result := reduce(&code, @array, $initial?)
253
254 Loop over the C<@array>, applying the binary function C<&code> to the current
255 C<$result> and next element of the C<@array>, each time saving the return
256 value of the C<&code> as the new C<$result>.  When all elements of the array
257 have been processed, the last C<$result> computed is returned.
258
259 If an C<$initial> value is supplied, it is used as the starting value for
260 C<$result> when iterating over the C<@array>.  This automatically works with
261 any length C<@array>, even an empty one.
262
263 Without an C<$initial> value, C<reduce()> applies the C<&code> to the first two
264 elements in the C<@array> to determine the inital C<$result> (and skips these
265 first two elements when looping).  If the C<@array> has only one element, it
266 is returned directly as the final C<$result>.  If the C<@array> is empty, the
267 C<$result> is an undefined value.
268
269 =end
270
271 sub reduce (&code, @array, *@initial) {
272     my    $init_elems := pir::elements(@initial);
273     if    $init_elems >  1 {
274         pir::die('Only one initial value allowed in reduce()');
275     }
276     elsif $init_elems == 1 {
277         return _reduce(&code, @array, @initial[0]);
278     }
279     else {
280         my    $array_elems := pir::elements(@array);
281         if    $array_elems == 0 {
282             return my $undef;
283         }
284         elsif $array_elems == 1 {
285             return @array[0];
286         }
287         else {
288             my $initial := &code(@array[0], @array[1]);
289             my $iter    := pir::iter__PP(@array);
290
291             pir::shift($iter);
292             pir::shift($iter);
293
294             return _reduce(&code, $iter, $initial);
295         }
296     }
297 }
298
299 sub _reduce(&code, $iter, $initial) {
300     my $result := $initial;
301
302     for $iter {
303         $result := &code($result, $_);
304     }
305
306     return $result;
307 }
308
309
310 =begin
311
312 =head2 Container Coercions
313
314 These functions create a container of a desired type from one or more
315 containers of another type.  While some of these would not exist in the Perl 6
316 setting, they are still generally useful for NQP programs because NQP syntax is
317 considerably more wordy than Perl 6.  DRY thus applies.
318
319 =over 4
320
321 =item %hash := hash(:key1(value1), :key2(value2), ...)
322
323 Coerce a list of pairs into a hash.
324
325 =end
326
327 sub hash (*%h) { return %h }
328
329
330 =begin
331
332 =item %set := set_from_array(@array)
333
334 Converts an array into a set by using the array elements as hash keys and
335 setting their corresponding value to 1, thus allowing cheap set membership
336 checks.
337
338 =end
339
340 sub set_from_array (@array) {
341     my %set;
342
343     for @array {
344         %set{$_} := 1;
345     }
346
347     return %set;
348 }
349
350
351 =begin
352
353 =back
354
355
356 =head2 Regular Expression Functions
357
358 These functions add more power to the basic regex matching capability,
359 including doing global matches and global substitutions.
360
361 =over 4
362
363 =item @matches := all_matches($regex, $text)
364
365 =end
366
367 sub all_matches($regex, $text) {
368     my @matches;
369
370     my  $match := $text ~~ $regex;
371     while $match {
372         @matches.push($match);
373         $match := $match.CURSOR.parse($text, :rule($regex), :c($match.to));
374     }
375
376     return @matches;
377 }
378
379
380 =begin
381
382 =item $edited := subst($original, $regex, $replacement)
383
384 Substitute all matches of the C<$regex> in the C<$original> string with the
385 C<$replacement>, and return the edited string.  The C<$regex> must be a regex
386 object as returned by C</.../>.
387
388 The C<$replacement> may be either a simple string or a sub that will be called
389 with each match object in turn, and must return the proper replacement string
390 for that match.
391
392 =end
393
394 sub subst($original, $regex, $replacement) {
395     my @matches := all_matches($regex, $original);
396     my $edited  := pir::clone($original);
397     my $is_sub  := pir::isa($replacement, 'Sub');
398     my $offset  := 0;
399
400     for @matches -> $match {
401         my $replace_string := $is_sub ?? $replacement($match) !! $replacement;
402         my $replace_len    := pir::length($replace_string);
403         my $match_len      := $match.to - $match.from;
404         my $real_from      := $match.from + $offset;
405
406         Q:PIR{
407              $P0 = find_lex '$edited'
408              $S0 = $P0
409              $P1 = find_lex '$real_from'
410              $I0 = $P1
411              $P2 = find_lex '$match_len'
412              $I1 = $P2
413              $P3 = find_lex '$replace_string'
414              $S1 = $P3
415              substr $S0, $I0, $I1, $S1
416              $P0 = $S0
417         };
418
419         $offset := $offset - $match_len + $replace_len;
420     }
421
422     return $edited;
423 }
424
425
426 =begin
427
428 =back
429
430
431 =head2 I/O Functions
432
433 Basic stdio and file I/O functions.
434
435 =over 4
436
437 =item print('things', ' to ', 'print', ...)
438
439 Print a list of strings to standard output.
440
441 =end
442
443 sub print (*@strings) {
444     for @strings {
445         pir::print($_);
446     }
447 }
448
449
450 =begin
451
452 =item say('things', ' to ', 'say', ...)
453
454 Print a list of strings to standard output, followed by a newline.
455
456 =end
457
458 sub say (*@strings) {
459     print(|@strings, "\n");
460 }
461
462
463 =begin
464
465 =item $contents := slurp($filename)
466
467 Read the C<$contents> of a file as a single string.
468
469 =end
470
471 sub slurp ($filename) {
472     my $fh       := pir::open__Pss($filename, 'r');
473     my $contents := $fh.readall;
474     pir::close($fh);
475
476     return $contents;
477 }
478
479
480 =begin
481
482 =item spew($filename, $contents)
483
484 Write the string C<$contents> to a file.
485
486 =end
487
488 sub spew ($filename, $contents) {
489     my $fh := pir::open__Pss($filename, 'w');
490     $fh.print($contents);
491     pir::close($fh);
492 }
493
494
495 =begin
496
497 =item append($filename, $contents)
498
499 Append the string C<$contents> to a file.
500
501 =end
502
503 sub append ($filename, $contents) {
504     my $fh := pir::open__Pss($filename, 'a');
505     $fh.print($contents);
506     pir::close($fh);
507 }
508
509
510 =begin
511
512 =back
513
514
515 =head2 Filesystem and Path Functions
516
517 These functions provide convenient ways to interact with the file system,
518 user PATH, and similar operating system constructs.
519
520 =over 4
521
522 =item $path := fscat(@path_parts [, $filename])
523
524 Join C<@path_parts> and C<$filename> strings together with the appropriate
525 OS separator.  If no C<$filename> is supplied, C<fscat()> will I<not> add a
526 trailing slash (though slashes inside the C<@path_parts> will not be removed,
527 so don't do that).
528
529 =end
530
531 sub fscat(@path_parts, *@filename) {
532     pir::die('Only one filename allowed in fscat()')
533         if @filename > 1;
534
535     my $sep    := pir::getinterp__P()[6]<slash>;
536     my $joined := pir::join($sep, @path_parts);
537        $joined := $joined ~ $sep ~ @filename[0] if @filename;
538
539     return $joined;
540 }
541
542
543 =begin
544
545 =item $home := user_home_dir()
546
547 Determine the user's home directory in the proper platform-dependent manner.
548
549 =end
550
551 sub user_home_dir() {
552     my %env := pir::root_new__PP(< parrot Env >);
553     return (%env<HOMEDRIVE> // '') ~ %env<HOME>;
554 }
555
556
557 =begin
558
559 =item $found := path_exists($path);
560
561 Return a true value if the C<$path> exists on the filesystem, or a false
562 value if not.
563
564 =end
565
566 sub path_exists ($path) {
567     my @stat := pir::root_new__PP(< parrot OS >).stat($path);
568     return 1;
569
570     CATCH {
571         return 0;
572     }
573 }
574
575
576 =begin
577
578 =item $is_dir := is_dir($path);
579
580 Return a true value if the C<$path> exists on the filesystem and is a
581 directory, or a false value if not.
582
583 =end
584
585 sub is_dir($path) {
586     my @stat := pir::root_new__PP(< parrot OS >).stat($path);
587     return pir::stat__isi($path, 2);   # STAT_ISDIR
588
589     CATCH {
590         return 0;
591     }
592 }
593
594
595 =begin
596
597 =item $writable := test_dir_writable($directory_path)
598
599 Sadly there is no portable, guaranteed way to check if a directory is writable
600 (with create permission, on platforms that separate it) except to actually try
601 to create a file within it.  This function does just that, and then removes the
602 test file afterwards.
603
604 This function should only be considered helpful from a usability sense, allowing
605 the program to detect a likely failure case early, before wasting the user's
606 time.  In no circumstance should it be considered a security function; only
607 checking for errors on every real operation can avoid security holes due to
608 race conditions between test and action.
609
610 =end
611
612 sub test_dir_writable($dir) {
613     my $test_file := fscat([$dir], 'WrItAbLe.UtL');
614
615     pir::die("Test file '$test_file'\nthat should never exist already does.")
616         if path_exists($test_file);
617
618     try {
619        spew($test_file, "test_dir_writable() test file.\n");
620     };
621
622     if path_exists($test_file) {
623         pir::root_new__PP(< parrot OS >).rm($test_file);
624         return 1;
625     }
626     else {
627         return 0;
628     }
629 }
630
631
632 =begin
633
634 =item $binary_path := find_program($program)
635
636 Search C<%*ENVE<lt>PATHE<gt>> to find the full path for a given C<$program>.  If
637 the program is not found, C<find_program()> returns an empty path string,
638 which is false in boolean context.  Thus this is typically used in the
639 following way:
640
641     my $path := find_program($program);
642     if $path {
643         # Found it, run it with some options
644     }
645     else {
646         # Not found, try a different $program or fail
647     }
648
649 =end
650
651 sub find_program ($program) {
652     my $path_sep := pir::sysinfo__si(4) eq 'MSWin32' ?? ';' !! ':';
653     my %env      := pir::root_new__PP(< parrot Env >);
654     my @paths    := pir::split($path_sep, %env<PATH>);
655     my @exts     := pir::split($path_sep, %env<PATHEXT>);
656
657     @exts.unshift('');
658
659     for @paths -> $dir {
660         my $path := fscat([$dir], $program);
661
662         for @exts -> $ext {
663             my $pathext := "$path$ext";
664             return $pathext if path_exists($pathext);
665         }
666     }
667
668     return '';
669 }
670
671
672 =begin
673
674 =item mkpath($directory_path)
675
676 Basically an iterative C<mkdir()>, C<mkpath()> works its way down from the
677 top making directories as needed until an entire path has been created.
678
679 =end
680
681 sub mkpath ($path) {
682     my @path := pir::split('/', $path);
683     my $cur  := @path.shift;
684
685     for @path -> $dir {
686         $cur := fscat([$cur, $dir]);
687
688         unless path_exists($cur) {
689             pir::root_new__PP(< parrot OS >).mkdir($cur, 0o777);
690         }
691     }
692 }
693
694
695 =begin
696
697 =back
698
699
700 =head2 Program Spawning Functions
701
702 These functions provide several variations on the "spawn a child program
703 and wait for the results" theme.
704
705 =over 4
706
707 =item $status_code := run($command, $and, $args, ...)
708
709 Spawn the command with the given arguments as a new process; returns
710 the status code of the spawned process, which is equal the the result
711 of the waitpid system call, right bitshifted by 8.  Throws an exception
712 if the process could not be spawned at all.
713
714 =end
715
716 sub run (*@command_and_args) {
717     return pir::shr(pir::spawnw__iP(@command_and_args), 8);
718 }
719
720
721 =begin
722
723 =item $success := do_run($command, $and, $args, ...)
724
725 Print out the command and arguments, then spawn the command with the given
726 arguments as a new process; return 1 if the process exited successfully, or
727 0 if not.  Unlike C<run()> and C<qx()>, will I<not> throw an exception if
728 the process cannot be spawned.  Since this is a convenience function, it will
729 instead return 0 on spawn failure, just as if the child process had spawned
730 successfully but itself exited with failure.
731
732 =end
733
734 sub do_run (*@command_and_args) {
735     say(pir::join(' ', @command_and_args));
736
737     return pir::spawnw__iP(@command_and_args) ?? 0 !! 1;
738
739     CATCH {
740         return -1;
741     }
742 }
743
744
745 =begin
746
747 =item $output := qx($command, $and, $args, ...)
748
749 Spawn the command with the given arguments as a read only pipe;
750 return the output of the command as a single string.  Throws an
751 exception if the pipe cannot be opened.  Sets the caller's C<$!>
752 to the exit value of the child process.
753
754 B<WARNING>: Parrot currently implements the pipe open B<INSECURELY>!
755
756 =end
757
758 sub qx (*@command_and_args) {
759     my $cmd  := pir::join(' ', @command_and_args);
760     my $pipe := pir::open__Pss($cmd, 'rp');
761     pir::die("Unable to execute '$cmd'") unless $pipe;
762
763     $pipe.encoding('utf8');
764     my $output := $pipe.readall;
765     $pipe.close;
766
767     store_dynlex_safely('$!', $pipe.exit_status);
768
769     return $output;
770 }
771
772
773 =begin
774
775 =back
776
777
778 =head2 HLL Interop Functions
779
780 These functions allow code in other languages to be evaluated and the
781 results returned.
782
783 =over 4
784
785 =item $result := eval($source_code, $language)
786
787 Evaluate a string of C<$source_code> in a known Parrot C<$language>,
788 returning the C<$result> of executing the compiled code.
789
790 =end
791
792 sub eval ($source_code, $language) {
793     $language := pir::downcase($language);
794
795     pir::load_language($language);
796     my $compiler := pir::compreg__Ps($language);
797
798     return $compiler.compile($source_code)();
799 }
800
801
802 =begin
803
804 =head2 Deep Magic
805
806 These functions reach into the guts of NQP, PIR, or Parrot and shuffle them.
807 Use with care.
808
809 =over 4
810
811 =item store_dynlex_safely($var_name, $value)
812
813 Set a dynamic lexical ("contextual") variable named C<$var_name> to C<$value>
814 if such a variable has been declared in some calling scope, or do nothing if
815 the variable has not been declared.  This allows library code to
816 unconditionally set well-known contextual variables such as C<$!> and C<%*VM>
817 without worrying about an exception being thrown because the calling code
818 doesn't care about the value of that contextual and thus has not declared it.
819
820 =end
821
822 sub store_dynlex_safely($var_name, $value) {
823     pir::store_dynamic_lex__vsP($var_name, $value)
824         unless pir::isnull(pir::find_dynamic_lex($var_name));
825 }
826
827
828 =begin
829
830 =back
831
832
833 =head2 Global Variables
834
835 Standard variables available in Perl 6, variously known as "core globals",
836 "setting contextuals", and "predefined dynamic lexicals".
837
838 =over 4
839
840 =item $*EXECUTABLE_NAME
841
842 Full path of interpreter executable
843
844 =item $*PROGRAM_NAME
845
846 Name of running program (argv[0] in C)
847
848 =item $*OSNAME
849
850 Operating system generic name
851
852 =item $*OSVER
853
854 Operating system version
855
856 =item @*ARGS
857
858 Program's command line arguments (including options, which are NOT parsed)
859
860 =item %*ENV
861
862 Process-wide environment variables
863
864 =item %*VM
865
866 Parrot configuration (in the %*VM<config> subhash)
867
868 =item $*OS
869
870 Parrot operating system control object
871
872 =back
873
874 =end
875
876 INIT {
877     # Needed for rest of code to work
878     pir::load_bytecode('config.pbc');
879     pir::load_bytecode('P6Regex.pbc');
880
881     my $interp  := pir::getinterp__P();
882     my @argv    := $interp[2];   # IGLOBALS_ARGV_LIST
883     my $config  := $interp[6];   # IGLOBALS_CONFIG_HASH
884
885     # Only fill the config portion of %*VM for now
886     my %vm;
887     %vm<config> := $config;
888     store_dynlex_safely('%*VM', %vm);
889
890     # Handle argv properly even for -e one-liners
891     @argv.unshift('<anonymous>')   unless @argv;
892     store_dynlex_safely('$*PROGRAM_NAME', @argv.shift);
893     store_dynlex_safely('@*ARGS',         @argv);
894
895     # INTERPINFO_EXECUTABLE_FULLNAME
896     store_dynlex_safely('$*EXECUTABLE_NAME', pir::interpinfo__si(19));
897
898     # SYSINFO_PARROT_OS / SYSINFO_PARROT_VERSION
899     store_dynlex_safely('$*OSNAME', pir::sysinfo__si(4));
900     store_dynlex_safely('%*OSVER',  pir::sysinfo__si(5));
901
902     # Magic objects
903     store_dynlex_safely('%*ENV', pir::root_new__PP(< parrot Env >));
904     store_dynlex_safely('$*OS',  pir::root_new__PP(< parrot OS  >));
905 }
906
907
908 =begin
909
910 =head2 Plumage Specific Functions
911
912 While the previous functions are likely usable by a great variety of NQP
913 programs, these functions are likely only directly useful to Plumage-related
914 programs.
915
916 =over 4
917
918 =item $replaced := replace_config_strings($original)
919
920 Replace all config strings (marked as C<#config_var_name#>) within the
921 C<$original> string with replacements found in one of the global
922 configuration hashes. These are searched in the following order:
923
924     %*CONF        # Plumage configuration
925     %*VM<config>  # VM (Parrot) configuration
926     %*BIN         # Locations of system programs
927     %*ENV         # Program environment
928
929 If no replacement is found in any of the above, an empty string is used
930 instead.
931
932 C<replace_config_strings()> will do a full pass replacing all config strings
933 within the original, and then loop back to the beginning and try again with
934 the updated string.  This continues until the string stops changing.  This
935 allows configuration settings to be defined in terms of other configuration
936 settings.
937
938 B<NOTE> that this function is currently B<NOT> protected from an infinite loop
939 caused by bad config settings, nor is it protected from nefarious inputs
940 producing unintended expansions.
941
942 =end
943
944 sub replace_config_strings ($original) {
945     my $new := $original;
946
947     repeat {
948         $original := $new;
949         $new      := subst($original, /\#<ident>\#/, config_value);
950     }
951     while $new ne $original;
952
953     return $new;
954 }
955
956 sub config_value ($match) {
957     my $key    := $match<ident>;
958     my $config := %*CONF{$key}
959                || %*VM<config>{$key}
960                || %*BIN{$key}
961                || %*ENV{$key}
962                || '';
963
964     return $config;
965 }
966
967
968 =begin
969
970 =back
971
972 =end