-- def_macro hello
my $name = shift || "world";
print "Hello $name!";
####
-- hello
##
##
-- def_macro hello
my @in = map { chomp;length($_) ? $_ :() } (@ARGV,);
chomp(@in);
@in = "world" unless @in;
print "Hello $_" for @in;
##
##
-- hello me
myself
I
##
##
Hello me
Hello myself
Hello I
##
##
#!/usr/bin/perl -l
# clipcommand.pl by antirice on perlmonks
# This is released under the same terms as perl
package TempOut;
use overload '""' => 'as_string', fallback => 1;
sub new {
my $opt = shift;
my $content = '';
open my $t, '>', \$content or die "Unable to open temp stdout: $!";
my $orig = select $t;
undef $\ if $opt;
return bless [ $orig, \$content];
}
sub DESTROY {
my $self = shift;
return unless $self->[0];
select $self->[0];
undef $self->[0];
$\ = $/;
}
*release = \&DESTROY;
sub as_string {
return ${shift->[1]};
}
package TempIn;
sub new {
my (undef,$txt) = @_;
open my $fh, "<&STDIN" or die "Unable to duplicate STDIN: $!";
close STDIN;
open STDIN, "<", \$txt;
return bless [ $fh ];
}
sub DESTROY {
my $self = shift;
close STDIN;
open STDIN, "<&", $self->[0] or die "Unable to restore STDIN: $!";
close $self->[0]
}
package main;
use Win32::Clipboard;
use IPC::Run 'run';
use File::Temp;
use File::Spec::Functions 'rel2abs';
use Text::ParseWords 'shellwords';
use Data::Dumper;
use B::Deparse;
use strict;
use vars '$c';
$/ = "\r\n";
my $v = shift;
$v = $v && $v eq '-v' ? 1 : 0;
$main::c = Win32::Clipboard->new();
my $last = "";
my $count = 0;
my %macros;
my %subs = (
reload => \&reload,
list => \&list,
def_macro => \&def_macro,
rem_macro => \&rem_macro,
exit => sub { $c->Set("Good bye ;-)");exit },
restart => \&restart,
codefor => \&codefor,
fullcodefor => \&fullcodefor,
justrestart => sub { restart([1]) },
promote_macro => \&promote_macro
);
my %commands;
my %scripts;
# find available commands in commands directory
reload();
while ($c->WaitForChange) {
next unless $c->IsText && $count++;
my $t = $c->GetText or next;
next if $t eq $last || $t !~ /^'?-+\s*([\w-]+)([ \t]+[^\r\n]+)?[\r\n]*(.*)$/s;
$last = $t;
my ($command,$params,$in) = ($1,$2,$3);
# do this afterwards so we have our variables set before using the regex engine again
$command = lc $command;
$params =~ s/^\s+//g;
next unless exists $commands{$command};
if (ref $commands{$command}) {
print "Executing macro $command";
eval { $commands{$command}->(parse($params),$in) };
print "Finished execution";
print $c->GetText if $v;
next;
}
my $out;
$c->Set('** EXECUTING **');
(my $stupid_win = $^X) =~ s/\\/\\\\/g;
if ($v) {
print qq{Executing: [$^X "$commands{$command}" $params]};
print "Parses as: ",Dumper(parse(qq["$stupid_win" "$commands{$command}" $params]));
}
eval {
run(parse(qq["$stupid_win" "$commands{$command}" $params]), \$in, \$out);
};
$out = "***** ERROR *****:\n$@" if $@;
$out =~ s~(?Set($out);
print $c->GetText if $v;
$last = $out;
}
sub parse {
my $line = shift ;
$line =~ s{(\\[\w\s])}{\\$1}g ;
return [ shellwords $line ];
}
sub reload {
undef %commands;
for () {
next unless -f;
my ($check) = m!([\w-]+)\.pl$!g or next;
$commands{lc $check} = rel2abs($_);
$commands{lc $check} =~ s/\\/\\\\/g;
}
%scripts = %commands;
%commands = (%commands,%subs,%macros);
my $out = "Commands available: \r\n";
$out .= join "\r\n", map qq[ -- $_], sort keys %commands;
print $out;
$c->Set(($count ? "Reload successful!\r\n":'').$out);
print Dumper(\%commands) if $v;
}
sub list {
my $out = "Commands available: $/";
$out .= join $/, map qq[ -- $_], sort keys %commands;
print $out;
$c->Set($out);
}
sub def_macro {
my ($args,$in) = @_;
my ($name,$opt) = @$args;
$c->Set("No body for the macro '$name' detected") unless $in;
my $exec = eval { 'sub { my $temporary_out = TempOut->new("' . ($opt || '') . '"); my $temporary_in;local $_;local *ARGV;local $\\ = $/;local $/ = $/;local ${"} = ${"};local ${,} = ${,};{ my($XYZARGS,$INPUT) = @_;*_ = $XYZARGS;@ARGV = @_;$temporary_in = TempIn->new($INPUT) };' . $in . $/ . '; undef $temporary_in; $main::c->Set($temporary_out->as_string); }' } or warn "Error! $@" and return;
my $sub = eval { eval $exec or die $@ } or $c->Set("Error creating macro '$name': $@") and print "Body: $/$exec" and return;
$macros{lc $name} = $commands{lc $name} = $sub;
local $, = $/;
print "Built code as: ",B::Deparse->new->coderef2text($sub),"Macro $name successfully created", if $v;
$c->Set("Macro $name successfully created");
}
sub rem_macro {
my ($args,$in) = @_;
my ($name) = @$args;
$c->Set("Macro $name not found") and return unless exists $commands{$name};
delete $commands{lc $name};
delete $macros{lc $name};
$c->Set("Macro $name successfully removed");
}
sub restart {
my $args = shift;
$c->Set("You will lose all macros. Please pass 1 as the first parameter if you wish to continue.") and return unless @$args && $args->[0] eq "1";
$c->Set("** RESTARTING **");
print "$/$/Please stay tuned for the following messages.$/$/****** RESTARTING ******$/";
undef $c;
exec("$^X $0");
}
sub codefor {
my $args = lc shift->[0];
my $out;
if (exists $macros{$args} && ref $macros{$args}) {
my @x = map { s/^ {4}//;$_ } split m!\n!,B::Deparse->new->coderef2text($macros{$args});
$out = join($/, " -- def_macro $args", @x[16..($#x - 3)],"","# End of macro");
} else {
$out = "$args is not a macro"
}
$c->Set($out);
}
sub fullcodefor {
my $args = lc shift->[0];
my $out;
if (exists $macros{$args}) {
$out = join $/, split m!\n!,B::Deparse->new->coderef2text($macros{$args});
} else {
$out = "$args is not a macro"
}
$c->Set($out);
}
sub promote_macro {
my $args = lc shift->[0];
my $out;
if (! exists $macros{$args}) {
$out = "Macro $args doesn't exist";
} else {
$out = eval {
my @x = map { s/^ {4}//;chomp;$_ } split m!\n!,B::Deparse->new->coderef2text($macros{$args});
mkdir "commands" unless -d "commands";
open my $f, '>', rel2abs("commands/$args.pl") or die $@;
print $f $_ for "#!/usr/bin/perl -l","",'# Macro promoted ' . localtime,'# shift defaults to @_ in subroutines so we ought to copy this over','@_ = @ARGV;','',@x[16..($#x - 3)];
close $f or die $@;
delete $macros{$args};
$commands{$args} = $scripts{$args} = rel2abs("commands/$args.pl");
"Macro $args successfully promoted!";
} || "Error promoting macro $args: $@";
}
$c->Set($out);
}
__END__
##
##
-- def_macro eval
eval join "",<>