Never been to DZone Snippets before?

Snippets is a public source code repository. Easily build up your personal collection of code snippets, categorize them with tags / keywords, and share them with the world

About this user

Peter Cooperx http://www.petercooper.co.uk/

« Newer Snippets
Older Snippets »
Showing 1-8 of 8 total  RSS 

Fix Content-Length header on UTF8 with HTTP::Daemon in Perl

It seems that HTTP/Daemon.pm is bogus when it calculate
the header 'Content-Length' when the data contains UTF8 data .

In attachement a patch , to calculate the length in bytes
of the data .

-- 
     ____________________________________________________________
    / Erwan MAS                                                 /\
   | mailto:[EMAIL PROTECTED]                                   |_/
___|________________________________________________________   |
\___________________________________________________________\__/

--- Daemon.pm.orig      2004-12-11 16:13:22.000000000 +0100
+++ Daemon.pm   2006-05-02 22:53:33.660393022 +0200
@@ -436,7 +436,7 @@
            }
        }
        elsif (length($content)) {
-           $res->header("Content-Length" => length($content));
+           $res->header("Content-Length" => bytes::length($content));
        }
        else {
            $self->force_last_request;
to perl utf8 unicode http daemon by peter on Jul 17, 2006

Check SQLite version used by DBD::SQLite

use DBI;
$db = DBI->connect("dbi:SQLite:dbname=x", "", "");
print $db->{sqlite_version};
to perl sqlite dbi by peter on Jul 02, 2006

Text synonymizer in Perl - unintelligent text rewriter

Very scrappy and silly, but you get some funny results. It uses the great Lingua::EN::Tagger for POS (Parts of Speech) tagging.

use WordNet::QueryData;
use Lingua::EN::Tagger;

my $t = new Lingua::EN::Tagger;
my $wn = WordNet::QueryData->new;

my $text;

open (FH, "<" . $ARGV[0]);
while (<FH>) { $text .= $_; }
close (FH);

my $tagged = $t->add_tags($text);

while ($tagged =~ /\<(.+?)\>(\w+)\<.+?\>/g) {
        my $sense = $1;
        my $word = $2;
        my $newsense = "";
        $newsense = "n" if ($sense =~ /nn/i);
        $newsense = "a" if ($sense =~ /jj/i);
        $newsense = "v" if ($sense =~ /vb/i);
        if ($newsense) {
                foreach ($wn->querySense($word . "#" . $newsense . "#1" , "syns")) {
                        s/\#.+//;
                        next if (/$word/);
                        $text =~ s/$word/$_/;
                        last;
                }
        }

};

print $text;
exit;


Or to do it to a Web page / URL, use HTML::Parser like so:

use WordNet::QueryData;
use Lingua::EN::Tagger;
use HTML::Parser;
use LWP::Simple;

my $t = new Lingua::EN::Tagger;
my $wn = WordNet::QueryData->new;
my $p = HTML::Parser->new( text_h => [\&text, "text"] );

$p->parse(get("http://www.petercooper.co.uk/"));

exit;

sub text {
        my $text = shift;
        $text =~ s/\s+/\ /g;
        if ($text =~ /\w{5}/) {        
                print "WAS: " . $text . "\n\n";
                print "BECOMES: " . &synonymize($text) . "\n\n\n\n";
        }
}

sub synonymize {
        my $text = shift;

        my $tagged = $t->add_tags($text);

        while ($tagged =~ /\<(.+?)\>(\w+)\<.+?\>/g) {
        my $sense = $1;
        my $word = $2;
        my $newsense = "";
        $newsense = "n" if ($sense =~ /nn/i);
        $newsense = "a" if ($sense =~ /jj/i);
        $newsense = "v" if ($sense =~ /vb/i);
        if ($newsense) {
                foreach ($wn->querySense($word . "#" . $newsense . "#1" , "syns")) {
                        s/\#.+//;
                        next if (/$word/);
                        $text =~ s/$word/$_/;
                        last;
                }
        }

        };
        return $text;
}
to perl text pos rewriting by peter on Apr 14, 2006

Search and replace over file(s) with Perl

A quick bit of Perl can come in handy if you have an old site to update that has no CMS, or something similar.

To change 'source' to 'destination' in all HTML files in the current directory:

perl -pi -e 's/source/destination/g' *.html


You could use this to update copyright notices, etc.. but bear in mind you need to stay with Perl/regex syntax, so escape those forward slashes, etc :)
to linux perl replace search by peter on Feb 21, 2006 4 Comments

Complex file copy

find *.orig.jpg | perl -p -e 's/\n//; $x = $_; s/\.orig/\.large/; $_ = "cp " . $x . " " . $_ . "\n"'


Would have used the basename | xargs method covered here, but the filenames were odd.
to files perl find copy copying by peter on May 30, 2005

FastCGI test script

If you're having trouble with FastCGI (as I was), this Perl script can help you see if the problem is at the Apache end or the app end. In my case I'd simply not deleted the old Ruby sessions for my Rails app when switching from CGI to FCGI ;-) This script proved my Apache wasn't broken, at least.

#!/usr/bin/perl

use FCGI;

$cnt = 0;

while (FCGI::accept() >= 0)
{
   print ("Content-type: text/html\r\n\r\n");
   print ("<head>\n<title>FastCGI Demo Page (perl)</title>\n</head>\n");
   print  ("<h1>FastCGI Demo Page (perl)</h1>\n");
   print ("This is coming from a FastCGI server.\n<BR>\n");
   print ("Running on <EM>$ENV{USER}</EM> to <EM>$ENV{REMOTE_HOST}</EM>\n<BR>\n");
    $cnt++;
   print ("This is connection number $cnt\n");
}
to apache perl fastcgi mod_fastcgi fcgi by peter on May 15, 2005

User friendly hashes with only upper case characters and digits

I need a fast, user friendly hash. This means I want it to be only capital letters and digits. No symbols that people can't pronounce, and no mixed case to be misunderstood on the phone, etc. Use a hashing method like MD5 or SHA1 first, and then apply this..

Ruby
newhash = oldhash.scan(/./).map{|t1| t2 = t1[0] % 36; t2 < 26 ? (t2+65).chr : (t2+22).chr }.join

Perl
$newhash = join "", map { $t1 = ord($_) % 36; $t1 < 26 ? chr($t1+65) : chr($t1+22) } split(//, $oldhash);

This turns any hash into only using [A-Z0-9]. Even a 8 character hash/key using [A-Z0-9] results in 2,821,109,907,456 combinations ;-)
to ruby hash perl hashing by peter on May 07, 2005

Pre-forking HTTP daemon in Perl

Version 2.. it had issues with zombie / defunct processes on Linux. This is significantly more stable, and I'm currently serving 300,000+ requests a day on something based off of this:

#!/usr/bin/perl

# Basic pre-forking HTTP daemon - version 2
# By Peter Cooper - http://www.petercooper.co.uk/
#
# Inspiration and various rehashed snippetsof code from the Perl 
# cfdaemon engine - http://perl-cfd.sourceforge.net/
#
# You can switch out HTTP::Daemon and make it a pre-forking daemonized 
# 'anything' if you wish..

use HTTP::Daemon;
use HTTP::Status;
use CGI;
use POSIX;

my $totalChildren = 15;				# Number of listening children to keep alive
my $childLifetime = 10;			# Let each child serve up to this many requests
my $logFile = "/tmp/daemon.log";	# Log requests and errors to this file
my %children;							# Store pids of children
my $children = 0;						# Store number of currently active children

&daemonize;								# Daemonize the parent

my $d = HTTP::Daemon->new( LocalPort => 1981, LocalAddr => '127.0.0.1', Reuse => 1, Timeout => 180 ) || die "Cannot create socket: $!\n";

warn ("master is ", $d->url);

&spawnChildren;
&keepTicking;
exit;


# spawnChildren - initial process to spawn the right number of children

sub spawnChildren {
	for (1..$totalChildren) {
		&newChild();
	}
}


# keepTicking - a never ending loop for the parent process which just monitors
# dying children and generates new ones

sub keepTicking {
	while ( 1 ) {
		sleep;
	  	for (my $i = $children; $i < $totalChildren; $i++ ) {
		  &newChild();
		}
	};
}


# newChild - a forked child process that actually does some work

sub newChild {
	my $pid;
	my $sigset = POSIX::SigSet->new(SIGINT);				# Delay any interruptions!
   sigprocmask(SIG_BLOCK, $sigset) or die "Can't block SIGINT for fork: $!";
   die "Cannot fork child: $!\n" unless defined ($pid = fork);
	if ($pid) {
		$children{$pid} = 1;										# Report a child is using this pid
		$children++;												# Increase the child count
		warn "forked new child, we now have $children children";
		return;														# Head back to wait around
	}
	
	my $i;
	while ($i < $childLifetime) {				# Loop for $childLifetime requests
		$i++;
		my $c = $d->accept or last;							# Accept a request, or if timed out.. die early
		$c->autoflush(1);
		logMessage ("connect:". $c->peerhost . "\n");	# We've accepted a connection!
     	my $r = $c->get_request(1) or last;					# Get the request. If it fails, die early

		# Insert your own logic code here. The request is in $r
		# What we do here is check if the method is not GET, if so.. send back a 403.

		my $url = $r->url;
		$url =~ s/^\///g;

     	if ($r->method ne 'GET') { 
			$c->send_error(RC_FORBIDDEN); 
			logMessage ($c->peerhost . " made weird request\n"); 
			redo;
		}
		
		my $response = HTTP::Response->new(200);			# Put together a response
		logMessage ($c->peerhost . " " . $d->url . $url . "\n");	
		$response->content("<html><body>The daemon works! This child has served $i requests.</body></html>");
#				$response->content("document.write('OK $i<br \/>');");
		$response->header("Content-Type" => "text/html");
		$c->send_response($response);							# Send back a basic response
		
		logMessage ("disconnect:" . $c->peerhost . " - ct[$i]\n");		# Log the end of the request
      $c->close;
	}
	
	warn "child terminated after $i requests";
	exit;
}


# REAPER - a reaper of dead children/zombies with exit codes to spare

sub REAPER {                            
	my $stiff;
	while (($stiff = waitpid(-1, &WNOHANG)) > 0) {
		warn ("child $stiff terminated -- status $?");
		$children--;
		$children{$stiff};
	}
	$SIG{CHLD} = \&REAPER;
}        

# daemonize - daemonize the parent/control app

sub daemonize {
	my $pid = fork;												# Fork off the main process
	defined ($pid) or die "Cannot start daemon: $!"; 	# If no PID is defined, the daemon failed to start
	print "Parent daemon running.\n" if $pid;				# If we have a PID, the parent daemonized okay
	exit if $pid;													# Return control to the user

   # Now we're a daemonized parent process!

	POSIX::setsid();												# Become a session leader

	close (STDOUT);												# Close file handles to detach from any terminals
	close (STDIN);
	close (STDERR);

	# Set up signals we want to catch. Let's log warnings, fatal errors, and catch hangups and dying children

	$SIG{__WARN__} = sub {
			&logMessage ("NOTE! " . join(" ", @_));
	};
	
	$SIG{__DIE__} = sub { 
		&logMessage ("FATAL! " . join(" ", @_));
		exit;
	};

	$SIG{HUP} = $SIG{INT} = $SIG{TERM} = sub {			# Any sort of death trigger results in instant death of all
	  my $sig = shift;
	  $SIG{$sig} = 'IGNORE';
	  kill 'INT' => keys %children;
	  die "killed by $sig\n";
	  exit;
	};	
	
	$SIG{CHLD} = \&REAPER;
}

# logMessage - append messages to a log file. messy, but it works for now.

sub logMessage {
	my $message = shift;
	(my $sec, my $min, my $hour, my $mday, my $mon, my $year) = gmtime();
	$mon++;
	$mon = sprintf("%0.2d", $mon);
	$mday = sprintf("%0.2d", $mday);
	$hour = sprintf("%0.2d", $hour);
	$min = sprintf("%0.2d", $min);
	$sec = sprintf("%0.2d", $sec);
	$year += 1900;
	my $time = qq{$year/$mon/$mday $hour:$min:$sec};
	open (FH, ">>" . $logFile);
	print FH $time . " - " . $message;
	close (FH);
}
to perl http daemon by peter on May 05, 2005 1 Comments
« Newer Snippets
Older Snippets »
Showing 1-8 of 8 total  RSS