############################################################################
#
#	Simple Mail Proxy
#
############################################################################

use Carp;
use Net::SMTP;
use Net::SMTP::Server;
use Mail::Message;
use Sys::Hostname;

use strict;

my $debug = 0;


## SMTP server address and port ##
#
my $SMTP_Server_Address = 'smtp.server.address';
my $SMTP_Server_Port = 25;


### Mail proxy (this server) address and port ##
#
my $Proxy_Port = 25;


#===========================================================================
#	Mail client connection service
#===========================================================================

### Constants ###

my $SUCCEEDED = 0;

my %commands = (DATA => \&cmd_data,
		EXPN => \&cmd_dummy,
		HELO => \&cmd_helo,
		HELP => \&cmd_help,
		MAIL => \&cmd_mail,
		NOOP => \&cmd_noop,
		QUIT => \&cmd_quit,
		RCPT => \&cmd_rcpt,
		RSET => \&cmd_rset,
		VRFY => \&cmd_dummy);

### Variables ###

my $client_socket;
my $from;
my @to;
my $message;


sub client_put ($) {
    my ($message) = @_;
    print "Sent:     $message\n" if ($debug);
    print $client_socket $message, "\r\n";
}

sub cmd_data () {
    if (!defined($from)) {
	client_put("503 5.5.1 Sender address not yet specified");
	return 1;
    };
    if (!@to) {
	client_put("503 5.5.1 Recepient address not yet specified");
	return 1;
    };
    client_put("354 Start mail input; end with .");

    my $done = 0;
    while (<$client_socket>) {
	# print "Received: $_" if ($debug);
	if (/^\.\r\n$/) {
	    $done = 1;
	    last;
	};
	s/^\.\./\./;
	$message .= $_;
    };
    if (!$done) {
	client_put("451 5.6.0 Message input failed");
	return 1;
    };
    return 0;
}

sub cmd_helo () {
    client_put("250-Action completed, okay");
    client_put("250 ENHANCEDSTATUSCODES");
}

sub cmd_help () {
    my $out = "214-Commands\r\n";
    my $total = keys %commands;
    my $i = 0;
    foreach my $cmd (keys %commands) {
	$out .= "\r\n214";
	if ($i++ % 5 != 0) {
	    $out .= $total - $i < 5 ? " " : "-";
	} else {
	    $out .= " ";
	};
    };
    client_put($out);
}

sub cmd_noop () {
    client_put("252 Unknown status, but attempting delivery");
}

sub cmd_quit () {
    client_put("221 Service closing");
    $client_socket->close();
    return 0;
}

sub cmd_mail ($) {
    my ($arg)  = @_;
    $arg =~ /FROM:\s*(\S+)$/i;
    $from = $1;
    client_put("250 Mail sender okay");
}

sub cmd_rcpt ($) {
    my ($arg) = @_;
    $arg =~ /TO:\s*(\S+)$/i;
    my $to = $1;
    push(@to, $to);
    client_put("250 Mail recepient okay");
}

sub cmd_rset () {
    $from = undef;
    @to = ();
    client_put("250 Reset action okay");
}

sub cmd_dummy () {
}



#===========================================================================
#	SMTP server connection service
#===========================================================================

### relay ($from, @to, $msg) ###
#   forward a mail to specified SMTP server
#
sub relay ($\@$) {
    my ($from, $to, $msg) = @_;
    
    $from =~ /<.*@(.*)>/;
    my $domain = $1;
    print "Domain: $domain\n" if ($debug);
    my $client = new Net::SMTP($SMTP_Server_Address, Port => $SMTP_Server_Port,
			       Hello => $domain, Timeout => 30, Debug => $debug) ||
	croak "Unable to connect to mail server: $!\n";
    if ($client) {
	$client->mail($from);
	foreach my $recipient (@$to) {
	    $client->to($recipient);
	};
	$client->data($msg);
	$client->quit() || croak "Relay failed: $!\n";
    };
}


#===========================================================================
#	Main
#===========================================================================

my $server = new Net::SMTP::Server(hostname(), $Proxy_Port) ||
    croak "Unable to create a new mail proxy: $!\n";

while ($client_socket = $server->accept()) {

    $from = undef;
    @to = ();
    $message = undef;
    my $accepted;

    client_put("220 Service ready");

    while (<$client_socket>) {
	print "Received: $_" if ($debug);
	chomp;
	my ($cmd, $arg);
	/^\s*(\S+)(\s+(.*\S))?\s*$/;
	$cmd = $1;
	$arg = $3;
	$cmd =~ tr/a-z/A-Z/;
	if (!defined($commands{$cmd})) {
	    client_put("500 5.5.2 Syntax error, command unrecognized");
	    next;
	};

	&{$commands{$cmd}}($arg);

	if ($cmd eq 'DATA') {
	    my $msg = Mail::Message->read($message);
	    my $body = $msg->body;
	    if ($body =~ /viagra/i) {
		client_put("554 5.6.0 Invalid keyword included: viagra");
		$accepted = 0;
	    } else {
		client_put("250 2.0.0 Message accepted for delivery");
		$accepted = 1;
	    };
	};
    };

    $client_socket->close();

    if ($accepted) {
	relay($from, @to, $message);
    };
}

Audio::Wav is a package that handles wave files.

use Time::HiRes qw(time sleep);	# for exact time measurements and sleep

Here, package Time::HiRes is to measure the time accurately.

my $CODEC = 'linear16';		# 'ulaw', 'ulaw16', 'linear16' or 'linear32'

my $CHANNELS = $CODEC eq 'ulaw16' || $CODEC eq 'linear32' ? 2 : 1;

This program handles 1- or 2-channel (i.e., stereo) signal. If the value of $CODEC is 'ulaw' or 'linear16', the voice is 1-channel, and it is 'ulaw16' or 'linear32', the voice is 2-channel.

my $SAMPLING_RATE = 8000;

The sampling rate is 8000 Hz. This program must run when replacing the sampling rate by a different value.

my $volume = 0.45;

The sound volume can be changed by this value.

my $wav_file = "WaveFile.wav";

The file name is given here.

my $FRAME_LENGTH = $SAMPLING_RATE / 50;	# number of samples in a packet

my $PACKET_SIZE = 1500;	# Assumed max UDP packet size

my $REMOTE_PORT_RTP = 10000;
my $REMOTE_PORT_RTCP = 10001;

my $LOCAL_PORT_RTP = 8000;
my $LOCAL_PORT_RTCP = 8001;	# local ports for output (UDP)
        # input and output local ports must be different.
        # (implementation restriction)

my $ip = '192.168.1.33';

IP address and port number IP アドレス s とポート番号 d はここできめている．

my $rtp_addr = pack_sockaddr_in($REMOTE_PORT_RTP, inet_aton($ip));
my $rtcp_addr = pack_sockaddr_in($REMOTE_PORT_RTCP, inet_aton($ip));

my ($fd_out_rtp, $fd_out_rtcp, $fd_in_rtcp);

my (@out_ip_rtp, @out_buf_rtp);
my (@out_ip_rtcp, @out_buf_rtcp);

my $debug_switch = 0;
my $inspection_switch = 0;

$inspection_switch |= $debug_switch;


#=============================================================================
# Utility function
#=============================================================================

my $power32 = 4294967296;
my $power16 = 65536;

### current_npt_time()
#   return exact current time
#
sub current_npt_time() {
    my $time = time;
    my $lower = ($time - int($time)) * 4294967296.0;
    my $upper = int($time) + 2208988800;
    return ($upper, $lower);
}

### decode_sockaddr($sockaddr)
#   decode sockaddr_in structure to "$IP:$port" format.
#
sub decode_sockaddr($) {
    my ($sockaddr) = @_;
    if (length($sockaddr) != 16) {
        return '';
    };
    my ($port, $ip) = unpack_sockaddr_in($sockaddr);
    return inet_ntoa($ip) . ":$port";
}

### check_codec($codec)
#   check whether the specified CODEC is appropriate
#
sub check_codec($) {
    my ($codec) = @_;
    if ($codec ne 'ulaw' && $codec ne 'ulaw16' &&
        $codec ne 'linear16' && $codec ne 'linear32') {
	print STDERR "Unknown CODEC: $codec\n";
    };
}

### check_wav($details)
#   check whether the wave file format is appropriate
#
sub check_wav($) {
    my ($details) = @_;
    my $error = 0;
    # my $channels = $$details{channels};
    my $bits_sample = $$details{bits_sample};
    if ($bits_sample != 16) {
	$error = 1;
	print STDERR "#bits in sample ($bits_sample) must be 16\n";
    };
    # my $sample_rate = $$details{sample_rate};
    # if ($sample_rate != 8000) {
    #	$error = 1;
    #	print STDERR "Sample rate ($sample_rate) must be 8000\n";
    # };
    if ($error) {
	exit 1;
    };
}


#=============================================================================
# Network Output functions
#=============================================================================

### open_socket($proto)
#   open a UDP port of the local host (both for input and output),
#   and return the file descriptor.
#
sub open_socket($) {
    my ($port) = @_;
    my $fd;
    socket($fd, AF_INET, SOCK_DGRAM, getprotobyname('udp')) ||
        die "socket($fd)$!\n";
    setsockopt($fd, SOL_SOCKET, SO_REUSEADDR, pack("l", 1)) ||
        die "setsockopt()$!\n";
    bind($fd, pack_sockaddr_in($port, INADDR_ANY)) ||
        die "bind($fd)$!\n";
    return $fd;
}

my %packet_count;
my %octet_count;

### send_rtp($destination_addr, $buf)
#   send an RTP packet which is stored in the ring buffer.
#
sub send_rtp($$) {
    my ($destination_addr, $buf) = @_;
    send($fd_out_rtp, $buf, 0, $destination_addr) || die "send()$!";
    $packet_count{$destination_addr}++;
    $octet_count{$destination_addr} += length($buf);
    if ($inspection_switch) {
        my ($d1, $d2, $seq_no, $timestamp, $ssrc, $a1, $a2, $a3, $a4) =
            unpack('CCnNNCCCC', $buf);
        print decode_sockaddr($destination_addr),
	" out: $a1 $a2 $a3 $a4 seq=$seq_no ssrc=$ssrc\n";
	if ($debug_switch) {
	    print "RTP timestamp=$timestamp length=", length($buf), "\n";
	};
    };
}

### send_rtcp($destination_addr, $buf)
#   send an RTCP packet.
#
sub send_rtcp($$) {
    my ($destination_addr, $buf) = @_;
    send($fd_out_rtcp, $buf, 0, $destination_addr) || die "send()$!";
    if ($inspection_switch) {
	my ($d1, $d2, $seq_no, $timestamp, $ssrc, $a1, $a2, $a3, $a4) =
	    unpack('CCnNNCCCC', $buf);
        print decode_sockaddr($destination_addr),
	" out: $a1 $a2 $a3 $a4 seq=$seq_no ssrc=$ssrc\n";
	if ($debug_switch) {
	    print "RTCP timestamp=$timestamp length=", length($buf), "\n";
	};
    };
}

### receive_rtcp()
#   receive an RTCP packet and reply to the sender.
#
sub receive_rtcp() {
    my $buf;
    my $source_addr = recv($fd_in_rtcp, $buf, $PACKET_SIZE, 0);
    defined($source_addr) || die "recv()$!";
    my ($dummy, $ip) = unpack_sockaddr_in($source_addr);
    my ($first_byte, $payload_type, $length, $ssrc) = unpack('CCnN', $buf);
    my $version = $first_byte >> 6;		# must be 2
    unless ($version == 2) {
        print STDERR "Invalid RTCP packet header: version=$version\n";
    };

    # if ($inspection_switch) {
        my $report_count = $first_byte & 31;
        print "RTCP payload_type=$payload_type rerport_count=$report_count\n";
        print "Control data received from ", inet_ntoa($ip),
        ", length=", length($buf), "\n";
    # };

    ### to analyze the packet here ###

    if ($payload_type == 201) {	# if Receiver Report
        analyze_receiver_report($buf);
    };
}

### analyze_receiver_report()
#
sub analyze_receiver_report($) {
    my ($message) = @_;
    my $jitter = 0;
    my ($time_upper, $time_lower) = current_npt_time();
    my $curr_time = ($time_upper << 16) + ($time_lower >> 16);
    my $delay_since_last_SR = 0;
    my ($ssrc, $frac_lost, $highest_seq_no, $jitter);
    my ($last_SR, $delay_since_last_SR);
    ($_, $_, $ssrc, $frac_lost, $highest_seq_no, $jitter,
     $last_SR, $delay_since_last_SR) =
        unpack('NNNNNNNN', $message);	# 2B rtp header + 6B report block 1
    my $fraction_lost = $frac_lost >> 24;
    my $cumulative_packets_lost = $frac_lost & 0xFFFFFF;
    printf "Round trip time: %5.6f S\n", ($curr_time - $last_SR) / 65536.0;
}

ここから RTCP メッセージを生成するための部分である．

#=============================================================================
# RTCP Message Generator
#=============================================================================

my $CNAME = 1;

my $RTCP_INTERVAL = 5; # sec

my %rtcp_next_time;

### generate_outgoing_rtcp($out_addr, $ssrc, $cname, $timestamp)
#   generate Source Description and Sender Report messages of RTCP
#
sub generate_outgoing_rtcp($$$$) {
    my ($out_addr, $ssrc, $cname, $timestamp) = @_;
    my $current_time = time;
    if ($current_time >= $rtcp_next_time{$out_addr}) {
	if ($rtcp_next_time{$out_addr} == 0) {	# first time
	    $rtcp_next_time{$out_addr} = rand ($RTCP_INTERVAL / 2);
	    # Compute initial sending time
        # } elsif ($rtcp_next_time{$out_addr} == 0) {
	# 			# first time (SDES only)
        #     send_rtcp($out_addr, source_description($ssrc, $cname));
        #         # send a Source Description message of RTCP
        } else {		# not first time (SR and SDES)
            send_rtcp($out_addr,
                      sender_report($out_addr, $ssrc, $timestamp) .
                      source_description($ssrc, $cname));
                # send SR and SDES messages of RTCP
            print "Sending SR and SDES to ", decode_sockaddr($out_addr), "\n";

	    $rtcp_next_time{$out_addr} = $current_time +
		$RTCP_INTERVAL / 2 + rand ($RTCP_INTERVAL);
	};
    };
}

### source_description($ssrc, $my_cname)
#   Return a Source Description of RTCP
#
sub source_description($$) {
    my ($ssrc, $my_cname) = @_;
    my $cname_length = length($my_cname);
    return pack("nnNCCC*",
                0x81ca,	# V=2, PT=202 (SDES), SourceCount=1 (single chunk)
                1 + ($cname_length + 2 + 3) / 4, # length in words
		$ssrc, $CNAME, $cname_length) .
          $my_cname;
}

### sender_report($ssrc, $timestamp)
#   return a Sender Report of RTCP
#
sub sender_report($$$) {
    my ($out_addr, $ssrc, $timestamp) = @_;
    my ($curr_time_upper, $curr_time_lower) = current_npt_time();
    my $packet_count = $packet_count{$out_addr};
    my $octet_count = $octet_count{$out_addr};
    $packet_count{$out_addr} = 0;
    $octet_count{$out_addr} = 0;
    my $sender_info = pack("NNNNN", $curr_time_upper, $curr_time_lower,
                           $timestamp, $packet_count, $octet_count);
    my $header = pack("nnN", 
                      0x81c8, # V=2, PT=200(SR), ReportCount=1 (single chunk)
                      1 + length($sender_info) / 4,	# length in words
                      $ssrc);
    return $header . $sender_info;
}

ここから G.711 のデコーダである． G.711 のあつかいについては 「Perl による G.711 の処理」 において，よりくわしくあつかっている．

#=============================================================================
# Linear to ulaw conversion table generator
#=============================================================================

my $QUANT_MASK = 0xf;
my $BIAS = 0x84;
my $SEG_MASK = 0x70;
my $SEG_SHIFT = 4;
my $SIGN_BIT = 0x80;

my (@u2l, @l2u);

sub u2l($) {
    my ($uval) = @_;
    $uval = ~$uval;
    my $t = (($uval & $QUANT_MASK) << 3) + $BIAS;
    $t <<= ($uval & $SEG_MASK) >> $SEG_SHIFT;
    return ($uval & $SIGN_BIT) ? ($BIAS - $t) : ($t - $BIAS);
}

### gen_u2l()
#   generate ulaw-to-linear conversion table (@u2l)
#
sub gen_u2l() {
    for (my $i = 0; $i < 256; $i++) {
        $u2l[$i] = u2l($i);
    };
}

### gen_l2u()
#   generate linear-to-ulaw conversion table (@l2u)
#   (This method might not generate an optimum converter.)
#
sub gen_l2u() {
    for (my $i = 0; $i < 256; $i++) {
        my $j = $u2l[$i];
        if ($j < 0) {
            $j += 65536;
        };
        $l2u[$j] = $i;
    };
    for (my $i = 1; $i < 65536; $i++) {
        if ($l2u[$i] == 0) {
            $l2u[$i] = $l2u[$i-1];
        };
    };
}

### gen_ul_conv()
#   generate ulaw <-> linear conversion tables
#
sub gen_ul_conv() {
    gen_u2l();
    gen_l2u();
}

ここから主要部分である．

#=============================================================================
# main
#=============================================================================

if ($ARGV[0] ne '') {
    $wav_file = "$SAMPLING_RATE/$ARGV[0]";
    print "Playing file $wav_file\n";
};
if ($ARGV[1] ne '') {
    $volume = $ARGV[1];
    print "Volume=$volume\n";
};
my $loop = 1;
if ($ARGV[2] eq 'noloop') {
    $loop = 0;
}

$fd_out_rtp =  open_socket($LOCAL_PORT_RTP);
$fd_out_rtcp = open_socket($LOCAL_PORT_RTCP);
$fd_in_rtcp = $fd_out_rtcp;

gen_ul_conv();

check_codec($CODEC);

my $wav = new Audio::Wav;
my $wav_reader = $wav->read($wav_file);

check_wav($wav_reader->details());

my $ssrc = $ARGV[3] | int(rand 0x80000000);
my $seq_no = 0;

my $time_interval = 1000 * $FRAME_LENGTH / $SAMPLING_RATE;
my $timestamp = 0;
my $real_time = time;
my $playout_time = 1000 * $real_time;

for (;;) {
    my @buf;
    for (my $i = 0; $i < $FRAME_LENGTH; $i++) {
        my @data = $wav_reader->read();
        if (!defined($data[0])) {
            if (!$loop) {
                exit 0;
            };
            $wav_reader = $wav->read($wav_file);	# read the file again
            @data = $wav_reader->read();
            print "Repeating...\n";
        };
        $data[0] = $volume * $data[0];
        if ($CODEC eq 'ulaw') {
            $buf[$i] = $l2u[$data[0]];	# only the first channel data is used
        } elsif ($CODEC eq 'linear16') {
            $buf[$i] = $data[0];	# only the first channel data is used
        } elsif ($CODEC eq 'linear32') {
            if (@data >= 2) {		# use two-channel data
                $buf[2*$i] = $data[0];
                $data[1] = $volume * $data[1];
                $buf[2*$i+1] = $data[1];
            } else {			# duplicate single-channel data
                $buf[2*$i] = $data[0];
                $buf[2*$i+1] = $data[0];
            };
        } elsif ($CODEC eq 'ulaw16') {
            if (@data >= 2) {		# use two-channel data
                $buf[2*$i] = $l2u[$data[0]];
                $data[1] = $volume * $data[1];
                $buf[2*$i+1] = $l2u[$data[1]];
            } else {			# duplicate single-channel data
        	my $data = $l2u[$data[0]];
                $buf[2*$i] = $data;
                $buf[2*$i+1] = $data;
            };
        };
    };
    my $buf;
    if ($CODEC eq 'ulaw') {
        $buf = pack('NNNC*', 0x80000000 + $seq_no, $timestamp, $ssrc, @buf);
    } elsif ($CODEC eq 'ulaw16') {
        $buf = pack('NNNC*', 0x80600000 + $seq_no, $timestamp, $ssrc, @buf);
    } else { # linear16 or linear32
        $buf = pack('NNNn*',
        	    ($CODEC eq 'linear16' ? 0x80610000 : 0x80620000) + $seq_no,
        	    $timestamp, $ssrc, @buf);
    };

    send_rtp($rtp_addr, $buf);
    my $cname = getlogin() . ":$LOCAL_PORT_RTP";
    generate_outgoing_rtcp($rtcp_addr, $ssrc, $cname, $timestamp);

    my $rin = '';
    vec($rin, fileno($fd_in_rtcp), 1) = 1;
    my $rout;
    my $nfound = select($rout = $rin, undef, undef, 0);
    if ($nfound > 0) {			# Non-blocking I/O possible
        if (vec($rout, fileno($fd_in_rtcp), 1)) {	# RTCP data readable
            receive_rtcp();
        };
    };

    if ($debug_switch) {
        print "$real_time $playout_time ", decode_sockaddr($rtp_addr), "\n";
    };

    $seq_no++;
    if ($seq_no >= 65536) {
        $seq_no = 0;
    };
    $timestamp += @buf / $CHANNELS;
    $real_time = time;
    $playout_time += $time_interval;
    my $sleep_time = $playout_time / 1000 - $real_time;
    if ($sleep_time > 0) {
        sleep($sleep_time);
    };
    # printf "%f %f\n", $real_time, $sleep_time;
}

#!/usr/bin/perl
##############################################################################
#
#	UDP port kicker
#
##############################################################################

use strict;
use Socket;

my $IP = '192.168.2.2';	# destination
my $REMOTE_PORT_RTP = 8000;
my $LOCAL_PORT_RTP = 8000;

socket(SOCK, AF_INET, SOCK_DGRAM, getprotobyname('udp')) ||
    die "socket(SOCK)$!\n";
setsockopt(SOCK, SOL_SOCKET, SO_REUSEADDR, pack("l", 1)) ||
    die "setsockopt()$!\n";
bind(SOCK, pack_sockaddr_in($LOCAL_PORT_RTP, INADDR_ANY)) ||
    die "bind(SOCK)$!\n";
open_socket($LOCAL_PORT_RTP);

send(SOCK, '', 0, pack_sockaddr_in($REMOTE_PORT_RTP, inet_aton($IP))) ||
    die "send()$!";

close(SOCK);

1;

In such cases, I often use simple (pseudo) XML interface by using the pattern match function of Perl. Examples of such a requester and responder program fragments are shown below. In this program, the requester sends a request by using an HTML-like protocol called XXP. (The essense of this program is to restrict the data format to a table.)

A value of the table can be represented, for example, as follows.

<tables>
<table>
<col1>value11</col1>
<col2>value12</col2>
</table>
<table>
<col1>value21</col1>
<col2>value22</col2>
</table>
</tables>

The table has its type -- "table" is the type name. This means a table as follows.

However, the first line (col1, col2) represents the title (i.e., it is not part of the content).

Responder

make_xml() inputs an array that contains hashes and converts it to XML, and returns it ($result) as the function value. For example, you can input the following array to generate the XML text shown above.

[{col1 => value11, col2 => value12}, {col1 => value21, col2 => value22}]

send_reply($result) returns a responce message that contains an XML text by XXP. The request message part is omitted here, but it is a responce to an XXP-based request. The table type name is TAG here.

### make_xml(%hash)
#
sub make_xml(\%) {
    my ($group) = @_;
    my $result = "<TAGs>\r\n";
    foreach my $key (sort keys %group) {
	my $item = $group{$key};
	if (ref($item) eq 'HASH') {
	    $result .= "<TAG>\r\n";
	    foreach my $key (keys %$item) {
		$result .= "<${key}>$item->{$key}</${key}>\r\n";
	    };
	    $result .= "</TAG>\r\n";
	};
    };
    $result .= "</TAGs>\r\n";
    return $result;
}
# -- Whole message is created on memory.

### send_reply($result)
#
sub send_reply($) {
    my ($result) = @_;
    my $protocol = "XXP/1.0 ";
    if ($result < 0) {
	put($Client, $protocol . (400-$result) . " $error_message{-$result}\r\n");
	put($Client, "Content-length: 0\r\n\r\n");
    } else {
	if ($result) {
	    $result = "<?xml version=\"1.0\" encoding=\"shift_jis\"?>\r\n" .
		"$result\r\n";
	};
	
	# Put XXP header
	put($Client, $protocol . "200 OK\r\n");
	put($Client, "Content-length: " . length($result) . "\r\n\r\n");

	# Put XXP body
	put($Client, $result);
    };
}

Receiver

The receiver first calls get_header($file_descriptor) to read the response header of XXP, and calls get_body($file_descriptor, $table_type, $body_length) to read the response body. It is assumed that the table type ($table_type) is decided by the request message in XXP. get_body() converts the XML text to hashes. This is the reverse function of make_xml().

### get_header($file)
#   get XXP reply message header
#   returns $body_length;
#
sub get_header($) {
    my ($file) = @_;
    my $line = <$file>;
    if ($line =~ / 200 /) {	# OK
	my $body_length = 0;
	while (($line = <$file>) !~ /^\s*$/) {	# Until empty line read
	    if ($line =~ /Content-length:\s+(\d+)\s/i) {
		$body_length = $1;		# Use content-length header only
	    };
	};
	return $body_length;
    } else {	# Error
	return -1;
    };
}

### get_body($file, $table_type, $body_length)
#   get XXP reply message body
#
sub get_body($$$) {
    my ($file, $table_type, $body_length) = @_;
    my $length = 0;
    my $table = [];
    my $record = {};
    while ($length < $body_length) {
	my $line = <$file>;
	$length += length($line);
	if ($line =~ /<\s*(\S+)\s*>(.*)<\s*\/\s*(\S+)\s*>/) {
	    my $stag = $1;
	    my $content = $2;
	    my $etag = $3;
	    if ($stag ne $etag) {
		system_error("Illegal tag syntax: <$stag$gt;...$lt;/$etag$gt;");
	    };
	    $record->{$stag} = $content;
	} elsif ($line =~ /<\s*${table_type}\s*>/) {		# record start tag
	    $record = {};		# create a new record
	} elsif ($line =~ /<\s*\/\s*${table_type}\s*>/) {	# record end tag
	    push(@$table, $record);	# push the record into the table
	} elsif ($line =~ /<\s*(\/\s*)?${table_type}s\s*>/) {	# collection tag
	    # ignore
	} elsif ($line =~ /<\s*\?\s*xml(.*)\?\s*>/) {	# first line
	    # ignore
	} elsif ($line =~ /\s*/) {
	    # ignore
	} else {
	    print STDERR "Illegal line: $line ($length)\n";
	};
    };
    return $table;
}

Warning: The above program is based on a tested program, but it was rewritten and was not yet tested again.

Microsoft Excel is often used when creating a data group such as a database or data to be entered to a database. So, we often want to enter data created by Excel or another program, for example, by outputting it to a tab-separated text. The following program is an example for such task.

############################################################################
#
#	Text to DBM converter
#
############################################################################

use strict 'subs';
use strict 'refs';

use SDBM_File;

use Fcntl;

my $FileName = "C:\DB_File";

sub error($) {
    my ($message) = @_;
    print STDERR "Error: $message\n";
}


my %db;

tie(%db, 'SDBM_File', $FileName, O_RDWR | O_CREAT, 0666) ||
    error("Can't open database file!");

%db = ();

$| = 1;
print "Input file name: ";
my $file = <>;
chomp $file;
open(INPUT, $file);
while (<INPUT>) {
    if (/^(\w+)\s+(\w+)\s+(\w+)\s+(\w+)/) {
	my $A = $1;
	my $B = $2;
	my $C = $3;
	my $D = $4;
	print "A=${A} B=${B} C=${C} D=${D}\n";
	$db{A} = "${B}\t${C}\t${D}";
    } else {
	error("Syntax error: $_");
    };
};

untie(%db);

1;

You can see the source code of this page, a radio button is basically represented by an HTML tag such as the one below.

<div style="position:absolute; left:xcoordinate px; top:ycoordinate px;">button</div>

Because the coordinates are specified by pixel, the location of a button does not move when changing other contents, such as the font size of the characters, so it may overlap with other contents. In the case of this page, I added extra white space not to overlap, but still they may overlap under some conditions.

An example of a Perl CGI program that generates a page with such a radio button. I had to write a more complicated program for the experiment, but a much more simpler program is shown here.

#!/usr/bin/perl	--	# -*-Perl-*-
############################################################################
#
#	Print radio button circle
#
############################################################################

use strict;


### print_button_circle($tableName, $y0, $value)
#   print a radio button array
#
sub print_button_circle($$$) {
    my ($tableName, $y0, $value) = @_;
    my $factor = 40;
    my $roomSize = $factor * 5;
    my $Pi = 3.1416;

    # Display center of the circle
    my $x = $factor * 2.25 + 13;
    my $y = $factor * 2.25 + $y0 - 3;
    print "<div style=\"position:absolute; left:${x}px; top:${y}px;\">";
    print "+</div>\n";

    # Display radio buttons
    my $distance = 1;
    for (my $angle = 1; $angle <= 12; $angle++) {
	my $r = $factor * $distance;
	my $displacement = $factor * (2.25 - $distance);
	my $x = int($r * (1 + cos($Pi*($angle-1)/6))) + $displacement + 8;
	my $y = int($r * (1 + sin($Pi*($angle-1)/6))) + $displacement + $y0;
	my $checked = $value eq $angle ? 'checked="checked" ' : "";
	print "<div style=\"position:absolute; left:${x}px; top:${y}px;\">";
	print "<input type=\"radio\" name=\"${tableName}\" ";
	print "value=\"${angle}\" ${checked}/></div>\n";
    };
}


#===========================================================================
#	Main program
#===========================================================================

print<<END;
Content-type: text/html

<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE html PULIC "-//W3C//DTD XHTML 1.0 Strict//EN"
 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd" />
<html xmlns="http://www.w3.org/1999/xhtml"" xml:lang="ja" lang="ja">
<head>
<title>Title</title>
<meta HTTP-EQUIV=CONTENT-TYPE CONTENT="text/html; charset=UTF-8" />
</head>
<body>

<h1>Header</h1>

<form id="form" action="" method="get">
END

print_button_circle("A", 220, 1);

print<<END;
</form>
</body>
</html>
END

1;