Showing posts with label Perl. Show all posts
Showing posts with label Perl. Show all posts

Monday, April 6, 2015

Perl - extend lib path

See: http://www.perlhowto.com/extending_the_library_path

This is useful when you want to use personal lib for perl modules, which is not on perl path (@INC) and cannot be found.

3 methods are mentioned.

1) The non-invasive method is to use -I switch:

perl -I /home/path/lib -I /usr/another/lib script.pl

2) add path to environment:

# unix, bourne shell
PERL5LIB=/home/path/lib:/usr/another/path/lib; export PERL5LIB


3) add path to perl code:

#!/usr/bin/perl
use lib "/home/path/lib";
use lib "/usr/another/lib";

use MyCustomModule;

Friday, July 25, 2014

Online books for Perl

Talk about web client programming, and LWP module.

[1] Web Client Programming in Perl 
[2] Perl and LWP

Saturday, July 19, 2014

Write a crawler in Perl

Now improve a web crawler in Perl, based on a script I wrote several years ago. This can be useful if there is a need to download a bundle of files from a website.

The crawl and storage parts are there now. Some general considerations are below. These considerations, of course, are independent of implementation language.

- Crawl
  - keeps links crawled, in queue or hash
  - get header: status code (200, 404 etc.), content-size, content-type, modification time
  - broken links
  - dynamic page
  - special chars in url if create local folder using url path
  - relative url - handled by relevant lib.
  - wait interval between requests
  - robot.txt [11]
  - mime types
  - referrer
  - html parsing
  - header 302 redirect, and redirect level
  - javascript submit/redirect
  - non-stardard tags

- Storage
  - use web structure, or flat (need to resolve file name conflicts)
  - store progress: in file or database: link_queue, non_link_queue, current pointer in link_queue.

- Data Analysis and mining
  - text mining
  - reverse index
  - NLP etc.

- Rank Analysis
  - web link graph
  - page rank


== Compile Perl to executable ==

Seems PAR is a good choice [1][2].


== Other Perl Crawlers ==

[5] is a good introduction on the modules to use to write a crawler in Perl.
[4] is a simple one. [6] seems more involved.

[10] is a good introduction to general principles of web crawler.


== GUI with Perl/Tk ==

With Tk it's easy to make event driven GUI interface [7][8][9].

Tried to install Tk. Type:

sudo Perl -MCPAN -e shell
> install Tk

But there is error that prevents the installation to finish:

t/wm-tcl.t ................... 119/315 
#   Failed test 'attempting to resize a gridded toplevel to a value bigger'
#   at t/wm-tcl.t line 1153.
#          got: '4'
#     expected: '6'

#   Failed test at t/wm-tcl.t line 1155.
#          got: '4'
#     expected: '5'
t/wm-tcl.t ................... 312/315 # Looks like you failed 2 tests of 315.
t/wm-tcl.t ................... Dubious, test returned 2 (wstat 512, 0x200)
Failed 2/315 subtests 
(less 43 skipped subtests: 270 okay)
(31 TODO tests unexpectedly succeeded)

Test Summary Report
-------------------
t/listbox.t                (Wstat: 0 Tests: 537 Failed: 0)
  TODO passed:   320, 322, 328, 502
t/text.t                   (Wstat: 0 Tests: 415 Failed: 0)
  TODO passed:   121
t/wm-tcl.t                 (Wstat: 512 Tests: 315 Failed: 2)
  Failed tests:  160-161
  TODO passed:   64, 86-87, 154-157, 164-165, 171-176, 221-224
                237-239, 264-265, 275-276, 280-283, 300
  Non-zero exit status: 2
t/zzScrolled.t             (Wstat: 0 Tests: 94 Failed: 0)
  TODO passed:   52, 66, 80, 94
Files=74, Tests=4348, 55 wallclock secs ( 0.84 usr  0.25 sys + 14.66 cusr  1.57 csys = 17.32 CPU)
Result: FAIL
Failed 1/74 test programs. 2/4348 subtests failed.
make: *** [test_dynamic] Error 255
  SREZIC/Tk-804.032.tar.gz
  /usr/bin/make test -- NOT OK
//hint// to see the cpan-testers results for installing this module, try:
  reports SREZIC/Tk-804.032.tar.gz
Running make install
  make test had returned bad status, won't install without force
Failed during this command:
 SREZIC/Tk-804.032.tar.gz                     : make_test NO

Only 2 tests failed out of many on a resize issue, shouldn't be serious. So use force option to install and it worked:

sudo perl -fi Tk


References:

[1] Create self-contained Perl executables, Part II
[2] PAR: Perl Archiving Toolkit
[3] Compiling or packaging an executable from perl code on windows

[4] Web scraping with modern perl
[5] Web crawling with Perl
[6] spider.pl - Example Perl program to spider web servers

[7] Tk:UserGuid
[8] Learning Perl/Tk: Graphical User Interfaces with Perl
[9] Book: Mastering Perl/Tk

[10] Wiki: web crawler
[11] Robots Exclusion Standard


Monday, July 14, 2014

Supporting PHP, ASP, JSP/Servlet and Tomcat in Perl Web Server

Last time we implemented a small but functional HTTP web server in Perl, which works like Apache by serving static contents. When that was done, it became instantly clear how and why a HTTP web server, such as Apache, works that way.  It also became somewhat clear how Apache uses extensions to work with non-static content, such as PHP, JSP, ASP etc.

For example, when a PHP file test.php is requested, in the Perl web server, just call something like this:
system("php test.php");
then grab the output and send it back to the client. The basic principle is as simple as that.

Now I'm looking at JEE, which uses Tomcat application server and a connector module in the middle to work with Apache.  I'm thinking I should be able to extend my Perl web server to work with  Tomcat, and thus the JSP/Servlet/JEE stack as well.

To do this is easy: in a config file, tell the Perl web server which paths should be mapped to Tomcat. Then, when a request coming for that path, establish a TCP client, transfer the request URL to Tomcat, which basically means to send a request to "http://localhost:8080/path", and receive the response from Tomcat server, then send it back to the Perl web server client.

Actually, this can be easily verified by using telnet. Type:
telnet localhost 8080
This will establish a connection session to Tomcat server. Next type this request:
GET /
The Tomcat server will send the index page back, and close the connection.

Basically, what the Perl web server should do is exactly the same. To implement this, we need to be able to code a web client in Perl.  We can either build it from scratch in socket programming, or use the LWP module, as in reference [1]. 

To work with ASP or ASP.NET, the Perl web server can work as a proxy, passing the request to an internal IIS web server, and sends back the response.

This way, the Perl web server in principle can work with any other web technologies.

== Create Web Browser with a GUI ==

Chapter 7 of [1] is on graphical examples in Perl/Tk. This basically demonstrates how to implement your own web browser with a GUI (not just command line interface), similar to firefox or any other popular web browsers.  And if we can do it in Perl/Tk, we can also create the GUI interface in Java or C/C++. Following this way, we can reinvent the entire wheel of the internet world [2][3]. [3] talks about the libwww module of Python, which was written by Tim Berners-Lee, and contains many functions needed by a web application including a browser.

One of the most difficult part of this is the amount of work involved in html/javascript/css parser and renderer. In 2006 Netscape wanted to create a new one from scratch, they failed after 3 years.  Many of current browsers are based on a rendering engine, this is WebKit [6][7] for Safari and Chrome (before 28), blink for Opera and Chrome (28+) [11][12], Gecko for Firefox [10], and Trident for IE [8][9].

A list of browser html rendering engines can be found in [4][5], including Amaya, Blink, Gecho, KHTML, Presto, Tasman, Trident and WebKit.


References:

[1] Web Client Programming in Perl
[2] Where should you start Coding a Web Browser?
[3] W3C Blog: Build Your Own Browser
[4] Comparison of layout engines (HTML)
[5] Web browser engine
[6] The WebKit Open Source Project
[7] Wiki: WebKit
[8] Wiki: Trident (layout engine)
[9] Internet Explorer Architecture
[10] Wiki: Gecko
[11] Wiki: Blink (layout engine)
[12] The Chromium Projects: Blink


Saturday, June 28, 2014

A Perl HTTP Web Server - Full source code

This is the full source code of the HTTP web server written in Perl we discussed in the previous post.

If you visit a page /index.html which contains an image tag <img src="bg.jpg">, the log file of this HTTP web server will be something like:

2014-7-3 3:47:28  server is started
2014-7-3 3:47:28  Listening on [IO::Socket::INET=GLOB(0x7f8bd98bd9f0)] 0.0.0.0:9000 ...
2014-7-3 3:52:40  == incoming connection from [IO::Socket::INET=GLOB(0x7f8bd98bd9f0)] 127.0.0.1:51659 ...
2014-7-3 3:52:40  request file: /index.html
2014-7-3 3:52:40  == incoming connection from [IO::Socket::INET=GLOB(0x7f8bd98bd9f0)] 127.0.0.1:51661 ...
2014-7-3 3:52:40  request file: /bg.jpg


Some notes:
- Here LocalAddr should be "0.0.0.0" instead of "localhost" or "127.0.0.1" if you want remote computers to be able to access it. If it's "localhost" or "127.0.0.1" then you can access it only from local machine.
- Besides using a browser, you can also access the web server using telnet: telnet [ip] [port]
- Use this command to see open ports on local machine: netstat -an | grep "LISTEN"
- On Ubuntu, use this to add a chain rule to iptables firewall to open a port (e.g., see here): iptables -A INPUT -p tcp --dport 9000 -j ACCEPT
- On Mac, besides the firewall in System Preferences -> Security & Privacy -> Firewall, there is another deprecated firewall: ipfw. By default it opens all the ports though. To see its rules, use: sudo ipfw list.
- Here we use a buffer size of 1024 in the recv call. In reality, the GET request length is limited from 2K to 8K bytes for different browsers. For example, this source says: The limit (of HTTP GET Request) is in MSIE and Safari about 2KB, in Opera about 4KB and in Firefox about 8KB. We may thus assume that 8KB is the maximum possible length and that 2KB is a more affordable length to rely on at the server side and that 255 bytes is the safest length to assume that the entire URL will come in.

Note that since HTTP is a stateless protocol, we close the connection immediately after each time we send response. In reality, we may not be able to receive the entire request message in one read. But as a demonstration of concept this serves pretty well.

One may ask why recreate the wheel? The answer is, of course, we don't need another primitive HTTP web server, we already got so many. But if we need a service, which resides on a linux/unix/mac server and listens to a specific port, to accomplish a specific task, then we can easily write a server of our own this way using this template, using our own customized protocol.  Another situation is that if for some reason you don't have a web server, then you can use this template to build one. Of course, this later case rarely happens today.

As for the applicability, this Perl server runs well on linux/unix/mac. For windows, it is easy to build something similar as a windows service, such as a .NET remoting TCP server, to listen on a specific port and accomplish similar tasks.


#
# This script demonstrates a functional HTTP web server in Perl:
# 1) running the Perl HTTP web server as a daemon in background.
# 2) only one copy of the server can run by checking "Proc::PID::File->running()".
# 3) implementation of daemon commands: start, stop, status.
#    e.g. start the web server by: sudo perl dmon_server.pl start.
#
# Note: 
# 1) to run as daemon, "sudo" should be used for non-admin user.
# 2) parameters that can change: $LOG_FILE, $WWWROOT, $USE_OPT,
#     and $localport in functoin do_start().
#
# @By: X.C.
# @Created on: 6/28/2014
# @Last modified: 7/2/2014
#

#!/usr/bin/perl

use strict;
use warnings;
use Getopt::Long;
use Proc::Daemon;
use Proc::PID::File;
use IO::Select;
use IO::Socket;
use URI::Escape;

#
# Location of log file.
#
my $LOG_FILE = "/Users/chenx/tmp/dmon.log";
#
# Location of web root.
#
my $WWWROOT = "/Users/chenx/tmp/wwwroot";

#
# If $USE_OPT = 1, use GetOptions. 
# 0 is better here because if an arg does not start with "--",
# it will be ignored and no usage information is printed.
#
my $USE_OPT = 0; 


my $len = @ARGV;
if ($len == 0) {
    show_usage();
} else {
    if ($USE_OPT) {
        GetOptions(
            "start" => \&do_start,
            "status" => \&show_status,
            "stop" => \&do_stop,
            "help" => \&show_usage
        ) or show_usage();
    } else {
        my $cmd = $ARGV[0];
        if ($cmd eq "start") { do_start(); }
        elsif ($cmd eq "stop") { do_stop(); }
        elsif ($cmd eq "status") { show_status(); }
        else { show_usage(); }
    }
}


#
# 1 at the end of a module means that the module returns true to use/require statements. 
# It can be used to tell if module initialization is successful. 
# Otherwise, use/require will fail.
#
# 1;


sub show_usage {
    if ($USE_OPT) {
        print "Usage: sudo perl $0 --[start|stop|status|help]\n";
    } else {
        print "Usage: sudo $0 [start|stop|status]\n";
    }
    exit(0);
}


sub show_status {
    if (Proc::PID::File->running()) {
        print "daemon is running..\n";
    } else {
        print "daemon is stopped\n";
    }
}


sub do_stop {
    my $pid = Proc::PID::File->running();
    if ($pid == 0) {
        print "daemon is not running\n";
    } else {
        #print "stop daemon now ..\n";
        kill(9, $pid);
        print "daemon is stopped\n";
    }
    do_log("server is stopped");
}


sub do_start {
    print "start daemon now\n";

    Proc::Daemon::Init();

    if (Proc::PID::File->running()) {
        do_log( "A copy of this daemon is already running, exit" );
        exit(0);
    }

    do_log("server is started");

    my ($data, $fh, $data_len); 
    my $localhost = "0.0.0.0";
    my $localport = 9000;
    my $ipc_select = IO::Select->new();
    my $IPC_SOCKET = new IO::Socket::INET(
             Listen  => 5, LocalAddr => $localhost, LocalPort => $localport, Proto => "tcp" );

    $ipc_select->add($IPC_SOCKET);
    do_log( "Listening on [$IPC_SOCKET] $localhost:$localport ..." );
    while (1) {
      if (my @ready = $ipc_select->can_read(.01)) {
        foreach $fh (@ready) {
            if($fh == $IPC_SOCKET) {
                my $new = $IPC_SOCKET->accept;
                $ipc_select->add($new);
                do_log( "== incoming connection from [$fh] " . 
                        $new->peerhost() . ":" . $new->peerport() . " ...");
            } else {
                recv($fh, $data, 1024, 0);
                my $data_len = length($data);
                if ($data_len > 0) { # feedback to client.
                    print $fh http_response($data);
                }
                $ipc_select->remove($fh);
                $fh->close;
            }
        }
      }
    }
}



#
# Implements part of the HTTP protocal:
# - GET command
# - Status code: 200, 400, 404, 500
# - Customized command TEST, with status code -1.
#
# Reference: http://www.w3.org/Protocols/rfc2616/rfc2616.html
#
sub http_response {
    my ($request) = @_;

    my $status = 0;
    my $data = "";
    if ($request =~ m/^GET\s(\S+)\s/) {
        do_log("request file: $1");
        my $file = ($1 eq "/") ? "/index.html" : $1;  # default file under a directory.
        $file = uri_unescape($file); # url_decode() function. E.g. change %20 back to space.

        my $path = "$WWWROOT$file";
        if (-e $path) {
           my $open_ok = 1;
           open my $fh, '<', $path or $open_ok = 0; # die "error opening $path: $!";
           if ($open_ok == 1) {
               $data = do { local $/ = undef; <$fh> };
               $status = 200;
           } else {
               $data = "Internal Server Error";
               $status = 500;
           }
        }
        else { # file not found.
           $data = "Not Found";
           $status = 404;
        }
    } elsif ($request =~ m/^TEST\s/) {
        $status = -1; # for testing purpose of the Perl Web Server.
    } else { # bad request: unknown command.
        $data = "Bad Request";
        $status = 400;
    }


    my $response = "";
    if ($status == 200) {
        my $data_len = length($data);
        $response = "HTTP/1.1 200 OK\nContent-Type:text\nContent-Length:$data_len\n\n$data";
    }
    elsif ($status == 400 || $status == 404 || $status == 500) {
        my $body = "";
        my $data_len = length($body);
        $response = "HTTP/1.1 $status $data\nContent-Type:text\nContent-Length:$data_len\n\n$body";
    }
    else { # status == -1
        my $hdr = "PERL Web Server Received:\n";
        my $data_len = length($hdr) + length($request);
        $response = "HTTP/1.1 200 OK\nContent-Type:text\nContent-Length:$data_len\n\n$hdr$request";
    }

    return $response;
}


sub do_log {
    my ($msg) = @_;

    my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime();
    $year += 1900;
    $mon += 1;

    open FILE, ">>$LOG_FILE" or die "cannot open log file $!\n";
    print FILE "$year-$mon-$mday $hour:$min:$sec  $msg\n";
    close FILE;
}


A Perl HTTP Web Server

This is a simple server written in Perl. It listens on a port, but does not follow the HTTP protocol. It just echoes whatever the client sent in.

Note for examples in this post the value of "LocalAddr" is "localhost", so the servers here are accessible only on local machine. If you want access from a remote machine, you should change it to "0.0.0.0".


# This demonstrates a simple Perl HTTP server.
# A user can connect using: telnet [host] [port], here port = 9000.
# The user will say something, which the server repeats.
# When the user says "bye", the connection is closed.
#
# Modified from: http://www.perlmonks.org/?node_id=49823
# By: X.C.
# Created on: 6/28/2014
# Last modified: 6/28/2014
#
#!/usr/bin/perl -w
use strict;
use IO::Select;
use IO::Socket;

my ($data, $fh);
my $ipc_select = IO::Select->new();
my $IPC_SOCKET = new IO::Socket::INET(Listen    => 5,
                                    LocalAddr => 'localhost',
                                    LocalPort => 9000,
                                    Proto   => "tcp" );


$ipc_select->add($IPC_SOCKET);
print "Listening on Socket [$IPC_SOCKET] ...\n";
while (1) {
    if (my @ready = $ipc_select->can_read(.01)) {
        foreach $fh (@ready) {
            if($fh == $IPC_SOCKET) {
                #add incoming socket to select
                my $new = $IPC_SOCKET->accept;
                $ipc_select->add($new);
                print "== incoming connection...\n";
            } else {
                # Process socket
                my $n = recv($fh, $data, 1024, 0); # this seems to be empty.
                my $data_len = length($data); # $data ends with "\r\n".
                #print "data len:" . length($data) . "\n";
                if ($n || $data_len > 0) {
                    print $fh "Server feedback: $data"; # feedback to client.
                    $data = substr($data, 0, $data_len - 2);
                    print "incoming data: $data\n";
                    #chomp($data); # this won't work, since $data is a buffer not filled with 0s.
                    if (uc($data) eq "BYE") {
                        print "== close connection\n";
                        $ipc_select->remove($fh);
                        $fh->close;
                    }
                } else { # seems this won't get executed ever.
                    $ipc_select->remove($fh);
                    $fh->close;
                }
            }
        }
    }
}

Or it can be simplified into the code below. Now this uses standard HTTP response and is a HTTP web server, so you can actually visit it from a browser using url http://localhost:9000/.


#!/usr/bin/perl -w
use strict;
use IO::Select;
use IO::Socket;

my ($data, $fh);
my $ipc_select = IO::Select->new();
my $IPC_SOCKET = new IO::Socket::INET(
    Listen  => 5, LocalAddr => 'localhost', LocalPort => 9000, Proto => "tcp" );

$ipc_select->add($IPC_SOCKET);
print "Listening on Socket [$IPC_SOCKET] ...\n";
while (1) {
    if (my @ready = $ipc_select->can_read(.01)) {
        foreach $fh (@ready) {
            if($fh == $IPC_SOCKET) {
                my $new = $IPC_SOCKET->accept;
                $ipc_select->add($new);
                print "== incoming connection from [$fh]...\n";
            } else {
                recv($fh, $data, 1024, 0); 

                my $data_len = length($data);
                if ($data_len > 0 && uc($data) ne "BYE\r\n") { # feedback to client.
                    print $fh "HTTP/1.0 200 OK\nContent-Type:text\nContent-Length:$data_len\n\n$data"; 
                } else { 
                    $ipc_select->remove($fh);
                    $fh->close;
                }
            }
        }
    }
}

So far this is run in a console, and is tied to the controlling console. If you type CTRL-C then it's stopped, or when the console is closed it's gone.  However, by combining this with the Perl daemon we discussed in the previous post, we obtain a full-fledged web server written in Perl! This web server runs as a daemon process. You can visit it in a web browser using http://localhost:9000. So far the only thing this web server does is to prepend the client request with "PERL Web Server Received:" and send it back to the client.

To be exact, the only modifications needed to the Perl daemon in the previous post are:

1) add this to the top of file:

use IO::Select;
use IO::Socket;


2) replace the do_start() function with:

sub do_start {
    print "start daemon now\n";

    Proc::Daemon::Init();

    if (Proc::PID::File->running()) {
        do_log( "A copy of this daemon is already running, exit" );
        exit(0);
    }

    my ($data, $fh, $data_len);
    my $ipc_select = IO::Select->new();
    my $IPC_SOCKET = new IO::Socket::INET(
        Listen  => 5, LocalAddr => 'localhost', LocalPort => 9000, Proto => "tcp" );

    $ipc_select->add($IPC_SOCKET);
    do_log( "Listening on Socket [$IPC_SOCKET] ..." );
    while (1) {
      if (my @ready = $ipc_select->can_read(.01)) {
        foreach $fh (@ready) {
            if($fh == $IPC_SOCKET) {
                my $new = $IPC_SOCKET->accept;
                $ipc_select->add($new);
                do_log( "== incoming connection from [$fh]..." );
            } else {
                recv($fh, $data, 1024, 0);
                my $data_len = length($data);
                if ($data_len > 0) { # feedback to client.
                    print $fh http_response($data);
                }
                $ipc_select->remove($fh);
                $fh->close;
            }
        }
      }
    }
}

sub http_response {
    my ($request) = @_;
    my $hdr = "PERL Web Server Received:\n";
    my $data_len = length($hdr) + length($request);

    return "HTTP/1.0 200 OK\nContent-Type:text\nContent-Length:$data_len\n\n$hdr$request";
}

A Perl daemon

A daemon is a process running in the background continuously. It is the linux comparable of a windows service. A daemon or windows service can do many things in the background. If you let it open and listen to a port, it becomes a server, e.g., a web server like Apache or IIS, or a database server like MySQL or MongoDB. For this reason, it is a very interesting and useful thing to learn how to write a daemon or windows service. The installation and/or execution of a linux daemon or windows service usually requires the user to have admin permission.

A Perl daemon can be easily implemented using the Proc::Daemon module [1]. If you don't have this installed, you can do it by:

sudo perl -MCPAN -e shell
cpan[1]> install Proc::Daemon
cpan[2]> install Proc::PID::File

A Perl daemon can be as simple as this (note you will need to run it with "sudo"):

#!/usr/bin/perl
use Proc::Daemon;
use Proc::PID::File;

Proc::Daemon::Init; # Demonize.
if (Proc::PID::File->running()) { exit(0); # Exit if already running, so only 1 instance can run.
for (;;) { 
    # print "do something every 5 seconds..\n"; # This won't print because STDOUT is closed.
    sleep(5); 
}


You cannot really see any console print output since STDOUT is closed by Proc::Daemon. You can see output by printing to a log file, or use the "top" command to see this new process.

Here is a more full-fledged version of a Perl daemon. It allows you to use start/stop/status commands to control and monitor the daemon. A log file is also generated.


#
# This script demonstates:
# 1) running a Perl script as daemon in background, using the Daemon module.
# 2) only one instance of the daemon can run by checking "Proc::PID::File->running()".
# 3) implementation of daemon commands: start, stop, status.
# 4) use of Getopt::Long, $0 (name of this file).
#
# Note:
# 1) to run as daemon, "sudo" should be used for non-admin user.
# 2) parameters that can change: $LOG_FILE, $USE_OPT.
#
# @By: X.C.
# @Created on: 6/28/2014
# @Last modified: 6/28/2014
#

#!/usr/bin/perl

use strict;
use warnings;
use Getopt::Long;
use Proc::Daemon;
use Proc::PID::File;

#
# Location of log file.
#
my $LOG_FILE = "/Users/chenx/tmp/dmon.log";

#
# If $USE_OPT = 1, use GetOptions.
# 0 is better here because if an arg does not start with "--",
# it will be ignored and no usage information is printed.
#
my $USE_OPT = 0;


my $len = @ARGV;
if ($len == 0) {
    show_usage();
} else {
    if ($USE_OPT) {
        GetOptions(
            "start" => \&do_start,
            "status" => \&show_status,
            "stop" => \&do_stop,
            "help" => \&show_usage
        ) or show_usage();
    } else {
        my $cmd = $ARGV[0];
        if ($cmd eq "start") { do_start(); }
        elsif ($cmd eq "stop") { do_stop(); }
        elsif ($cmd eq "status") { show_status(); }
        else { show_usage(); }
    }
}


#
# 1 at the end of a module means that the module returns true to use/require statements.
# It can be used to tell if module initialization is successful.
# Otherwise, use/require will fail.
#
# 1;


sub show_usage {
    if ($USE_OPT) {
        print "Usage: sudo perl $0 --[start|stop|status|help]\n";
    } else {
        print "Usage: sudo $0 [start|stop|status]\n";
    }
    exit(0);
}


sub show_status {
    if (Proc::PID::File->running()) {
        print "daemon is running..\n";
    } else {
        print "daemon is stopped\n";
    }
}


sub do_stop {
    my $pid = Proc::PID::File->running();
    if ($pid == 0) {
        print "daemon is not running\n";
    } else {
        #print "stop daemon now ..\n";
        kill(9, $pid);
        print "daemon is stopped\n";
    }
}


sub do_start {
    print "start daemon now\n";

    Proc::Daemon::Init();

    #
    # To use this, you need to start the daemon with "sudo" to have the permission
    # to PID file. To kill the daemon, "sudo" is also needed.
    #
    if (Proc::PID::File->running()) {
        do_log( "A copy of this daemon is already running, exit" );
        exit(0);
    }

    my $continue = 1;
    $SIG{TERM} = sub { $continue = 0; };

    while ($continue) {
        #print "continue ..\n"; # this won't work, since STDOUT is closed.
        do_log("continuing ..");

        sleep(2);
    }
}


sub do_log {
    my ($msg) = @_;

    my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime();
    $year += 1900;

    open FILE, ">>$LOG_FILE" or die "cannot open log file $!\n";
    print FILE "$year-$mon-$mday $hour:$min:$sec  $msg\n";
    close FILE;
}


Alternatively, you can also implement a daemon without using Proc::Daemon.  An example is below.

This code [2] is back from year 2000. The current Proc::Daemon implements majority of these ideas. These are also the basic requirements of a well-rounded daemon, so it won't become a demon:

1) Fork a child process as the daemon, the exit the parent process. This guarantees the daemon process is free of any controlling process and terminal.
2) Call setsid. This makes the daemon process a session leader, and free of any controlling terminal/shell.
3) Change working dir, usually "/". This prevents the relevant partition where the working dir resides from resisting unmounting by admin.
4) Use umask to cancel the default file creation mode permission inherited from parent process.
5) Close unneeded file handlers, mostly STDIN, STDOUT and STDERR, by redirecting them to /dev/null. This is because a daemon has no associated terminal/shell and has nowhere to write these to.
6) Logging message, so you know what's going on when STDOUT and STDERR are closed.


#!/usr/bin/perl

#
# This demonstrates running a Perl program in background as daemon without using Proc::Daemon.
# More than 1 instance can run at the same time.
# From: [2] 
#

use POSIX qw(setsid);

chdir '/';
umask 0;
open STDIN, '/dev/null';
#open STDOUT, '>/Users/chenx/tmp/dmon.log';
open STDERR, '>/dev/null';

defined(my $pid = fork);
exit if $pid;
setsid;

while(1)
{
    sleep(2);
    #print "Hello...\n";
    do_log();
}

# note: cannot use "log" as it's preserved.
sub do_log {
    open LOGFILE, '>>', '/Users/chenx/tmp/dmon.log' or die "cannot open file"; # $!;
    print LOGFILE "continue on ..\n";
    close LOGFILE;
}


There is an interesting Perl Daemon Contest [3] here, back in 2000. Some of these are pretty complicated and highly practical, such as web proxy, system monitoring and reporting, stock monitoring, even a reversed-engineered printer daemon, and an interesting AI game of rock/scissors/paper played inside the file system.


References:

[1] Proc::Daemon implementation version 0.14
[2] Unix Daemon In Perl Tutorial
[3] Perl Daemon Contest


Tuesday, September 4, 2012

A Chinese poem processor

A lot of language games can be done. I am also thinking of doing some Natural Language Processing stuff later.
The code below can be improved significantly in the data processing part. For example, on things such as 1) length of poem sentence, 2) position of target character, 3) tone (平仄), 4) semantic analysis so the mood matches.
More poem source files can be added.
The only tricky thing here so far is handling UTF8 characters.
#
# This script reads Chinese poems and store the sentences into a repository,
# then find poem sentences that start with letters in the given target sentence.
#
# This can be used for some language games, 
# such as forming a poem for somebody's birthday in the form of a "藏头诗".
#
# This script should be saved in utf8 format. 
#
# http://ahinea.com/en/tech/perl-unicode-struggle.html
# http://stackoverflow.com/questions/519309/how-do-i-read-utf-8-with-diamond-operator
# http://stackoverflow.com/questions/9574198/comparing-two-unicode-strings-with-perl
# 
# Chinese poems:
# http://www.shuku.net/novels/mulu/shici.html
#
# 藏头诗 generator: http://www.zhelizhao.com/cangtoushi/
#
# By: HomeTom
# Created on: 2012/09/04
#

require Encode;
use utf8;
use strict;

##################
# Change setting here.
##################

# Data source
my @files = ("tang300.txt", "song100.txt");
# Target sentence
my $target = ("小明生日快乐");

##################

my $cnt = 1;
my $len;
my @chars;
my @first = (); # first char.
#my $char;
my $DEBUG1 = 0;
my $DEBUG2 = 0;
#print "hi\n";

#binmode STDIN, ":utf8";
binmode STDOUT, ":utf8";

##################
# Read data.
##################

my @lines = ();
my @lines2;

foreach my $file (@files) {
  open FILE, $file or die $!;
  @lines2 = <FILE>;
  close FILE;
  push(@lines, @lines2);
}

##################
# Process and analyze data.
##################

foreach my $line (@lines) {
  chomp($line);
  $line = trim($line);
  $line = Encode::decode_utf8($line);
  @chars = split //, $line;

  if ($DEBUG1) { 
    print "$cnt: $line\n"; 
    print "$cnt: "; 
    print "$_." foreach (@chars); 
    print "\n"; 
  }

  #if ($chars[0] ne "") 
  {
    push (@first, $chars[0]);
  }

  $cnt ++;
}

if ($DEBUG2) {
  print "$_\n" foreach (@first);
}

$len = @first;


##################
# Search poem sentences for each word in the target sentence.
##################

my @words = split //, $target;

foreach my $w (@words) {
  print "==$w==\n";
  getLetterLines($w);
}


1;


##################
# Subroutines
##################

sub getLetterLines() {
  my $i;
  my $c;
  my $letter = shift;
  for ($i = 0; $i < $len; $i ++) {
    $c = $first[$i];
    if ($c eq $letter) { print "$i: $lines[$i]\n"; }
  }
  #print "\n";
}


#
# Trim functions, from: http://www.somacon.com/p114.php
#

# Perl trim function to remove whitespace from the start and end of the string
sub trim($)
{
  my $string = shift;
  $string =~ s/^\s+//;
  $string =~ s/\s+$//;
  return $string;
}
# Left trim function to remove leading whitespace
sub ltrim($)
{
  my $string = shift;
  $string =~ s/^\s+//;
  return $string;
}
# Right trim function to remove trailing whitespace
sub rtrim($)
{
  my $string = shift;
  $string =~ s/\s+$//;
  return $string;
}

Wednesday, December 29, 2010

Perl OOP and reference

Perl can do OOP for sure. I reviewed relevant material for recent work. Use "Package" to define a class. What's interesting is the use of "bless" keyword. An object is used in the syntax of a C++ object, say you use "->" to retrieve its member variable or function.

The use of reference facilitates a lot of programming features. In Perl using a back slash "\" in front of a variable (scalar, array or hash) turns it into a reference. This can be passed to subroutines, to be used recursively etc. To cast it back and refer to the object, use $/@{}/%{} for scalar/array/hash respectively.

References:
- Object Oriented Programming in PERL

Tuesday, December 14, 2010

Perlpod

Perlpod: The Plain Old Document format.

Description about Perlpod from the above source:

Pod is a simple-to-use markup language used for writing documentation for Perl, Perl programs, and Perl modules.
Translators are available for converting Pod to various formats like plain text, HTML, man pages, and more.
Pod markup consists of three basic kinds of paragraphs: ordinary, verbatim, and command.

Wednesday, May 12, 2010

OLE with Perl

Perl can do many things beyond normal expectation. One example is with OLE objects. If you have MS Office installed on your computer, you can try the following code. It creates a word document and saves as C:\test.doc. You will see the Word document automatically opening up, adding lines and closing down. This demonstrates the capability of Perl to manipulate MS Office files. Application is such as automatic business report generation.

#!\usr\bin\perl -w
# http://www.adp-gmbh.ch/perl/word.html
# http://www.xav.com/perl/faq/Windows/ActivePerl-Winfaq12.html
# http://www.ngbdigital.com/perl_ole_word.html

use warnings;
use strict;

use Win32::OLE;

my $word = CreateObject Win32::OLE 'Word.Application' or die $!;
$word->{'Visible'} = 1;

my $filename = "C:\\test.doc";
my $document = $word->Documents->Add;

my $selection = $word->Selection;

$selection -> TypeText("Hello HomeTom");
$selection -> TypeParagraph;
$selection -> TypeText("How are you doing today?");
$selection -> TypeParagraph;

$selection -> TypeText("Great. How about you?");
$selection -> {'Style'} = "Heading 1";

$selection -> TypeParagraph;

my $heading_1 = $document->Styles("Heading 1");
my $heading_1_font = $heading_1 -> Font;

$heading_1_font -> {Name} = "Bookmann";
$heading_1_font -> {Size} = 20;
$heading_1_font -> {Bold} = 1;

# Save As
$word->ActiveDocument->SaveAs({FileName => $filename});

$selection -> Typeparagraph;
$selection -> TypeText("Now save and exit after 3 seconds");

sleep 3;

$word->Documents->Close;
$word->Quit;

1;

Monday, January 25, 2010

Perl 5.10 Install GD library

In Perl 5.10, the ActiveState ppm server no longer includes the GD package because it's difficult to include it in the automated build process [1]. The GD module however is available from the repository of the University of Winnipeg at http://theoryx5.uwinnipeg.ca/ppms/ (for Perl 5.8) or http://cpan.uwinnipeg.ca/PPMPackages/10xx/ (for Perl 5.10) [2].

So when use ppm to install GD module, one needs to add the second repository.

[1] http://docs.activestate.com/activeperl/5.10/faq/ActivePerl-faq2.html
[2] http://trouchelle.com/perl/ppmrepview.pl

[Added 3/6/2010]
On Centos, installing GD library for PHP can be easily done by: yum -install php-gd

Saturday, December 12, 2009

Read/Write Excel on Windows & Linux

On windows read/write Excel is easy. Set up ODBC for read and write connections on source and destination Excel files. For some reason Microsoft does not allow delete records in Excel through the ODBC interface (actually might be in any other interfaces), so delete can be done by replacing the current Excel with a blank Excel at the File System level.

In linux, there are modules created by people in PHP to do this, such as PHPExcel. So you download the library and use it. In Perl, the modules Spreadsheet::ParseExcel and Spreadsheet:WriteExcel are written by Takanori Kawai and John McNamara in 2000 and tincluded into CPAN. If your Perl installation does not come with this, install them (e.g., using PPM on windows or CPAN on linux). Some example code are here. This code works for Excel up to version 2000. I didn't try on more recent versions. On windows Perl also can manipulate Excel using the Win32::OLE package which is recommended.

To write Excel file, there is a shortcut to output to a *.csv file. A *.csv file uses comma as delimiter and is opened by Excel, then you can save it as a true Excel file. To escape comma in a *.csv file, quote the entry by double quotes, e.g., "a,b". To include a double quote in an quoted entry, replace it with two double quotes, e.g., "a""b".

Monday, November 30, 2009

A Perl script to count LOC (Lines Of Code)


#!/usr/bin/perl

#
# This script counts number of lines in files of specified type.
# The counting is done recursively into subdirectory.
# @Usage: perl getLOC.pl [dir|file]
# If no argument is provided, start from current dir ".".
# @By: XC
# @Created on: 11/29/2009
#

print "\n- Line Counter -\n\n";

# specify file type(s) here. Use "[]" to escape ".".
my @types = ("[.]c", "[.]h");
#my @types = ("[.]cs"); #, "[.]aspx");
#my @types = ("[.]asp");

my $dirname = ".";
my $total_loc = 0;

# Get input directory name.
my $argc = $#ARGV + 1;
if ($argc > 0) {
$dirname = $ARGV[0];
}

# Process the starting directory or file.
if (-d $dirname) {
processDIR($dirname);
} else {
if (inTypesArray($dirname)) { countLOC($dirname); }
}

# Output total line count.
print "\n[$dirname] Total Lines: $total_loc\n";

1;


#
# Recursively process directory.
#
sub processDIR() {
my ($dirname) = @_;
my $file;

opendir(DIR, $dirname) or die "can't opendir $dirname: $!";
# Exclude "." and "..".
my @files = grep { !/^\.{1,2}$/ } readdir (DIR);
closedir(DIR);
#sort @files;

foreach (@files) {
$file = "$dirname/$_";

if (-d $file) {
processDIR($file); # Is directory. Recursion.
}
elsif (inTypesArray($file)) {
countLOC($file);
}
}
}


#
# Determine if this file is of specified type.
#
sub inTypesArray() {
my ($f) = @_;
my $t;
foreach $t (@types) {
if ($f =~ /$t$/) { return 1; }
}
return 0;
}


#
# Count number of lines in the file.
#
sub countLOC() {
my ($file) = @_;
my $loc = 0;
my @lines;
my $line_ct;

open(FILE, "$file");
while(<FILE>) {
@lines = split(/\r/, $_);
$line_ct = @lines;
#$loc ++;
$loc += $line_ct;
}
close(FILE);
print "[$file] Lines: $loc\n";

$total_loc += $loc;
}

Blog Archive

Followers