Beefy Boxes and Bandwidth Generously Provided by pair Networks
Don't ask to ask, just ask
 
PerlMonks  

use Drugs;

by Dylan (Monk)
on Aug 30, 2002 at 17:01 UTC ( #194178=sourcecode: print w/ replies, xml ) Need Help??

Category: Miscellaneous
Author/Contact Info /msg Dylan
Description: Drugs is a perl module that makes existing perl scripts more interesting. I'd be interested if anyone else finds this funny... "This is your script, this is your script on drugs" <g> Update: Modifed to be less C-like (Thanks, Aristotle).
Update: Fixed sprintf thing.
package IO::Drug;
use strict;
use Tie::Handle;
our @ISA = qw(Tie::Handle);

sub PRINT {
    my $self = shift;
    print $self (map lsd($_), @_);
}

sub PRINTF {
    my ($self, $fmt) = splice @_, 0, 2;
    print $self lsd(sprintf $fmt, @_);
}
sub TIEHANDLE {
    my ($class, $handle) = @_;
    bless $handle, $class;
}

sub lsd {
    my @colors = qw(red green yellow blue cyan magenta);
    push @colors, map "bold $_", @colors;
    # map chr, unpack "c*" is faster than split //
    return
        join '', map colored(chr $_, $colors[rand @colors]),
        unpack "c*", $_[0];
}

package Drugs;
use strict;
use Carp;
use Filter::Util::Call;
use Term::ANSIColor;

sub import { filter_add bless {} }

sub filter {
    my ($self) = @_ ;
    my $status = filter_read();
    intoxicate_linenums() if $status;
    return $status;
}

sub intoxicate_linenums {
    return join "\n", map {
        my $rnd = 1 + int rand 1000;
        my ($prog) = $0 =~ /([^\/]+)\z/;
        
        if(rand 2) {
            my @files =
                grep {$_ ne $prog and not -d $_}
                glob('*'), glob('**/*');
            my $file = $files[rand @files] || 'Fat Albert';
            qq(#line $rnd "$file"\n$_);
        }
        else {
            "#line $rnd $prog\n$_";
        }
    } split /\n/;
}

$SIG{__WARN__} = sub { print STDERR @_ };
$SIG{__DIE__} = sub { print STDERR @_ ; exit };

open my $out, ">&STDOUT" or die "Can't dup!";
tie *STDOUT, "IO::Drug", $out;

open my $err, ">&STDERR" or die "Can't dup!";
tie *STDERR, "IO::Drug", $err;

1;

Comment on use Drugs;
Download Code
Re: use Drugs;
by Dylan (Monk) on Aug 30, 2002 at 17:04 UTC
    Er, can someone please delete this? I thought for some reason I was previewing it, and I obviously forgot <code> tags...
Re: use Drugs;
by Dylan (Monk) on Aug 31, 2002 at 05:30 UTC

    Here's an idea: Put -MDrugs in PERL5OPT, in someone else's .bashrc file <evil grin>...

Re: use Drugs;
by Aristotle (Chancellor) on Sep 01, 2002 at 19:30 UTC
    my @colors = qw(red green yellow blue cyan magenta); my @tmp = (); for (@colors) { push (@tmp, "bold $_"); } @colors = (@colors, @tmp);
    Ugh. How about
    my @colors = qw(red green yellow blue cyan magenta); push @colors, map "bold $_", @colors;
    In fact the code is very C-ish and can be cleaned up quite significantly, and the current form both violates strict and produces warnings. A bit of rearranging also makes it much easier to grok. Here's a cleaned up version:
    package IO::Drug; use strict; use Tie::Handle; our @ISA = qw(Tie::Handle); sub PRINT { my $self = shift; print $self (map lsd($_), @_); } sub PRINTF { my ($self, $fmt) = splice @_, 0, 2; # changed to accomodate fix print $self lsd(sprintf $fmt, @_)); # fixed } sub TIEHANDLE { my ($class, $handle) = @_; bless $handle, $class; } my @colors = qw(red green yellow blue cyan magenta); push @colors, map "bold $_", @colors; sub lsd { # map chr, unpack "c*" is faster than split // return join '', map colored(chr $_, $colors[rand @colors]), unpack "c*", $_[0]; } package Drugs; use strict; use Carp; use Filter::Util::Call; use Term::ANSIColor; sub import { filter_add bless {} } sub filter { my ($self) = @_ ; my $status = filter_read(); intoxicate_linenums() if $status; return $status; } sub intoxicate_linenums { return join "\n", map { my $rnd = 1 + int rand 1000; my ($prog) = $0 =~ /([^\/]+)\z/; if(rand 2) { my @files = grep {$_ ne $prog and not -d $_} glob('*'), glob('**/*'); my $file = $files[rand @files] || 'Fat Albert'; qq(#line $rnd "$file"\n$_); } else { "#line $rnd $prog\n$_"; } } split /\n/; } $SIG{__WARN__} = sub { print STDERR @_ }; $SIG{__DIE__} = sub { print STDERR @_ ; exit }; open my $out, ">&STDOUT" or die "Can't dup!"; tie *STDOUT, "IO::Drug", $out; open my $err, ">&STDERR" or die "Can't dup!"; tie *STDERR, "IO::Drug", $err; 1;

    ++ for the idea. :-) Fortunately, use Drugs (); causes the line number intoxication to be sidestepped, and I might even use it that way occasionally for fun. *grin*

    Update: Pulled @colors initialization out of the lsd() routine.

    Update 2002-09-08: had to s/sprintf @_/sprintf $fmt, @_/ because sprintf has prototype ($@) *grumble* See code comments for changes.

    Makeshifts last the longest.

      hrm, I hadn't thought of its strictness.
      Thanks for the improvments!

      As for it being C-like, that is very strange. Perl is my first (programming) language and I just started looking at C... I also really like map {} (and grep {}), but I thought for() was faster than map for some reason.

        It can be. That very much depends on what you're trying to do. Note I didn't pick map for efficiency here, more because it pulls the code together with fewer temporary variables at least using my overall style (and fewer of those do tend to lead to more efficiency).

        Selectively modifying elements of an array inplace, esp when you only need to touch few, most likely is best left to a for loop. Touching each or almost each and every element it can be a toss-up. When you are building a new array as you iterate over another, map is very likely the clear winner.

        Makeshifts last the longest.

      Darn. Noone called me on the sprintf @_ mistake. Lucky that I ran across this node again while looking for another; fixed now. It's still untested code though so YMMV. If you find any more errors, please let me know.

      Makeshifts last the longest.

        I ran it, (With sprintf problem), no problems. I hardly ever use printf so I'd have never caught the problem. Fixed above version as-par your fix.

Back to Code Catacombs

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: sourcecode [id://194178]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others musing on the Monastery: (6)
As of 2014-09-03 04:13 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    My favorite cookbook is:










    Results (35 votes), past polls