dan-perl.el

(require 'url)
(require 'url-util)
(require 'json)

(defun dan-perl (word)
  "Run dan's perl"
  (interactive
   (let* ((cur (or (thing-at-point 'word) ""))
          (val (read-string (if (not (equal cur ""))
                                (format "dan the perl (default %s): " cur)
                              "dan the perl: ")
                            nil nil cur)))
     (list val)))
  (let ((url (format "http://api.dan.co.jp/perleval.cgi?c=cb&s=%s" (url-hexify-string word)))
;        (url-request-method "POST")
;        (url-request-extra-headers
;         '(("Content-Type" . "application/x-www-form-urlencoded")))
;        (url-request-data (format "c=cb&s=%s" (url-hexify-string word)))
        (cb (lambda (status)
              (url-mark-buffer-as-dead (current-buffer))
              (if status
                  (message status)
                (let ((raw (buffer-string)))
                  (with-temp-buffer
                    (insert (decode-coding-string raw 'utf-8))
                    (beginning-of-buffer)
                    (if (re-search-forward "\r?\n\r?\ncb(\\(.*\\));$" nil t)
                        (message (cdr
                                  (assoc 'result
                                       (json-read-from-string (match-string 1)))))
                      (message (buffer-string)))))))))
    (url-retrieve url cb)))

(defun dan-perl-region (begin end)
  "Run dan's perl on the current region"
  (interactive "r")
  (save-excursion
    (dan-perl (buffer-substring begin end))))

(defun dan-perl-buffer ()
  "Run dan's perl on the current buffer"
  (interactive)
  (dan-perl (buffer-string)))

(provide 'dan-perl)

dan-the-shell.pl

#!/usr/bin/env perl -w

use strict;
use warnings;
use URI::Escape 'uri_escape';
use LWP::UserAgent;
use JSON 'decode_json';
use Term::ReadLine;
use HTTP::Request::Common;

my $ua = LWP::UserAgent->new(agent => "Dan the shell");
&main;exit;

sub main {
    my $term = Term::ReadLine->new("Dan the shell");
    while (defined($_ = $term->readline("dan> "))) {
        do_dan($_);
        $term->addhistory($_) if /\S/;
    }
}

sub do_perl {
    my $src = <<"__CODE__";
open my \$fh, '|/usr/local/bin/perl' or die "open error: \$!";
while (<DATA>) { print \$fh \$_ }
close \$fh;
__DATA__
$_[0]

__CODE__
}

sub do_dan {
    my $src = shift;
    $_ =~ s/\n//;
    $_ =~ s/^\s+//;
    $_ =~ s/\s+$//;

    if ($src =~ /^ls\s+(.+)$/) {
        my $p = index($1,'//',0) == 0 ? '../../../../'.$1 : $1;
        $src = do_perl(qq[print join "\n", <$p/*>;]);
    }
    elsif ($src =~ /^mkdir\s+(.+)$/) {
        $src = do_perl(qq[mkdir "$1" or die 'mkdir ' . \$!]);
    }
    elsif ($src =~ /^cat\s+(.+)$/) {
        my $p = index($1,'//',0) == 0 ? '../../../../'.$1 : $1;
        $src = sprintf q{open my $f, '%s' or die $!;print do { local $/; <$f>;}}, $p;
    }
    elsif ($src =~ /^kill\s+(.+)$/) {
        $src = do_perl(q[kill %s], $1);
    } elsif ($src eq 'ENV') {
        $src = 'while (my($k, $v) = each %ENV) { print "$k => $v\n" }';
    } elsif ($src eq 'INC') {
        $src = 'print join "\n", @INC;';
    } elsif ($src eq 'SEGV') {
        $src = 'unpack "p", 0xdeadbeef';
    }

#    my $res = $ua->request( POST 'http://api.dan.co.jp/perleval.cgi', [ c => 'callback', s => $src ]);
    my $url = URI->new('http://api.dan.co.jp/perleval.cgi');
    $url->query_form(
        c => 'callback',
        s => $src,
    );
    my $res = $ua->get($url);
    if ($res->is_success) {
        my $json = $res->content;
        $json =~ s/callback\((.+)\);\n/$1/;
        my $dat = eval{ decode_json $json };
        if ($dat->{error}) {
            print $dat->{error}, "\n";
        } elsif (defined $dat->{result}) {
            print $dat->{result}, "\n";
        } else {
            print "invalid json: $json\n";
        }
    } else {
        print $res->status_line, "\n";
    }
}