Search This Blog

Tuesday, January 15, 2013

Example perl scripts.

This post is a place where perl scripts or fragments are recorded, hopefully there will be useful annotations.
For me Perl is the sort of language where I find it difficult to remember the particulars of the syntax.

Example 1 - Simple DBI Script.

#!/usr/local/perl/bin/perl -wT
#
use strict;
use DBI();
my $query;
my $sthinsert;
my $sthcommit;
my $dbuser='dbuser';
my $dbpass='dbpassword';

my $dbh = DBI->connect("DBI:Oracle:host=localhost;sid=oradbname",
  $dbuser, $dbpass, {'RaiseError' => 1});

if ($#ARGV != 0) {
die "Usage: $#ARGV load.pl \n";
}
my $doclist =shift;
open(DOCLIST, $doclist) || die "$! - input file: $doclist\n";

$query = 'INSERT INTO missingdocs_full (doc_id) VALUES (?)';
$sthinsert = $dbh->prepare($query);
$query = 'COMMIT';
$sthcommit = $dbh->prepare($query);

my $rowcount = 0;
while () {
 chop $_;
print "Inserting [$_]\n";
 $sthinsert->execute($_)
   or warn('db line '.$rowcount.' insert '.$_.' insert error: '.$sthinsert->errstr);
   $rowcount++;
 if (  ! ($rowcount % 100)) {
  $sthcommit->execute();
 }
 
}

Notes:
  • Use strict, taint and warnings are turned on.
  • This example uses the Oracle DBD driver, the connect string for this is slightly different to the more commonly used MySQL.
  • The example checks for expected arguments and prints a meaningfull message if they are not found. This is useful if re-running or re-using the (once-only) script several months later.
  • Prepared SQL statements are used, this is useful as they may be executed many times (given the length of the input file).
  • The results of the file open and database calls are checked and logged.
  • Oracle in the default configuration requres an explicit commit, the script will commit after every 100 inserts (too frequent commits can cause load issues on the server).
  • The input data is read and the trailing carriage return/line feed is removed, note if run on Linux you will need to check the file line terminators - if generated on Windows and then uploaded.
  • Note no checking/validation is done on the source data.

Example 2 - Mysql - CGI - File Upload Example:

This is a multi-purpose script that provides a user entry feedback form - with file upload, an ajax lookup and a database insert.
The file upload example and handling of the taint flag are from perlmonks.org
The CGI, HTML::Template and JSON modules are used.
The Ajax search on the client uses the JQuery module jqeasy.com jquery autosuggest plugin and the validation module docs.jquery.com Validation
This script does 3 things,
1) displays a search form
2) responds to an AJAX request.
3) responds to a POST request - together with file upload.


#!/usr/bin/perl -wT
#
# fileupload - with taint flag
use strict;
use Crypt::Rot13;
use HTML::Template;
use CGI qw(:standard);
use JSON;
use CGI::Carp qw(warningsToBrowser fatalsToBrowser);
use File::Basename; $CGI::POST_MAX = 1024 * 20000; 
use DBI();
my $safe_filename_characters = "a-zA-Z0-9_.-"; 

my $upload_dir = "/home/www/prsubmit"; 

sub AJAX_SEARCH{}

sub PROCESS_FORM{}



############## Main ###################

my $formPost = 1;
my $method = $ENV{'REQUEST_METHOD'};
$formPost = 0 if ($method eq "GET");

my $ajax=0;
my $lookupdata='';
my $max_results=10;
my $sql_match_type='company';
if ( ! $formPost && param('data')) {
 $ajax=1;
 $lookupdata = param('data');
 $max_results = param('max_results');
 $sql_match_type = param('sql_match_type');
}

my $query;
my $sth;
my  $gpress_user = "dbuser";
my  $gpress_pass = "dbpassword";
my  $gpress_host = "localhost";
my  $gpress_db   = "mysqldbname";

my $dbh = DBI->connect("DBI:mysql:database=${gpress_db};host=${gpress_host}",
  $gpress_user, $gpress_pass, {'RaiseError' => 1});

my ($companyId);
my $inputstring;

#ajax search
if ( $ajax ) {
 warn("lookupdata: $lookupdata, sql_match_type: $sql_match_type, max_results: $max_results\n");
 my $searchresults=AJAX_SEARCH($dbh, $lookupdata, $sql_match_type, $max_results);
 print "Content-type: text/html; charset=iso-8859-1\n\n";
 print $searchresults;
 $dbh->disconnect();
 exit; 
}

if (param('company_id')) {
 $companyId = param('company_id');
 %companyDetails = GET_COMPANY($dbh, $companyId);
}

my $template;
if (! $formPost) {
 $template = HTML::Template->new(filename => '/home/www/cgi-bin/prsubmitinline.tmpl');
 $template->param(
   COMPANY_ID => $encCompanyId
  ,REQUEST_ID => $requestId
  );

} else {
 my $insertId = PROCESS_FORM ($dbh, $companyId);
 $template = HTML::Template->new(filename => '/home/www/cgi-bin/prsubmitresponseinline.tmpl');
 $template->param(
   LOGO_URL => $companyDetails{'logourl'},
   INSERT_ID => $insertId
  );
}
print "Content-type: text/html; charset=iso-8859-1\n\n";
print $template->output;
$dbh->disconnect();
exit;


Notes:
sub AJAX_SEARCH{
 my $dbh=shift;
 my $lookup_data=shift;
 my $match_type=shift;
 my $max_results=shift;
 my $like_value;

 my %row_data;
 my $query;
 $like_value = $lookup_data.'%';
 if ( $match_type eq 'email') {
  $query = "SELECT companyid, feedback_recipient from companies where feedback_recipient LIKE '${like_value}' limit ${max_results}";
 } else {
  $query = "SELECT companyid, companyname from companies where companyname LIKE '${like_value}' limit ${max_results}";
 }

 my($resultid, $resultname);
 my $sth;
 $sth = $dbh->prepare($query);
 $sth->execute()   || die "Failed: $query\n";
 $sth->bind_columns(undef, \$resultid,\$resultname);
 while ($sth->fetch()) {
  $row_data{$resultid}= $resultname;
 } 
 $sth->finish();

 return encode_json \%row_data;
}; ##GET_COMPANY

AJAX_SEARCH

When using the JQuery jqEasySuggest plugin, the following parameters can be configured:
data - query string, max_results - number of results to return and sql_match_type - typically a starts with or contains option.
In this example the sql_match_type is used to determine which field to match on.
Any matches are saved in a hash array ( id ->name ) and the JSON module encodes these.
This is then sent back to the client (after a Content-type tag) and the script exits.

The JSON module saves the

sub PROCESS_FORM{
 my $dbh=shift;
 my $companyId=shift;

 my  @form_fields = qw{category realname email company_id company phone title comments image1 image1caption};   
 my %form_data;
 ##tbd clean
  foreach my $ff (@form_fields) {
   $form_data{$ff} =  param($ff);
  } 

 my @news_types = param('news_type');
 $form_data{'news_type'}='';
 foreach my $news_type (@news_types) {
    $form_data{'news_type'} .= $news_type.':';
 }

 my ($query, $sthinsert, $insertId, $sthtest);
 $query = "insert into test(news_type, category, realname, emailaddress, company, company_id, phonenumber, title, image1file, image1caption, article_text)values(?,?,?,?,?,?,?,?,?,?,?)";
  $sthtest = $dbh->prepare($query);
 $sthtest->execute($form_data{'news_type'},$form_data{'category'},$form_data{'realname'},$form_data{'email'},$form_data{'company'},
  $form_data{'company_id'},$form_data{'phone'},$form_data{'title'},
  $form_data{'image1'},$form_data{'image1caption'},$form_data{'comments'});
  my $sthid = $dbh->prepare('SELECT LAST_INSERT_ID();');
  $sthid->execute();
  $sthid->bind_columns(undef, \$insertId);
  $sthid->fetch();

 warn("test insert id: ${insertId}");
 if (param('image1')) {
  my $filename = param('image1');
  my ( $name, $path, $extension ) = fileparse ( $filename, '\..*' ); 
  $filename = $name . $extension; 
  $filename =~ tr/ /_/;
  $filename =~ s/[^$safe_filename_characters]//g;
  if ( $filename =~ /^([$safe_filename_characters]+)$/ ) { 
     $filename = $1; 
   my $upload_filehandle = param('image1'); 
   open ( UPLOADFILE, ">${upload_dir}/${insertId}_1_${filename}" ) or die "$!"; 
   binmode UPLOADFILE; 
   while ( <$upload_filehandle> ){ 
       print UPLOADFILE; 
   } 
   close UPLOADFILE; 
   ##warn("imagefile: |$upload_dir/$insertId$filename|"); #"
    }
 }  
 
 return $insertId;
  
}
The PROCESS_FORM

Perl References -Reading Apache Config File


2 comments:

  1. PERL Online Training
    http://www.21cssindia.com/courses/perl-online-training-36.html
    Course Contents
    Command line options
    Syntax
    Variables
    Literals
    Operators and precedence
    Statements
    Subroutines, packages and modules
    Pragmatic modules
    Object oriented programming
    21st Century providing Online training and support on All Technologies. If you are seeking training and support you can reach me on 91-9000444287. Online training by real time Experts. Call us 001-309-200-3848 for online training

    ReplyDelete
  2. PERL Online Training, ONLINE TRAINING – IT SUPPORT – CORPORATE TRAINING http://www.21cssindia.com/courses/perl-online-training-36.html The 21st Century Software Solutions of India offers one of the Largest conglomerations of Software Training, IT Support, Corporate Training institute in India - +919000444287 - +917386622889 - Visakhapatnam,Hyderabad PERL Online Training, PERL Training, PERL, PERL Online Training| PERL Training| PERL| "Courses at 21st Century Software Solutions
    Talend Online Training -Hyperion Online Training - IBM Unica Online Training - Siteminder Online Training - SharePoint Online Training - Informatica Online Training - SalesForce Online Training - Many more… | Call Us +917386622889 - +919000444287 - contact@21cssindia.com
    Visit: http://www.21cssindia.com/courses.html"

    ReplyDelete