Show COEHtml.pm.in syntax highlighted
package COEHtml;
##############################################################################################
# File: COEHtml.pm
# Description: Handle interactive HTML (Push & Pull)
# Author: Lee Mayes ( email leem@atl.hp.com )
# Created: Oct 23,1997 - For HPUX RMN
# Language: perl
# See after __END__ for details...
##############################################################################################
# © Copyright 2000-2006 Hewlett-Packard Development Company, L.P
#
# 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., 675 Mass Ave, Cambridge, MA 02139, USA.
##############################################################################################
use Carp;
use strict;
use vars qw($AUTOLOAD $IS_NT);
my %fields = (
htmlfile => undef, # Filename for client pull (undef for push)
delay => 30, # Seconds delay for client pull (default)
endhtml => undef, # Flag to halt interactive HTML
title => undef, # The title on the page
persist => undef, # The persistent message
message => undef, # The message displayed
trailer => undef, # If defined, printed last in plain text
terse => 0, # Set to 1 if calling from cron
newsicon => "<img src=\"/@PACKAGE_NAME@/images/hpuxnews.gif\" alt=\"Newspaper Icon\" border=0>", # The Newspaper Icon
feedicon => "<img src=\"/@PACKAGE_NAME@/images/tellus.gif\" alt=\"Mailbox Icon\" border=0>", # The Feedback Icon
traficon => "<img src=\"/@PACKAGE_NAME@/images/traffic.gif\" alt=\"Traffic Light Icon\" border=0>", # The Feedback Icon
ploticon => "<img src=\"/@PACKAGE_NAME@/images/hpuxgraphs.gif\" alt=\"Plot Icon\" border=0>", # The 'Plot' Icon
myicon => undef, # Icon for Push/Pull
boundary => "RmnBoundaryDude",
serverroot => undef,
do_nothing => undef, # If Set, don't do anything (it's overridden)
);
sub new {
my $proto = shift;
my $class = ref($proto) || $proto;
my $self = { _permitted => \%fields, %fields };
bless ($self, $class);
if ( -d "C:/" ) {
$IS_NT = 1;
$ENV{"PATH_TRANSLATED"} =~ tr/\\/\//;
my @root = split('/',$ENV{"PATH_TRANSLATED"});
if ( $ENV{"SERVER_SOFTWARE"} =~ /Microsoft/ ) {
pop(@root); #drop script name
pop(@root); #drop cgi-bin
}
my $root = join('/',@root);
$self->serverroot($root);
} else {
$IS_NT = 0;
$self->serverroot($ENV{"DOCUMENT_ROOT"});
}
return $self;
}
sub AUTOLOAD {
my $self = shift;
my $type = ref($self) or croak "$self is not an object";
my $name = $AUTOLOAD;
$name =~ s/.*://; # strip fully-qualified portion
#warn "AUTOLOAD Intercepted $name\n";
unless (exists $self->{"_permitted"}->{$name} ) {
croak "Can't access `$name' field in class $type";
}
if (@_) { return $self->{$name} = shift; }
else { return $self->{$name}; }
}
sub DESTROY {}
sub kickstart {
my $self = shift;
return if ( $self->do_nothing );
if ( defined($self->htmlfile) ) { # It's client pull
# Open the file the browser will pull on
my $htmlfile=join('',$self->serverroot,$self->htmlfile);
if (!open(HTML,">$htmlfile")) {
print STDOUT "Content-type: text/html\n\n",
"<TITLE>Bad Path Dude!</TITLE>\n",
"<H3>Open failed on $htmlfile : $! ",
"</h3>\nAborting...\n";
exit;
}
# Preload the self updating page w/default
print HTML "<META HTTP-EQUIV=\"Refresh\" CONTENT=\"",$self->delay,"; ",
"URL=",$self->htmlfile,"\">\n",
"<TITLE>",$self->title,"</TITLE>\n",
"<H2>",$self->myicon," ",$self->persist,"</H2>\n",
"<H4>",$self->message,"</H4>\n",
"This message should update in ",$self->delay," seconds if you are using Netscape 1.1 ",
"or greater. <p> If your browser is Netscape 1.1 challenged, click ",
"<a href=",$self->htmlfile,"><b><i>HERE!</i></b></a>";
close(HTML);
unless ( $self->terse == 1 ) {
# If called via cron, terse == 1 (create HTML, just not on STDOUT)
# Send HTML to the browser to re-direct to htmlfile
print STDOUT "Content-type: text/html\n\n";
print STDOUT "<META HTTP-EQUIV=\"Refresh\" CONTENT=\"1; ",
"URL=",$self->htmlfile,"\">",
"<TITLE>",$self->title,"</TITLE>\n",
"<h3>",$self->myicon," ",$self->persist,
" - Validating input paramaters</h3>\n\n",
"This message should update in 1 seconds if you are using Netscape 1.1 ",
"or greater. <p> If your browser is Netscape 1.1 challenged, click ",
"<a href=",$self->htmlfile,"><b><i>HERE!</i></b></a>";
# Flush to browser...
select(STDOUT);
$|=1;
}
# Detach so we'll process in background.
if ($IS_NT == 0 ) {
if ( my $pid = fork ) {
exit; # Parent here, just get out of the pool
}
close(STDOUT);
open(STDOUT,">/dev/null");
} else {
close(STDOUT);
close(STDIN);
close;
my $stdout = $self->serverroot."/_dev_null";
open(STDOUT,">$stdout");
}
} else { # It's server push
# Check to make sure script name start w/nph-
my $name = $ENV{"SCRIPT_NAME"};
my @foo = split('/',$name);
$name = pop(@foo);
$foo[0] = substr($name,0,4);
if ( $foo[0] ne "nph-" ) {
print STDOUT "Content-type: text/html\n\n",
"<TITLE>Bad Name Dude!</TITLE>\n",
"<H3>For Server Push to work, you must name your ",
"script nph-whatever!!!!</h3>\nMight I suggest ",
"<b>/nph-$name</b>?<p>Aborting...\n";
exit;
}
# Start the HTML push
print STDOUT "HTTP/1.0 200\nContent-type: multipart/x-mixed-replace;",
"boundary=",$self->boundary,"\n\n";
$self->boundary("--".$self->boundary); # Update boundary
print STDOUT $self->boundary,"\nContent-type: text/html\n\n",
"<TITLE>",$self->title,"</TITLE>\n",
"<H2>",$self->myicon," ",$self->persist,"</H2>\n",
"<H4>",$self->message,"</H4>\n";
# Flush to browser...
select(STDOUT);
$|=1;
}
} # End of kickstart()
sub updatehtml {
my $self = shift;
return if ( $self->do_nothing );
if (@_) { $self->delay(shift(@_)) }
if ( defined($self->htmlfile) ) { # It's client pull
# Update the file htmlfile.PID
my $htmlfile=join('',$self->serverroot,$self->htmlfile);
my $pid = $$;
if (!open(HTML,">$htmlfile.$pid")) {
my $message = "Couldn't open $htmlfile.pid : $!\n";
die $message; # BUG
}
unless ( ( $self->endhtml ) || ( $self->delay == 0 ) ) {
print HTML "<META HTTP-EQUIV=\"Refresh\" CONTENT=\"",$self->delay,"; ",
"URL=",$self->htmlfile,"\">\n",
}
print HTML "<TITLE>",$self->title,"</TITLE>\n",
"<H2>",$self->myicon," ",$self->persist,"</H2>\n",
"<H4>",$self->message,"</H4>\n";
unless ( ( $self->endhtml ) || ( $self->delay == 0 ) ) {
print HTML "This message should update in ",$self->delay,
" seconds if you are using Netscape 1.1 ",
"or greater. <p> If you desire more frequent updates,",
"click <a href=",$self->htmlfile,"><b><i>HERE!</i></b></a>";
}
if ( $self->trailer ) {
print HTML "<hr>\n",$self->trailer,"\n";
}
close(HTML);
# Move to htmlfile
if ( $IS_NT == 0 ) {
rename("$htmlfile.$$","$htmlfile");
} else {
system "cp $htmlfile.$$ $htmlfile";
unlink "$htmlfile.$$";
}
} else { # It's server push
print STDOUT $self->boundary,"\nContent-type: text/html\n\n",
"<TITLE>",$self->title,"</TITLE>\n",
"<H2>",$self->myicon," ",$self->persist,"</H2>\n",
"<H4>",$self->message,"</H4>\n",
$self->trailer;
select(STDOUT);
$|=1;
}
} # End of UpdateHTML
__END__
=head1 NAME
COEHtml - Server Push/Client Pull HTML module
=head1 DESCRIPTION
This module implements a simple server push & client pull model.
=head1 USAGE
Usage verbiage goes here...
=head2 Sample Server Push Code
B<WARNING:> For server push to work, your script must be named nph-whatever,
to signal Non-Parsed Headers to the server. If you attempt to use server push
without this script naming convention, this module will simple return an
error.
#!/usr/bin/perl
# Script nph-blastoff
use strict;
use COEHtml;
my $q = new COEHtml;
$q->title("Countdown Test"); # Define the title
$q->persist("Countdown to Blastoff"); # Define the <h2> banner
my $count = 10;
$q->message("T minus $count and counting"); # Define the <h4> banner
$q->kickstart; # Kick off the process
while ( $count > 0 ) {
sleep(1);
$count--;
$q->message("T minus $count and counting"); # Update the <h4> banner
$q->updatehtml; # Send it to the browser
}
$q->title("Countdown Test Done"); # Finish up
$q->persist("Blastoff!");
$q->message("You're outta here!");
$q->updatehtml;
exit;
=head2 Sample Client Pull Code
#!/usr/bin/perl
use strict;
use COEHtml;
my $q = new COEHtml;
# Where should the browser pull from. Note that $ENV{"DOCUMENT_ROOT"}
# will be prepended to this filename!
$q->htmlfile("/hpux/uptime2+/scratch_monkey/myfile");
$q->title("Client Pull Test"); # Define the title
$q->persist("Offline working!"); # Define the <h2> text
$q->message("initializing"); # Define the <h4> text
$q->myicon($q->newsicon); # Put an icon in
$q->delay(1); # Set pull delay
$q->kickstart; # Start it up
my $count = 5;
while ( $count > 0 ) {
sleep($count);
$count--;
$q->message("sleeping $count seconds"); # Re-define <h4> text
$q->updatehtml(1); # Update the browser
}
$q->endhtml(1); # Stop it!
$q->message("Done!");
$q->updatehtml;
exit;
=head2 Method Calls
=over 4
=item C<new>
C<COEHtml::new>
I<class method>
Creates a new, blank push/pull CGI object ripe for your abuse.
=item C<kickstart>
C<COEHtml::kickstart>
I<object method>
Creates the original Server Push/Client pull HTML
B<NOTE:> This should only be called once!
=item C<updatehtml()>
C<COEHtml::updatehtml()>
I<object method>
Update the current HTML (Push & Pull).
If passed a value, it updates delay() as well.
If pass 0, this is equivalent to setting endhtml() and terminates the client
pull.
=item C<endhtml>
C<COEHtml::endhtml>
I<object method>
When using Client pull, this signals the script to write a 'non-renewing' file.
=back
=back
=head2 Appearance
=over 4
=item C<title>
C<COEHtml::title>
I<object method>
The Title of the page displayed. Default : undef
=item C<persist>
C<COEHtml::persist>
I<object method>
This text is placed in header 2 (<H2>) brackets at the top of the page. Default : undef
=item C<myicon>
C<COEHtml::myicon>
I<object method>
This icon is placed in the persist field if defined... Default : undef
Example Usage: COEHtml::myicon('<img src=/pic.gif alt="My Pic" border=0>');
=item C<message>
C<COEHtml::message>
I<object method>
This text is placed in header 4 (<H4>) brackets directly beneath persist(). Default : undef
=item C<trailer>
C<COEHtml::trailer>
I<object method>
This text is placed at the bottom of the page. HTML markup is allowed. Default : undef
=back
=head2 Push/Pull Control
=over 4
=item C<htmlfile>
C<COEHtml::htmlfile>
I<object method>
Path to HTML file to update relative to ServerRoot (e.g. ~www/htdocs ). Default : undef
B<NOTE:>
This variable is used as the switch between server push and client pull. If undefined, server push is used.
B<NOTE:>
The environment variable $DOCUMENT_ROOT directory will be prepended to this filename!
=item C<delay>
C<COEHtml::delay>
I<object method>
Sets/Returns the seconds of delay between client updates. (This sets the REFRESH value in the HTML generated). Default : 30
=back
=head1 AUTHOR
Lee Mayes (leem@atl.hp.com) for Perl COEHtml
=head1 BUGS
This section intentionally left blank, but the AUTHOR section
should qualify this as buggy software...
=cut
See more files for this project here