Perl Tutorial - Practical Extraction and Reporting Language (Perl)

Please leave a remark at the bottom of each page with your useful suggestion.


Table of Contents

  1. Perl Introduction
  2. Perl Program Startup
  3. Perl Regular Expressions
  4. Perl Array Program
  5. Perl Basic Program
  6. Perl Subroutine / Function Program
  7. Perl XML Program
  8. Perl String Program
  9. Perl Statement Program
  10. Perl Network Program
  11. Perl Hash Program
  12. Perl File Handling Program
  13. Perl Data Type Program
  14. Perl Database Program
  15. Perl Class Program
  16. Perl CGI Program
  17. Perl GUI Program
  18. Perl Report Program

Perl Network Program

A Daytime Client

 #!/usr/bin/perl
use strict;
use Socket;
use constant DEFAULT_ADDR => 'timer server';
use constant PORT=> 13;
use constant IPPROTO_TCP  => 6;
my $address = shift || DEFAULT_ADDR;
my $packed_addr = inet_aton($address);
my $destination = sockaddr_in(PORT,$packed_addr);
socket(SOCK,PF_INET,SOCK_STREAM,IPPROTO_TCP) or die "Can't make socket: $!";
connect(SOCK,$destination) or die "Can't connect: $!";
print <SOCK>;

Add a host, delete a host, add a user, delete a user, ping a host, list processes, list filesystems, lists hosts, and kill a process.

 To add or delete hosts and users, ptadmin.pl must be ran as root. Normal user may only kill their own processes.
#! /usr/bin/perl
use Tk;
# anderson.stephen@gmail.com
# Copyright (C) 2006 Stephen W. Anderson
#
#This program is free software; you can redistribute it and/or
#modify it under the terms of the GNU General Public License
#as published by the Free Software Foundation; either version 2
#of the License, or (at your option) any later version.
#
#This program is distributed in the hope that it will be useful,
#but WITHOUT ANY WARRANTY; without even the implied warranty of
#MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#GNU General Public License for more details.
#
#You should have received a copy of the GNU General Public License
#along with this program; if not, write to the Free Software
#Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
# 02/18/01 - Birth of ptadmin. 
# Updated for Ubuntu 01/07/05
# Fixed Add User - will now create home directory, add encrypted password
# Process listing will no longer list the ps -ef command used to get the processes
# Widened the GUI so all buttons are readable
# Fixed the order of the added host entries (e.g. IP, fqdn, hostname, alias)
#
$computer =`hostname`;
$seconds_time = time();
$time = localtime($seconds_time);
chomp($computer);
chomp($time);
my $mw = MainWindow->new;
$mw->geometry("710x375+0+0");
$mw->title("$computer - $time");
$mw->iconname("ptadmin");
$mw->iconmask();
$mw->iconmask("info");
$mw->client();
$mw->client("ptadmin");
#----------------- Main Window
my $f = $mw->Frame(-highlightbackground => 'blue',
-highlightthickness => 4)->pack(-side => 'top');
$lb = $f->Scrolled("Listbox", -selectmode => "single", -width => "100", -height => "5",
-scrollbars => 'osoe');
@dfk = `df -k`;
$how_many = scalar @dfk;
for ($count=0;$count<$how_many;$count++){
 chomp($dfk[$count]);
 }
$lb->insert('end', @dfk);
$lb->bind('<Button-1>', sub { 
my $selected = $lb->get($lb->curselection());
});
foreach $part_disk (@dfk){
  @part_use = split (/\s+/, $part_disk);
  $part_use[4] =~ s/%//;
  #Change this number to the percentage that you desire
  $part_limit = 95;
  if (($part_use[4] > $part_limit) && ($part_use[4] cmp 'Use')) {
 $lb->insert('end', "Warning! $part_use[0] Usage Percentage exceeds $part_limit");
}
  else {
  #do nothing
 } 
}
$lb->pack(-side => 'top', -fill => 'both', -expand => 1);
@proc = `ps -ef|grep -v "ps -ef"`;
$how_many = scalar @proc;
for ($count=0;$count<$how_many;$count++){
 chomp($proc[$count]);
 }
$lb4 = $f->Scrolled("Listbox", -selectmode => "single",
-height => "5",-width => "100",
-scrollbars => 'osoe')->pack(-side=>'bottom', 
-fill => 'both', -expand => 1);
$lb4->insert('end',@proc);
$lb4->bind('<Button-1>', sub { 
  my $selected4 = $lb4->get($lb4->curselection());
  });
@hosts = `cat /etc/hosts`;
$how_many = scalar @hosts;
for ($count=0;$count<$how_many;$count++){
 chomp($hosts[$count]);
 $hosts[$count] =~ s/\t/ /g;
 }
$lb2 = $f->Scrolled("Listbox", -selectmode => "single",
-height=> "5", -width => "60",
-scrollbars => 'osoe')->pack(-side=>'right', 
-fill => 'both', -expand => 1);
$lb2->insert('end',@hosts);
$lb2->bind('<Button-1>', sub {
 my $selected1 = $lb2->get($lb2->curselection());
 });
@users = `cat /etc/passwd | awk -F : '{if (\$3 > 99) print \$1"  "  \$3"  " \$4"  " \$5}'`;
$how_many = scalar @users;
for ($count=0;$count<$how_many;$count++){
 chomp($users[$count]);
 }
$lb3 = $f->Scrolled("Listbox", -selectmode => "single",
-height=> "5", -width => "40",
-scrollbars => 'osoe')->pack(-side=>'left',
-fill => 'both', -expand => 1);
$lb3->insert('end',@users);
$lb3->bind('<Button-1>', sub { 
  my $selected3 = $lb3->get($lb3->curselection());
 });
my $g = $mw->Frame(-highlightbackground => 'blue',
-highlightthickness => 4);
my $but = $g->Button(-text => "Exit",
 -command => sub { exit } )->pack(-side => "right",
 -fill => "x");
my $but1 = $g->Button(-text => "Ping",
  -command => \&ping)->pack(-side => "right",
  -fill => "x");
my $but2 = $g->Button(-text => "Kill Process",
  -command => \&kill_proc)->pack(-side => "right",
  -fill => "x");
my $but3 = $g->Button(-text => "Refresh",
  -command => \&StatsClear)->pack(-side => "right",
  -fill => "x");
my $but5 = $g->Button(-text => "Hosts",
  -command => \&HostClear)->pack(-side => "right",
  -fill => "x");
my $but4 = $g->Button(-text => "Add Host",
  -command => \&add_host)->pack(-side => "right",
  -fill => "x");
my $but6 = $g->Button(-text => "Delete Host",
  -command => \&DelHost)->pack(-side => "right",
  -fill => "x");
my $but8 = $g->Button(-text => "Add User",
  -command => \&UserAdd)->pack(-side => "right",
  -fill => "x");
my $but7 = $g->Button(-text => "Delete User",
  -command => \&UserDel)->pack(-side => "right",
  -fill => "x");
$f->pack(-side => 'top', -fill => 'x');
$g->pack(-side => 'top', -fill => 'x');
MainLoop;
sub ping {
if (!$lb2->selectionIncludes('active')){
print "Select a host to Ping!";
}
  else{
my $selected1 = $lb2->get($lb2->curselection());
@ip = split (/ /, $selected1);
chomp ($ip[0]);
if (!`ping -c 1 $ip[0]`) { 
$lb2->delete(0, 'end');
$lb2->insert('end',"IP appears to be invalid!");
 }
else {
`ping -c 3 $ip[0]>ptping.txt`;
@ping_results = `cat ptping.txt`;
$how_many = scalar @ping_results;
for ($count=0;$count<$how_many;$count++){
 chomp($ping_results[$count]);
 }
$lb2->delete(0, 'end');
$lb2->insert('end',@ping_results);
  }
}
}
sub kill_proc {
  if (!$lb4->selectionIncludes('active')){
  print "Select a process to kill!";
  }
  else{
my $selected4 = $lb4->get($lb4->curselection());
@proc = split (/\s+/,$selected4);
`kill -9 $proc[1]`;
$lb4->delete(0, 'end');
@proc = `ps -ef`;
$how_many = scalar @proc;
for ($count=0;$count<$how_many;$count++){
 chomp($proc[$count]);
 }
  $lb4->insert('end',@proc);
  }
}  
sub disk {
 $lb->delete(0, 'end');
 @dfk = `df -k`;
 $how_many = scalar @dfk;
 for ($count=0;$count<$how_many;$count++){
  chomp($dfk[$count]);
  }
 $lb->insert('end', @dfk);
 foreach $part_disk (@dfk){
  @part_use = split (/\s+/, $part_disk);
  $part_use[4] =~ s/%//;
  $part_limit = 95;
  if ($part_use[4] > $part_limit && $part_use[4] ne "Use") {
  $lb->insert('end', "Warning! $part_use[0] Usage Percentage exceeds $part_limit%");
 }
 else {
 #does nothing
}
  }
} 
sub add_host {
  if (! Exists ($HostAdd)) {
  $HostAdd = $mw->Toplevel();
  $HostAdd ->title("ptadmin - Add Host");
  $HostAdd->geometry("290x210+0+0");
  $b1 = $HostAdd->Frame(-highlightbackground => 'blue',
  -highlightthickness => 4)->pack(side=>'top', -fill => 'x');
  $b2 = $b1->Frame(-highlightbackground => 'blue',
 -highlightthickness => 4)->pack(side=>'top', -fill => 'x');
  $b2->Label(-text => "Host Name" ) ->pack(-side => 'top');
  $b2->Entry(-width => 25, -textvariable => \$hostname) 
 ->pack(-side => 'top');
  $b2->Label(-text => "IP Address" ) ->pack(-side => 'top');
  $b2->Entry(-width => 16, -textvariable => \$ipaddress) 
 ->pack(-side => 'top');
  $b2->Label(-text => "Fully Qualified Name (hostname.domainname)" ) 
 ->pack(-side => 'top');
  $b2->Entry(-width => 25, -textvariable => \$fqdn) 
 ->pack(-side => 'top');
  $b2->Label(-text => "Alias" ) ->pack(-side => 'top');
  $b2->Entry(-width => 15, -textvariable => \$alias) 
 ->pack(-side => 'top');
  $b1->Button(-text => "Cancel", -command => sub {$HostAdd->destroy})
  ->pack(-side => 'right');
  $b1->Button(-text => "Add the Host", -command => \&host_end)
 ->pack(-side => 'right');
  } else {
  $HostAdd->raise();
}
}
sub host_end {
  $line_cnt=`cat /etc/hosts|wc -l`;
  open(OLD, "</etc/hosts") ||print "Could not open hosts";
  open (NEW, ">/etc/hosts.txt")||print "Could not open hosts.txt";
  select (NEW);
  while (<OLD>) {
  print NEW $_;
  if ($. == $line_cnt && $ipaddress ne "") {
  print NEW "$ipaddress\t$fqdn\t$hostname\t$alias\n"; 
  }
  }
  close (OLD);
  close (NEW);
  select (STDOUT);
  rename ("/etc/hosts", "/etc/hosts.orig")||print "HELP1";
  rename("/etc/hosts.txt", "/etc/hosts")||print "HELP";
  @hosts = `cat /etc/hosts`;
  $how_many = scalar @hosts;
  for ($count=0;$count<$how_many;$count++){
 chomp($hosts[$count]);
 $hosts[$count] =~ s/\t/ /g;
 }
  $lb2->delete(0, 'end');
  $lb2->insert('end',@hosts);
  $HostAdd->destroy;
}
sub DelHost {
 if (!$lb2->selectionIncludes('active')){
  print "Select Host!";
 }
else{
  my $selected1 = $lb2->get($lb2->curselection());
  @hosts = `cat /etc/hosts`;
  $how_many = scalar @hosts;
  for ($count=0;$count<$how_many;$count++){
 chomp($hosts[$count]);
 $hosts[$count] =~ s/\t/ /g;
 if ($hosts[$count] eq $selected1){
 $delete_line=$count+1;
 }
}
$line_cnt=`cat /etc/hosts|wc -l`;
open(OLD, "</etc/hosts") ||print "Could not open hosts";
open (NEW, ">/etc/hosts.txt")||print "Could not open hosts.txt";
select (NEW);
while (<OLD>) {
next if ($. == $delete_line);
print NEW $_;
  }
close (OLD);
close (NEW);
select (STDOUT);
rename ("/etc/hosts", "/etc/hosts.orig")||print "HELP1";
rename("/etc/hosts.txt", "/etc/hosts")||print "HELP";
@hosts = `cat /etc/hosts`;
$how_many = scalar @hosts;
for ($count=0;$count<$how_many;$count++){
chomp($hosts[$count]);
$hosts[$count] =~ s/\t/ /g;
  }
$lb2->delete(0, 'end');
$lb2->insert('end',@hosts);
}
}
sub UserDel {
 if (!$lb3->selectionIncludes('active')){
  print "Select User!";
 }
 else{
if (! Exists ($UserWarn)) {
  $UserWarn = $mw->Toplevel();
  $UserWarn ->title("ptadmin Warning!");
  $UserWarn->geometry("200x80+0+0");
  $b1 = $UserWarn->Frame(-highlightbackground => 'blue',
  -highlightthickness => 4)->pack(side=>'top', -fill => 'x');
  $b2 = $b1->Frame(-highlightbackground => 'blue',
 -highlightthickness => 4)->pack(side=>'top', -fill => 'x');
  $b2->Label(-text => "Warning! User directories \n will be permanently removed!" ) ->pack(-side => 'top');
  $b1->Button(-text => "Remove the User!", -command => \&RemoveUser)
  ->pack(-side => 'right');
  $b1->Button(-text => "Cancel", -command => sub {$UserWarn->destroy})
  ->pack(-side => 'right');
  } else {
  $UserWarn->raise();
}
  }
}
sub RemoveUser{
my $selected3 = $lb3->get($lb3->curselection());
my @login = split (/\s+/, $selected3);
`/usr/sbin/userdel -r $login[0]`;
@users = `cat /etc/passwd | awk -F : '{if (\$3 > 99) print \$1"  "  \$3"  " \$4"  " \$5}'`;
$how_many = scalar @users;
for ($count=0;$count<$how_many;$count++){
  chomp($users[$count]);
  }
  $lb3->delete(0, 'end');
  $lb3->insert('end',@users);
  $UserWarn->destroy;
  }

sub UserAdd {
 if (! Exists ($UserAdd)) {
  $UserAdd = $mw->Toplevel();
  $UserAdd ->title("ptadmin - Add User");
  $UserAdd->geometry("240x215+0+0");
  $b1 = $UserAdd->Frame(-highlightbackground => 'blue',
  -highlightthickness => 4)->pack(side=>'top', -fill => 'x');
  $b2 = $b1->Frame(-highlightbackground => 'blue',
 -highlightthickness => 4)->pack(side=>'top', -fill => 'x');
  $b2->Label(-text => 'Login (Required)' ) ->pack(-side => 'top');
  $b2->Entry(-width => 25, -textvariable => \$login) 
 ->pack(-side => 'top');
  $b2->Label(-text => 'User Name (Optional)' ) ->pack(-side => 'top');
  $b2->Entry(-width => 25, -textvariable => \$username) 
 ->pack(-side => 'top');
  $b2->Label(-text => 'Password (Required)' ) ->pack(-side => 'top');
  $b2->Entry(-width => 25, -show => "*", 
 -textvariable => \$password) ->pack(-side => 'top');
  $b2->Label(-text => 'Home Directory (Required)' ) ->pack(-side => 'top');
  $b2->Entry(-width => 25, -textvariable => \$homedir) 
->pack(-side => 'top');
  $b1->Button(-text => "Add the User", -command => \&AddUser)
  ->pack(-side => 'right');
  $b1->Button(-text => "Cancel", -command => sub {$UserAdd->destroy})
  ->pack(-side => 'right');
  } else {
  $UserAdd->raise();
}
}
sub AddUser {
  $enc_password = crypt($password,L3);
  `/usr/sbin/useradd -c "$username" -m -d "$homedir" -p $enc_password $login`;
  @users = `cat /etc/passwd | awk -F : '{if (\$3 > 99) print \$1"  "  \$3"  " \$4"  " \$5}'`;
  $how_many = scalar @users;
  for ($count=0;$count<$how_many;$count++){
 chomp($users[$count]);
 }
  $lb3->delete(0, 'end');
  $lb3->insert('end',@users);
  $UserAdd->destroy;
}
sub HostClear{
@hosts = `cat /etc/hosts`;
$how_many = scalar @hosts;
for ($count=0;$count<$how_many;$count++){
chomp($hosts[$count]);
$hosts[$count] =~ s/\t/ /g;
  }
$lb2->delete(0, 'end');
$lb2->insert('end',@hosts);
}
sub UserClear {
  @users = `cat /etc/passwd | awk -F : '{if (\$3 > 99) print \$1"  "  \$3"  " \$4"  " \$5}'`;
  $how_many = scalar @users;
  for ($count=0;$count<$how_many;$count++){
 chomp($users[$count]);
 }
  $lb3->delete(0, 'end');
  $lb3->insert('end',@users);
}
  
sub ProcClear {
 $lb4->delete(0, 'end');
 @proc = `ps -ef`;
 $how_many = scalar @proc;
 for ($count=0;$count<$how_many;$count++){
chomp($proc[$count]);
  }
 $lb4->insert('end',@proc);
}
sub StatsClear {
 disk();
 HostClear();
 UserClear();
 ProcClear();
}

A Perl TCP server without the Socket module.

 #!/usr/bin/perl -w
$PF_INET = 2;
$SOCK_STREAM = 1;
$port = 9999;
$pattern = 'S n C4 x8';
# Create an address using 0.0.0.0.
$this_addr = pack($pattern,$PF_INET, $port, 0,0,0,0);
$proto = getprotobyname("tcp");
socket(SERVER, $PF_INET, $SOCK_STREAM, $proto) or die "Can't create socket: $!";
bind(SERVER, $this_addr) or die "Can't bind: $!";
listen(SERVER,1) or die "Can't listen: $!";
print "Server listening on port $port\n";
for ( ; $paddr = accept(CLIENT,SERVER); close(CLIENT) ) {
 print CLIENT "Hello from server.\n";
}

A Simple script to update your host/ip with dyndns.org service.

 #!/usr/bin/perl -w
#Author is not held responsible for any damages by this script. 
#Feel free to redistribute and modify the script.
#
#
# Author: brian2004[at] hotmail[dot] com
#
# DynDNS Utility v1.0
# Feel free to modify and redistribute under GNU
# Obtain IP address from http://checkip.dyndns.org

$^W++; # Turn on debug warnings
use strict;  # Strict Variables!
use IO::Socket; # Sock support
use MIME::Base64;  # Base64 encoding support
use Data::Dumper;  # Data Dumper
use Tk;
use Tk::Dialog;
use Tk::Entry;
use Tk::Label;
use Tk::Scrollbar;
use Tk::Text;
use Tk::Menu;
use Tk::Frame;
use Tk::DialogBox;
use Tk::Menubutton;
use Tk::Button;
use Tk::Radiobutton;
use Tk::Toplevel;
use Tk::Optionmenu;
my $version = "1.0";
my $lupdate = "April/11/2004";
my $reported_ip = "0.0.0.0";
my $remote_host = "checkip.dyndns.org";
my $remote_port = "80";
my $remote_url = "/";
my @socket_buffer = ();
my $tmpdata = "";
my $username = "";
my $password = "";
my $dyntype = "statdns";
my $g_dyntype = "statdns";
my $dynhost = "yourhost.ath.cx";
my $dynstate = "Idle...";
my $encoded;
my $decoded;
my $h_type = {'Dynamic DNS' => 'dyndns',
  'Static DNS'  => 'statdns',
  'Custom DNS'  => 'custom'};
my @host_type = keys %$h_type;
# Create and Display GUI
my $mw = MainWindow->new();
$mw->title ("Tk-DYNDNS IP Manager");
$mw->geometry('+500+300');
$mw->configure(-menu => my $menubar = $mw->Menu);
# File Menu
my $file = $menubar->cascade(-label  => '~File',
  -tearoff=> 0,
);
$file->command(
 -label => "Close",
 -accelerator => 'Ctrl-w',
 -underline=> 0,
 -command  => \&exit,
);
# Help Menu
my $help = $menubar->cascade(-label  => '~Help',
  -tearoff=> 0,
);
$help->command(
-label  => "About",
-command=> \&mnabout,
);
my $frm1 = $mw->Frame(
  -relief => 'groove',
  -borderwidth  => 2,
  -background=> 'black',
)
  ->pack(
  -side  => 'top',
  -fill  => 'x'
);
my $lbl1 = $mw->Label(
  -text=> "Tk-DYNDNS Client. VER: $version",
  -font=> "-family Elephant -weight normal",
)
  ->pack(
  -side=> 'top'
);
my $frm2 = $mw->Frame(
  -relief => 'groove',
  -borderwidth  => 2,
  -background=> 'gray',
)
  ->pack(
  -side  => 'top',
  -padx  => 120,
  -pady  => 10,
  -fill  =>'x'
);
my $lbl2 = $mw->Label(
  -text=> "Detected IP address:",
)
  ->pack(
  -side=> 'top',
  -anchor => 'nw'
);
 
my $txt1 = $mw->Entry(
  -textvariable => \$reported_ip,
  -background=> 'gray',
  -foreground=> 'black',
)
  ->pack(
  -side=> 'top',
  -anchor => 'ne'
);
my $lbl3 = $mw->Label(
  -text=> "Your DNS host type:",
)
  ->pack(
  -side=> 'top',
  -anchor => 'nw',
);
my $opt1 = $mw->Optionmenu(
  -options=> \@host_type,
  -variable  => \$dyntype,
  -background=> 'gray',
)
  ->pack(
  -side=> 'top',
  -anchor => 'ne'
);
my $lbl4 = $mw->Label(
  -text=> "Your DNS host name:",
)
  ->pack(
  -side=> 'top',
  -anchor => 'nw',
);
my $txt2 = $mw->Entry(
  -textvariable => \$dynhost,
  -background=> 'gray',
)
  ->pack(
  -side=> 'top',
  -anchor => 'ne'
);
my $lbl5 = $mw->Label(
  -text=> "Your DNS username:  ",
)
  ->pack(
  -side=> 'top',
  -anchor => 'nw',
);
my $txt3 = $mw->Entry(
  -textvariable => \$username,
  -background=> 'gray',
)
  ->pack(
  -side=> 'top',
  -anchor => 'ne'
);
my $lbl6 = $mw->Label(
  -text=> "Your DNS password: ",
)
  ->pack(
  -side=> 'top',
  -anchor => 'nw',
);
my $txt4 = $mw->Entry(
  -textvariable => \$password,
  -show=> "*",
  -background=> 'gray',
)
  ->pack(
  -side=> 'top',
  -anchor => 'ne'
);
my $lbl7 = $mw->Label(
  -text=> "Program status: ",
)
  ->pack(
  -side=> 'top',
  -anchor => 'nw',
);
my $txt7 = $mw->Entry(
  -textvariable => \$dynstate,
  -background=> 'grey',
)
  ->pack(
  -side=> 'top',
  -anchor => 'ne',
);
my $frm3 = $mw->Frame(
  -relief => 'groove',
  -borderwidth  => 2,
  -background=> 'black',
)
  ->pack(
  -side  => 'top',
  -padx  => 120,
  -pady  => 10,
  -fill  => 'x'
);
my $btn1 = $mw->Button(
  -text=> "Update",
  -command=> sub { &update_ip }
)
  ->pack(
  -side=> 'left',
  -anchor => 'nw',
);
my $btn2 = $mw->Button(
  -text=> "Done",
  -command=> sub { exit }
)
  ->pack(
  -side=> 'left',
  -anchor => 'ne',
);
# Focus in the username box
$txt3->focus;
my $socket = new IO::Socket::INET (PeerAddr => $remote_host,
  PeerPort => $remote_port,
  Proto => "tcp",
  Type  => SOCK_STREAM)
 or die "Can't connect to $remote_host:$remote_port : $!\n";
print $socket "GET $remote_url HTTP/1.0\n";
print $socket "Accept: */*\n";
print $socket "User-Agent: Tk-DynIP ($version)\n";
print $socket "Connection: Keep-Alive\n";
print $socket "\r\n\r\n";
@socket_buffer = <$socket>;
foreach (@socket_buffer) {
 #print $_."\n";
 $reported_ip = $_;
 chop ($reported_ip);
 if ($reported_ip =~ /[0-9]*\.[0-9]*\.[0-9]*\.[0-9]*/) {
  # Debug
  # print "\nIP address detected by DynDNS Server: $&\n";
  $reported_ip = $&;
 }
}
# Initiate Main Loop where the Loop.
MainLoop();
# Subroutine for about operation.
sub mnabout{
  my $dw = $mw->Dialog(
  -title  => 'About IP Manger',
  -bitmap => 'info',
  -buttons=> ["OK",],
  -text=> "Tk-DYNDNS IP Manager $version\n".
 "Brian Ponnampalam\n".
 " ".
 "Last Updated: $lupdate\n",
  );
  $dw->Show;
}
# Subroutine for Update operation.
sub update_ip{
# Debug
# print "Update Loop\n";
# print "Selected: ".$dyntype."\=".$h_type->{"$dyntype"}."\n";
# print $dyntype;
$dynstate = "Sending...";
$g_dyntype = $h_type->{"$dyntype"};
$encoded = encode_base64("$username:$password");
#$decoded = decode_base64($encoded);
  
# Debug
# print "Encoded: ".$encoded."\n";
# print "Decoded: ".$decoded."\n";
 
$remote_host = "members.dyndns.org";
$remote_url  = "/nic/update\?system\=$g_dyntype\&hostname\=$dynhost\&".
"myip\=$reported_ip\&wildcard\=OFF\&mx\=$dynhost\&".
"backmx\=YES&offline\=NO";
# Debug
# print $remote_url."\n";
$socket = new IO::Socket::INET (PeerAddr => $remote_host,
 PeerPort => $remote_port,
 Proto => "tcp",
 Type  => SOCK_STREAM)
or die "Can't connect to $remote_host:$remote_port : $!\n";
print $socket "GET $remote_url HTTP/1.0\n";
print $socket "Accept: */*\n";
print $socket "User-Agent: Tk-DynIP ($version)\n";
print $socket "Connection: Keep-Alive\n";
print $socket "Authorization: Basic $encoded\n";
print $socket "\r\n\r\n";
@socket_buffer = <$socket>;
  
# Debug
foreach(@socket_buffer){
#Debug
#print $_;
if ($_ =~ /badauth/){
$dynstate = "Invalid username/password.";
#Debug
#print $dynstate."\n";
}
elsif ($_ =~ /nochg/){
$dynstate = "No change necessary.";
#Debug
#print $dynstate."\n";
}
elsif($_ =~ /good/){
$dynstate = "Updated sucessfully.";
#Debug
#print $dynstate."\n";
}
elsif($_ =~ /nohost/){
$dynstate = "Host type doesn't match/exist.";
#Debug
#print $dynstate."\n";
}
elsif($_ =~ /abuse/){
$dynstate = "Abuse host is blocked.";
#Debug
#print $dynstate."\n";
}
else{
  #Debug
  print $_
}
}
}

A web server

 use HTTP::Daemon;  
$HTTPserver = HTTP::Daemon->new(Timeout => 600);
print "My URL is: ", $HTTPserver->url, ".\n";
while ($HTTPclient = $HTTPserver->accept) {
 $HTTPclient->autoflush(1);
 print $HTTPclient 
'<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML//EN">
<HTML>
<HEAD>
<TITLE>Welcome to my Web server!</TITLE>
</HEAD>
<BODY>
<CENTER>
<H1>Welcome to my Web server!</H1>
</CENTER>
</FORM>
</BODY>
</HTML>';
$HTTPclient->close;
}

Checking for an open port

 #!/usr/bin/perl -w
# Finds an open port.
$port = 2345;
while (getservbyport($port, "tcp") ) {
 $port++;
}
print "An open port number is $port\n";

Child handle and parent handle

 use Socket;
use IO::Handle;
socketpair(CHILDHANDLE, PARENTHANDLE, AF_UNIX, SOCK_STREAM, PF_UNSPEC)
 or  die "Could not create socketpair.";
CHILDHANDLE->autoflush(1);
PARENTHANDLE->autoflush(1);
if ($pid = fork) {
 close PARENTHANDLE;
 print CHILDHANDLE "Hello from the parent!\n";
 $line = <CHILDHANDLE>;
 print "Parent read: $line";
 close CHILDHANDLE;
 waitpid($pid,0);
} else {
 close CHILDHANDLE;
 $line = <PARENTHANDLE>;
 print "Child read: $line";
 print PARENTHANDLE "Hello from the child!\n";
 close PARENTHANDLE;
 exit;
}

Daytime client, using symbolic host and service names

 #!/usr/bin/perl
use strict;
use Socket;
use constant DEFAULT_ADDR => 'your server';
my $packed_addr  = gethostbyname(shift || DEFAULT_ADDR) or die "Can't look up host: $!";
my $protocol  = getprotobyname('tcp');
my $port= getservbyname('daytime','tcp') or die "Can't look up port: $!";
my $destination  = sockaddr_in($port,$packed_addr);
socket(SOCK,PF_INET,SOCK_STREAM,$protocol)  or die "Can't make socket: $!";
connect(SOCK,$destination)or die "Can't connect: $!";
print <SOCK>;

Example of a Perl TCP server using Socket module.

 #!/usr/bin/perl -w  
  
use IO::Socket;  
  
$port = 9999;  
$server_socket = IO::Socket::INET->new(
  LocalPort => $port,
  Listen => SOMAXCONN,
  Proto  => 'tcp',
  Reuse  => 1)
  or die "Cannot open socket: $!";

print "Server listening on port $port\n";  
  
while ( $client_socket = $server_socket->accept() ) {
 $client_host = $client_socket->sockhost();
 print $client_socket "Hello from server.\n";
 print "Sent message to client on $client_host.\n";
 $client_socket->close();
}

Extract link from a web page

 use LWP::Simple;
use HTML::LinkExtor;
$html = get("http://www.java2s.com");

$link_extor = HTML::LinkExtor->new(\&handle_links);
$link_extor->parse($html);
sub handle_links
{
 ($tag, %links) = @_;
 if ($tag eq 'a') {
  foreach $key (keys %links) {
if ($key eq 'href') {
 print "Found a hyperlink to $links{$key}.\n";
}
  }
 }
}

Forking Servers

 #!/usr/bin/perl
use warnings;
use IO::Socket;
my $servsock = IO::Socket::INET->new( Listen => 5,LocalPort => 5000);
sub reap { 
wait(); 
$SIG{CHLD} = \&reap;
} # catch and handle children dying
$SIG{CHLD} = \&reap;
while($client = $servsock->accept()) {
 if ($pid = fork()) {
  close $servsock; 
 } else {
  close $client; #let the child deal with the client socket
 }
}

Get a web page

 use LWP::Simple;
$content = get("http://www.cpan.org/doc/FAQs/index.html");

open FILEHANDLE, ">file.txt";
print FILEHANDLE $content;
close FILEHANDLE;

Get a web page and save it to a local file

 use LWP::UserAgent;
$user_agent = new LWP::UserAgent;
$request = new HTTP::Request('GET', 
 'http://www.cpan.org/doc/FAQs/index.html');

$response = $user_agent->request($request);
open FILEHANDLE, ">file.txt";
print FILEHANDLE $response->{_content};
close FILEHANDLE;

Get emails from server and save the emails to local drive

 use Mail::POP3Client;
$mail = new Mail::POP3Client("username", "password", "pop3.yourserver.com");
if ($mail->Count) {
 print "You have ", $mail->Count, " new message(s).\n";
 print "Storing message(s) to disk.\n";
 open FILEHANDLE, ">file.txt";
 for($loop_index = 1; $loop_index <= $mail->Count; $loop_index++) {
  print FILEHANDLE $mail->HeadAndBody($loop_index);
 }
 close FILEHANDLE;
}

getprotoent function reads the next line from the network protocols database, /etc/protocol, and returns a list.

 #Format
#getprotoent;
#setprotoent (STAYOPEN);
#endprotoent;
while (($name,  $aliases, $proto ) = getprotent){
printf "name=%-5s,aliases=%-6sproto=%-8s\n",
  $name, $aliases, $proto;
}

Get system host name.

 #!/usr/bin/perl -w
use Sys::Hostname;
$host = hostname();
print "Network host name is: $host\n";

Get the DNS address of a host by using inet_ntoa and inet_aton

 use Socket;
$site_name = 'www.cpan.org';
$address = inet_ntoa(inet_aton($site_name));
print "The DNS address of www.cpan.org is $address";

Listen to a port

 use Socket;
socket(SERVER, PF_INET, SOCK_STREAM, getprotobyname('tcp'));
setsockopt(SERVER, SOL_SOCKET, SO_REUSEADDR, 1);
$addr = sockaddr_in(2336, inet_aton('server.com'));
bind(SERVER, $addr) or die "Could not bind to port.\n";
listen(SERVER, SOMAXCONN) or die "Could not listen to port.\n";
while (accept(CLIENT, SERVER)) {
 print CLIENT "Hello from the server!\n";
}
close(SERVER);

Login to a FTP server

 use Net::FTP;
$ftp = Net::FTP->new("ftp.cpan.org", Timeout => 30)
  or die "Could not connect.\n";
$username = "anonymous";
$password = "asdf";
$ftp->login($username, $password)
  or die "Could not log in.\n";
$ftp->cwd('/pub/CPAN');
$remotefile = "CPAN.html";
$localfile = "file.txt";
$ftp->get($remotefile, $localfile)
  or die "Can not get file.\n";

Open a socket

 use IO::Socket;
$socket = IO::Socket::INET->new
(
 PeerAddr => 'yourserver.com',
 PeerPort => 1116,
 Proto => "tcp",
 Type  => SOCK_STREAM
) or die "Could not open port.\n";
print $socket "Hello from the client!\n";
close($socket);

Open SENDMAIL

 #!/usr/bin/perl
$from="$me\@mydomain.com";
$to="you\@yourdomain.com";
$subject="Test email";
$sendmailpath="/usr/sbin/sendmail";
$message = "This is a test e-mail using Sendmail\n\nFrom me\n\n";
open (SENDMAIL, "| $sendmailpath -t") or die "Cannot open $sendmail: $!";
print SENDMAIL "Subject: $subject\n";
print SENDMAIL "From: $from\n";
print SENDMAIL "To: $to\n\n";
print SENDMAIL "$message";
close (SENDMAIL);

Perl Modules for Networking with Sockets

 OptionValue
ListenSize of the incoming listen queue. Normally set to SOMAXCONN.
LocalAddrIP address or hostname for a server socket, optional.
LocalPortPort number for a server socket to listen on.
PeerAddr IP address or hostname of the server, for client sockets.
PeerPort Port number of the server, for client sockets.
Proto Protocol to use, usually tcp or udp.
Reuse Set to 1 for servers.
Timeout  Sets network timeouts.
Type  Type of socket, normally SOCK_STREAM (TCP) or SOCK_DGRAM (UDP).

Ping a host

 use Net::Ping;
$pingobject = Net::Ping->new(icmp);
if ($pingobject->ping('cpan.org')) {print "Could reach CPAN."};
$pingobject->close();

Post query to a CGI

 use IO::Socket;
$socket = IO::Socket::INET->new
(
 Proto  => "tcp",
 PeerAddr  => "reference.perl.com",
 PeerPort  => 80,
);
$socket->autoflush(1);
print $socket "GET /query.cgi?cgi HTTP/1.0\015\012\015\012";
open FILEHANDLE, ">local.html";
while (<$socket>) {
 print FILEHANDLE;
}
close FILEHANDLE;
close $socket;

Query a Perl CGI

 use LWP::Simple;
use URI::URL;
$url = url('http://www.yourserver.com/cgireader.cgi');

$url->query_form(text1 => 'Hello', text2 => 'there');
$html = get($url);
print $html;
#File: cgireader.cgi
#!/usr/local/bin/perl
use CGI;  
$co = new CGI;
print $co->header,  
$co->start_html(
 -title=>'CGI Example', 
 -author=>'yourName', 
 -BGCOLOR=>'white', 
 -LINK=>'red'
);
if ($co->param()) {
 print 
  "You entered this text: ", 
  $co->em($co->param('text1')), 
  " ",
  $co->em($co->param('text2')), 
  ".";
} else {
 print "Sorry, I did not see any text.";
}
print $co->end_html;

Read from server

 use Socket;
socket(SERVER, PF_INET, SOCK_STREAM, getprotobyname('tcp'));
$addr = sockaddr_in(2336, inet_aton('server.com'));
connect(SERVER, $addr)
 or die "Could not connect.\n";
$line = <SERVER>;
print $line;
close(SERVER);

Read the first line from a remote server

 #!/usr/bin/perl
use IO::Socket;
my $server = "localhost";
my $fh  = IO::Socket::INET->new($server);
my $line= <$fh>;
print $line;

Retrieving a Web Page with get()

 #!/usr/bin/perl -w
use LWP::Simple;
use strict;
my $webpage = get("http://www.demo.org/");

if (($webpage) && (grep {/Steve/} $webpage)) {
 print "I found the text\n";
}

Sample TCP client.

 #!/usr/bin/perl -w
use Socket;
$port = 9999;
$proto = getprotobyname("tcp");
socket(SOCKET, PF_INET, SOCK_STREAM, $proto) or die "Can't create socket: $!";
$host = 'localhost';
print "Connecting to $host\n";
$iaddr = inet_aton($host);
$paddr = sockaddr_in($port, $iaddr);
connect(SOCKET, $paddr) or die "Can't connect: $!";
while ($data = <SOCKET>) {
 print $data;
}
close (SOCKET);

Sample TCP client without the Socket module.

 #!/usr/bin/perl -w
$PF_INET = 2;
$SOCK_STREAM = 1;
$port = 9999;
$pattern = 'S n C4 x8';
$this_addr = pack($pattern,$PF_INET, 0, 0,0,0,0);
$serv_addr = pack($pattern, $PF_INET, $port, 127,0,0,1);
$proto = getprotobyname("tcp");
socket(SOCKET, $PF_INET, $SOCK_STREAM, $proto) or die "Can't create socket: $!";
bind(SOCKET, $this_addr) or die "Can't bind: $!";
connect(SOCKET, $serv_addr) or die "Can't connect: $!";
while ($data = <SOCKET>) {
 print $data;
}
close (SOCKET);

Save link to file

 use LWP::Simple;
require HTML::Parser;
require HTML::LinkExtor;
$html = get("http://www.google.com");

$link_extor = HTML::LinkExtor->new(\&handle_links);
$link_extor->parse($html);
sub handle_links 
{
  ($tag, %links) = @_;
  if ($tag = 'a href' && $links{href} ne '') {
  $url = $links{href};
  $file = $url;
  $file =~ s/http:\/\/www\.//;
  $file =~ s/http:\/\///g;
  $file =~ tr/\//-/;

  print "Creating $file.\n";
  mirror ($url, $file);
  };
}

Send a TCP or UDP ping

 #!/usr/bin/perl
use warnings;
use Net::Ping;
$hostname = shift @ARGV;
$p = Net::Ping->new("icmp"); #could be "udp" or "tcp" instead
print "$host is alive.\n" if $p->ping($host);
$p->close();

Send data from client to server

 use Socket;
socket(SERVER, PF_INET, SOCK_STREAM, getprotobyname('tcp'));
$addr = sockaddr_in(2336, inet_aton('server.com'));
connect(SERVER, $addr) or die "Could not connect.\n";
print SERVER "Hello from the client!\n";
close(SERVER);

Send email out

 $mailprogram="/usr/lib/sendmail";
$sendto="$input{xemailx}"; 
$from="$input{xmailx}";
$subject="$input{xsubjext}";
open(MAIL, "|$mailprogram -t -oi") || die "Can't open mail program: $!\n";
print MAIL "To: $sendto\n";
print MAIL "From: $from\n";
print MAIL "Subject: $subject\n\n";
print MAIL <<EOF; # Start a "here document"
 Registration Information for $input{$first_name}
  $input{$last_name}:
 Date of Registration: $today
 First Name:  $input{$first_name}
 Last Name:$input{$last_name}
 Street Address: $input{$address}
 City:  $input{$city}
 State/Province: $input{$state}
EOF
close MAIL;

Send email out with SMTP

 #!c:\perl\bin
use Net::SMTP;
print "Content-type: text/html \n\n";
$server = 'mail.mydomain.com';
$fromaddress = 'me@mydomain.com';
$toaddress = 'you@yourdomain.com';
$subject = "Test Example \n\n";
$message = "This is a test \n\n";
$smtp = Net::SMTP->new($server);
$smtp->mail($fromaddress);
$smtp->to($toaddress);
$smtp->data();
$smtp->datasend("Subject: $subject");
$smtp->datasend($message);
$smtp->dataend();
$smtp->quit();

Sending mail with Net::SMTP on Windows

 #!/usr/bin/perl -w
use Net::SMTP;
$server = 'server.mail';
$from_address = 'from@mail.com';
$to_address= 'to@mail.com';
# If you have problems, turn on debugging output.
#$mailserv = Net::SMTP->new( $server, Debug => 1 );
$mailserv = Net::SMTP->new( $server );
unless ($mailserv) {
die "Could not connect to server $server, $!\n";
}
# Note multi-line string. See Chapter 2.
$data ='Subject: This is a subject.
This is a test.
Oh, joy.';
$mailserv->mail( $from_address );
$mailserv->to( $to_address );
$mailserv->data( $data );
$mailserv->quit();

Send mail

 use Net::SMTP;
print "Content-type:text/html\n\n";
my $relay="relay.demo.net";
my $smtp="Net::SMTP->new($relay);
die "Could not open connection: $!" if (! defined $smtp);
$smtp->mail("Bate");
$smtp->to("admin@demo.net");
$smtp->data();
$smtp->datasend("To: admin@demo.net\n");
$smtp->datasend("From: admin@demo.net\n");
$smtp->datasend("Subject: Test1");
$smtp->datasend("\n");
$smtp->datasend("This is a test ...\n");
$smtp->dataend();
$smtp->quit;
print "Completed ...\n";

Setting a User Agent and Retrieving a Web Page

 #!/usr/bin/perl -w
use LWP;
use strict;
my $browser = LWP::UserAgent->new(agent => 'Perly v1');
my $result = $browser->get("http://www.braingia.org/ewfojwefoj");
die "An error occurred: ", $result->status_line() unless $result->is_success;
print $result->content;

Simple FTP client

 #!/usr/bin/perl -w
use warnings;
use strict;
use POSIX qw(O_RDWR O_CREAT O_EXCL tmpnam);
use Sys::Hostname; # for 'hostname'
die "Simple anonymous FTP command line client\n Usage: $0 <server> <command>\n" unless scalar(@ARGV)>=2;
my ($ftp_server,@ftp_command)=@ARGV;
my $ftp_resultfile;
do {
 $ftp_resultfile = tmpnam();
 sysopen FTP_RESULT, $ftp_resultfile, O_RDWR|O_CREAT|O_EXCL;
} until (defined fileno(FTP_RESULT));
if (open (FTP, "|ftp -n > $ftp_resultfile 2>&1")) {
 print "Client running, sending command\n";
 print FTP "open $ftp_server\n";
 my $email=getlogin.'@'.hostname;
 print FTP "user anonymous $email\n";
 print FTP "@ftp_command\n";
 close FTP;
} else {
 die "Failed to run client: $!\n";
}
print "waiting for response\n";
my @ftp_results = <FTP_RESULT>;
check_result(@ftp_results);
close FTP_RESULT;
unlink $ftp_resultfile;
print "Done\n";
sub check_result {
  return unless @_;
  print "Response:\n";
  print "\t$_" foreach @_;
}

Simple server

 #!/usr/bin/perl
use warnings;
use strict;
use IO::Socket;
my $serv = IO::Socket::INET->new(LocalPort => 9876,Listen => 5); # queue up no more than 5 pending clients
while(my $client = $serv->accept()) { #somebody connected!
 print $client "The time is now: ".scalar(localtime(time()))."\n";
 close $client;
}

Simple TCP Clients

 #!/usr/bin/perl
use warnings;
use strict;
use IO::Socket;
my $sock = IO::Socket::INET->new('remote.host.com:7777');
while (<$sock>) {
 print "Server: $sock\n";
 print "Response?";
 my $response = <STDIN>;
 print $sock $response;
}

sockaddr_un($file)

 use Socket;
$file = 'transfer';
socket(SOCKET, PF_UNIX, SOCK_STREAM, 0) or die "Could not create socket.\n";
connect(SOCKET, sockaddr_un($file))  or die "Could not connect.\n";
 
print SOCKET "Hello from the client!\n";
close SOCKET;
exit;

Socket answer

 use IO::Socket;
$socket = IO::Socket::INET->new
(
 PeerAddr => 'yourserver.com',
 PeerPort => 1116,
 Proto => "tcp",
 Type  => SOCK_STREAM
) or die "Could not open port.\n";
$answer = <$socket>;
print $answer;
close($socket);

Socket pair

 use Socket;
use IO::Handle;
socketpair(CHILDHANDLE, PARENTHANDLE, AF_UNIX, SOCK_STREAM, PF_UNSPEC)
 or  die "Could not create socketpair.";
CHILDHANDLE->autoflush(1);
PARENTHANDLE->autoflush(1);
if ($pid = fork) {
 close PARENTHANDLE;
 print CHILDHANDLE "the parent!\n";
 $line = <CHILDHANDLE>;
 print "Parent: $line";
 close CHILDHANDLE;
 waitpid($pid,0);
} else {
 close CHILDHANDLE;
 $line = <PARENTHANDLE>;
 print "Child : $line";
 print PARENTHANDLE "from the child!\n";
 close PARENTHANDLE;
 exit;
}

Socket server

 use IO::Socket;
$server = IO::Socket::INET->new
(
 LocalPort => 1116,
 Type=> SOCK_STREAM,
 Reuse  => 1,
 Listen => 5 
) or die "Could not open port.\n";
while ($client = $server->accept()) {
 $line = <$client>;
 print $line;
}
close($server);

Socket server waiting for clients

 use IO::Socket;
$server = IO::Socket::INET->new
(
 LocalPort => 1247,
 Type=> SOCK_STREAM,
 Reuse  => 1,
 Listen => 5 
) or die "Could not create server.\n";
while ($client = $server->accept()) {
 unless (defined($child_pid = fork())) {die "Can not fork.\n"};
 if ($child_pid) {
  while ($line = <$client>) {
print "Read this from client: $line";
  }
 } else {
  while ($line = <>) {
print $client $line; 
  }
 } 
}

TCP client

 #!/usr/bin/perl 
use warnings;
use strict;
use IO::Socket;
my $host = 'localhost'; 
my $port = 4444;
my $server = new IO::Socket::INET(
 Proto => 'tcp',
 PeerAddr => $host,
 PeerPort => $port,
);
die "Connect failed: $!\n" unless $server;
print "Client connected.\n";
print "Server says: ", scalar(<$server>);
print $server "Hello from the client!\n";
print "Server says: ", scalar(<$server>);
print $server "And goodbye!\n";
print "Server says: ", scalar(<$server>);
close $server;

TCP client using Socket module.

 #!/usr/bin/perl -w  
use IO::Socket;  
  
$port = 999;  
$num_args = scalar( @ARGV );  
  
$host = 'localhost';  
print "Connecting to $host\n";
  
$client_socket = IO::Socket::INET->new(
  PeerPort  => $port,
  PeerAddr  => $host,
  Proto  => 'tcp',
  Type=> SOCK_STREAM )
  or die "Cannot open socket: $!";
# Read data from server.
$msg = <$client_socket>;
print "Recieved message from server:\n";
print "$msg\n";
 
$client_socket->close();

tcp inet client

 #!/usr/bin/perl 
use warnings;
use strict;
use Socket;
my $proto = getprotobyname('tcp');
my $host = inet_aton('localhost');
my $port = 4444;
my $servaddr = sockaddr_in($port, $host);
socket SERVER, PF_INET, SOCK_STREAM, $proto or die "Unable to create socket: $!";
connect SERVER, $servaddr or die "Unable to connect: $!";
select SERVER; $| = 1; select STDOUT;
print "Client connected.\n";
print "Server says: ", scalar(<SERVER>);
print SERVER "Hello from the client!\n";
print "Server says: ", scalar(<SERVER>);
print SERVER "And goodbye!\n";
print "Server says: ", scalar(<SERVER>);
close SERVER;

TCP inet server

 #!/usr/bin/perl 
use strict;
use warnings;
use Socket;
my $proto = getprotobyname('tcp');
my $port = 4444;
my $servaddr = sockaddr_in($port, INADDR_ANY);
socket SERVER, PF_INET, SOCK_STREAM, $proto or die "Unable to create socket: $!";
bind SERVER, $servaddr or die "Unable to bind: $!";
listen SERVER, 10;
print "Server running on port $port...\n";
while (accept CONNECTION, SERVER) {
 select CONNECTION; $| = 1; select STDOUT;
 print "Client connected at ", scalar(localtime), "\n";
 print CONNECTION "You're connected to the server!\n";
 while (<CONNECTION>) {
  print "Client says: $_\n";
 }
 close CONNECTION;
 print "Client disconnected\n";
}

TCP server

 #!/usr/bin/perl 
use warnings;
use strict;
use IO::Socket;
my $port = 4444;
my $server = new IO::Socket::INET(
 Proto  => 'tcp',
 LocalPort => $port,
 Listen => SOMAXCONN,
);
print "Server running on port $port...\n";
while (my $connection = $server->accept) {
 print "Client connected at ", scalar(localtime), "\n";
 print $connection "You're connected to the server!\n";
 while (<$connection>) {
  print "Client says: $_";
 }
 close $connection;
 print "Client disconnected\n";
}

Telnet to a remote host

 use Net::Telnet;
$telnet = Net::Telnet->new
( 
 Timeout => 90,
 Prompt  => '%', 
 Host => 'server.com' 
);
$telnet->login('username', 'password');
$telnet->cmd("cd folder1");
@listing = $telnet->cmd("ls");
print "Here are the files:\n";
print "@listing";
$telnet->close;

The Client Program

 #!/usr/bin/perl
print "client\n";
$AF_UNIX=1;
$SOCK_STREAM=1;
$PROTOCOL=0;
socket(CLIENTSOCKET, $AF_UNIX, $SOCK_STREAM, $PROTOCOL);
$name="./greetings";
do{
$result = connect(CLIENTSOCKET, "$name" );
if ($result != 1 ){
sleep(1);
}
}while($result !=  1 ); # Loop until a connection is made
read(CLIENTSOCKET, $buf, 500);
print STDOUT "$buf\n";
close (CLIENTSOCKET);
exit(0);

The Client with Socket

 #!/usr/local/bin/perl -Tw
require 5.6.0;
use Socket;
use FileHandle;
use strict;
my($remote, $port, @thataddr, $that,$them, $proto,@now,$hertime);
print "client\n";
$remote = shift || 'localhost' ;
$port = 99999 ;  # timeserver is at this port number
@thataddr=gethostbyname($remote);
$that = pack('Sna4x8', AF_INET, $port, $thataddr[4]);
$proto = getprotobyname('tcp');
if ( socket(SOCK, PF_INET, SOCK_STREAM, $proto ) ){
  print "Socket ok.\n";
}
else { 
  die $!; 
}
if (connect(SOCK, $that)) {
  print "Connect ok.\n";
}
else {
  die $!;
}
SOCK->autoflush;
$hertime = <SOCK>;
close(SOCK);
print "Server machine time is: $hertime\n";
@now = localtime($hertime);
print "\tTime-$now[2]:$now[1] ","Date-",$now[4]+1,"/$now[3]/$now[5]\n";

The following commands allow you to pick up a file via FTP

 #!/usr/bin/perl -w
# Usage:
# perl ftp.pl host username password
use Net::FTP;
$host  = $ARGV[0];
$user  = $ARGV[1];
$password = $ARGV[2];
$ftp = Net::FTP->new($host);
$ftp->login($user, $password);
$ftp->cwd("/pub");
$dir = $ftp->dir();
foreach $line ( @$dir ) {
print "$line\n";
}
$ftp->binary();
$ftp->get("filename.tgz");
$ftp->quit();

The gethostbyaddr function searches the file /etc/hosts for the host name.

 # The syntax is (name, altnames, addrtype, len, addrs) = gethostbyaddr (inaddr, inaddrtype); 
#!/usr/local/bin/perl 
$machine ="123.1.1.1"; 
@bytes = split (/\./, $machine); 
$packaddr = pack ("C4", @bytes); 
if (!(($name, $altnames, $addrtype, $len, @addrlist) = gethostbyaddr ($packaddr, 2))) { 
 die ("Address $machine not found.\n"); 
} 
print ("Principal name: $name\n"); 
if ($altnames ne "") { 
 print ("Alternative names:\n"); 
 @altlist = split (/\s+/, $altnames); 
 for ($i = 0; $i < @altlist; $i++) { 
  print ("\t$altlist[$i]\n"); 
 } 
}

The gethostbyaddr function translates a network address to its corresponding names.

 Format: gethostbyaddr(ADDRESS, DOMAIN_NUMBER);
#!/bin/perl
$address=pack("C4", 127,0,0,1);
($name, $aliases,  $addrtype, $length, @addrs) = gethostbyaddr($address,2);
($a, $b, $c, $d) = unpack ( 'C4', $addrs[0]);
print "Hostname Is $name and the Internet address Is $a.$b.$c.$d.\n";

The gethostbyname function returns an entry from the /etc/hosts file for the name of a specific host passed as an argument.

 Format: gethostbyname(NAME);
($name, $aliases, $addtrtype, $length,@addrs)=gethostbyname("dolphin");

The gethostbyname function searches for an /etc/hosts entry that matches a specified machine name.

 # The syntax is (name, altnames, addrtype, len, addrs) = gethostbyname (inname); 
#!/usr/local/bin/perl 
$machine ="123.1.1.1"; 
if (!(($name, $altnames, $addrtype, $len, @addrlist) = gethostbyname ($machine))) { 
 die ("Machine name $machine not found.\n"); 
} 
print ("Equivalent addresses:\n"); 
for ($i = 0; $i < @addrlist; $i++) { 
 @addrbytes = unpack("C4", $addrlist[$i]); 
 $realaddr = join (".", @addrbytes); 
 print ("\t$realaddr\n"); 
}

The gethostent function returns a list consisting of the next line from the /etc/hosts file.

 #!/bin/perl
while ( ($name,  $aliases, $addrtype, $length, @addrs) =gethostent ){
 ($a, $b, $c, $d) = unpack ( 'C4', $addrs[0]);
 print "The name of the host is $name.\n";
 print "Local host address (unpacked) $a.$b.$c.$d\n";
}

The getnetent function steps through the file /etc/networks, which lists the names and addresses of the networks your machine is on.

 # The syntax is (name, altnames, addrtype, net) = getnetent(); 
#!/usr/local/bin/perl 
while (($name, $altnames, $addrtype, $rawaddr) = getnetent()) { 
 @addrbytes = unpack ("C4", $rawaddr); 
 $address = join (".", @addrbytes); 
 print ("$name, at address $address\n"); 
}

The getprotobyname takes the protocol name as an argument and returns its name, any aliases, and its protocol number.

 # Format: getprotobyname(NAME);
($name,  $aliases, $proto ) = getprotobyname('tcp');
print "name=$name\taliases=$aliases\t$protocol number=$proto\n";

The getprotobynumber function takes the protocol number as an argument and returns the name of the protocol, any aliases, and its protocol number.

 # Format: getprotobynumber(NUMBER);
($name,  $aliases, $proto) = getprotobynumber(0);
print "name=$name\taliases=$aliases\t$protocol number=$proto\n";

The getservbyname function translates the service port name to its corresponding port number.

 Format: getservbyname(NAME, PROTOCOL);
($name,$aliases,$port,$protocol)=getservbyname('telnet', 'tcp');

The getservbyport function retrieves information from the /etc/services file.

 # Format: getservbyport(PORT, PROTOCOL);
#!/bin/perl
print "What is the port number? ";
chomp($PORT=<>);
print "What is the protocol? ";
chomp($PROTOCOL=<>);
($name, $aliases, $port, $proto ) = getservbyport($PORT, $PROTOCOL);
print "The getservbyport function returns:
  name=$name
  aliases=$aliases
  port number=$port
  prototype=$protocol \n";

The getservent function reads the next line from the /etc/services file.

 setservent(1 );
($name, $aliases, $port, $proto) = getservent;
print "Name=$name\nAliases=$aliases\nPort=$port\nProtocol=$protocol\n";
($name, $aliases, $port, $proto) = getservent;
# Retrieves the next entry in /etc/services
print "Name=$name\nAliases=$aliases\nPort=$port\nProtocol=$protocol\n";
endservent;

The server and the client are on the same machine

 #!/bin/perl
print "Server Started.\n";
$AF_UNIX=1;  # The domain is AF_UNIX
$SOCK_STREAM=1; # The type is SOCK_STREAM
$PROTOCOL=0; # Protocol 0 is accepted as the "correct protocol" by most systems.
socket(SERVERSOCKET, $AF_UNIX, $SOCK_STREAM, $PROTOCOL) || die " Socket $!\n";
print "socket OK\n";
$name="./greetings"; 
unlink "./greetings" || warn "$name: $!\n";
bind(SERVERSOCKET, $name) || die "Bind $!\n";
print "bind OK\n";
listen(SERVERSOCKET, 5) || die "Listen $!\n";
print "listen OK\n";
while(1){
 accept(NEWSOCKET, SERVERSOCKET ) || die "Accept $!\n";
 $pid=fork || die "Fork: $!\n";
 if ($pid == 0 ){
print (NEWSOCKET "Greetings from your server!!\n";
close(NEWSOCKET);
exit(0);
 }else{
  close (NEWSOCKET);
 }
}

Time client

 #!/usr/local/bin/perl
#Usage: timeclient [server_host_name]
$them = 'localhost';
$port = 9876 ; 
$AF_INET = 2;
$SOCK_STREAM = 1;
$sockaddr = 'S n a4 x8';
($name, $aliases, $proto) = getprotobyname('tcp');
($name,$aliases, $port, $proto)=getservbyname($port, 'tcp') unless $port =~ /^\d+$/;
($name,$aliases, $type, $len, $thataddr)=gethostbyname($them);
$that = pack($sockaddr, $AF_INET, $port, $thataddr);
if ( socket(SOCK, $AF_INET, $SOCK_STREAM, $proto ) ){
 print "Socket ok.\n";
}
else { 
die $!; 
}
if(connect(SOCK, $that)){
print "Connect ok.\n";
}
else { 
die $!;
}
select(SOCK); $| = 1; select (STDOUT);
$hertime = <SOCK>;
close(SOCK);
print "Server machine time is: $hertime\n";
@now = localtime($hertime);
print "\t$now[2]:$now[1] ", $now[4]+1,"/$now[3]/$now[5]\n";

Time server

 #!/usr/bin/perl  -T
#Usage: timeserver [port number]
use strict;
use warnings;
$port=9876;
$AF_INET=2;
$SOCK_STREAM = 1;
$sockaddr = 'S n a4 x8';
($name,$aliases,$proto)=getprotobyname('tcp');
if($port !~ /^\d+$/){
 ($name, $aliases, $port)=getservbyport($port,'tcp');
}
print "Port = $port\n";
$this = pack($sockaddr, $AF_INET, $port, "\0\0\0\0");
select(COMM_SOCK); $| = 1; select (STDOUT);
socket(R_SOCKET, $AF_INET, $SOCK_STREAM, $proto ) ||die "socket: $!\n";
bind(R_SOCKET, $this) || die "bind: $!\n";
listen(R_SOCKET, 5) || die "connect: $!\n";
while(1){
  accept(COMM_SOCK, R_SOCKET) || die "$!\n";
  $now = time;
  print COMM_SOCK $now;
}

Time Server with Socket

 #!/bin/perl  -Tw
require 5.6;
use strict;
use Socket;
use FileHandle;
#Usage: timeserver
my($this, $now);
my $port = shift || 99999;
$this = pack('Sna4x8', AF_INET, $port, "\0\0\0\0");
print "Port = $port\n";
my $prototype = getprotobyname('tcp');
socket(SOCKET, PF_INET, SOCK_STREAM, $prototype) || die "socket: $!\n";
print "Socket ok.\n";
bind(SOCKET, $this) || die "bind: $!\n";
print "Bind ok.\n";
listen(SOCKET, SOMAXCONN) || die "connect: $!\n";
print "Listen ok.\n";
COMM_SOCKET->autoflush;
SOCKET->autoflush;
while(1){
  print "In loop.\n";
  accept(COMM_SOCKET, SOCKET) || die "$!\n";
  print "Accept ok.\n";
  $now = time;
  print COMM_SOCKET $now;
}

Translating hostnames into IP addresses

 #!/usr/bin/perl
use Socket;
my $packed_address = gethostbyname("localhost");
unless ($packed_address) {
 print "$_ => ?\n";
 next;
}
my $dotted_quad = inet_ntoa($packed_address);
print "$_ => $dotted_quad\n";

Translating IP addresses into hostnames

 #!/usr/bin/perl
use Socket;
my $ADDR_PAT = /^\d+\.\d+\.\d+\.\d+$/;
while (<>) {
  chomp;
  die "$_: Not a valid address" unless /$ADDR_PAT/o;
  my $name = gethostbyaddr(inet_aton($_),AF_INET);
  $name ||= '?';
  print "$_ => $name\n";
}

Two way client

 use IO::Socket;
$socket = IO::Socket::INET->new
(
 PeerAddr => 'server.com',
 PeerPort => 1247,
 Proto => "tcp",
 Type  => SOCK_STREAM
) or die "Could not create client.\n";
unless (defined($child_pid = fork())) {die "Can not fork.\n"};
if ($child_pid) {
 while ($line = <>) {
  print $socket $line;
 }
} else {
 while($line = <$socket>) {
  print "Read this from server: $line";
 }
}

Two way server

 use IO::Socket;
$server = IO::Socket::INET->new
(
 LocalPort => 1111,
 Type=> SOCK_STREAM,
 Reuse  => 1,
 Listen => 5 
) or die "Could not create server.\n";
while ($client = $server->accept()) {
 unless (defined($child_pid = fork())) {die "Can not fork.\n"};
 if ($child_pid) {
  while ($line = <$client>) {
print "Read this from client: $line";
  }
 } else {
  while ($line = <>) {
print $client $line; 
  }
 } 
}

UDP client

 #!/usr/bin/perl 
use warnings;
use strict;
use IO::Socket;
my $host = 'localhost';
my $port = 4444;
my $client = new IO::Socket(
 Domain=> PF_INET,
 Proto => 'udp',
);
die "Unable to create socket: $!\n" unless $client;
my $servaddr = sockaddr_in($port, inet_aton($host));
$client->send("Hello from client", 0, $servaddr) or die "Send: $!\n";
my $message;
$client->recv($message, 1024, 0);
print "Response was: $message\n";

UDP inet client

 #!/usr/bin/perl 
use warnings;
use strict;
use Socket;
my $proto = getprotobyname('udp');
my $host  = inet_aton('localhost');
my $port  = 4444;
socket CLIENT, PF_INET, SOCK_DGRAM, $proto or die "Unable to create socket: $!";
my $servaddr = sockaddr_in($port, $host);
send CLIENT, "Hello from client", 0, $servaddr or die "Send: $!\n";
my $message;
recv CLIENT, $message, 1024, 0;
print "Response was: $message\n";

UDP server

 use IO::Socket;
$socket = IO::Socket::INET->new
(
 LocalPort => 4321,
 Proto => 'udp'
);
$socket->recv($text, 128);

UPD inet server

 #!/usr/bin/perl 
use warnings;
use strict;
use Socket;
my $proto = getprotobyname('udp');
my $port = 4444; 
my $servaddr = sockaddr_in($port, INADDR_ANY);
socket SERVER, PF_INET, SOCK_DGRAM, $proto or die "Unable to create socket: $!";
bind SERVER, $servaddr or die "Unable to bind: $!";
print "Server running on port $port...\n";
my $message;
while (my $client = recv SERVER, $message, 1024, 0) {
 my ($port, $ip) = unpack_sockaddr_in($client);
 my $host = gethostbyaddr($ip, AF_INET);
 print "Client $host:$port sent '$message' at ", scalar(localtime), "\n";
 send SERVER, "Message '$message' received", 0, $client;
}

use Mail::POP3Client to send an email out

 use Mail::POP3Client;
$mail = new Mail::POP3Client("username", "password", 
"pop3.yourserver.com");
if ($mail->Count) {
 print "You have ", $mail->Count, " new message(s).\n";
 print "Storing message(s) to disk.\n";
 open FILEHANDLE, ">file.txt";
 for($loop_index = 1; $loop_index <= $mail->Count; $loop_index++) {
  print FILEHANDLE $mail->HeadAndBody(1);
 }
 close FILEHANDLE;
}

Using a Net::FTP Object

 #!/usr/bin/perl
use warnings;
use strict;
use Net::FTP;
my $ftp = Net::FTP->new("ftp.cpan.org")
or die "Couldn't connect: $@\n";
$ftp->login("anonymous");
$ftp->cwd("/pub/CPAN");
$ftp->get("README.html");
$ftp->close;

Using getstore() to Print an Invalid Page

 #!/usr/bin/perl -w
use LWP::Simple;
use strict;
my $status = getstore("http://www.demo.org/nofile.aspx","/tmp/demo");

unless (is_success($status)) {
  die "Couldn't retrieve page: ${$status}";
}
open (PAGE, "/tmp/demo") or die "$!";
while (<PAGE>) {
  print();
}
close(PAGE);

Using HTTP::Request to post request and save response to a file

 use LWP::UserAgent;
$user_agent = new LWP::UserAgent;
$request = new HTTP::Request('GET', 'http://www.cpan.org/doc/FAQs/index.html');

$response = $user_agent->request($request);
open FILEHANDLE, ">file.txt";
print FILEHANDLE $response->{_content};
close FILEHANDLE;

Using is_success() with getstore()

 #!/usr/bin/perl -w
use LWP::Simple;
use strict;
my $status = getstore("http://www.demo.org/","/tmp/demo");
unless (is_success($status)) {
 die "Couldn't retrieve page: $status";
}
open (PAGE, "/tmp/braingia") or die "$!";
while (<PAGE>) {
 print();
}
close(PAGE);

Using Net::FTP to get a file on the server

 use Net::FTP;
$ftp = Net::FTP->new("ftp.cpan.org", Timeout => 30)
  or die "Could not connect.\n";
$username = "anonymous";
$password = "asdf";
$ftp->login($username, $password)
  or die "Could not log in.\n";
$ftp->cwd('/pub/CPAN');
$remotefile = "CPAN.html";
$localfile = "file.txt";
$ftp->get($remotefile, $localfile)
  or die "Can not get file.\n";

Using news group

 use News::NNTPClient;
$nntp = new News::NNTPClient('news.yourserver.com');
($first, $last) = $nntp->group("comp.lang.perl.moderated");
open FILEHANDLE, ">file.txt";
for ($loop_index = $first; $loop_index <= $last; $loop_index++) {
 print FILEHANDLE $nntp->article($loop_index);
}
close FILEHANDLE;

Using POST to post parameters to a Perl CGI

 use HTTP::Request::Common; 
use LWP::UserAgent;
$user_agent = LWP::UserAgent->new;
$request = POST 'http://www.yourserver.com/cgireader.cgi',[text1 => 'Hello', text2 => 'there'];
$response = $user_agent->request($request);
print $response->as_string;
#File: cgireader.cgi
#!/usr/local/bin/perl
use CGI;  
$co = new CGI;
print $co->header,  
$co->start_html(
 -title=>'CGI Example', 
 -author=>'yourName', 
 -BGCOLOR=>'white', 
 -LINK=>'red'
);
if ($co->param()) {
 print 
  "You entered this text: ", 
  $co->em($co->param('text1')), 
  " ",
  $co->em($co->param('text2')), 
  ".";
} else {
 print "Sorry, I did not see any text.";
}
print $co->end_html;

Using regular expresion to validate an IP address

 #!/usr/bin/perl
use Socket;
my $ADDR_PAT = /^\d+\.\d+\.\d+\.\d+$/;
while (<>) {
  chomp;
  die "$_: Not a valid address" unless /$ADDR_PAT/o;
  my $name = gethostbyaddr(inet_aton($_),AF_INET);
  $name ||= '?';
  print "$_ => $name\n";
}

Using Socket to call a Perl CGI

 use IO::Socket;
$name = 'Tom';
$email = 'a@a.com';
$string = '?' . "name=" . $name . "&" . "email=" . $email;
$string =~ tr/ /+/;
$socket = IO::Socket::INET->new
( 
 Proto  => "tcp",
 PeerAddr  => "yourserver.com",
 PeerPort  => 80,
);
$socket->autoflush(1);
print $socket "GET /reg.cgi$string ', 'HTTP/1.0\015\012\015\012";
while ($line = <$socket>) {
 $results .= $line
}
close $socket;
print $results;
if ($results =~ /Thanks for registering./mg) {
 print "Success."
} else {
 print "Sorry, there was an error."
}
#File: reg.cgi
#!/usr/local/bin/perl
use CGI;  
$co = new CGI;
print $co->header,  
$co->start_html(
 -title=>'CGI Example', 
 -author=>'yourName', 
 -meta=>{'keywords'=>'CGI Perl'}, 
 -BGCOLOR=>'white', 
 -LINK=>'red'
);
if ($co->param()) {
 $! = 0;
 open FILEHANDLE, ">>reg.log";
 print FILEHANDLE "Date: " . `date`;
 print FILEHANDLE "Name: " . $co->param('name') . "\n";
 print FILEHANDLE "email: " . $co->param('email') . "\n";
 close FILEHANDLE;
 unless ($!) {
  print "Success.";
 } else {
  print "Sorry, there was an error: $!";
 }
}
print $co->end_html;

Using the mirror() Function

 #!/usr/bin/perl -w
use LWP::Simple;
use strict;
my $url = "http://www.demo.org/";
my $file = "/tmp/demo";
my $status = mirror($url,$file);
die "Cannot retrieve $url" unless is_success($status);


Write Your Comments or Suggestion...