comment on

Note: this script currently only works in Windows.

I still need to tidy this up a bit but I've found it to be extremely useful.

Basically with this you can create short programs (I call them macros) that you can either use temporarily or promote it to a permanent macro. To create a macro is fairly simple:

-- def_macro hello
my $name = shift || "world";
print "Hello $name!";
[download]

If you copy and paste, it will tell you that macro hello has been created. Now if you copy and paste:

-- hello
[download]

When you paste it will print "Hello world!" Now let's make our macro able to process either from cl or input.

-- def_macro hello
my @in = map { chomp;length($_) ? $_ :() } (@ARGV,<STDIN>);
chomp(@in);
@in = "world" unless @in;
print "Hello $_" for @in;
[download]

Now this works:

-- hello me
myself
I
[download]

Which produces:

Hello me
Hello myself
Hello I
[download]

If we restart our script, we will lose our sweet -- hello macro (you can try this with -- restart 1). If you want this to become a permanent macro, we can promote it with -- promote_macro hello. Once we do that, it creates a standalone script that works as normal.

Script follows:

#!/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~(?<!\r)\n~$/~g;
    $c->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 (<commands/*.pl>) {
        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("' . ($o
+pt || '') . '"); my $temporary_in;local $_;local *ARGV;local $\\ = $/
+;local $/ = $/;local ${"} = ${"};local ${,} = ${,};{ my($XYZARGS,$INP
+UT) = @_;*_ = $XYZARGS;@ARGV = @_;$temporary_in = TempIn->new($INPUT)
+ };' . $in . $/ . '; undef $temporary_in; $main::c->Set($temporary_ou
+t->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 $command
+s{$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 para
+meter 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->code
+ref2text($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($mac
+ros{$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 c
+opy this over','@_ = @ARGV;','',@x[16..($#x - 3)];
            close $f or die $@;
            delete $macros{$args};
            $commands{$args} = $scripts{$args} = rel2abs("commands/$ar
+gs.pl");
            "Macro $args successfully promoted!";
        } || "Error promoting macro $args: $@";
    }
    $c->Set($out);
}


__END__
[download]

If you have any suggestions, please message me.

UPDATE: I forgot to give a macro that lets you just evaluate whatever you pass in:

-- def_macro eval
eval join "",<>
[download]

You will probably want to promote that macro.

UPDATE 2: Someone asked me what scenarios I use this for. My answer is: nearly everything. I use it to grab stuff out of sourcesafe and svn, lookup stuff in help files, look on the internet for stuff for me (-- perlmonks is nice =P), keep track of my time, generate code, etc etc. This is perl in your clipboard! Use your imagination! =)

UPDATE 3: Refer to Update 5.

UPDATE 4: I fixed a problem that had been bugging me (macros did not override STDIN).

UPDATE 5: I'm getting asked this a lot so I'm adding it here. IPC::Run is difficult to install through cpan. You will need to add the Bribes de Perl repository to ppm. To add the repository, you will need to follow these instructions and search for IPC-Run. If you have never used ppm, please refer to this page.

In reply to clipcommand.pl (Embed perl into your clipboard) by antirice

Are you posting in the right place? Check out Where do I post X? to know for sure.
Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
<code> <a> <b> <big> <blockquote> <br /> <dd> <dl> <dt> <em> <font> <h1> <h2> <h3> <h4> <h5> <h6> <hr /> <i> <li> <nbsp> <ol> <p> <small> <strike> <strong> <sub> <sup> <table> <td> <th> <tr> <tt> <u> <ul>
Snippets of code should be wrapped in <code> tags not <pre> tags. In fact, <pre> tags should generally be avoided. If they must be used, extreme care should be taken to ensure that their contents do not have long lines (<70 chars), in order to prevent horizontal scrolling (and possible janitor intervention).
Want more info? How to link or How to display code and escape characters are good places to start.


"be consistent"
	PerlMonks