Ruby.pm

package Inline::Ruby;

use strict;
use warnings;

use Carp;
require Inline;
require DynaLoader;
require Exporter;
use vars qw(@ISA $VERSION @EXPORT_OK);

$VERSION = '0.07';
@ISA = qw(Inline DynaLoader Exporter);
@EXPORT_OK = qw(rb_eval
		rb_call_function
		rb_iter
		rb_call_class_method
		rb_new_object
		rb_call_instance_method
		rb_bind_class
		rb_bind_func
	       );

# Prevent Inline's import from complaining
sub import {
    Inline::Ruby->export_to_level(1, @_);
}

sub dl_load_flags { 0x01 }
Inline::Ruby->bootstrap($VERSION);

use constant _GET_NAMESPACE => <<EOF;
Proc.new {
    ns = { 'classes' => {}, 'modules' => {}, 'functions' => {} }
    ObjectSpace.each_object(Class) do |x|
        ns['classes'][x.name] = 1
    end
    ObjectSpace.each_object(Module) do |x|
        ns['modules'][x.name] = 1
    end
    Object.private_instance_methods.each do |x|
        ns['functions'][x] = 1
    end
    ns
}.call
EOF

#==============================================================================
# Register Ruby.pm as a valid Inline language
#==============================================================================
sub register {
    return {
            language => 'Ruby',
            aliases => ['rb', 'ruby', 'RUBY'],
            type => 'interpreted',
            suffix => 'rbdat',
           };
}

#==============================================================================
# Validate the Ruby config options
#==============================================================================
sub validate {
    my $o = shift;

    $o->{ILSM} ||= {};
    $o->{ILSM}{FILTERS} ||= [];
    $o->{ILSM}{AUTO_INCLUDE} ||= {};
    $o->{ILSM}{built} ||= 0;
    $o->{ILSM}{loaded} ||= 0;

    $o->{ILSM}{bindto} = [qw(classes modules functions)];
    $o->{ILSM}{ITER} ||= 'iter';

    while (@_) {
	my ($key, $value) = (shift, shift);

	if ($key eq 'REGEX' or $key eq 'REGEXP') {
	    $o->{ILSM}{regexp} = qr/$value/;
	}
	elsif ($key eq 'BIND_TYPE' or $key eq 'BIND_TYPES') {
	    $o->_add_list($o->{ILSM}, 'bindto', $value, []);
	}
	elsif ($key eq 'ITER') {
	    $o->{ILSM}{$key} = $value;
	}
	elsif ($key eq 'FILTERS') {
	    next if $value eq '1' or $value eq '0'; # ignore ENABLE, DISABLE
	    $value = [$value] unless ref($value) eq 'ARRAY';
	    my %filters;
	    for my $val (@$value) {
		if (ref($val) eq 'CODE') {
		    $o->_add_list($o->{ILSM}, $key, $val, []);
	        }
		else {
		    eval { require Inline::Filters };
		    croak "'FILTERS' option requires Inline::Filters to be installed."
		      if $@;
		    %filters = Inline::Filters::get_filters($o->{API}{language})
		      unless keys %filters;
		    if (defined $filters{$val}) {
			my $filter = Inline::Filters->new($val,
							  $filters{$val});
			$o->_add_list($o->{ILSM}, $key, $filter, []);
		    }
		    else {
			croak "Invalid filter $val specified.";
		    }
		}
	    }
	}
	else {
	    croak "$key is not a valid config option for Ruby";
	}
	next;
    }
}

sub _usage_validate {
    return "Invalid value for config option $_[0]";
}

sub _add_list {
    my $o = shift;
    my ($ref, $key, $value, $default) = @_;
    $value = [$value] unless ref $value;
    croak _usage_validate($key) unless ref($value) eq 'ARRAY';
    foreach my $val (@$value) {
	if (defined $val) {
	    push @{$ref->{$key}}, $val;
	}
	else {
	    $ref->{$key} = $default;
	}
    }
}

=begin Removed

sub _add_string {
    my $o = shift;
    my ($ref, $key, $value, $default) = @_;
    $value = [$value] unless ref $value;
    croak _usage_validate($key) unless ref($value) eq 'ARRAY';
    foreach my $val (@$value) {
	if (defined $val) {
	    $ref->{$key} .= " $val";
	}
	else {
	    $ref->{$key} = $default;
	}
    }
}

sub _add_text {
    my $o = shift;
    my ($ref, $key, $value, $default) = @_;
    $value = [$value] unless ref $value;
    croak _usage_validate($key) unless ref($value) eq 'ARRAY';
    for my $val (@$value) {
	if (defined $val) {
	    chomp($val);
	    $ref->{$key} .= $val . "\n";
	}
	else {
	    $ref->{$key} = $default;
	}
    }
}

=end Removed

=cut


#==========================================================================
# Print a short information section if PRINT_INFO is enabled.
#==========================================================================
sub info {
    my $o = shift;
    my $info =  "";

    $o->build unless $o->{ILSM}{built};

    my @functions = @{$o->{ILSM}{namespace}{functions}||[]};
    $info .= "The following Ruby functions have been bound to Perl:\n"
      if @functions;
    for my $function (sort @functions) {
	$info .= "\tdef $function()\n";
    }
    my %classes = %{$o->{ILSM}{namespace}{classes}||{}};
    $info .= "The following Ruby classes have been bound to Perl:\n";
    my $i = ' ' x 4;
    for my $class (sort keys %classes) {
	$info .= "${i}class $class\n";
	$i .= $i;
	for my $method (sort @{$classes{$class}{imethods}}) {
	    next unless $method =~ /^\w+$/;
	    $info .= "${i}def $method(...)\n";
	}
	for my $method (sort @{$classes{$class}{methods}}) {
	    next unless $method =~ /^\w+$/;
	    $info .= "${i}def $class.$method(...)\n";
	}
    }

    return $info;
}

sub _eval_support_code {
    rb_eval(<<'END');
def inline_ruby_class_grokker(*classes)
    if classes == []
	ObjectSpace.each_object(Class) do |x|
	    yield ['classes', x.name]
	end
	ObjectSpace.each_object(Module) do |x|
	    yield ['modules', x.name]
	end
	Kernel.methods.each do |x|
	    yield ['functions', x]
	end
    else
	classes.each do |k|
	    n = {}
	    begin
		n['methods'] = eval "#{k}.methods"
		n['imethods'] = eval "#{k}.instance_methods"
	    rescue Exception
		p "Exception: " + $!
	    end
	    yield [k, n]
	end
    end
end
END
}

#==========================================================================
# Run the code, study the main namespace, and cache the results.
#==========================================================================
sub build {
    my $o = shift;
    return if $o->{ILSM}{built};

    # Filter the code
    $o->{ILSM}{code} = $o->filter(@{$o->{ILSM}{FILTERS}});

    # Get the namespace before & after evaluating the code:
    my $pre = rb_eval(_GET_NAMESPACE);
    rb_eval($o->{ILSM}{code});
    my $post = rb_eval(_GET_NAMESPACE);

    # Select those things which sprang into existence after running the code:
    my @skip_clas = qw(PerlException PerlProc);
    my @skip_func = qw();
    delete @{ $post->{classes} }{@skip_clas, keys(%{$pre->{classes}})};
    delete @{ $post->{functions} }{@skip_func, keys(%{$pre->{functions}})};
    delete @{ $post->{modules} }{
        keys(%{$pre->{modules}}), keys(%{$post->{classes}})
    };

    # Filter the results according to the {bindto} and {REGEXP} selections:
    for my $type (qw(classes modules functions)) {
	if ($o->{ILSM}{bindto}) {
	    delete $post->{$type}
	      unless grep { $_ eq $type } @{$o->{ILSM}{bindto}};
	}
	if ($o->{ILSM}{regexp}) {
	    for my $k (keys %{$post->{$type}}) {
		delete $post->{$type}{$k} unless $k =~ $o->{ILSM}{regexp};
	    }
	}
    }

    # Get more details about the classes and modules.
    # FIXME! Is the quoting correct?
    my $classes_arg = join ', ', map { quotemeta $_ } keys %{$post->{classes}};
    my $c = rb_eval(<<EOF);
Proc.new {
    ns = {}
    classes = [$classes_arg]
    classes.each do |k|
        ns[k] = {}
        begin
            ns[k]['methods'] = eval "#{k}.methods"
            ns[k]['imethods'] = eval "#{k}.instance_methods"
        rescue Exception
            p "Exception: " + \$!
        end
    end
    ns
}.call
EOF

    my $modules_arg = join ', ', map { quotemeta $_ } keys %{$post->{modules}};
    my $m = rb_eval(<<EOF);
Proc.new {
    ns = {}
    classes = [$modules_arg]
    classes.each do |k|
        ns[k] = {}
        begin
            ns[k]['methods'] = eval "#{k}.methods"
            ns[k]['imethods'] = eval "#{k}.instance_methods"
        rescue Exception
            p "Exception: " + \$!
        end
    end
    ns
}.call
EOF

    # And the namespace is:
    my %namespace = (
	classes		=> { %$c, %$m },
	functions	=> [keys %{$post->{functions} || {}}],
    );

    if ((! @{$namespace{functions}})
            and (! %{$namespace{classes}}))
    {
        warn "No functions or classes found!";
    }

    # Cache the results
    require Inline::denter;
    my $namespace = Inline::denter->new->indent(
	*namespace => \%namespace,
	*filtered  => $o->{ILSM}{code},
	*itername  => $o->{ILSM}{ITER},
    );

    $o->mkpath("$o->{API}{install_lib}/auto/$o->{API}{modpname}");

    {
        open my $rbdat_fh, '>', $o->{API}{location}
            or croak "Inline::Ruby couldn't write parse information!";
        print {$rbdat_fh} $namespace;
        close($rbdat_fh);
    }

    $o->{ILSM}{namespace} = \%namespace;
    $o->{ILSM}{built}++;
}

sub _slurp
{
    my $filename = shift;

    open my $in, '<', $filename
        or croak "Cannot open '$filename' for slurping - $!";

    local $/;
    my $contents = <$in>;

    close($in);

    return $contents;
}

#==============================================================================
# Load the code, run it, and bind everything to Perl
#==============================================================================
sub load {
    my $o = shift;
    return if $o->{ILSM}{loaded};

    my $rbdat = _slurp($o->{API}{location});

    require Inline::denter;
    my %rbdat = Inline::denter->new->undent($rbdat);
    $o->{ILSM}{namespace} = $rbdat{namespace};
    $o->{ILSM}{code} = $rbdat{filtered};
    $o->{ILSM}{ITER} = $rbdat{itername};
    $o->{ILSM}{loaded}++;

    # Run it
    rb_eval($o->{ILSM}{code});

    # Bind it all
    for my $func (@{ $o->{ILSM}{namespace}{functions} || [] })
    {
        rb_bind_func("$o->{API}{pkg}::$func", $func);
    }
    for my $class (keys %{ $o->{ILSM}{namespace}{classes} || {} })
    {
        rb_bind_class("$o->{API}{pkg}::$class", $class, $o->{ILSM}{ITER},
            %{$o->{ILSM}{namespace}{classes}{$class}});
    }

    # Bind the global function 'iter':
    eval <<END;
sub $o->{API}{pkg}::$o->{ILSM}{ITER} {
    unshift \@_, undef;
    return &Inline::Ruby::rb_iter;
}
END
    croak $@ if $@;
}

#==============================================================================
# Wrap a Ruby function with a Perl sub which calls it.
#==============================================================================
sub rb_bind_func {
    my $perlfunc = shift;	# The fully-qualified Perl sub name to create
    my $function = shift;	# The fully-qualified Ruby sub name to wrap

    my $bind = <<END;
sub $perlfunc {
    unshift \@_, "$function";
    return &Inline::Ruby::rb_call_function;
}
END

    eval $bind;
    croak $@ if $@;
}

#==============================================================================
# Wrap a Ruby class in a Perl package. We wrap every method we know about,
# and we inherit from Inline::Ruby::Object so the Perverse Ruby Programmer
# can still create dynamic methods on-the-fly using its AUTOLOAD.
#==============================================================================

my %bound_pkgs;

sub rb_bind_class {
    my $pkg  	= shift;	# The perl class to use
    my $class	= shift;	# The ruby class to wrap
    my $iter	= shift;	# The name to use for 'iter'
    my %methods = @_;

    $pkg =~ s/\Amain:://;
    if (exists($bound_pkgs{$pkg}))
    {
        return;
    }
    $bound_pkgs{$pkg} = 1;

    my $bind = <<END;
package ${pkg};
\@${pkg}::ISA = qw(Inline::Ruby::Object);
sub new {	# ${class}::new
    splice \@_, 1, 0, "$class";
    return &Inline::Ruby::rb_new_object;
}
END
    $bind .= <<END if $iter;
sub $iter {
    return &Inline::Ruby::rb_iter;
}
END

    my %bound_methods;

    for my $method (@{$methods{methods}}) {
	next unless $method =~ /^\w+$/;
	next if $method eq 'new';	# handled specially
    next if $bound_methods{$method}++;
	$bind .= <<END;
sub $method {	# ${class}::${method}
    splice \@_, 1, 0, "$method";
    return &Inline::Ruby::rb_call_class_method;
}
END
    }
    for my $method (@{$methods{imethods}}) {
	next unless $method =~ /^\w+$/;
    next if $bound_methods{$method}++;
	$bind .= <<END;
sub $method {	# ${class}::${method}
    splice \@_, 1, 0, "$method";
    return &Inline::Ruby::rb_call_instance_method;
}
END
    }

    eval $bind;
    croak $@ if $@;
}

#==============================================================================
# Create a new instance of a Ruby object.
#==============================================================================
sub rb_new_object {
    return &Inline::Ruby::Object::new;
}

#==============================================================================
# We provide Inline::Ruby::Object as a base class for Ruby objects. It
# knows how to create, destroy, and call methods on objects.
#==============================================================================
package Inline::Ruby::Object;

sub new {
    my $pkg = shift;
    splice @_, 1, 0, 'new';
    return bless &Inline::Ruby::rb_call_class_method, ref($pkg) || $pkg;
}

sub AUTOLOAD {
    no strict;
    $AUTOLOAD =~ s|^.*::||;
    splice @_, 1, 0, $AUTOLOAD;
    return &Inline::Ruby::rb_call_instance_method;
}

#==============================================================================
# We provide Inline::Ruby::Exception as a class for Ruby exceptions. Creating
# an instance of it throws a Perl exception. You can call Ruby methods on the
# exception object to get more information about what went wrong.
#
# Don't create your own Inline::Ruby::Exception objects. This is intended to
# be created from XS.
#==============================================================================
package Inline::Ruby::Exception;
use overload '""' => \&to_str;

sub new {
    my ($cls, $obj) = @_;
    die bless $obj, ref($cls) || $cls;
}

sub to_str {
    $_[0]->inspect . "\n";
}

1;