1. # Takes a foreign code object and tries to make it feel somewhat like a Perl
  2. # 6 one. Note that it doesn't have signature information we can know about.
  3. my class ForeignCode does Callable { # declared in BOOTSTRAP
  4. # class ForeignCode
  5. # has Code $!do; # Code object we delegate to
  6. method arity() { self.signature.arity }
  7. method count() { self.signature.count }
  8. method signature(ForeignCode:D:) { (sub (|) { }).signature }
  9. method name() { (nqp::can($!do, 'name') ?? $!do.name !! nqp::getcodename($!do)) || '<anon>' }
  10. multi method gist(ForeignCode:D:) { self.name }
  11. multi method Str(ForeignCode:D:) { self.name }
  12. }
  13. my class Rakudo::Internals::EvalIdSource {
  14. my Int $count = 0;
  15. my Lock $lock = Lock.new;
  16. method next-id() {
  17. $lock.protect: { $count++ }
  18. }
  19. }
  20. proto sub EVAL($code is copy where Blob|Cool|Callable, Str() :$lang = 'perl6', PseudoStash :$context, *%n) {
  21. die "EVAL() in Perl 6 is intended to evaluate strings, did you mean 'try'?"
  22. if nqp::istype($code,Callable);
  23. # First look in compiler registry.
  24. my $compiler := nqp::getcomp($lang);
  25. if nqp::isnull($compiler) {
  26. # Try a multi-dispatch to another EVAL candidate. If that fails to
  27. # dispatch, map it to a typed exception.
  28. CATCH {
  29. when X::Multi::NoMatch {
  30. X::Eval::NoSuchLang.new(:$lang).throw
  31. }
  32. }
  33. return {*};
  34. }
  35. $code = nqp::istype($code,Blob) ?? $code.decode(
  36. $compiler.cli-options<encoding> // 'utf8'
  37. ) !! $code.Str;
  38. $context := CALLER:: unless nqp::defined($context);
  39. my $eval_ctx := nqp::getattr(nqp::decont($context), PseudoStash, '$!ctx');
  40. my $?FILES := 'EVAL_' ~ Rakudo::Internals::EvalIdSource.next-id;
  41. my \mast_frames := nqp::hash();
  42. my $*CTXSAVE; # make sure we don't use the EVAL's MAIN context for the
  43. # currently compiling compilation unit
  44. my $LANG := $context<%?LANG> || CALLERS::<%?LANG>;
  45. my $compiled := $compiler.compile:
  46. $code,
  47. :outer_ctx($eval_ctx),
  48. :global(GLOBAL),
  49. :mast_frames(mast_frames),
  50. |(:optimize($_) with nqp::getcomp('perl6').cli-options<optimize>),
  51. |(%(:grammar($LANG<MAIN>), :actions($LANG<MAIN-actions>)) if $LANG);
  52. $*W.add_additional_frames(mast_frames)
  53. if $*W and $*W.is_precompilation_mode; # we are still compiling
  54. nqp::forceouterctx(nqp::getattr($compiled, ForeignCode, '$!do'), $eval_ctx);
  55. $compiled();
  56. }
  57. multi sub EVAL($code, Str :$lang where { ($lang // '') eq 'Perl5' }, PseudoStash :$context) {
  58. my $eval_ctx := nqp::getattr(nqp::decont($context // CALLER::), PseudoStash, '$!ctx');
  59. my $?FILES := 'EVAL_' ~ (state $no)++;
  60. state $p5;
  61. unless $p5 {
  62. {
  63. my $compunit := $*REPO.need(CompUnit::DependencySpecification.new(:short-name<Inline::Perl5>));
  64. GLOBAL.WHO.merge-symbols($compunit.handle.globalish-package);
  65. CATCH {
  66. #X::Eval::NoSuchLang.new(:$lang).throw;
  67. note $_;
  68. }
  69. }
  70. $p5 = ::("Inline::Perl5").default_perl5;
  71. }
  72. $p5.run: nqp::istype($code,Blob)
  73. ?? Blob.new($code).decode('utf8-c8')
  74. !! $code.Str;
  75. }
  76. proto sub EVALFILE($, *%) {*}
  77. multi sub EVALFILE($filename, :$lang = 'perl6') {
  78. EVAL slurp(:bin, $filename), :$lang, :context(CALLER::);
  79. }