------------------------------------------------------
--# tag_region(header1, text:"Header",type:ada_code)
--
-- Scott Moody, scott@shuksan.ds.boeing.com
--
-- @(#) $Header: /gusr1/Denali/Sun_9x/Web/RCS/html_echo.adb,v 1.1 1995/07/07 15:24:58 scott Exp $
-- $Revision: 1.1 $
-- $Date: 1995/07/07 15:24:58 $
--
-- $Author: scott $
-- $Locker: $
-- $State: Exp $
--# tag_region_end(header1)
------------------------------------------------------
-- This is a program to run as an httpd CGI-BIN form processor
-- This program will echo the arguments, echo them converted, and return
-- a HTML form
--
-- So the form would have
-- <form method="POST" action= "http:/cgi-bin/PROGRAM_NAME>
--
-- where PROGRAM_NAME is a constant defined below:
------------------------------------------------------
with Ada.Strings.Unbounded;
use Ada.Strings.Unbounded;
with text_io; use text_io;
with interfaces.c.strings;
use interfaces.c.strings;
with ada.strings.maps;
use ada.strings.maps;
procedure html_echo is
illegal_html : exception;
program_name : constant string := "html_echo.ada"; --<< make this the name of cgi-bin program
type field_value_pair is
record
field_length : integer;
field_name : Unbounded_String;
field_value : Unbounded_String;
end record;
type html_lines is array(positive range <>) of field_value_pair;
function get_line(file : text_io.file_type := text_io.current_input)
return unbounded_string is
char : character;
s : unbounded_string := null_unbounded_string;
begin
while not text_io.end_of_line(file) loop
text_io.get( file, char);
s := s & char;
end loop;
-- skip line terminator - ready to 'get' next 'line'
text_io.skip_line(file);
return s;
end get_line;
------------------------------------------------------------------------
function call_system_command(command:string) return Unbounded_String is
--
-- NOTE: this is supposed to call the command, then return the standard-output
-- results. This is what the CGI program would be doing to actually
-- perform something..
--
-- Also: the 'system' command seems to not work if I don't have the put_line command??
--
procedure system(n:string);
pragma import(c,system);
pragma convention(c,system);
function getpid return integer;
pragma import(c,getpid);
pragma convention(c,getpid);
file_name : constant string := "/tmp/tmp."
& to_string(translate(to_unbounded_string(integer'image(getpid)),
to_mapping(" ", "_")));
fd : file_type;
result : Unbounded_String;
procedure do_command(s:unbounded_string) is
begin
put_line("System:" & to_string(s)); -- Taking this line out is bad.. runs
-- a different program.. Why?
system(to_string(s));
end do_command;
begin
do_command( to_unbounded_string(command & ">" & file_name));
open(fd,in_file,file_name);
while not end_of_file(fd) loop
result := result & get_line(fd) & ascii.lf;
--result := result & to_unbounded_string(get_line(fd) & ascii.lf);
end loop;
delete(fd);
return result;
exception
-- This occurs if system command isn't known
when others =>
return to_unbounded_string("");
end call_system_command;
function get_env_value(s:string) return Unbounded_String is
function getenv(name: string) return chars_ptr;
pragma Import(C,getenv);
pragma Convention(C,getenv);
result : chars_ptr := getenv(s);
begin
if result = null_ptr then
return To_Unbounded_String("");
else
return To_Unbounded_String(value(result));
end if;
end get_env_value;
------------------------------------------------------------
------------------------------------------------------------
procedure html_header(document_title:string) is
begin
put_line("Content-type: text/html");
new_line;
put_line("<HTML>");
put_line("<HEAD>");
put_line( "<TITLE>" & document_title & "</TITLE>");
put_line( "</HEAD>");
put_line( "<BODY>");
put_line( "<H1>" & document_title & "</H1>");
put_line( "<P>");
end html_header;
procedure html_trailer is
begin
put_line("</BODY>");
put_line("</HTML>");
end html_trailer;
procedure replace_html_hex(str:IN OUT unbounded_string) is
n : integer;
begin
loop
n := index(str,"%");
exit when n = 0;
if n+2 > length(str) then
raise illegal_html;
end if;
str := to_unbounded_string(
slice(str,1,n-1)
& character'val
(integer'value
("16#"
& slice(str,n+1,n+2)
& "#"))
& slice(str,n+3,length(str))
);
end loop;
end replace_html_hex;
procedure process_lines(lines: html_lines) is
line_count : integer;
max_width : integer := 0;
len : integer;
function string_in_width(s:unbounded_string; width:integer)
return unbounded_string is
len : integer := length(s);
slong : unbounded_string;
begin
slong := s;
while len < max_width loop
slong := slong & " ";
len := len + 1;
end loop;
return slong;
end string_in_width;
begin
-- Compute max width
for i in lines'range loop
if lines(i).field_length > max_width then
max_width := lines(i).field_length;
end if;
end loop;
max_width := max_width + 3;
put_line("<pre>");
put_line("<Form method=""POST"" action=""http:/cgi-bin/" & program_name & """>");
for i in lines'range loop
line_count := Ada.Strings.Unbounded.count
( SOURCE => lines(i).field_value, SET => to_set(ascii.lf));
if lines(i).field_value = "on" then
put("<input type=checkbox name=""" & to_string(lines(i).field_name)
& """ value=""on"">" & to_string(lines(i).field_name));
else
put("<b>" & to_string(string_in_width(lines(i).field_name,max_width)) & "</b>");
if line_count > 0 then
-- Text field
put("<textarea name=""" & to_string(lines(i).field_name) & """ cols=49 ");
put(" rows=" & integer'image(line_count) & ">");
put(to_string(lines(i).field_value));
put_line("</textarea>");
else
put("<input name=""" & to_string(lines(i).field_name) & """ size=49 ");
put("value = """ & to_string(lines(i).field_value) & """>");
new_line;
end if;
end if;
put_line("<p>");
end loop;
put_line("<input type=""submit"" value = ""SEND"">");
put_line("</form>");
put_line("</pre>");
end process_lines;
procedure process_input(buffer: string) is
new_buf : unbounded_string := to_unbounded_string(buffer);
sys : unbounded_string;
line_count: integer;
begin
html_header("ECHO OF FORM ARGUMENTS");
put_line("<pre>");
put_line("PROCESS INPUT: *********");
put_line(buffer);
put_line("************************");
-- Should first Split the lines where the '&' are
line_count := Ada.Strings.Unbounded.count(
SOURCE => new_buf, SET => to_set('&'));
PROCESS_HTML_LINES:
declare
our_lines : html_lines(1..line_count+1);
n : integer;
full_line : Unbounded_String;
function unbounded_slice(str:unbounded_string;low:integer;high:integer)
return unbounded_string is
begin
return to_unbounded_string(slice(str,low,high));
exception
when Ada.Strings.index_error | constraint_error =>
return null_unbounded_string;
end unbounded_slice;
begin
put_line("CONVERTED INPUT: *********");
-- Should be count of & plus 1.
-- eg. "this&that" -> 2
-- "this" -> 1
-- "this&that&" -> 2
for i in 1..line_count+1 loop
put("line " & integer'image(i) & ": ");
n := index(new_buf,"&");
if n > 0 then
full_line := unbounded_slice(new_buf,1,n-1);
-- loose the '&'
new_buf := unbounded_slice(new_buf,n+1,length(new_buf));
else
-- last case
full_line := new_buf;
new_buf := null_unbounded_string;
end if;
--
-- Translate Plus (+) to Space ( )
--
translate(full_line, To_Mapping(from => "+", to => " "));
--
-- Translate hex "%xx" to the equalivant character
--
replace_html_hex(full_line);
our_lines(i).field_name :=
unbounded_slice(full_line,
1,
index(full_line,"=")-1);
our_lines(i).field_length := length(our_lines(i).field_name);
our_lines(i).field_value :=
unbounded_slice(full_line,
index(full_line,"=")+1,
length(full_line));
put_line(to_string(our_lines(i).field_name) & "-> "
& to_string(our_lines(i).field_value));
end loop;
process_lines(our_lines);
--This is where the
-- call_system_command would go
end PROCESS_HTML_LINES;
html_trailer;
end process_input;
procedure html_request is
s : unbounded_string;
begin
s := get_env_value("REQUEST_METHOD");
if s = "POST" then
declare
len : integer := integer'value(to_string(get_env_value("CONTENT_LENGTH")));
buffer : string(1..len);
begin
-- Read Len characters;
for i in 1..len loop
-- standard input
get(buffer(i));
end loop;
process_input(buffer);
end;
elsif s = "GET" then
process_input( to_string(get_env_value("QUERY_STRING")));
else
null;
end if;
end html_request;
begin
html_request;
end html_echo;