# This is a commented out single line
 
# Use POD
=for comment
This is a multiple line
comments
=Cut
 
# Use Acme::Comment
use Acme::Comment type => 'C++';
/*
    This is a comment ...
    ... C++ style!
*/

#!/usr/bin/perl -w # -w: produce extra warnings
$secretword="llama";
print("What is your name?"); # writes to screen
$name = <STDIN>; # reads from keyboard
chomp($name); # removes trailing newline character
if ($name eq "Jimmy") { # if statement
  print("Hello, Jimmy! How good of you to be here!\n");
} else {
  print("Hello, $name!\n");
  print("What's the secret word? ");
  $guess = <STDIN>;
  chomp($guess);
  while ($guess ne $secretword) { # while loop
    print("Wrong, try again. What is the secret word?");
    $guess = <STDIN>;
    chomp($guess);
  }
  print("Welcome again, $name");
}

my $heredoc = <<END;
Hello,
Here Doc.
END

my ($current_min, $current_hour, $current_day, $current_mon,$current_year) 
	= (localtime)[1,2,3,4,5];
my $curretn_date_string = sprintf '%02d/%02d/%d %02d:%02d', 
	$current_mon+1, $current_day, $current_year+1900, $current_hour, $current_min;

@pets = ("dog", "cat", "fish", "hermit crab");
$dog = $pets[0];
 
# Anonymous array
$array = [ 'One', 'Two', 'Three' ];
@arrayarray = ( 1, 2, [1, 2, 3]);

%words = (
"fred", "camel",
"barney", "llama",
"betty", "fish"
);
 
$word1 = $words{"fred"};
 
# Anonymous hash
$hash = { 'Man' => 'Bill',
          'Woman' => 'Mary,
          'Dog' => 'Ben'
};

my $str1 = 'Hello world!';
if ($str1 =~ m/world/){
  print "\$str1 contains 'world'\n";
}
 
if ($str1 =~ /Hello/){
  print "\$str1 contains 'Hello'\n";
}
 
my $str2 = '10:10:10';
my ($hours, $minutes, $seconds) = ($str2 =~ m/(\d+):(\d+):(\d+)/);
print "hour: $hours, minute: $minutes, second: $seconds";

/PATTERN/i # case insensitive
/PATTERN/m # ^ $ match begin and end of line char
/PATTERN/g # global find all matches

s/PATTERN/REPLACEMENT/i # case insensitive
s/PATTERN/REPLACEMENT/m # ^ $ match begin and end of line char
s/PATTERN/REPLACEMENT/g # global find all matches

tr/SEARCHLIST/REPLACEMENTLIST/c # Complement search list, i.e. all non-matched will be replaced
tr/SEARCHLIST/REPLACEMENTLIST/d # Delete found but unreplaced characters
tr/SEARCHLIST/REPLACEMENTLIST/s # Squash duplicately replaced characters

# Match first word is jimmy, case insensitive:
$name =~ /^jimmy\b/i
 
# Remove everything after the first word:
$name =~ s/\W.*//;
 
# Convert all letters to lower case:
$name =~ tr/A-Z/a-z/;
 
if ($name =~ /^jimmy\b/i) {
  print("Hi Jimmy!");
}else{
  print("Hi, not Jimmy.");
}

# Call subroutine
good_word('john', 'myguess');
 
sub good_word {
  # Access parameters
  #my $somename = shift;
  #my $someguess = shit;
 
  # Or
  my($somename, $someguess) = @_; # my() defines variables as private
 
  $somename =~ s/\W.*//; # want want only the first word
  $somename =~ tr/A-Z/a-z/; # convert to lower cases
  if ($somename eq "jimmy") {
    return 1;
  } elsif (($words{$somename} || "groucho") eq $someguess) {
    return 1;
  } else {
    return 0;
  }
}

# include a perl file
do '/home/perl/loadme.pl';
 
# include the old-style (and obsolete) getopts library
require 'getopts.pl';
 
# include the newer Getopt::Std library
# (i.e. PATH/Getopt/Std.pm)
require Getopt::Std;
 
# include Getopt::Std at compile time 
use Getopt::Std;
 
# importing a list of symbols with a comma-separated list:
use Module qw(sub1 sub2 $scalar @list :tagname);
 
use Module; # import default symbols 
use Module(); # suppress all imports
 
# if pragma
use if $ENV{USE_XML_PARSER},"XML::Parser"; 
use if !$ENV{USE_XML_PARSER},"XML::SAX";
 
# require Perl version 5.6.0 or higher
require 5.6.0;
use 5.6.0;
 
# require CGI.pm version 2.36 or higher
use CGI 2.36 qw(:standard);

# Print out @INC
print "$_\n" foreach @INC;
foreach (@INC) { print "$_\n"; }
 
# Print out %INC which contains modules requested
print "\%INC contains: \n";
     foreach (keys %INC) {
     print "  $INC{$_}\n";
}
 
# Add to start of @INC externally
perl -I/home/httpd/perl/lib,/usr/local/extra/lib/modules perl
PERL5OPT="I/home/httpd/perl/lib,/usr/local/p5lib"
PERL5LIB="/home/httpd/perl/lib:/usr/local/p5lib"
 
# add directory to end of @INC
push @INC, "/home/httpd/perl/lib";
use lib '/home/httpd/perl/lib';
 
# include libraries relative to script
use FindBin qw($RealDir); # or $Bin, $Dir, or $RealBin ... 
use lib "$RealDir/../lib";
 
# remove paths from @INC with the no directive:
no lib 'home/httpd/perl/lib';
 
# lazy include a module
use autouse 'Module' => qw(sub1 sub2 Module::sub3);
 
# Checking for module availability
warn "GD module not available" unless eval {require GD; 1};
BEGIN {
    foreach ('GD', 'CGI', 'Apache::Session') {
       warn "$_ not available" unless eval "use $_; 1";
    }
}

#!/usr/bin/perl
# installedfiles.pl
use warnings;
use strict;
 
use ExtUtils::Installed;
 
my $inst = new ExtUtils::Installed;
 
foreach my $package ($inst->modules) {
    my $valid = $inst->validate($package)?"Failed":"OK";
    my $version = $inst->version($package);
    $version = 'UNDEFINED' unless defined $version;
 
    print "\n\n--- $package v$version [$valid] ---\n\n";
    if (my @source = $inst->files($package, 'prog')) {
        print "\t", join "\n\t", @source;
    }
    if (my @docs = $inst->files($package, 'doc')) {
        print "\n\n\t", join "\n\t", @docs;
    }
}

BEGIN 
(compile phase) 
CHECK
INIT
(run phase)
END

package My::Module;
 
use strict;
use Exporter;
 
# Extends Exporter
@My::Module::ISA = qw(Exporter);
 
# Export hello subroutine
@My::Module::EXPORT = qw(hello);
 
# exported only on request
@EXPORT_OK = qw(helloAgain);
 
sub hello {
    return "Hello World\n";
}
 
sub helloAgain {
    return "Hello World\n";
}
 
1;

#!/usr/bin/perl
use warnings;
use strict;
 
use lib '.'; #look in current directory for My/Module.pm
use My::Module; # or use My::Module qw(hello);
 
print hello;

h2xs -AXn MyModule

$foo = 'foo';
$fooref = \$foo;
 
$arrayref = \@ARGV;
$hashref = \%ENV;
$globref = \*STDOUT;
 
sub foo { print "foo" };
$foosub = \&foo;

$$fooref;
 
testRef();
sub testRef {
	my $foo = 'foo';
	print "\$foo: $foo";
	print "\n";
	my $fooref = \$foo;
	print "\$fooref: $fooref";
	print "\n";
	$$fooref = 'bar';
	print "\$foo: $foo";
	print "\n";
}
 
@$arrayref;
 
%$hashref;
 
&$foosub;

# Class name
package Person;
 
# Imports
use strict;
use Exporter;
 
# Export
@Person::ISA = qw(Exporter);
@Person::EXPORT = qw(new getFirstName setFirstName);
 
# Constructor
sub new
{
    my $class = shift;
    my $self = {
        # These are class variables
        _firstName => shift,
        _lastName  => shift,
        _ssn       => shift,
    };
    # Return a reference to this object
    bless $self, $class;
    return $self;
}
 
# Destructor
sub DESTROY {
	print "Employee::DESTROY called\n";
}
 
# Called whenever undefined subroutines are called
sub AUTOLOAD
{
   print "Employee::AUTOLOAD called.\n";
   return();
}

# Subclass name
package Employee;
 
use strict;
use Person;
use Exporter;
 
# Inherits Person
@Employee::ISA = qw(Person);
 
# Overrides constructor
sub new {
	my $class = $_[0];
	my $self = $class->SUPER::new($_[1], $_[2], $_[3]);
 
       # Defines new class variable
	$self->{_title} = $_[4];
	bless $self, $class;
	return $self;
}

# trim string
$blank =~ s/^\s+|\s+$//g;

c:\perl -MCAPN -e shell
cpan>install DBI
cpan>install DBD::Oracle

# Connect to Oracle
my $host = "192.168.1.4";
my $sid = "orcl";
my $user = "scott";
my $passwd = "tiger";
my $dbh = DBI->connect("dbi:Oracle:host=$host;sid=$sid", $user, $passwd, {AutoCommit => 0})
		or die $DBI::errstr;
# Default to AutoCommit on
#my $dbh = DBI->connect("dbi:Oracle:host=$host;sid=$sid", $user, $passwd) or die $DBI::errstr;

use DBI;
 
my ($dbh);
 
openDB();
testCreate();
testRetrieve();
testUpdate();
testRetrieve();
testDelete();
closeDB();
sub openDB {
	print "Open DB...";
	print "\n";
    my $host = "192.168.0.105";
    my $sid = "orcl";
    my $user = "scott";
    my $passwd = "tiger";
    unless (defined $dbh){
		$dbh = DBI->connect("dbi:Oracle:host=$host;sid=$sid", $user, $passwd, {AutoCommit => 0})
			or die $DBI::errstr;
    }
    print "DB opened";
	print "\n";
}
 
sub closeDB {
	print "Closing DB...";
	print "\n";
	$dbh->disconnect() or warn $dbh->errstr();
	print "DB closed";
	print "\n";
}
 
sub testCreate {
	print "Creating...\n";
	my $sth = $dbh->prepare("insert into test_table values ('John', 'Doe')");
	$sth->execute() or die $DBI::errstr;
	$dbh->commit() or die $DBI::errstr;
	$sth->finish();
 
	my $sth2 = $dbh->prepare("insert into test_table values (?,?)");
	$sth2->execute('Jane', 'Doe') or die $DBI::errstr;
	$dbh->commit() or die $DBI::errstr;
	$sth2->finish();
	print "Done Creating...\n";
}
 
sub testRetrieve {
	print "Retrieving...\n";
	my $sth3 = $dbh->prepare("select * from test_table");
	$sth3->execute() or die $DBI::errstr;
	while (my @row = $sth3->fetchrow_array()){
		my ($firstName, $lastName) = @row;
		print "Fist name: $firstName; Last name: $lastName\n";
	}
	$sth3->finish;
	print "Done Retrieving...\n";
}
 
sub testUpdate {
	print "Updating...";
	print "\n";
	my $updateSth = $dbh->prepare("update test_table set first_name= ? where first_name = ?");
	$updateSth->execute('Jack', 'Jane') or die $DBI::errstr;
	print "Number of rows update: ", $updateSth->rows;
	print "\n";
	$dbh->commit() or die $DBI::errstr;
	$updateSth->finish();
	print "Done updating";
	print "\n";
}
 
sub testDelete {
	print "Deleting...\n";
	my $deleteSth = $dbh->prepare("delete from test_table");
	$deleteSth->execute() or die $DBI::errstr;
	$deleteSth->finish();
	$dbh->commit() or die $DBI::errstr;
	$deleteSth->finish();	
	print "Done Deleting...\n";
}

# trim string
$blank =~ s/^\s+|\s+$//g;
 
# Find and replace string in files
# e.g. find all .txt files and replace string two with ten
perl -e "s/two/ten/g;" -pi $(find . -name "*.txt")
 
# Same as above but save found files with .ori extenstion
perl -e "s/two/ten/g;" -pi.ori $(find . -name "*.txt")