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. |