LevSelector.com New York
home > Perl examples

Perl examples - Under construction - but still useful.
This page Other pages
- first program
- first CGI script
- send email
- read file
- process file
- extract emails		 - web robots_http_clients
- factorial
- command line args
- external programs
-
-		 - dbi_oracle
- dbi_mysql
- dbi_sybase
- dbi_db2
- email_arttachments
- my grep
- hash array init		 -
-
-
-
-

 
First programs home - top of the page -

First program prints the word Hello:
#/usr/local/bin/perl
print "Hello\n";		   first line (also called "shebang-line)- tells where perl compiler is
\n - end of the line (start new line) symbol

First CGI script:
#/usr/local/bin/perl
$|++;
print "Content-type: text/html\n\n";
print "<html>Hello</html>\n";		   $|   is a special variable which controls bufferring of the output. It has an undef-value by default. It is a good idea to set it (increase to 1 in this example) to turn off bufferring.

Note that the "Content-type" line has 2 "\n" symbols at the end - thus there is an empty line between the header and the html itself.

Sending email (simple example using external program sendmail, plain text, no attachments):
$sendmail' => '/usr/sbin/sendmail -t -oi';
open(MAIL,"|$sendmail");
print MAIL <<EOM;
From: $from_email ($from_name)
To: $to_email ($to_name)
Subject: $subject

$email_txt
EOM
close(MAIL);

Read a text file "file1.txt" and print it line by line on the screen:
#/usr/local/bin/perl
use strict;
my $fname = "file1.txt";
open(IN, $fname) or die "can't open file $fname: $!";
while (my $line = <IN>) { print $line; }		   "use strict" pragma - always use it when using variables
variable may contain text or number
when opening file - provide a way to exit (die) and show the error ($!).

Extract emails from a text file:
  read a source text file "s.txt",
  find lines which contain '@' in them
  and print only these lines into the destination file "d.txt":
#/usr/local/bin/perl
open(IN, "s.txt") or die "can't open file for reading: $!";
open(OUT, ">d.txt") or die "can't open file for writing: $!";
while (<IN>) {  if (/@/) { print OUT; }}

Now a longer version of the same email-extracting program.
It is a real script I used when looking for a job.
It uses many idioms which were not explained yet:
  #---------------------------------------------------------------
  # conv.pl - utility to extract emails from bunch of text advertisings
  # The program reads source file <s.txt>,
  # selects lines with a "@" symbol, cleans them, removes duplicates,
  # and stores in the array
  # sorts this array of emails by domain name (tail after "@")
  # saves these emails into the file <d.txt>.
  #---------------------------------------------------------------

  use strict;

  my @data=();
  open (IN,"s.txt");
  while ( <IN> ){
    if (/@/) { chomp; push @data, $_; }
  }
  close (IN);

        #-----   clean emails   -----#

  for (@data) {
    tr/[A-Z]/[a-z]/;
    s/e(-|:|\s+)?mail:?\s*//;
    s/(^\s+|\s+$)//g;
    s/[.,]$//g;

    s/<br>//g;
    s/<\/a>//g;
    s/^[^@]*?mailto://;
    s/\?subject.*//;
  }

        #-----   remove duplicates  -----#

  my %myhash=();
  @myhash{@data} = ();  # intialize hash to undef values using slice syntax
  @data =keys %myhash;

        #-----   sort by domain name   -----#

  my @sorteddata =         # Schwartzian Transform:
    map {$_->[0]}            # map back
    sort { $a->[1] cmp $b->[1] } # sort by cleanned element
    map { m/@([a-zA-Z0-9\-.]*)\b/; [$_, $1]} # map to a list anon.2-element arrays
  @data;

        #-----   write to file   -----#

  open (OUT,">d.txt");
  map { print $_ , "\n"; print OUT $_ , "\n"; } @sorteddata;
  close (OUT);
  exit(0);
  __END__

With Perl it is easy to make automatic robots browsing Internet.
Here is how simple it is to get the html source text of some internet page:
use LWP::Simple; 
$text = get('http://www.someaddress.com');

Calculations example: asking for input and calculate factorial
use strict;

# ---- recursive function ----
sub factorial {
  my $k = shift;
  return 1 if $k<=1;
  return $k*factorial($k-1);
}

print"Calculating factorial\n";
while(1) {
  print "Enter number (^C to exit):";
  my $n=<>; chomp($n); $n = int($n);
  if($n<1) { print "need integer >1\n"; next; } 
  print "factorial of $n is ",&factorial($n),"\n";
}

Command line parameters:
use strict;
if (! @ARGV) {
  print"you entered no parameters\n"; 
  exit;
}
print"you entered ", scalar @ARGV, " parameters:\n";
for (@ARGV) { print "$_\n"; }

Run external programs from inside perl - and gather their output:
# --- run another program (returns error code)
  system $command, @args;

# --- gather ouput from another program
  $output = `program args`;   # backticks
  $output = qx(program args); # same as using backticks
  @aoutput = qx(program args); # collect output into array of lines

 
database home - top of the page -

Here is a CGI script which queries the Oracle database and shows results on the browser:
#!/usr/local/bin/perl 
$|++;
use DBI;
$ENV{ORACLE_HOME}='/usr/local/oracle/8i/u01/app/oracle/product/8.1.6';

my $dbh = DBI->connect("dbi:Oracle:starter", "scott", "tiger", 
                     { RaiseError => 1, PrintError => 1 } ) 
                 or die $DBI::errstr;

my $sql = "SELECT * FROM EMP";
my $sth = $dbh->prepare($sql);
my $rv  = $sth->execute();

print "Content-Type: text/html\n\n";
print "<html><head><title>test oracle</title></head><body><table>\n";

while(@row = $sth->fetchrow_array) {
  print "<tr>\n";
  map { print "<td>$_</td>\n"; } @row;
  print "</tr>\n";
}

print "</table></body></html>\n";
$dbh->disconnect;

Similar example for MySQL:
$dbh = DBI->connect( "dbi:mysql:somedatabase", "somename", "",
                     { PrintError => 0 })
       or die "Can't connect to mysql database: $DBI::errstr\n";

$in{fname} = 'John';
$in{lname} = 'Smith';

$sth = $dbh-> prepare ( "INSERT into MyTable (fname, lname) 
                         values ('$in{flname}', '$in{lname}')" );
$sth->execute();

$sth = $dbh-> prepare ("select fname, lname from MyTable");
$sth->execute();

# ....

while( @data = $sth->fetchrow_array ) {
  print "<tr><td>$data[0]</td><td>$data[1]</td></tr>";
}

Similar example for Sybase:
#!/usr/bin/perl
use DBI;
use strict;

# ....

$dbh = DBI->connect("dbi:Sybase:$server", "$user", "$password")
      or die "Cannot log into $server\n";
  ($dbh->do("use $dbname") != -2)
      or die "Cannot switch to $dbname\n";

&get_info();
&finish();

# ------------------------------------------------------------------
# exec_sql()
# ------------------------------------------------------------------
sub exec_sql {
   my $sql = shift;
   my $sth = $dbh->prepare($sql) 
      or die "Can't prepare SQL statement: $DBI::errstr\n";
   $sth->execute 
      or die "Can't execute SQL statement: $DBI::errstr\n";
   return $sth;
}

# ------------------------------------------------------------------
# get_info()
# ------------------------------------------------------------------
sub get_kerb {
  my $sql = "select * from somedb..sometbl where fname is not null";
  my $sth = exec_sql($sql);
  my $hash_ref = '';
  my @result=();
  while ( $hash_ref = $sth->fetchrow_hashref()) {
    my $kid = $hash_ref->{kid};
    my $fname = $hash_ref->{fname};
    my $lname = $hash_ref->{lname};
    my $email = $hash_ref->{email};
    my $phone = $hash_ref->{work_phone};
    push @result, "$kid - $lname, $fname - $email - $phone";
  }
  $sth->finish();
  if (! @result) { print "nothing found\n"; return; }
  for (@result) {print "$_ \n";}
}

# ------------------------------------------------------------------
# finish()
# ------------------------------------------------------------------
sub finish {
   debug "finishing\n";
   $dbh->disconnect;
}

__END__

Similar for DB2 - here is a comparison side by side: db2 vs Sybase::
#!/usr/local/bin/perl

use DBI;

db2_example();
syb_example();

# ------------------------------------------------------------------
#  db2_example()
# ------------------------------------------------------------------
sub db2_example {

    my $database = "sample";
    my $dbh = DBI->connect("dbi:DB2:$database")
         || die "Cannot log into $database\n";

    my $sql = "select TABSCHEMA, TABNAME from syscat.tables" ;

    my $sth = $dbh->prepare($sql)
        or die "Can't prepare SQL statement: $DBI::errstr\n";

    $sth->execute
        or die "Can't execute SQL statement: $DBI::errstr\n";

#    while( @row = $sth->fetchrow ) { print @row; }
    while ($hash_ref = $sth->fetchrow_hashref()) {
        foreach $k (keys %$hash_ref) {
            printf("%-30s %-30s\n", $k, $hash_ref->{"$k"});
        }
        print '-' x 77 . "\n";
    }
    $dbh->disconnect;
}

# ------------------------------------------------------------------
#  syb_example()
# ------------------------------------------------------------------
sub syb_example {
    my $server = 'xxx'
    my $user   = 'yyy';
    my $pass   = 'zzz';
    my $dbname = 'mydb';

    my($dbh) = DBI->connect("dbi:Sybase:$server", "$user", "$pass")
         || die "Cannot log into $server\n";

    if (defined ($dbname) && $dbname ne "") {
        ($dbh->do("use $dbname") != -2)
            || die "Cannot switch to $dbname\n";
    }

    my $sql = "select name from sysobjects" ;

    my $sth = $dbh->prepare($sql)
        or die "Can't prepare SQL statement: $DBI::errstr\n";

    $sth->execute
        or die "Can't execute SQL statement: $DBI::errstr\n";

    my $hash_ref = $sth->fetchrow_hashref();
    $sth->finish();
    $dbh->disconnect;
}

Sending email with an attachment - this is what I use often:
#!/usr/local/bin/perl
# mymail - script to send email with attachments
# Usage: mymail <from> <to> <subject> file file ...

use MIME::Lite;   # Standard CPAN module

# ----- Select parameters.
$from = $ARGV[0];
$to = $ARGV[1];
$subj = $ARGV[2];
@files = @ARGV[3..$#ARGV];

# ----- Define association of some file extensions with mime types
%mime_type = (
 eps => 'application/postscript',
 ps => 'application/postscript',
 pdf => 'application/pdf',
 log => 'text/plain',
 gif => 'image/gif'
);

# ----- Create a new multipart message:
$msg = new MIME::Lite
 From    =>$from,
  To      =>$to,
  Subject =>$subj,
  Type    =>'multipart/mixed';

# ----- Attach files
foreach $file (@files) {
  $file =~ /\.([^.]+)$/;
  $ext = $1;
  $msg->attach(
   Type=>$mime_type{$ext},
   Encoding=>'base64',
   Path=>$file
 );
}

# ----- Send via sendmail.
$msg->send;

Emulating built-in functions which accept code ref (like map or grep):
sub mygrep (&@) {
  my $coderef = shift;
  my @result;
  for (@_) {
    push (@result,$_) if &$coderef; # do grep filtering here
  }
  return @result;
}

my @ar1 = qw(1 2 3 4 5);
my @ar2 = mygrep { $_ >=3 } @ar1;
print "@ar2\n";

 
use strict;

my %hh=();
my @aa = (1..1000);

## ----- example of initializing a hash using a slice syntax - very fast:

@hh{@aa}=();

print "created ", scalar keys %hh, " hash elements
press any key to continue\n";
<>;

## ----- example of initializing a hash using a map syntax - fast and convenient:

%hh = map { ($_,1) } @aa;
for (sort {$a <=> $b} keys %hh) { print "$_ => $hh{$_} \n"; }

-----------------------------------------------

misc examples of idiomatic perl:
use strict;

print "---------- default values\n";
my $val;
print "defined \$val\n" if (defined $val);
print "zero value \$val\n" if ($val == 0);  # this will print
print "zero width \$val\n" if ($val eq ""); # this will print

print "---------- splitting \$_ by whitespace\n";
$_ = 'aa    bb cc      dd    ee';
my @aa = split;
for (@aa) {print"$_\n"}

print "---------- substitute in \$new but not \$old\n";
my ($old, $new) = ("bad man","");
($new = $old) =~ s/bad/good/g;
print "$old\n";
print "$new\n";

print "---------- same on arrays \@new, \@old\n";
my (@old,@new);
@old = qw(bad1 bad2 bad3);
for (@new = @old) {s/bad/good/g}
print "@old\n";
print "@new\n";

print "---------- how many lines started with these 4 words?\n";
my $words="fee fie foe foo";
print "$words\n";
my %seen;
while(<DATA>) {
  my ($a,$b,$c,$d) = split;
  print unless $seen{$a}{$b}{$c}{$d}++;
}
if (my $tmp = $seen{fee}{fie}{foe}{foo}) {
  printf qq(Saw $words %d time%s.\n),
    $tmp, $tmp==1 ? "":"s";
}
__END__
fee fie foe foo    aa    bb cc      dd    ee
fee1 fie foe foo    aa    bb cc      dd    ee
fee fie       foe foo    aa    bb cc      dd    ee
fee fie2 foe foo    aa    bb cc      dd    ee
fee       fie foe foo    aa    bb cc      dd    ee
aa  bb cc    dd    ee

 
count the number of returned values

$count = () = function();
sub aa {return (2,3,4);}
$count = () = &aa();  ## -- cool
print "$count\n";

JAPH - Just Another Perl Hacker - some examples
print map { chr } ('10611711511603209711011111610410'.
 '1114032112101114108032104097099107101114') =~ /.../g;

tie $" => A; $, = " "; $\ = "\n"; @a = ("") x 2; print map {"@a"} 1 .. 4;
sub A::TIESCALAR {bless \my $A => A}
sub A::FETCH     {@q = qw /Just Another Perl Hacker/ unless @q; shift @q}

Here is an explanation for the 2nd one:
tie $" => A;  # means calling function A::TIESCALAR
$, = " "; # to separate words while printing
$\ = "\n"; # to print "\n" at the end of print statement
@a = ("") x 2; # creates a dummy array with 2 elements
print map {"@a"} 1 .. 4; # prints dummy array 4 times
                         # each time a separator $" is inserted between elements
                         # thus each time A::FETCH is called - prints next word

sub A::TIESCALAR {
  bless \my $A => A # bless reference of "my" variable $A to package A
}                   # and returns it

sub A::FETCH {
  @q = qw/Just Another Perl Hacker/ unless @q; # creates a 4-element's array
  shift @q;    # returns next word each time it is called
}

for more examples, just search for JAPH on Google.
You will get hundreds of examples:
  www.perl.com/CPAN-local/misc/japh

----------------------------------