map {if (/^".*"$/) {s/\s*"\s*//g; push @fields, $_;} else {push @field
+s, split /\s*,\s*/;}} split /,*("[^"]*"),*/, $line;
[download]

#!/usr/bin/perl -w
use strict;

use Term::ReadLine;
# for correction and command history you must have
# Term::ReadLine::Gnu (from CPAN) installed

my $term = new Term::ReadLine 'regexp Smode';
my $pr1 = "string: "; my $pr2 = "replace: "; 
my $pr3 = "with: "; my $pr4= "suffix: ";
my $OUT = $term -> OUT || *STDOUT;
my $output;

while (1) {
        my $string = $term -> readline($pr1);
        my $replace = $term->readline($pr2);
        my $with = $term->readline($pr3);
        my $suffix = $term->readline($pr4);
        eval{ eval "(\$output = \$string) =~ s/\$replace/\$with/$suffi
+x" };
        print $OUT "$output\n";
}
[download]

#!/usr/bin/perl -w
use strict;

my $regexp = $ARGV[0] || die "\nREQUIRES COMMAND-LINE ARGUMENT\n";
my $dir;
if (defined($ARGV[1])) {$dir = $ARGV[1]}
else {$dir = `pwd`}
chomp $dir;

print "\"$regexp\" in $dir/*.pl:\n";

my (%N_index, @files);

opendir(DIR, $dir) || die "can't open $dir";
@files = readdir(DIR);
closedir(DIR);

foreach my $pl (@files) {
        if ($pl =~ /\.pl$/) {
                my $content;
                open (PL, "<$dir/$pl") || die "can't open $dir/$pl"; 
#while (<PL>) {
                $content = do {local $/; <PL>};
#} that was the deleted "while loop"
                close (PL); my $N; 
                if ($content =~ /$regexp/) {
                        $_=$content;
                        $N =()= /$regexp/g;
                        $N_index{$pl}=$N;
                }   
        }   
}

my @rank = sort {$N_index{$b} <=> $N_index{$a}} keys %N_index;
foreach (@rank) {print "\t$N_index{$_} -- $_\n";}
[download]

use strict;
use Win32::API;

print "Getting API function\n";
my $hllapi = new Win32::API('D:/PC3270W/EHLAPI32.dll', 'hllapi', ['P',
+'P','P','P'], 'N');
die("oups not created") unless(defined($hllapi));

print "Connecting to session A";
my $fct=pack('L', 1);
my $connBuffer="A"."\0" x 3;
my $connBufferLen = pack('L', 4);
my $returnCode=pack('L',13);
$hllapi->Call($fct,$connBuffer,$connBufferLen,$returnCode);
my $ret=unpack('L',$returnCode);
print "return code -$ret-\n";
die("oups") if($ret != 0);

print "Trying sendkeys - JD\n";
$fct=pack('L', 3);
my $keys='JD@E';
my $keysLengh=pack('L', 4);
$hllapi->Call($fct,$keys,$keysLengh,$returnCode);

print "Waiting for command to be finished\n";
$fct=pack('L',4);
my $a="\0";
my $b=pack('L',0);
my $rc=pack('L',0);
$hllapi->Call($fct,$a,$b,$rc);

print "Reading screen\n";
$fct=pack('L',8);
my $readBuf= "\0" x 3000;
my $lenToRead=pack('L',1920);
my $offset=pack('L',1);
$hllapi->Call($fct,$readBuf,$lenToRead,$offset);

for(my $k=0;$k<24;$k++){
    my $offset=$k*80;
    print substr($readBuf,$offset,80)."\n";
}
print "\n";

exit(0);
[download]

--- /home/dpavlin/.cpan/build/Module-Install-0.68/lib/Module/Install/A
+utoInstall.pm     2007-10-31 11:34:27.000000000 +0000
+++ /usr/local/share/perl/5.8.8/Module/Install/AutoInstall.pm   2008-0
+3-12 20:58:01.000000000 +0000
@@ -30,6 +30,15 @@
     my @core = map @$_, map @$_, grep ref,
                $self->build_requires, $self->requires;
 
+       my @debs;
+       while ( my $module = shift @core ) {
+               my $ver = shift @core;
+               my $deb = 'lib' . lc($module) . '-perl';
+               $deb =~ s/::/-/g;
+               push @debs, $deb;
+       }
+       system "sudo apt-get install @debs";
+
     my @config = @_;
 
     # We'll need Module::AutoInstall
[download]

sub countLines
{
    my $filename=shift(@_);
    die("amaUtils:countLines:invalid filename") if(length($filename)==
+0);
    open(TMP,"<$filename") or die("amaUtils:countLines unable to open 
+file $filename");
    my $nb=0;
    $nb += tr/\n/\n/ while sysread(TMP, $_, 2 ** 16);
    close TMP;
    return $nb;
}

sub split_file
{
    my $filename=shift(@_);
    my $nbFiles=shift(@_);
    die("amaUtils:split_files invalid number") if($nbFiles !~ /^\d+$/)
+;
    die("amaUtils:split_files invalid number") if($nbFiles < 1);
    my $curNb=1;
    my $totalCount=countLines($filename);
    my $nbLinesPerFile=int($totalCount/$nbFiles);
    $nbLinesPerFile++ if( ($nbLinesPerFile * $nbFiles)!=$totalCount);
    my $currentCount=0;
    open(ORIG,"<$filename");
    my ($newfile,$ext)=split(/\./,$filename);
    open(DEST,">${newfile}_".sprintf("%02d",${curNb}).".$ext");
    while(<ORIG>) {
        if($currentCount==$nbLinesPerFile) {
            close DEST;
            $curNb++;
            $currentCount=0;
            open(DEST,">${newfile}_".sprintf("%02d",${curNb}).".$ext")
+;
        }
        print DEST $_;
        $currentCount++;
    }
    close DEST;
    close ORIG;
}
[download]

#!/usr/bin/perl
use warnings;
use strict;
use Tk;

# an 8 x 13 grid
my @keys = (
'~','`','!','@','#','$','%','^','&','*','(',')','_',    
'1','2','3','4','5','6','7','8','9','0','-','+','=',  
'Q','W','E','R','T','Y','U','I','O','P','{','}','"', 
'q','w','e','r','t','y','u','i','o','p','[',']','\'',
'A','S','D','F','G','H','J','K','L',':','|','\\','/',
'a','s','d','f','g','h','j','k','l',';','<','>','?', 
'Z','X','C','V','B','N','M','BackSpace','dummy','dummy','dummy','dummy
+','dummy',
'z','x','c','v','b','n','m','.','Clear','dummy','dummy','dummy','dummy
+');

#print "@keys\n";

my $mw=tkinit;

$mw->fontCreate('big',
   -family=>'arial',
  -weight=>'bold',
  -size=>int(-18*18/14));

 my $tframe = $mw->Frame()->pack(-expand=>1,-fill=>'both');   
 my $passwd = '';
 my $label = $tframe->Label(-text => "Password: ",
                            -font => 'big',
 )->pack(-side=>'left');
 
 my $entry = $tframe->Entry(
         -show => '*',
         -textvariable => \$passwd,
         -bg => 'black',
         -fg => 'white',
         -font => 'big',
         )->pack(-side=>'left',-expand=>1,-fill=>'x', -padx=> 5);

 my $submit = $tframe->Button(
                 -text=>'Submit',
                 -font => 'big',
                 -bg => 'yellow',
                 -activebackground => 'hotpink',
                 -command => \&submit,
          )->pack(-side=>'right',-expand=>1,-fill=>'x', -padx=> 5);


 for my $row (1..8){
    my $frame = $mw->Frame()->pack(-expand=>1,-fill=>'both');   
   
   for my $col (1..13){
     my $l = shift @keys;
     if($l eq 'dummy'){next}else{
          $frame->Button(-text=> $l,
               -bg => 'beige',
               -activebackground => 'lightyellow',
               -font => 'big',
               -command => [\&process_key, $l],
                 )->pack(-side=>'left',-anchor=>'w', -expand=>1,-fill=
+>'both');   
          
      }
   }
 
 }
MainLoop;
#####################
sub process_key{
  my $key = shift;
  print "$key\n";
  if ($key eq 'Clear'){$passwd = '';}
  elsif ($key eq 'BackSpace'){ chop $passwd;}
  else{ $passwd .= $key;}

}
#####################
sub submit {
 print $entry->get(),"\n";
 $entry->delete(0,'end');
}
[download]

{
my $hypertext_tag_name = 't000000'; # candidate for 'static'

# returns the tag name, in case there's anytyhing else
# you'd like to do with it.
sub Tk_Text_insert_active_text
{
    my( $Text, $linktext, %callbacks ) = @_;
    my $start_index = $Text->index( 'insert' );
    $Text->insert( insert => $linktext );
    my   $end_index = $Text->index( 'insert' );

    my $link_tag_name = ++$hypertext_tag_name;
    $Text->tagAdd( $link_tag_name, $start_index, $end_index );
    $Text->tagConfigure( $link_tag_name, -foreground => 'blue', -under
+line => 1 );

    $Text->tagBind( $link_tag_name, $_ => $callbacks{$_} ) for keys %c
+allbacks;

    $link_tag_name
}
}

# Example: make a real link:

sub Tk_Text_insert_hyperlink
{
    my( $Text, $url, $title ) = @_;

    Tk_Text_insert_active_text( $Text, $title,
        '<ButtonPress>' => sub { system $url }, # launch in system bro
+wser
        '<Enter>' => sub { set_status_bar($url) },
        '<Leave>' => sub { set_status_bar('') },
    );
}
[download]

print cmpHtml(
    '<p><font foo="bar" bar="1">bar 1</font></p>',
    '<p><font bar="2" foo="bar">bar 1</font></p>'
);
[download]

print cmpHtmlElt ($elt1, $elt2);
[download]

sub cmpHtml {
    my ($html1, $html2) = @_;
    my $root1 = HTML::TreeBuilder->new;
    my $root2 = HTML::TreeBuilder->new;

    $root1->parse_content ($html1);
    $root1->elementify    ();
    $root2->parse_content ($html2);
    $root2->elementify    ();

    return cmpHtmlElt ($root1, $root2);
}

sub cmpHtmlElt {
    my ($elt1, $elt2) = @_;

    my $cmp = defined $elt1 cmp defined $elt2;
    return $cmp if $cmp;
    return 0 unless defined $elt1;

    $cmp = ref $elt1 cmp ref $elt2;
    return $cmp if $cmp;
    return $elt1 cmp $elt2 unless ref $elt1;

    $cmp = $elt1->tag () cmp $elt2->tag ();
    return $cmp if $cmp;

    my %attribs1 = $elt1->all_attr ();
    my %attribs2 = $elt2->all_attr ();

    $cmp = keys %attribs1 <=> keys %attribs2;
    return $cmp if $cmp;

    for my $key (keys %attribs1) {
        return 1 unless exists $attribs2{$key};
        next if $key =~ /^_/;

        $cmp = $attribs1{$key} cmp $attribs2{$key};
        return $cmp if $cmp;
    }

    my @children1 = $elt1->content_list ();
    my @children2 = $elt2->content_list ();

    $cmp = @children1 <=> @children2;
    return $cmp if $cmp;

    for my $index (0 .. $#children1) {
        $cmp = cmpHtmlElt ($children1[$index], $children2[$index]);
        return $cmp if $cmp;
    }
}
[download]