ruby-perl 0.99.15j

data/lib/perl/ext/string.rb

@@ -0,0 +1,10 @@
+require 'perl/value/scalar'
+
+class String
+  #
+  # Returns a pointer suitable for passing to Perl.
+  #
+  def to_perl
+    Perl::Value::Scalar.to_perl(self)
+  end
+end

data/lib/perl/ffi_lib.rb

@@ -0,0 +1,65 @@
+module Perl
+  module FFILib
+    def self.included(klass)
+      klass.instance_eval do
+        require 'perl/internal'
+        extend FFI::Library
+
+        klass.ffi_lib '/System/Library/Perl/5.10.0/darwin-thread-multi-2level/CORE/libperl.dylib'
+
+        # PERL_SYS_INIT3()
+        attach_function 'Perl_sys_init3', [:int, :pointer, :pointer], :void
+        # PERL_SYS_TERM()
+        attach_function 'Perl_sys_term', [], :void
+
+        klass.attach_function 'perl_alloc', [], :pointer
+        attach_function 'perl_construct', [:pointer], :void
+        # PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
+        attach_function 'perl_parse', [:pointer, :pointer, :int, :pointer, :pointer], :void
+        attach_function 'perl_run', [:pointer], :void
+        attach_function 'perl_destruct', [:pointer], :void
+        attach_function 'perl_free', [:pointer], :void
+
+        # eval_pv()
+        attach_function 'Perl_eval_pv', [:pointer, :string, :int], :pointer
+        # call_pv()
+        attach_function 'Perl_call_pv', [:pointer, :string, :int], :int
+        # call_sv()
+        attach_function 'Perl_call_sv', [:pointer, :pointer, :int], :int
+
+        # ENTER()
+        attach_function 'Perl_push_scope', [:pointer], :void
+        # SAVETMPS()
+        attach_function 'Perl_save_int', [:pointer, :pointer], :void
+        # FREETMPS()
+        attach_function 'Perl_free_tmps', [:pointer], :void
+        # LEAVE()
+        attach_function 'Perl_pop_scope', [:pointer], :void
+        # PUSHMARK()
+        attach_function 'Perl_markstack_grow', [:pointer], :void
+
+        # newSV()
+        attach_function 'Perl_newSVpv', [:pointer, :string, :int], :pointer
+
+        attach_function 'Perl_newRV_noinc', [:pointer, :pointer], :pointer
+        attach_function 'Perl_sv_2mortal', [:pointer, :pointer], :pointer
+
+        attach_function 'Perl_newHV', [:pointer], :pointer
+        # hv_store()
+        attach_function 'Perl_hv_common_key_len', [:pointer, :pointer, :string, :int32, :int, :pointer, :uint32], :pointer
+
+        attach_variable 'PL_curinterp', :pointer
+
+        #
+        # Returns a reference to internal information on the current
+        # interpreter. Much of the public Perl API is in fact a thin
+        # wrapper over data contained in here. A lot of damage can be
+        # done my manipulating it incorrectly, so be careful.
+        #
+        def curinterp
+          Perl::Internal.new(Perl.PL_curinterp)
+        end
+      end
+    end
+  end
+end

data/lib/perl/internal.rb

@@ -0,0 +1,73 @@
+module Perl
+  class Internal < FFI::Struct
+    class Stat < FFI::Struct
+      size = 144
+      layout  :a, :pointer
+    end
+
+    class Tms < FFI::Struct
+      size = 32
+      layout  :a, :pointer
+    end
+
+    class Jmpenv < FFI::Struct
+      size = 168
+      layout  :a, :pointer
+    end
+
+    layout  :Istack_sp,         :pointer,
+            :Iopsave,           :pointer,
+            :Icurpad,           :pointer,
+            :Istack_base,       :pointer,
+            :Istack_max,        :pointer,
+            :Iscopestack,       :pointer,
+            :Iscopestack_ix,    :int32,
+            :Iscopestack_max,   :int32,
+            :Isavestack,        :pointer,
+            :Isavestack_ix,     :int32,
+            :Isavestack_max,    :int32,
+            :Itmps_stack,       :pointer,
+            :Itmps_ix,          :int32,
+            :Itmps_floor,       :int32,
+            :Itmps_max,         :int32,
+            :Imodcount,         :int32,
+            :Imarkstack,        :pointer,
+            :Imarkstack_ptr,    :pointer,
+            :Imarkstack_max,    :pointer,
+            :ISv,               :pointer,
+            :IXpv,              :pointer,
+            :Ina,               :int,
+            :Istatbuf,          Stat,           # FIXME that's just wrong
+            :Istatcache,        Stat,     288,  # FIXME that's just wrong
+            :Istatgv,           :pointer, 432,
+            :Istatname,         :pointer,
+            :Itimesbuf,         Tms,            # FIXME that's just wrong
+            :Icurpm,            :pointer, 480,
+            :Irs,               :pointer,
+            :Ilast_in_gv,       :pointer,
+            :Iofs_sv,           :pointer,
+            :Idefoutgv,         :pointer,
+            :Ichopset,          :string,
+            :Iformtarget,       :pointer,
+            :Ibodytarget,       :pointer,
+            :Itoptarget,        :pointer,
+            :Idefstash,         :pointer,
+            :Icurstash,         :pointer,
+            :Irestartop,        :pointer,
+            :Icurcop,           :pointer,
+            :Icurstack,         :pointer,
+            :Icurstackinfo,     :pointer,
+            :Imainstack,        :pointer,
+            :Itop_env,          :pointer,
+            :Istart_env,        Jmpenv,         # FIXME that's just wrong
+            :Ierrors,           :pointer, 784,
+            :Ihv_fetch_ent_mh,  :pointer,
+            :Ilastgotoprobe,    :pointer,
+            :Isortcop,          :pointer,
+            :Isortstash,        :pointer,
+            :Ifirstgv,          :pointer,
+            :Isecondgv,         :pointer,
+            # TODO more stuff here
+            :Iexit_flags,       :uint8,   1245
+  end
+end

data/lib/perl/interpreter.rb

@@ -0,0 +1,89 @@
+require 'perl'
+require 'perl/common'
+require 'perl/stack'
+
+module Perl
+  class Interpreter
+    include Perl::Common
+
+    G_SCALAR  = 0
+    G_ARRAY   = 1
+    G_DISCARD = 2
+    G_EVAL    = 4
+    G_NOARGS  = 8
+    G_KEEPERR = 16
+    G_NODEBUG = 32
+    G_METHOD  = 64
+    G_VOID    = 128
+
+    def initialize
+      start
+    end
+
+    def eval(str=nil, &block)
+      return Perl.Perl_eval_pv(Perl.PL_curinterp, str, 1) if str
+
+      if block_given?
+        yield(Statement.new)
+      end
+    end
+    alias_method :run, :eval
+
+    def load(filename)
+      file = File.read(filename)
+      eval(file)
+    end
+
+    def call(method_name, args, return_type)
+      Perl::Stack.function_stack(args) do |stack|
+        rc = do_call(method_name, options_for_call(args, return_type))
+        ret = handle_return(rc, return_type, stack)
+
+        if return_type == :void
+          return nil
+        else
+          if block_given?
+            return yield(ret)
+          else
+            ret.freeze!
+            return ret
+          end
+        end
+      end
+    end
+
+  protected
+    def do_call(method_name, options)
+      method = method_name.is_a?(String) ? :Perl_call_pv : :Perl_call_sv
+      Perl.send(method, Perl.PL_curinterp, method_name, options)
+    end
+
+    # XXX should we have G_DISCARD ?
+    def options_for_call(args, return_type)
+      options = G_EVAL
+      options |= G_NOARGS if args.empty?
+
+      case return_type
+      when :list
+        options |= G_ARRAY
+      when :scalar
+        options |= G_SCALAR
+      when :void
+        options |= G_VOID
+      else
+        raise "Unknown return type #{return_type}"
+      end
+    end
+
+    def handle_return(ret, return_type, stack)
+      case return_type
+      when :list
+      when :scalar
+        raise "Unexpected ret=#{ret}" unless ret == 1
+        Perl::Value::Scalar.new(stack.pop_scalar)
+      when :void
+        raise "Unexpected ret=#{ret}" unless ret == 0
+      end
+    end
+  end
+end

data/lib/perl/rack.rb

@@ -0,0 +1,45 @@
+require 'perl'
+require 'perl/interpreter'
+
+module Perl
+  class Rack
+    def initialize(filename)
+      @interpreter = Perl::Interpreter.new
+      @app = @interpreter.load(filename)
+    end
+
+    def call(env)
+      @interpreter.call(@app, {:ref => clean_env(env)}, :scalar) do |ret|
+        value = ret.deref.value # Array
+
+        status = value[0].value
+
+        v1 = value[1].deref.value
+        headers = Hash[*v1.map { |v| v.value }]
+
+        body = value[2].deref.value.map { |v| v.value }
+
+        [status, headers, body]
+      end
+    rescue => e
+      puts "e: #{e.inspect}\n#{e.backtrace.join("\n")}"
+    end
+
+    def clean_env(hash)
+      ret = hash.dup
+      if defined?(PhusionPassenger)
+        ret = ret.reject do |k,v|
+          v.is_a?(PhusionPassenger::Utils::RewindableInput)
+        end
+      end
+      ret.tap do |h|
+        ["async.close"].each do |k|
+          if h.has_key?(k)
+            puts "Cannot handle env['#{k}'] (#{k} => #{h[k].inspect}), skipping"
+            h.delete("async.close")
+          end
+        end
+      end
+    end
+  end
+end

data/lib/perl/shell.rb

@@ -0,0 +1,28 @@
+require 'perl'
+require 'perl/common'
+
+module Perl
+  class Shell
+    include Perl::Common
+
+    class << self
+      def run
+        new.run
+      end
+    end
+
+    def initialize
+      Perl.setup
+
+      @my_perl = Perl.perl_alloc
+      Perl.perl_construct(@my_perl)
+    end
+
+    def run
+      argc, argv = argv_to_ffi
+
+      Perl.perl_parse(@my_perl, nil, argc, argv, nil)
+      Perl.perl_run(@my_perl)
+    end
+  end
+end

data/lib/perl/stack.rb

@@ -0,0 +1,99 @@
+module Perl; class Stack; end; end
+
+require 'perl/stack/function'
+
+module Perl
+  class Stack
+    class << self
+      def function_stack(args, &block)
+        Function.new(self.new, args, &block)
+      end
+    end
+
+    def initialize
+      @sp = nil
+    end
+
+    def dSP
+      @sp = Perl.curinterp[:Istack_sp].tap { |sp| trace("dSP: @sp=#{sp}") }
+    end
+    alias_method :spagain, :dSP
+
+    def enter
+      Perl.Perl_push_scope(Perl.PL_curinterp)
+    end
+
+    def savetmps
+      curinterp = Perl.curinterp
+      trace("savetmps: curinterp=#{curinterp.to_ptr.inspect}")
+
+      trace("savetmps: tmps_floor=#{curinterp[:Itmps_floor].inspect}")
+      addr = Perl.PL_curinterp + curinterp.offset_of(:Itmps_floor)
+      trace("addr=#{addr.inspect}")
+
+      Perl.Perl_save_int(Perl.PL_curinterp, addr)
+      trace("savetmps: tmps_floor now #{curinterp[:Itmps_floor].inspect}")
+
+      trace("curinterp[:Itmps_ix] was #{curinterp[:Itmps_ix].inspect}")
+      curinterp[:Itmps_floor] = curinterp[:Itmps_ix]
+      trace("savetmps: tmps_floor now #{curinterp[:Itmps_floor].inspect}")
+    end
+
+    def pushmark
+      trace("pushmark: @sp=#{@sp}")
+
+      curinterp = Perl.curinterp
+      trace("curinterp[:Imarkstack_ptr] was #{curinterp[:Imarkstack_ptr].inspect} == #{curinterp[:Imarkstack_max].inspect}")
+      curinterp[:Imarkstack_ptr] += FFI.type_size(:int32)
+      trace("curinterp[:Imarkstack_ptr] now #{curinterp[:Imarkstack_ptr].inspect}")
+      if curinterp[:Imarkstack_ptr] == curinterp[:Imarkstack_max]
+        Perl.Perl_markstack_grow(Perl.PL_curinterp)
+      end
+      trace("curinterp[:Imarkstack_ptr] <= #{@sp.address - curinterp[:Istack_base].address}")
+      curinterp[:Imarkstack_ptr].put_pointer(0, @sp.address - curinterp[:Istack_base].address)
+      trace("curinterp[:Imarkstack_ptr] now #{curinterp[:Imarkstack_ptr].inspect}")
+    end
+
+    def push(sv)
+      trace("push: @sp=#{@sp}")
+      @sp += FFI.type_size(:pointer)
+      @sp.put_pointer(0, sv)
+      trace("push: is now @sp=#{@sp}")
+    end
+
+    def putback
+      trace("putback: @sp=#{@sp}")
+
+      curinterp = Perl.curinterp
+      curinterp[:Istack_sp] = @sp
+    end
+
+    def pops
+      trace("pops: @sp=#{@sp}")
+
+      ret = @sp.get_pointer(0)
+      @sp = FFI::Pointer.new(@sp.address - FFI.type_size(:pointer))
+      trace("pops: now @sp=#{@sp}")
+      ret
+    end
+
+    def freetmps
+      curinterp = Perl.curinterp
+      trace("#{curinterp[:Itmps_ix].inspect} > #{curinterp[:Itmps_floor].inspect}")
+
+      if curinterp[:Itmps_ix] > curinterp[:Itmps_floor]
+        Perl.Perl_free_tmps(Perl.PL_curinterp)
+        trace("#{curinterp[:Itmps_ix].inspect} > #{curinterp[:Itmps_floor].inspect}")
+      end
+    end
+
+    def leave
+      Perl.Perl_pop_scope(Perl.PL_curinterp)
+    end
+
+  protected
+    def trace(msg)
+      $stderr.puts(msg) if false
+    end
+  end
+end

data/lib/perl/stack/function.rb

@@ -0,0 +1,67 @@
+class Perl::Stack::Function
+  def initialize(stack, args, &block)
+    @stack = stack
+    @stack.dSP
+    @stack.enter
+    @stack.savetmps
+
+    case args
+    when nil
+      # nothing
+    when Hash
+      init_with_hash(args)
+    else
+      init_with_array(Array(args))
+    end
+
+    yield(self)
+  ensure
+    if @stack
+      @stack.freetmps
+      @stack.leave
+    end
+  end
+
+  def push(value)
+    value = Perl.Perl_sv_2mortal(Perl.PL_curinterp, value)
+    @stack.push(value)
+  end
+
+  def pop_scalar
+    @stack.spagain
+    return @stack.pops
+  ensure
+    @stack.putback
+  end
+
+protected
+  def init_with_hash(args)
+    return unless args.any?
+
+    begin
+      @stack.pushmark
+      args.each_pair do |type, arg|
+        value = arg.to_perl
+        value = Perl.Perl_newRV_noinc(Perl.PL_curinterp, value) if type == :ref
+        push(value)
+      end
+    ensure
+      @stack.putback
+    end
+  end
+
+  def init_with_array(args)
+    return unless args.any?
+
+    args = Array(args)
+    begin
+      @stack.pushmark
+      args.each do |arg|
+        value = arg.to_perl
+        push(value)
+      end
+    ensure
+      @stack.putback
+    end
+  end
+end