Sybase BCP date formatter
on Nov 21, 2008 at 17:53
|
1 reply
|
by runrig
|
When using Sybase's "bcp out" to a delimited file, fix the default date format to be something more portable (and sortable). This assumes a pipe delimited file, adding options to change that is left as an exercise. This is a function instead of a standalone script so that it can be included within another program.
BEGIN {
my $pgm = <<'EOT';
my @mon = qw( Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec );
my %mons;
my $i;
$mons{$_} = ++$i for @mon;
my $mon_str = join("|", @mon);
my $mon_re = qr/$mon_str/;
s/(^|\|)($mon_re)\s{1,2}(\d{1,2})\s(\d{4})\s\s?(\d\d?):(\d\d):(\d\d):(
+\d{3})([AP])M(\||$)/
$1.
sprintf("%04d-%02d-%02d %02d:%02d:%02d.%03d",
$4,
$mons{$2},
$3,
( $9 eq "P" && $5 < 12) ? $5 + 12 : ( $9 eq 'A' && $5 == 12 ) ? 0
+: $5,
$6,
$7,
$8).
$10
/eg;
EOT
sub fix_bcp_file {
my ($file) = @_;
system($^X, "-pi", "-e", $pgm, $file);
}
}
|
ColorRamp1785-w-Tk
on Nov 19, 2008 at 14:22
|
0 replies
|
by zentara
|
#!/usr/bin/perl
use warnings;
use strict;
use Tk;
my @colors;
# generate colors from BrowserUk's subs in
# http://perlmonks.org?node_id=724491
sub rgb2n{ unpack 'N', pack 'CCCC', 0, @_ }
my( $r, $g, $b ) = (0) x 3;
for my $step ( 0 .. 1784 ) {
if( $step < 255 ) { ++$b; }
elsif( $step < 510 ) { ++$g; }
elsif( $step < 765 ) { --$b; }
elsif( $step < 1020 ) { ++$r; }
elsif( $step < 1275 ) { --$g; }
elsif( $step < 1530 ) { ++$b; }
else { ++$g; }
#print "$r $g $b\t";
my $hexcurrent = '#'.sprintf('%.2x', $r).sprintf('%.2x', $g).sprintf(
+'%.2x', $b);
# print "$hexcurrent\n";
push @colors,$hexcurrent;
}
my %map = (
255 => sub{ 0, 0, $_[0] * 255 },
510 => sub{ 0, $_[0]*255, 255 },
765 => sub{ 0, 255, (1-$_[0])*255 },
1020 => sub{ $_[0]*255, 255, 0 },
1275 => sub{ 255, (1-$_[0])*255, 0 },
1530 => sub{ 255, 0, $_[0]*255 },
1785 => sub{ 255, $_[0]*255, 255 },
);
my @map = sort{ $a <=> $::b } keys %map;
sub colorRamp1785 {
my( $v, $vmin, $vmax ) = @_;
$v = $vmax if $v > $vmax;
$v = $vmin if $v < $vmin;
$v = ( $v - $vmin ) / ( $vmax - $vmin );
$v *= 1785;
$v < $_ and return rgb2n( $map{ $_ }->( $v ) ) for @map;
}
######################################3
#print "\n",join "\n", @colors,"\n";
#print scalar @colors,"\n";
my $mw=tkinit;
$mw->fontCreate('big',
-family=>'arial',
-weight=>'bold',
-size=> 38
);
my $bfr = $mw->Frame()->pack(-fill=>'x');
my $cur_color = '# ';
my $lab = $bfr->Label(-textvariable => \$cur_color,
-font => 'big',
)->pack();
my $sc = $mw->Scrolled('Canvas',
-bg=>'white',
-scrollbars=>'s',
)->pack(-expand=>1,-fill=>'x',-padx=>10);
my $realcanvas = $sc->Subwidget('scrolled');
my $x = 0;
foreach my $color(@colors) {
my $line = $realcanvas->createLine($x,0,$x, 250,
-fill=> $color,
-tags => [$color,'line']
);
$x++;
$realcanvas->bind("line", "<Enter>",
sub {
my (@tags) = $realcanvas->gettags('current');
$cur_color = $tags[0];
});
}
#print "$x\n";
$realcanvas->configure(-scrollregion=>[$realcanvas->bbox("all")]);
MainLoop;
__END__
|
ColorRamp1785
on Nov 19, 2008 at 01:55
|
1 reply
|
by BrowserUk
|
A while ago I had need of a color ramp and found one on-line which I implemented in Perl and have made regular use of since.
However, that ramp only allows a maximum of 1021 distinct colors, (four edges of the 24-bit color cube with 3 shared values), and I recently had the need of more. So I extended the ramp to start at black and transition to white: black->blue->cyan->green->yellow->red->magenta->white thus transitioning 7 edges of the color cube giving me 1785 distinct colors.
Update: seems I did a piss poor job of extracting the code below from the application where I used it, and attempting to generalise it. I believe I've corrected that now. The color ramp sub and data table:
sub rgb2n{ unpack 'N', pack 'CCCC', 0, @_ }
BEGIN {
my %map = (
255 => sub{ 0, 0, $_[0] * 255 },
510 => sub{ 0, $_[0]*255, 255 },
765 => sub{ 0, 255, (1-$_[0])*255 },
1020 => sub{ $_[0]*255, 255, 0 },
1275 => sub{ 255, (1-$_[0])*255, 0 },
1530 => sub{ 255, 0, $_[0]*255 },
1785 => sub{ 255, $_[0]*255, 255 },
);
my @map = sort{ $::a <=> $::b } keys %map;
sub colorRamp1785 {
my( $v, $vmin, $vmax ) = @_;
$v = $vmax if $v > $vmax;
$v = $vmin if $v < $vmin;
$v = ( $v - $vmin ) / ( $vmax - $vmin );
$v *= 1785;
$v < $_ and return rgb2n( $map{ $_ }->( $v % 255 / 256 ) ) for
+ @map;
}
}
A simple GD app that uses it to produce a png that displays the full range of the color ramp and the transitions:
#! perl -slw
use strict;
use GD;
use GD::Polygon;
sub rgb2n{ unpack 'N', pack 'CCCC', 0, @_ }
my $tri = GD::Polygon->new;
$tri->addPt( @$_ ) for [ 0, 0 ], [ -9, 16 ], [ 9, 16 ], [ 0, 0 ];
$tri->offset( 0, 132 );
my $img = GD::Image->new( 1784, 151, 1 );
$img->filledRectangle( 0, 0, 1784, 150, rgb2n( (128) x 3 ) );
my( $r, $g, $b ) = (0) x 3;
for my $step ( 0 .. 1784 ) {
$img->line( $step, 0, $step, 98, colorRamp1785( $step, 0, 1784 ) )
+;
$img->line( $step, 100, $step, 109, rgb2n( $r, 0, 0 ) );
$img->line( $step, 111, $step, 119, rgb2n( 0, $g, 0 ) );
$img->line( $step, 121, $step, 129, rgb2n( 0, 0, $b ) );
unless( grep{ $_ != 0 and $_ != 255 } $r, $g, $b ) {
$img->filledPolygon( $tri, rgb2n( $r, $g, $b ) );
$tri->offset( 255, 0 );
}
if( $step < 255 ) { ++$b; }
elsif( $step < 510 ) { ++$g; }
elsif( $step < 765 ) { --$b; }
elsif( $step < 1020 ) { ++$r; }
elsif( $step < 1275 ) { --$g; }
elsif( $step < 1530 ) { ++$b; }
else { ++$g; }
}
$img->filledPolygon( $tri, rgb2n( (255) x 3 ) );
open PNG, '>:raw', "colorRamp.png" or die $!;
print PNG $img->png;
close PNG;
system 'colorRamp.png';
BEGIN {
my %map = (
255 => sub{ 0, 0, $_[0] * 255 },
510 => sub{ 0, $_[0]*255, 255 },
765 => sub{ 0, 255, (1-$_[0])*255 },
1020 => sub{ $_[0]*255, 255, 0 },
1275 => sub{ 255, (1-$_[0])*255, 0 },
1530 => sub{ 255, 0, $_[0]*255 },
1785 => sub{ 255, $_[0]*255, 255 },
);
my @map = sort{ $::a <=> $::b } keys %map;
sub colorRamp1785 {
my( $v, $vmin, $vmax ) = @_;
$v = $vmax if $v > $vmax;
$v = $vmin if $v < $vmin;
$v = ( $v - $vmin ) / ( $vmax - $vmin );
$v *= 1785;
$v < $_ and return rgb2n( $map{ $_ }->( $v % 255 / 256 ) ) for
+ @map;
}
}
__END__
R G B
black -> blue 0 0 0..255 256
blue -> cyan 0 0..255 255 512
cyan -> green 0 255 255..0 768
green -> yellow 0..255 255 0 1024
yellow -> red 255 255..0 0 1280
red -> magenta 255 0 0..255 1536
magenta -> white 255 0..255 255 256
|
A Tribute To The Monks Of Wisdom
on Nov 15, 2008 at 20:41
|
6 replies
|
by koolgirl
|
May I have a drum roll please!
Ok, Monks, I have spent quite a bit of time contemplating whether or not this write-up would be a complete waste of time due to it's insignificance, and whether or not it might even warrant some serious XP loss on my part (though I prayed that it wouldn't *big pouty eyes*). However, I'm doing it anyways, so here goes....
This is a tiny snippet of code, an excersise which teaches basic file manipulation, which is my current venture into the world of Perl. It means nothing, I'm sure, to the code catacombs per se, however, it's significance lies in it's construction. I wrote this in about 45 minutes, encountered several problems, researched them, de-bugged my code, got it working, and even used, at least to a point, a less verbose approach than usual, and I did it all by myself. It is the very first time in several months of hard core studying, that I have accomplished this feat. To be blunt, I just couldn't be more proud of myself...I even did a dance, a 5 minute long dance mind you, after seeing the beautiful output.
Now, before you hit the -- vote while thinking to yourself "I can't believe this absurdity...I could've written that in my sleep and never even needed to de-bug a thing", please allow me to quickly end this monstrosity by explaining why I went ahead with it.
There are a countless number of you, who have dedicated your precious time to answering my many questions over the last few months, all of them revolving around my inability to de-bug my own code without asking another Monk to hold my hand. I wanted to show all of you who were nice enough to help, that your effort was not in vain...ya'll taught me how to de-bug my code. This is a testament to every monk that has ever answered a SoPW question, just to watch that same monk who asked, completely ignore it and continue to ask about it over and over again. I know the experts on here get frustrated with us newbies for such things. So, I wanted to give tangible proof, that the Perl Monks are fantastic teachers and should be praised for it.
So, I hereby dedicate this to every Monk on here, that has ever taken the time to answer a newbie question, in an effort to further a fellow Monk's knowledge. Monks it is truly a privilege and an honor to be a recipient of your guidance!
UPDATE: Fixed the typo and forgotten close. Thanks hossman :D
UPDATE:
Yes, I do realize that the file tests could have been performed without opening them, however, I didn't understand how to open files from the @ARGV, as it was my first time calling a program with file names behind it on the command line, so, I went ahead and researched it and incorporated it into my program, just to give myself the experience.
#!usr/bin/perl
use strict;
my $i = 0;
# This is a program which reads in a list of file names from the comma
+nd
# line and prints which files are readable, writable and/or executable
+,
# and whether each file exists.
while ($i < scalar(@ARGV)) {
open(MYFILE, $ARGV[$i]) or die("Error: cannot open file '$ARGV[$i]
+'\n");
print "$ARGV[$i] is readable!\n" if -r MYFILE;
print "$ARGV[$i] is writable!\n" if -w MYFILE;
print "$ARGV[$i] is executable!\n" if -x MYFILE;
print "$ARGV[$i] exists!\n" if -e MYFILE;
$i++;
} # end while
close(MYFILE);
|
Zero forgetfullness
on Nov 14, 2008 at 18:58
|
4 replies
|
by Odinator
|
Ok I have only been into Perl for a couple weeks (I am still technically on the Llama book), but when I found out that their were all these modules that let me experiment with the fabric of time and space, and artificial intelligence, I could not resist. Anyways I have forgetfullness down to 0.0000000 and I made a script I think is kind of neat. Anyways, the quantum and neural network modules go together like ham and swiss. Yes I know its just adding and removing from the tutorial program on the cpan. But I want to show everyone how great quantum and neural net modules mix. I imagine genetic algorithms would be fun to test to, but they do not go as smoothly with Quamtum mods as the NN`s do. I will be experimenting and adding to this alot tonight, and in the next few days, to see what else I can create. Any suggestions into ways I can take this farther, or ways a more experienced programmer could make this better, or even usefull. Would also be interesting. So without further adew, here we go..
use AI::NeuralNet::BackProp;
use Quantum::Superpositions;
use Quantum::Entanglement qw(:DEFAULT :complex :QFT);
# Create a new network with 1 layer, 5 inputs, and 5 outputs.
my $net = new AI::NeuralNet::BackProp(1,5,5);
# Add a small amount of randomness to the network
$net->random(0.001);
# Demonstrate a simple learn() call
my @inputs = all( 0,0,1,1,1 );
my @outputs = any( 1,0,1,0,1 );
print $net->learn(\@inputs, \@outputs),"\n";
# Create a data set to learn
my @set = entangle(
[ 2,2,3,4,1 ], [ 1,1,1,1,1 ],
[ 1,1,1,1,1 ], [ 0,0,0,0,0 ],
[ 1,1,1,0,0 ], [ 0,0,0,1,1 ]
);
# Demo learn_set()
my $f = $net->learn_set(\@set);
print "Forgetfulness: $f unit\n";
# Crunch a bunch of strings and return array refs
my $phrase1 = $net->crunch("Odin is a husky!");
my $phrase2 = $net->crunch("Star is a husky.");
my $phrase3 = $net->crunch("Rukia is also a husky");
my $phrase4 = $net->crunch("Sorry, are you more of a cat perso
+n?");
# Make a data set from the array refs
my @phrases = any(
$phrase1, $phrase2,
$phrase3, $phrase4
);
# Learn the data set
$net->learn_set(\@phrases);
# Run a test phrase through the network
my $test_phrase = eigenstates($net->crunch("I love neural netw
+orking and quantum mechanics!"));
my $result = $net->run($test_phrase);
print all($net->uncrunch($result)),"\n";
|
Delete an Excel worksheet
on Nov 10, 2008 at 15:29
|
0 replies
|
by PFudd
|
My input Excel file has four worksheets; I wanted to delete worksheet #2 and save the spreadsheet. There is no function to delete a worksheet in Spreadsheet::ParseExcel nor SpreadSheet::WriteExcel, as they assume that if you didn't want the sheet, you wouldn't have created it.
#!/usr/bin/perl -w
use strict;
use Spreadsheet::ParseExcel;
use Spreadsheet::ParseExcel::SaveParser;
my ($INFILE,$OUTFILE)=("in.xls","out.xls");
my $oExcel = new Spreadsheet::ParseExcel::SaveParser;
my $oBook = $oExcel->Parse($INFILE);
splice(@{$oBook->{Worksheet}},1,1);
$oBook->{SheetCount}--;
$oExcel->SaveAs($oBook, $OUTFILE);
|
CPAN searchplugin for firefox 3
on Nov 08, 2008 at 10:28
|
1 reply
|
by sir_lichtkind
|
beside smart bookmarks you have searchplugins in firefox. unfortunately in the mozilla addon repo doesn't have one for CPAN, but David showed how to get one. but because ff3 has a new API we need an update which i deliver here now:
<SearchPlugin xmlns="http://www.mozilla.org/2006/browser/search/">
<ShortName>CPAN</ShortName>
<Description>Comprehensive Perl Archive Network</Description>
<InputEncoding>UTF-8</InputEncoding>
<Image width="16" height="16">data:image/x-icon,%00%00%01%00%01%00%10%
+10%00%00%00%00%00%00(%01%00%00%16%00%00%00(%00%00%00%10%00%00%00%20%0
+0%00%00%01%00%04%00%00%00%00%00%C0%00%00%00%00%00%00%00%00%00%00%00%0
+0%00%00%00%00%00%00%00%FF%FF%FF%00%7B%00%00%00%00%7B%00%00%7B%7B%00%0
+0%00%00%7B%00%7B%00%7B%00%00%7B%7B%00%BD%BD%BD%00%7B%7B%7B%00%FF%00%0
+0%00%00%FF%00%00%FF%FF%00%00%00%00%FF%00%FF%00%FF%00%00%FF%FF%00%00%0
+0%00%00%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%F
+F%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%F
+F%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%F
+F%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%F
+F%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%F
+F%F0%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF%FF3l%FC%BF%EF%18%E6
+%D7%EB%F0%F6%DB%00%00%FA%E9%00%02%F8%C3al%FC%03te%F8%02Co%F0%02r%20%E
+0%01%5C%D0%E0%03%11%00%E6%0F%BF%E6'%1F%00%02%07%FF%00%06%87%FF2%80%E3
+%FF1%E0</Image>
<Url type="text/html" method="GET" template="http://search.cpan.org/se
+arch">
<Param name="query" value="{searchTerms}"/>
<Param name="mode" value="all"/>
</Url>
<SearchForm>http://cpan.perl.org/</SearchForm>
</SearchPlugin>
|
Search for <n>th occurrence of regex
on Nov 05, 2008 at 15:02
|
1 reply
|
by repellent
|
# only Perl 5.10+
my $a;
my $ref = "abc x abc y abc z abc\n";
# search 3rd occurence of 'abc' from start-of-line
($a = $ref) =~ s/^(?:.*?\Kabc){3}/___/;
print $a;
# search 4th occurence of 'abc' from start-of-line
($a = $ref) =~ s/^(?:.*?\Kabc){4}/___/;
print $a;
# omit ^ to search every 2nd occurence of 'abc'
($a = $ref) =~ s/(?:.*?\Kabc){2}/___/g;
print $a;
# omit ^ to search every 1st occurence of 'abc'
($a = $ref) =~ s/(?:.*?\Kabc){1}/___/g;
print $a;
__END__
abc x abc y ___ z abc
abc x abc y abc z ___
abc x ___ y abc z ___
___ x ___ y ___ z ___
If appropriate, this could be added as an update to: How do I change the Nth occurrence of something?
|
Beautiful .. operator
on Oct 28, 2008 at 11:31
|
2 replies
|
by grizzley
|
Some time ago I was preparing some presentation about Perl and while reading about flip-flop I was wondering how to easily explain how it works. I couldn't. It works in such intuitive way one can tell "get me everything between /start/ and /stop/". But to explain how it does it, you need two pages of paper :) Ok, I exaggerate a little. Anyway, I discovered another useful construction with the same properties: it can be easily described as "take everything between /start/ and (/end/ which is not inside other /start/ .. /end/ block)". Or shorter: "take /start/ .. /end/ block which can include other /start/ .. /end/ blocks", but kids don't try to analyze it at home :) It can be easily extended to two or more levels of nesting. Pity, I didn't discover it before 'beautiful Perl YAPC'... :)
#!perl
while(<DATA>)
{
if(/start/ .. (!(/start/../end/) && /end/))
{ print }
}
__DATA__
a
a
a
start
b
start
c
d
e
end
f
start
g
h
i
end
j
end
k
k
l
|
Randomly select N lines from a file, on the fly
on Oct 08, 2008 at 21:00
|
1 reply
|
by blokhead
|
Many people know the trick from perlfaq about how to choose a line uniformly at random from a file (or pipe), without knowing a priori how many lines are coming.
Here is a generalization of the method that chooses a random subset (without repetition) of N random lines from a file. The method only needs to keep N lines of the file in memory. It also preserves the ordering of lines. If the little script is named sample, you use it like this:
$ sample 10 somelongfile.txt ## to get 10 random lines
$ some long command | sample 50 > mysample.txt
Proof of correctness is fairly straight-forward by induction.
Note: perlfaq recommends File::Random for the case of choosing 1 random line. And indeed, the random_line function in that module has an option to choose more than 1 line. However, it selects with repetition.
my $wanted = shift || 10;
my @got;
die "Invalid number of lines!\n" if $wanted < 1;
while (<>) {
if (@got < $wanted) {
push @got, $_;
} elsif (rand($.) < $wanted) {
splice @got, rand(@got), 1;
push @got, $_;
}
}
die "Not enough lines!\n" if @got < $wanted;
print @got;
|
|