------------------------------------------------------
--# 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;