view release on metacpan or  search on metacpan

lib/Emacs/EPL.pm  view on Meta::CPAN

BEGIN {
    # Set inlinable constants based on feature tests.
    local ($@);
    if (eval { require B; }) {
	if (defined (&B::SVf_IOK)) {
	    B->import (qw( SVf_IOK SVf_NOK ));
	    eval ('sub HAVE_B () { 1 }');
	}
	else {
	    eval ('sub HAVE_B () { 1 }');
	    eval ('sub SVf_IOK () { 0x10000 }');
	    eval ('sub SVf_NOK () { 0x20000 }');
	}
    }
    else {
	eval ('sub HAVE_B () { 0 }');
	if ($@) { eval ('sub HAVE_B { 0 }'); }
	eval ('sub SVf_IOK; sub SVf_NOK;');
    }
}

##################################
# Conversion of Perl data to Lisp.
##################################

# Tell whether a scalar is "really" an int, float, or string.
# The Elisp Reference Manual says that integers are 28 bits.
sub guess_lisp_type {
    if (HAVE_B()) {
	my $fl = B::svref_2object (\$_[0]) ->FLAGS;
	if (($fl & SVf_IOK) != 0) {
	    return ((($_[0] + 0x8000000) & ~0xfffffff) ? 'float' : 'integer');
	}
	elsif (($fl & SVf_NOK) != 0) {
	    return ('float');
	}
	else {
	    return ('string');
	}
    }
    else {
	if ($_[0] =~ m/^-?\d+$/) {
	    return ((($_[0] + 0x8000000) & ~0xfffffff) ? 'float' : 'integer');
	}
	elsif ($_[0] =~ m/^-?\d+(?:\.\d+)(?:e-?\d+)$/) {
	    return ('float');
	}
	else {
	    return ('string');
	}
    }
}

# print_stuff (CALLBACK, VALUE)
sub print_stuff {
    my $callback = shift;

    # Optimize obviously non-circular cases.
    if ($callback eq 'unref') {
	# XXX all other callbacks take a single arg.
	print( "(epl-cb-unref");
	print( " $_") for @{$_[0]};
	print( ")");
    }
    elsif (! (tied ($_[0]) || ref ($_[0]))) {
	print( "(epl-cb-$callback ");
	&print_recursive;
	print( ")");
    }
    else {
	print( "(epl-cb-$callback (let ((epl-x `");
	# Could make pos, fixup, and seen globals.
	local $$emacs {'pos'} = "epl-x";
	local $$emacs {'fixup'} = '';
	local $$emacs {'seen'};
	&print_recursive;
	print( "))$$emacs{'fixup'} epl-x))");
    }
}

# Given a reference, return its package (or undef if non-blessed),
# representation type, and unique identifier.
sub get_ref_info {
    # This is copied from Data::Dumper.
    return (overload::StrVal ($_[0]) =~ /^(?:(.*)\=)?([^=]*)\(([^\(]*)\)$/);
}

sub get_ref_id { return ((&get_ref_info) [2]); }
sub get_ref_types { return ((&get_ref_info) [0, 1]); }

# print_recursive(VALUE)
sub print_recursive {
    # Avoid unnecessary FETCH if tied.
    # Avoid unnecessary string copy.
    my ($ref);

    if (tied ($_[0])) {
	# This theoretically supports typed scalars.
	if (tied ($_[0]) ->can ("PRINT_AS_LISP")) {
	    tied ($_[0]) ->PRINT_AS_LISP;
	    return;
	}
	my $value = $_[0];
	$ref = \$value;
    }
    else {
	$ref = \$_[0];
    }
    if (ref ($$ref)) {
	my ($value) = @_;
	my ($id, $pos);

	$id = get_ref_id ($$ref);
	$pos = $emacs->{'seen'}->{$id};
	if (defined ($pos)) {
	    $emacs->{'fixup'}
		.= fixup ($emacs->{'pos'}, $pos);
	    print( "nil");
	}
	else {