William Jiang

JavaScript,PHP,Node,Perl,LAMP Web Developer – http://williamjxj.com; https://github.com/williamjxj?tab=repositories

Perl 3

package commons;

use FileHandle;
use POSIX qw(setsid);
use SOAP::Lite;
use Data::Dumper;
use strict;
use Socket;
use Sys::Hostname;

use lib qw (/home/william/bin);
use config;
use ett_parser;

#------------------------------------------------
# OOP: create constructor. 
#------------------------------------------------
sub new
{
	my $proto = shift;  
	my $class = ref( $proto ) || $proto;  
	my $self = {};  

	bless $self, $class;
}


#------------------------------------------------
# 1. initialize environment:trap signal,log,etc.
#------------------------------------------------
sub init_environment
{
	my ($self, $log) = @_;

	# A well behaved daemon will chdir() to the root directory so it doesn't
	# prevent unmounting the filesystem containing the directory from which
	# it was launched.
	#
	chdir;		# or use Cwd; chroot( getcwd() );

	my ($name, $suffix);
	$name = qx(basename $0);   chomp($name);	#cci,ectrack,track
	$suffix = qx(date +'%Y%m');  chomp($suffix); # 200307

	if( $log ) {
		my $logfile = LOGDIR . $log . "_" . $suffix . ".log";

		open (STDOUT, '>>', $logfile) || die "stdout: $!";
		open (STDERR, '>>&STDOUT') || die "stderr: $!";
	}

	my $sql_name;
	if(  $self->{log_sql} ) {
			$sql_name = LOGDIR.$name."_".$self->{log_sql}.".log";
	}
	elsif( $self->{batch} ) {
			$sql_name = LOGDIR.$name."_".$self->{batch}."_sql.log";
	}	
	else {
			$sql_name = LOGDIR.$name."_sql.log";
	}

	# if file size > MAXLOGSIZE, then open by 'w', otherwize open by 'a'.
	# file exists and writable by effective uid/gid.
	if( -e $sql_name && -w _ ) {

		my $size = -s "$sql_name";	# get logfile's size.

		if ($size > MAXLOGSIZE) {
			rename($sql_name, $sql_name.".old") or die "$!";
			$self->{sql} = new FileHandle $sql_name, 'w' or die "$!";
			$self->{sql}->autoflush( 1 );
		}
	}
	else {
		$self->{sql} = new FileHandle $sql_name, 'a' or die "$!";
		$self->{sql}->autoflush( 1 );
	}

	# Flush standard output buffer.
	select(STDOUT); $| = 1;

	# It is better to use signal to prevent from interrupt.
	# Many signal must be omited, use 'kill -l' to choose.
	# SIGPIPE for pipe.
	# Consider what happens when start up a pipe to a command that doesn't exist? 
	#
	my @signals = ('INT', 'QUIT', 'TERM'); # 'PIPE'
	foreach (@signals) {
		$SIG{ $_ } = \&exit_request_handler;
	}

	# send e-mail;
  # $SIG{ 'ALRM' }  = $self->postMail("Alarm Signal generated at " . __PACKAGE__ . '[' . __LINE__. ']');


	#Zombies
	#You have to be prepared to ``reap'' the child process when it finishes 
	$SIG{ 'CHLD' } = \&child_handler;

	##open($self->{fifo}, ">". FIFO_PATH) || die "can't write $self->{fifo}: $!";

	# It is better to fork a child process to do the job.
	# Notice: 'unless' = 'not defined' + '0'.
	#
	my $pid = fork();
	die "Cannot fork, $!" unless defined $pid;
	exit 4 if $pid;

	# This will keep process is un-relative with the current shell.
	# use setsid() to generate new progress group.
	#
	POSIX::setsid() or die "Can't start a new session: $!";

	print '['.localtime() . "]: Now Begin Track Service ......\n\n";

	print '[ '.__LINE__." ] Initialize running environment is OK.\n";

	return 1;
}


#----------------------------------------------------------------------
# 3. use SOAP to span Intranet and Internet.
# Write common proxy() and uri() settings for all SOAP::Lite objects.
# All objects created after this will be cloned from the default object
# and hence get its properties.
#
# proxy: service address (endpoint): server.cgi
# It will dispatch SOAP calls on 'modules' directory.
# endpoint: 'http://localhost:80//cgibin/server.cgi',
# proxy server to pass through firewiall: http://vancouver:8080.
# uri: uri for SOAP methods.
#----------------------------------------------------------------------
sub setup_soap
{
	my ($self, $uri, $daemon) = @_;

	die "Which database should soap server access ?" unless (defined $uri);
	$daemon ||= SOAP_DAEMON;

	$self->{soap} = SOAP::Lite
		->uri( $uri )
		->proxy( $daemon )
	;

	# can ignore.
	$self->{soap}->transport->proxy(SOAP_PROXY) unless(defined $ENV{HTTP_proxy});

	# switch on.
	use SOAP::Lite
		on_fault => sub {
			my ($soap, $res) = @_;
			die ref $res ? $res->faultstring : $soap->transport->status, "\n";
		};

	print '[ '.__LINE__." ] Initialize SOAP server is OK.\n";

	return 1;
}

#------------------------------------------------
# 4.1. connect xmlcst tcp agent.
#------------------------------------------------
sub disconnect_xmlcst_agent
{
	my $self = shift;
	close( $self->{SOCK} )    || die "disconnect: $!";
	print "Close socket is OK.\n";
}

sub connect_xmlcst_tcp_agent
{
	my ($self, $server) = @_;
	my ($host, $addr, $remote, $port, $iaddr, $paddr, $proto, $raddr);

	# $0 IP address or hostname.
	$host = hostname() || 'localhost';
	$addr = inet_ntoa( scalar gethostbyname($host) );

	$remote = $server || SERVER;
	$iaddr = inet_aton($remote) || die "no host: $remote";
	$raddr = inet_ntoa( scalar gethostbyname($remote) );

	$port = PORT || 10000;  # random port
	# get from /etc/services
	if ($port =~ /\D/) { $port = getservbyname($port, 'tcp') }

	$paddr   = sockaddr_in($port, $iaddr);
	$proto   = getprotobyname('tcp');

	socket($self->{SOCK}, PF_INET, SOCK_STREAM, $proto)  || die "socket: $!";

	unless (connect($self->{SOCK}, $paddr) ) {

		$self->postMail("$0:  Connection refused at /home/william/bin/common.pm line ". __LINE__.", since xmlcst_tcp_agent was accidently down. Now automatically start xmlcst_tcp_agent, and program will continue process ......");

		# william adds patch here to prevent the server accidently down.
		system("/home/william/bin/xmlcst_tcp_agent");

		sleep (10);

		unless (connect($self->{SOCK}, $paddr) ) {
      $self->postMail("$0: Connection refused at /home/william/bin/common.pm line ". __LINE__ );
      die "connect: can not connect xmlcst_tcp_agent for the second time!";
    }
  }

	# autoflush($self->{SOCK}, 1);

	print '[ '.__LINE__." ] Connect xmlcst tcp agent server is OK.\n";
	print "\tServer name: <$remote>, Server address: <$raddr>\n";
	print "\tServer service port:<$port>, Client name: <$host>\n";

	return 1;
}

#------------------------------------------------
# 4.2. connect xmlcst tcp agent.
#------------------------------------------------
sub connect_xmlcst_ipc_agent 
{
	my $self = shift;

	my $rendezvous = shift || BASEDIR . '.IPC_PATH';

	socket($self->{SOCK}, PF_UNIX, SOCK_STREAM, 0) || die "socket: $!";

	unless(connect($self->{SOCK}, sockaddr_un($rendezvous))) {
		$self->postMail("Connection refused at /home/william/bin/common.pm line ". __LINE__.", since xmlcst_ipc was accidently down. Now automatically start xmlcst_ipc_agent, and program will continue process ......");

		# william adds patch here to prevent the server accidently down.
		system("/home/william/bin/restart_ipc");

		sleep (10);

		unless(connect($self->{SOCK}, sockaddr_un($rendezvous))) {
			$self->postMail("Connection refused at /home/william/bin/common.pm line ". __LINE__ );
			die "connect: can not find .IPC_PATH error!";
		}
	}

	#autoflush($self->{SOCK}, 1);

	my $host = hostname();
	print '[ '.__LINE__." ] Connect xmlcst ipc agent server is OK.\n";
	print "\tClient name: <$host>, IPC path: <$rendezvous>\n";
	
	return 1;
}

#------------------------------------------------
# 7. tidy_tracking_no
# Input:		db aryref of [sid,trk,country,city,date,comment]
# Output:	 $track_no
#------------------------------------------------

sub tidy_tracking_no_encuse
{
	my ($self, $track_aref) = @_;
	my ($track_no, @t1);

	%{$self->{DB}} = map{ $_->[3] => $_ } @$track_aref;
	@t1 = map( $_->[3], @$track_aref );

	if( scalar(@t1) ) {
		$track_no = join( DELIMITER, @t1 ); # assemble $track_no.

		# How about tracking_no like this 'NO DELIVERY, SALES RETURN'?
		$track_no =~ s/\D{2,}/,/g; # non-digital.
		$track_no =~ s/,+/,/g;

		# after sed, there still some track_no?
		unless ($track_no) {
			print '[ '.__LINE__." ] No Tracking Number available!\n";
			return undef;
		}

		$track_no .= TCP_TERMINATE_REQUEST;		 # end with ','
		$track_no =~ s/^,//; # cut of beginning with ','
	}
	#print Dumper($track_no);
	return $track_no;
}

sub tidy_tracking_no_ecship
{
	my ($self, $track_aref) = @_;
	my ($track_no, @t1);

	%{$self->{DB}} = map{ $_->[1] => $_ } @$track_aref;
	@t1 = map( $_->[1], @$track_aref );

	if( scalar(@t1) ) {
		$track_no = join( DELIMITER, @t1 ); # assemble $track_no.

		# How about tracking_no like this 'NO DELIVERY, SALES RETURN'?
		$track_no =~ s/\D{2,}/,/g; # non-digital.
		$track_no =~ s/,+/,/g;

		# after sed, there still some track_no?
		unless ($track_no) {
			print '[ '.__LINE__." ] No Tracking Number available!\n";
			return undef;
		}

		$track_no .= TCP_TERMINATE_REQUEST;		 # end with ','
		$track_no =~ s/^,//; # cut of beginning with ','
	}
	#print Dumper($track_no);
	return $track_no;
}

sub tidy_tracking_no
{
	# $tailer_flag=2, end
	# $tailer_flag=3, loop
	my ($self, $track_aref, $tailer_flag) = @_;

	my $track_no;

	# last account has no tracking_number, just send TERMINATE to stop program.
	if( !$track_aref && ($tailer_flag==2) ) {
		$track_no =~ s/,+/,/g;  # cut off more ','
    $track_no =  "0000000000,";
    return $track_no;
  }

  unless( $track_aref ) {
    print '[ '.__LINE__." ] Input tracking number is null!\n";
    return undef;
  }

	my ($records, @t1);
	
	# just for ETT. ETT's shipment_ref is char(30), not varchar.
	@$track_aref = grep{ $_->[1] =~ s"\s*$"" } @$track_aref;

	# make {track_no=>tracks} hash of array.
	%{$self->{DB}} = map{ $_->[1] => $_ } @$track_aref;

	if( $self->{debug} ) {
		$self->customize_output( __PACKAGE__.' [ '.__LINE__.' ] DB', $self->{DB} );	
	}

	@t1 = map( $_->[1], @$track_aref );

	if( scalar(@t1) ) {
		$track_no = join( DELIMITER, @t1 ); # assemble $track_no.

		# How about tracking_no like this 'NO DELIVERY, SALES RETURN'?
		$track_no =~ s/\D{2,}/,/g; # non-digital.
		$track_no =~ s/,+/,/g;

		# after sed, there still some track_no?
		unless ($track_no) {
			print '[ '.__LINE__." ] No Tracking Number available!\n";
			return undef;
		}

		if ($tailer_flag == 3) {
			# $track_no .= ',' if $track_no !~ m/,$/;
			$track_no .= TCP_AGAIN_REQUEST;		 # end with ','
		}
		else {
			$track_no .= TCP_TERMINATE_REQUEST;		 # end with ','
		}
	}
	else {
		print '[ '.__LINE__." ]  Never come here.\n";
		return undef;
	}

	$records = scalar(@$track_aref);

	print '[ '.__LINE__." ] Total <". $records . "> unprocessed tracking numbers.\n";
	#print Dumper( $track_no );

	if( $self->{debug} ) {
		$self->customize_output( __PACKAGE__.' [ '.__LINE__.' ] Total Tracking Numbers', $records );
		$self->customize_output( __PACKAGE__.' [ '.__LINE__.' ] Tracking Number', $track_no);
	}

	return $track_no;
}

#------------------------------------------------
# 9. validate xml from dummy CST server.
# Return value: loop:-1, terminate:-2, continue:1
#------------------------------------------------
sub validate_xml
{
	my ($self, $xmldata) = @_;

	unless ($xmldata) {
		print '[ '.__LINE__." ] Nothing received!\n";
		return -1;
	}
	elsif( $xmldata =~ m/AGAIN_LOOP/ ) {
		print '[ '.__LINE__." ] AGAIN_LOOP received!\n";
		return -2;
	}
	elsif( $xmldata =~ m/TERMINATE/ ) {
		print __PACKAGE__ .'[ '.__LINE__." ] TERMINATE received! <$xmldata>\n";
		return -3;
	}
	# 3. Without shipment message or exception message returned.
	#
	# How about error tracking number, such as 'LD'?
	# <Number>(\d+)</Number></TrackingNumber>
	elsif( $xmldata =~ m{
			<Number>(.+)</Number></TrackingNumber>
			<Error><Code>(\d+)</Code>
			<Message>(.*?)</Message>
		}sgx ) {

		#print "\n=============== Invalid Tracking#: $1 ===============\n";
		print "<$2>: <$3>\n";

		return -1;
	}
	elsif ($xmldata =~ m{
			<Error><Code>(\d+)</Code>
			<Message>(.*?)</Message>
		}sgx ) {
		#print "\n=============== Invalid Tracking#: UNKNOWN ===============\n";
		print "<$1>: <$2>\n";

		return -1;
	}
	else {
		if( $self->{debug} ) {
			$self->customize_output( __PACKAGE__.' [ '.__LINE__.' ] XMLDATA', $xmldata);
		}
		return 1;
	}
}

#------------------------------------------------
# sendmail for positively control.
#------------------------------------------------
sub postMail 
{
	my ($self, $message, $emailaddr) = @_;
	$message ||= "No message from " . __PACKAGE__;

$emailaddr ||= "william\@dummy.com,other\@dummy.com";

open (SENDMAIL, "|/usr/lib/sendmail -oi -t -odq") or die "Can't sendmail: $!\n";

my $package = __PACKAGE__;

print SENDMAIL <<"EOF";
From:   xmlcst <william\@cst-int>
To:			$emailaddr
Subject: Warning Message from $0 ($package module): CST-INT Machine

$message

EOF

close(SENDMAIL) or warn "sendmail didn't close nicely";
}

#------------------------------------------------
# signal routines used by init_environment().
#------------------------------------------------
sub exit_request_handler
{
	my ($recvsig) = @_;

	foreach (('INT', 'QUIT', 'TERM')) {
		$SIG{ $_ } = 'IGNORE';
	}

	die "Qutting on singal $recvsig\n";
}

#------------------------------------------------
# routine used by init_environment().
#------------------------------------------------
sub child_handler
{
	wait;
}


# What format output?
# $Data::Dumper::Varname = "ectrack";
# $Data::Dumper::Pad = "";
# $Data::Dumper::Useqq = 1;
# $Data::Dumper::Indent = 0;
# $Data::Dumper::Terse = 1; # don't output names where feasible
# $Data::Dumper::Indent = 2;

sub customize_output 
{
	my ($self, $title, $output) = @_;

	return unless $output;

	$title = __PACKAGE__ unless $title;

	unless (ref $output) {
   
		$output =~ s"\n""g;  #cut off newline.
		$output =~ s"\s+" "g;  #cut off multi-space into single space.

		print "\n$title:\n";
		print $output . "\n";
	}
	else {
		$Data::Dumper::Terse = 1; # don't output names where feasible
		
		print "\n$title:\n";
		print Dumper($output);
	}
}


sub seperate_xml
{
	my ($self, $xmldata) = @_;
	return unless $xmldata;

	my @xmls;

	if ($self->{left_data} ){
		$xmldata = $self->{left_data} . $xmldata;
		undef $self->{left_data};
	}

	if( ($xmldata =~ m"TERMINATE"s) or ($xmldata =~ m"AGAIN_LOOP"s) ) {
		$xmldata =~ s/^\s*//;
		$xmldata =~ s/\s*$//;
		if($xmldata eq 'TERMINATE' or $xmldata eq 'AGAIN_LOOP') {
			push @xmls, $xmldata;
			return \@xmls;
		}
	}

	my (@n1, $n2);

	@n1 = split( m/<\?xml version/, $xmldata );

	foreach my $m (@n1) {

		next if( length($m) eq 1 );
		next unless $m;

    if( $m !~ m"Response>$"s ) {
      if( $m =~ m"Response>"s ) {
        $m =~ m"(.*Response>?)(.*$)"s;
        $n2 = $1;

				if( $n2 ) {
					$n2 = '<?xml version' . $n2;
					push @xmls, $n2;
				}
				push @xmls, $2;
			}
			else {
				$self->{left_data} = $m;
				last;
			}
		}
		else {
			$n2 = '<?xml version' . $m;
			push @xmls, $n2;
		}

	} # End of foreach

	return \@xmls;
}

1;
Advertisements

One response to “Perl 3

  1. powercashadvance.com 10/26/2011 at 5:06 pm

    It was something of great pleasure locating your site this morning. I came here right now hoping to discover something new. And I was not let down. Your ideas in new approaches on this topic were helpful and a fantastic help to us. Thank you for making time to write down these things and for sharing your opinions.

Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out / Change )

Twitter picture

You are commenting using your Twitter account. Log Out / Change )

Facebook photo

You are commenting using your Facebook account. Log Out / Change )

Google+ photo

You are commenting using your Google+ account. Log Out / Change )

Connecting to %s

%d bloggers like this: