Emacs - Redefine Perl's system primitives to work inside of Emacs

    perlmacs -w -MEmacs -e main -- --display :0.0 file.txt

    #! /usr/bin/perlmacs
    use Emacs;
    use Emacs::Lisp;
    setq { $mail_self_blind = t; };
    exit main ($0, "-q", @ARGV);

    $string = &read_string ("Prompt: ");

    (setq
     user-mail-address "gnaeus@perl.moc"
     mail-self-blind t
     mail-yank-prefix "> "
     )

    (put 'eval-expression 'disabled nil)

    (global-font-lock-mode 1 t)
    (set-face-background 'highlight "maroon")
    (set-face-background 'region "Sienna")

    #! /usr/local/bin/perlmacs

    use Emacs;
    use Emacs::Lisp;

    setq {
	$user_mail_address = 'gnaeus@perl.moc';
	$mail_self_blind = t;
	$mail_yank_prefix = '> ';
	$eval_expression{\*disabled} = undef;
    };

    &global_font_lock_mode(1, t);
    &set_face_background(\*highlight, "maroon");
    &set_face_background(\*region, "Sienna");

    exit main($0, "-q", @ARGV);

  This program is free software; you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation; either version 2 of the License, or
  (at your option) any later version.

  This program is distributed in the hope that it will be useful, but
  WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with this program; see the file COPYING.  If not, write to the
  Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston,
  MA 02111-1307  USA

# Emacs.pm - redefine Perl's system primitives to work inside of Emacs.

package Emacs;

use 5.004;  # tied handles

use Emacs::Lisp ();
use Carp ();
use Tie::Handle ();
use Exporter ();

use strict;
use vars qw ( $VERSION @ISA $stuff_tied $old_warner @EXPORT );
use vars qw ( *REAL_STDIN *REAL_STDOUT *REAL_STDERR $real_pid );

$VERSION = '1.02';

@EXPORT = ('main', 'exit');
# XXX also need to redefine `open' to use Emacs locking.
# To think about: fork, exec, umask, Cwd.pm stuff, sysopen, kill
# (detect our pid or emacs's), chroot, alarm, ....

sub import {
    if (scalar (@_) == 1) {
	tie_stuff ();
    }
    for (my $i = 1; $i < scalar (@_); $i++) {
	if ($_[$i] eq ':tie') {
	    tie_stuff ();
	}
	else {
	    next;
	}
	splice (@_, $i, 1);
    }
    local @ISA = ('Exporter');
    Emacs->export_to_level (1, @_);
}

sub tie_stuff {
    return if $stuff_tied;

    if (defined (fileno (STDIN)) && ! defined (fileno (REAL_STDIN))) {
	open (REAL_STDIN, "<&=" . fileno (STDIN));
    }
    tie (*STDIN, 'Emacs::Minibuffer');

    if (defined (fileno (STDOUT)) && ! defined (fileno (REAL_STDOUT))) {
	open (REAL_STDOUT, ">&=" . fileno (STDOUT));
    }
    *::standard_output = *::standard_output;  # Avoid warnings.
    tie (*STDOUT, 'Emacs::Stream', \*::standard_output);

    if (defined (fileno (STDERR)) && ! defined (fileno (REAL_STDERR))) {
	open (REAL_STDERR, ">&=" . fileno (STDERR));
    }
    tie (*STDERR, 'Emacs::Minibuffer');

    $old_warner = $SIG{'__WARN__'};
    $SIG{'__WARN__'} = 'Emacs::SIG__WARN__';

    tie (%ENV, 'Emacs::ENV');
    tie (%SIG, 'Emacs::SIG');

    if (! defined ($real_pid)) {
	$real_pid = $$;
    }
    tie ($$, 'Emacs::PID');

    $stuff_tied = 1;
}

sub cleanup {
    return if ! $stuff_tied;

    untie ($$);
    untie (%SIG) if ref (tied (%SIG)) eq 'Emacs::SIG';
    untie (%ENV) if ref (tied (%ENV)) eq 'Emacs::ENV';

    $SIG{'__WARN__'} = $old_warner if $SIG{'__WARN__'} eq 'Emacs::SIG__WARN__';

    untie (*STDERR) if ref (tied (*STDERR)) eq 'Emacs::Minibuffer';
    untie (*STDOUT) if ref (tied (*STDOUT)) eq 'Emacs::Stream';
    untie (*STDIN) if ref (tied (*STDIN)) eq 'Emacs::Minibuffer';

    $stuff_tied = 0;
}

sub main {
    if (! defined (&_main)) {
	Carp::croak ("main() won't work, use \@Emacs::args instead");
    }
    package main;
    if (@_) {
	return Emacs::_main (@_);
    } else {
	return Emacs::_main ($0, @ARGV);
    }
}

sub SIG__WARN__ {
    my $msg = shift;
    chomp $msg;
    print STDERR $msg;
}

sub exit {
    my ($status) = @_;

    local $SIG{'__WARN__'} = 'DEFAULT';
    if ($Emacs::current) {
	&Emacs::Lisp::kill_emacs ($status);
    }
    CORE::exit ($status);
}


package Emacs::ENV;

sub TIEHASH {
    return (bless (\ do { my $x }, $_[0]));
}

sub FETCH	{ return &Emacs::Lisp::getenv ($_[1]); }
sub STORE	{ &Emacs::Lisp::setenv ($_[1], $_[2]); return ($_[2]); }

# XXX Need to write tests for these.

sub DELETE	{ &Emacs::Lisp::setenv ($_[1], undef); }
sub EXISTS	{ return defined (FETCH (@_)); }

sub FIRSTKEY {
    my ($pe, $str);

    $pe = Emacs::Lisp::Object::symbol_value (\*::process_environment);
    return undef if $pe->is_nil;
    $str = $pe->car->to_perl;
    $str =~ s/=.*//s;
    return $str;
}

sub NEXTKEY {
    my ($self, $lastkey) = @_;
    my ($tail, $str);

    for ($tail = Emacs::Lisp::Object::symbol_value (\*::process_environment);
	 not $tail->is_nil;
	 $tail = $tail->cdr)
    {
	if ($tail->car->to_perl =~ /^\Q$lastkey\E=/s) {
	    $tail = $tail->cdr;
	    return undef if $tail->is_nil;
	    $str = $tail->car->to_perl;
	    $str =~ s/=.*//s;
	    return $str;
	}
    }
    return undef;
}

sub CLEAR { &Emacs::Lisp::set (\*::process_environment, undef); }


package Emacs::Stream;

use vars ('@ISA');
@ISA = ('Tie::Handle');

sub TIEHANDLE {
    return (bless (\ do { my $x = $_[1] }, $_[0]));
}

sub WRITE {
    my ($stream, $output, $length, $offset) = @_;
    Emacs::Lisp::princ (substr ($output, $offset, $length),
			Emacs::Lisp::symbol_value ($$stream));
    return ($length);
}

sub PRINT {
    my ($stream, @items) = @_;
    Emacs::Lisp::princ (join ('', @items),
			Emacs::Lisp::symbol_value ($$stream));
    return (1);
}


package Emacs::Minibuffer;

use vars ('@ISA');
@ISA = ('Tie::Handle');

sub TIEHANDLE {
    return (bless (\ do { my $x }, $_[0]));
}

sub WRITE {
    my ($stream, $output, $length, $offset) = @_;
    Emacs::Lisp::message (substr ($output, $offset, $length));
    return ($length);
}

sub READ {
    die ("read() from STDIN is not implemented in Emacs.pm");
}

sub READLINE {
    return (Emacs::Lisp::read_string ("Enter input: "));
}


package Emacs::SIG;

sub TIEHASH {
    return (bless (\ do { my $x }, $_[0]));
}

sub signal_unsettable {
    return ($_[0] !~ m/^__/ && $_[0] !~ m/^USR[12]$/);
}

sub FETCH {
    my ($self, $sig) = @_;

    return 'EMACS' if signal_unsettable ($sig);
    { local $^W = 0; untie (%SIG); }
    my $handler = $SIG{$sig};
    tie (%SIG, 'Emacs::SIG');
    return $handler;
}

sub STORE {
    my ($self, $sig, $handler) = @_;

    if ($sig =~ m/^USR([12])$/) {
	no strict 'refs';
	my $key = \ [\*{"::usr${1}_signal"}];
	if (! defined ($handler)
	    || $handler eq 'DEFAULT'
	    || $handler eq 'IGNORE'
	    || $handler eq 'EMACS')
	{
	    Emacs::Lisp::global_unset_key ($key);
	}
	else {
	    # In Emacs, SIGUSR1 and SIGUSR2 are treated as keystrokes.
	    # Keys can be bound to commands, but not just ordinary
	    # functions.  Hence, "interactive".
	    $handler = Emacs::Lisp::Opaque->new ($handler)
		if ref ($handler);
	    $handler = [\*::lambda, undef, [\*::interactive],
			[\*::perl_call, $handler]];
	    Emacs::Lisp::global_set_key ($key, $handler);
	}
	return ($handler);
    }

    if (signal_unsettable ($sig)) {
	return if $handler eq 'EMACS';
	die ("Can't set signals under Emacs");
    }
    { local $^W = 0; untie (%SIG); }
    $SIG{$sig} = $handler;
    tie (%SIG, 'Emacs::SIG');
    return ($handler);
}

sub DELETE {
    my ($self, $sig) = @_;

    die ("Can't set signals under Emacs") if signal_unsettable ($sig);
    { local $^W = 0; untie (%SIG); }
    my $handler = delete $SIG{$sig};
    tie (%SIG, 'Emacs::SIG');
    return $handler;
}

sub EXISTS {
    my ($self, $sig) = @_;

    { local $^W = 0; untie (%SIG); }
    my $ret = exists $SIG{$sig};
    tie (%SIG, 'Emacs::SIG');
    return $ret;
}

sub CLEAR {}

sub FIRSTKEY {
    die "Can't iterate over signals under Emacs";
}

sub NEXTKEY {
    die "Can't iterate over signals under Emacs";
}

package Emacs::PID;

sub TIESCALAR { my ($x); return (bless (\$x, $_[0])); }
sub FETCH { return (Emacs::Lisp::emacs_pid ()); }
sub STORE { Carp::croak ("Can't change the process ID under Emacs"); }

1;
__END__