Perl-Start

Inhaltsübersicht

Thumbnails mit Photoshop erzeugen

#! /usr/bin/perl

use strict;
use warnings;
use Win32::OLE;
use Win32::OLE::Const 'Adobe Photoshop';
use File::Spec;
use Getopt::Long;

my $size = 350;
my $dir;
my $help;

GetOptions('-d=s' => \$dir,
           '-s=n' => \$size,
           '-h'   => \$help,);

if($help || !$dir){
  print qq~
  Usage: $0 -d  [-s <width>][-h]
~;
  exit(0);
}

opendir(DIR,$dir) or die $!;
my @files = grep{$_ !~ /^\.\.?$/}readdir(DIR);
closedir DIR;

# start photoshop
my $ps = Win32::OLE->new('Photoshop.Application') or die $!;
$ps->{Visible} = 0;

foreach my $image_file(@files){

  $image_file = $dir.'/'.$image_file;

  # open image
  my $desc = $ps->MakeDescriptor();
  my $control = $ps->MakeControlObject();
  $desc->PutPath(phKeyNull,$image_file);
  $control->Play(phEventOpen,$desc,phDialogSilent);

  # autolevels
  $desc = $ps->MakeDescriptor();
  $control = $ps->MakeControlObject();
  $desc->PutBoolean(phKeyAuto, 1);
  $control->Play(phEventLevels,$desc,phDialogSilent);

  # resize image
  $desc = $ps->MakeDescriptor();
  $control = $ps->MakeControlObject();
  $desc->PutUnitDouble(phKeyWidth, phUnitPixels, $size);
  $desc->PutBoolean(phKeyConstrainProportions, 1);
  $desc->PutEnumerated(phKeyInterfaceIconFrameDimmed,phTypeInterpolation,phEnumBicubic);
  $control->Play(phEventImageSize,$desc,phDialogSilent);

  $control = $ps->MakeControlObject();
  my $d1 = $ps->MakeDescriptor();
  my $d2 = $ps->MakeDescriptor();
  $d2->PutEnumerated(phKeyPNGInterlaceType,phTypePNGInterlaceType,phEnumPNGInterlaceNone);
  $d2->PutEnumerated(phKeyPNGFilter,phTypePNGFilter,phEnumPNGFilterAdaptive);
  $d1->PutObject(phKeyAs,phClassPNGFormat,$d2);

  (my $outfile = File::Spec->rel2abs($image_file)) =~ s/\.+[^\.]+$/_thumb${size}.png/;
  $outfile =~ s/\s//g;
  print $outfile,"\n";

  $d1->PutPath(phKeyIn,$outfile);
  $d1->PutBoolean(phKeyLowerCase, 1);
  $control->Play(phEventSave,$d1,phDialogSilent);

  $desc = $ps->MakeDescriptor();
  $control = $ps->MakeControlObject();
  $control->Play(phEventClose,$desc,phDialogSilent);
}

$ps->Quit();

Beispiel1: Alle Links aus einer HTML Seite parsen

#! /usr/bin/perl
use strict;
use warnings;
use HTML::Parser;

my @links;
my $string = qq~<a href="url1">linktext1</a> Ein anderer Text
                <a href="url2">linktext2</a> text~;

my $p = HTML::Parser->new();
$p->handler(start => \&start_handler,"tagname,attr,self");
$p->parse($string);

foreach my $link(@links){
  print "Linktext: ",$link->[1],"\tURL: ",$link->[0],"\n";
}

sub start_handler{
  return if(shift ne 'a');
  my ($class) = shift->{href};
  my $self = shift;
  my $text;
  $self->handler(text => sub{$text = shift;},"dtext");
  $self->handler(end => sub{push(@links,[$class,$text]) if(shift eq 'a')},"tagname");
}

            

Beispiel2: Umwandlung von HTML in BBCode

#! /usr/bin/perl
use strict;
use warnings;
use HTML::Parser;

my ($author,$text);
my $p = HTML::Parser->new();
$p->handler(start => \&start_handler,"tagname,attr,self");
$p->parse_file('html.txt');

sub start_handler{
  return if(shift ne 'div');
  my ($class) = shift->{class};
  my $self = shift;
  if($class eq 'bbcode_quote_header'){
    $self->handler(text => \&get_author,"dtext");
  }
  elsif($class eq 'bbcode_quote_body'){
    $self->handler(text => sub{$text = shift;},"dtext");
  }
  $self->handler(end => sub{print '[quote='.$author.']'.$text.'[/quote]' if($class eq 'bbcode_quote_body')});
}

sub get_author{
  my ($test) = @_;
  $test =~ s/(.*?)\s+schrieb:\s*?$/$1/;
  $author = $test;
}

Erzeugen von JPG-Bildern

#! /usr/bin/perl

use strict;
use warnings;
use GD::Simple;
use Getopt::Long;


my ($height,$width,$output) = (100,100);
GetOptions('-h=n' => \$height, '-w=n' => \$width,'-o=s' => \$output);

my $foreground = 'green';
my $background = 'black';

my $img = GD::Simple->new($height,$width);
$img->bgcolor($background);
$img->fgcolor($foreground);

my $ascii = 'A';

$img->moveTo($height/2,$width/2);
$img->string($ascii);

my $gd_img = $img->gd();

open(TARGET,">$output") or die $!;
binmode TARGET;
print TARGET $gd_img->jpeg(100);
close TARGET;

OnClick-Event einer Listbox (Perl/Tk)

#! /usr/bin/perl 

use strict; 
use warnings; 
use Tk; 

my $text;
my $mw = MainWindow->new(); 
my $list = $mw->ScrlListbox(-label           => 'Single Selection', 
                            -selectmode      => 'single', 
                            -height          => 5, 
                            -exportselection => 0)->pack(); 
my $lbl = $mw->Label(-textvariable => \$text)->pack();

for(0..10){ 
  $list->insert('end',$_); 
} 

$list->bind('<Button-1>',\&showItem); 

MainLoop; 

sub showItem{ 
  $text = $list->Getselected(); 
}

Warnungen abfangen

#! /usr/bin/perl

use strict;
use warnings;

my $counter = 0;
my @warnings;
$SIG{__WARN__} = \&count;

my $string;

for(0..10){
  print $string,"\n";
}

print $counter," Warnungen\n";
print $_,"\n" for(@warnings);

sub count{
  $counter++;
  push(@warnings,@_);
}

Chart erstellen und mit Tk anzeigen

#! /usr/bin/perl

use strict;
use warnings;
use Chart::Plot;
use Tk;

my $mw = MainWindow->new();

#--
#  create a chart
#--
my @data = qw(20 25 60 25 40 10 100 35 50 55);

my $chart = Chart::Plot->new();
$chart->setData(\@data);

my $output = '/homes/reneeb/test.gif';
open(GIF,">$output") or die $!;
binmode GIF;
print GIF $chart->draw('gif');
close GIF;

#--
# show Photo
#--

my $photo = $mw->Photo(-file => $output);
$mw->Label(-image => $photo)->pack();

MainLoop;

HTML-Quelltext über Win32::OLE auslesen

#! /usr/bin/perl

use strict;
use warnings;
use Win32::Ole;

my $iex = Win32::OLE->new('InternetExplorer.Application');
$iex->SetProperty('Visible',1);
$iex->navigate('www.google.de'); 

my $html = join("",$iex->{Document}->{body}->{innerHTML});
print $html;

Fehler in Tk::Text farbig darstellen

#!/usr/bin/perl

use strict;
use warnings;
use Tk::Text;
use Tk;

my $mw = tkinit;
my $text = $mw->Text()->pack;
$text->tagConfigure('red_text', -foreground => 'red');

my $line = 0;

while( my $inhalt =  ){
    $text->insert('end',$inhalt );
    ++$line;
    
    if( $inhalt =~ /^Fehler:/ ){
        $text->tagAdd('red_text',$line . ".0" , $line . "." . length $inhalt);
    }

}


MainLoop;

__DATA__
Dies ist ein Test!
Fehler: Laeuft nicht
Eine Zeile dazwischen.
Noch eine Zeile
Fehler: fehlerhafte Zeile
Fehler: noch ein Fehler
Alles ok!

CSV-Dateien als Datenbank behandeln

KonfID;KonfName;Monat
1;Perl-Workshop;Februar
2;YAPC::Europe;August
3;FrOSCon;August
4;"Linux-Tage Essen";November

#!/usr/bin/perl

use strict;
use warnings;
use DBI;

use Data::Dumper;

#Ordner, in dem die CSV-Datei liegt
my $dir = '.';

#Trennzeichen in der Datei (hier: das Semikolon)
my $sep = ';';

#Verwende DBI mit DBD::CSV damit mit den
#CSV-Dateien gearbeitet werden kann
my $dsn = "DBI:CSV:csv_sep_char=\\".$sep;

my $dbh = DBI->connect( $dsn,"","" ) or die $DBI::errstr;
$dbh->{'RaiseError'} = 1;

#SQL-Statement
my $select = qq~SELECT KonfName 
        FROM konferenzen 
        WHERE Monat = ?~;

my $gesuchter_monat = 'August';

# Abfrage ausfuehren
my $sth = $dbh->prepare( $select ) or die $dbh->errstr;
$sth->execute( $gesuchter_monat ) or die $dbh->errstr;

# Ausgabe Ergebnis
print "Konferenzen im $gesuchter_monat:\n";
while( my ($conf) = $sth->fetchrow_array ){
 print "\t",$conf,"\n";
}

C:\>csv_beispiel.pl
Konferenzen im August:
       YAPC::Europe
       FrOSCon