yourapp.hta
-----------
Your App
------------
server.pl
------------
#
# An simple way to give a perl script a windows interface.
# The application is scripted in html using "PerlScript"
# inside an HTML document. If the document is saved with
# a ".hta" extension it becomes an "HTML application".
#
# Requirements:
# ActivePerl from http://www.activestate.com
# Internet Explorer version 5 or later.
#
# This code is distriubuted under the "Artistic" license
# a copy of which is distributed with Perl.
#
# Copyright John Holdsworth (c) 2001
# http://www.openpsp.org/source/util/du.hta.gz
#
# Minor changes made by Rob Kinyon , 2004
#
# See also:
# http://www.openpsp.org/source/util/perltoc.pl # searchable perl docs
# http://www.openpsp.org/source/util/search.html.gz # search any docs
#
#
# use CGI with "non parsed headers" as
# script talks directly to browser
#
use CGI qw( -nph );
use IO::Socket;
use strict;
use warnings;
use vars qw(
$window
$listener
);
# required for open to work
close STDIN;
close STDOUT;
# server runs on any available port
# a zero second timeout is not possible using IO::Socket
$listener = IO::Socket::INET->new(
Listen => 5,
LocalAddr => "127.0.0.1",
Timeout => 0.000001,
) or warn "Could not open Socket";
#
# start polling for connections
#
poll();
#
# This function is called periodically
# to poll for incomming HTTP requests
#
sub poll
{
my $connection = $listener->accept();
# process connection if did not timeout
$connection
? ( accepted( $connection ) )
: ( $@ = '' );
# poll again in 100ms using timeout
$window->setTimeout( "poll();", 100 );
}
# A connection has been made, simulate CGI interface...
sub accepted
{
my ($connection) = @_;
# connect STDIN, STDOUT to browser socket using dup().
my $fd = fileno $connection;
open STDIN, "<& $fd";
open STDOUT, ">& $fd";
select STDOUT; $| = 1;
# parse initial request line of header
@ENV{qw(REQUEST_METHOD REQUEST_URI REMOTE_PROTOCOL)} = split /\s/, ;
# remove any parameters from a form of method "GET"
@ENV{qw(PATH_INFO QUERY_STRING)} = $ENV{REQUEST_URI} =~ /^([^?]*)\??(.*)/;
# unescape any path_info in request
$ENV{PATH_INFO} =~ s/%([0-9a-fA-F]{2})/chr hex($1)/ge;
# parse the rest of the "name: value\n" pairs
# in the header until there is a blank line.
while ( my ( $name, $value ) = =~ /^([^:]*):? ([^\r\n]*)/ )
{
$name =~ tr/-a-z/_A-Z/;
$name =~ s/^(?!CONTENT_)/HTTP_/;
$ENV{$name} = $value;
}
# run application
main();
# CGI needs to be reset
CGI->_reset_globals();
CGI->nph( 1 );
# close out files from dup()
# to disconnect from browser
# and complete request.
flush STDOUT;
close STDOUT;
close STDIN;
}