*Process LIMITS( EXTNAME( 31 ) ) macro;
*Process LANGLVL( SAA2 ) MARGINS( 1, 100 ) ;
CGI_pkg: package exports(gVariety);

 /********************************************************************/
 /*                                                                  */
 /*  NAME - gVariety.pli                                             */
 /*                                                                  */
 /*  DESCRIPTION                                                     */
 /*    Sample PL/I - CGI program.                                    */
 /*                                                                  */
 /*  DEPENDENCIES                                                    */
 /*    See readcgi.txt for details.                                  */
 /*                                                                  */
 /********************************************************************/
 /*                                                                  */
 /*    Licensed Materials - Property of IBM                          */
 /*    5639-A83, 5639-A24 (C) Copyright IBM Corp. 1992,2000.         */
 /*    All Rights Reserved.                                          */
 /*    US Government Users Restricted Rights-- Use, duplication or   */
 /*    disclosure restricted by GSA ADP Schedule Contract with       */
 /*    IBM Corp.                                                     */
 /*                                                                  */
 /*  DISCLAIMER OF WARRANTIES                                        */
 /*    The following enclosed code is sample code created by IBM   */
 /*    Corporation. This sample code is not part of any standard     */
 /*    IBM product and is provided to you solely for the purpose of  */
 /*    assisting you in the development of your applications.  The   */
 /*    code is provided "AS IS", without warranty of any kind.       */
 /*    IBM shall not be liable for any damages arising out of your   */
 /*    use of the sample code, even if IBM has been advised of the   */
 /*    possibility of such damages.                                  */
 /*                                                                  */
 /********************************************************************/

 /******************************************************************/
 /* Environment Variable set by PL/I builtin 'system':             */
 /*   For running in WindosNT it is set to 'WIN'                   */
 /*   For running in MVS environment it is set to 'MVS'.           */
 /******************************************************************/
  %Dcl RunsOn Char;
  %RunsOn = substr(system,2,3);

 dcl stdout             file record output;

 dcl contentIn          char(250);
 dcl currArea           char(32) var;
 dcl currPrice          char(32) var;
 dcl currWine           char(32) var;
 dcl firstName          char(32) var;
 dcl fromWhere          char(32) var;
 dcl outrec             char(256) var;

 dcl bytesRead          fixed bin(31);

gVariety: proc() options(main);

 /* prototypes */
 dcl gList    entry (pointer byvalue)
              returns( pointer byvalue )
              options( fetchable byvalue linkage(system) );

 dcl gTag     entry ( pointer, pointer, pointer )
              options( fetchable byvalue linkage(system) );

 dcl parseIt  entry ( pointer, pointer )
              options( fetchable byvalue linkage(system) );

 dcl sysin              file input;

 /* misc vars */
 dcl myPtr              pointer init(null());
 dcl rbPtr              pointer;
 dcl rtnPtr             pointer;
 dcl tagPtr             pointer;
 dcl tagValuePtr        pointer;

 dcl method             char(20) var;
 dcl rtnBuf             char(1022) var;
 dcl sysinTitle         char(62) var;
 dcl tagName            char(32) var ;
 dcl tagValue           char(64) var based(tagPtr);
 dcl WebSvrName         char(40) var;

 dcl cLen               fixed bin(31);
 dcl I                  fixed bin(31);

 dcl STDOUTFNAME        char(*) value('STDOUT:');
 dcl STDOUTTITLE        char(*) value( '/' || STDOUTFNAME ||
      ',lrecl(256),append(n),type(crlf),share(none)' );

 /* vars for wine info */
 Dcl 1 wineStruct       based(rtnPtr),
       2 arraySize      fixed bin(31),
       2 wineArray(25)  char(60) var;

 dcl area(0:1)          char(32) var init('Sonoma','Napa');
 dcl price(0:1)         char(32) var init('Cheap','Expensive');




 /* begin processing */
 rtnBuf = '';
 contentIn = '';

 /* open output file and start writing */
 open file ( stdout ) title( STDOUTTITLE );

 /* write out the CGI header */
 outrec = "Content-type: text/html";
 call w_html ( outrec, stdout );
 outrec = '';
 call w_html ( outrec, stdout );

 /* determine if GET or POST */
 method = getenv('REQUEST_METHOD');

 /* get the input */
 if method = 'GET'
   then
     do;
       rtnBuf = getenv('QUERY_STRING');
       bytesRead = length(rtnBuf);
     end;
   else
     do;
       cLen = getenv('CONTENT_LENGTH');
       sysinTitle = '/STDIN:,LRECL(' || trim(edit(cLen,'999999'))
                    || '),TYPE(U)';
       open file(sysin) title(sysinTitle)  record;
       bytesRead = fileread( sysin, addrdata(rtnBuf), cLen );
       outlen    = cLen;
     end;

 /* Load the Value pairs into a linked-list from the input string */
 contentIn = substr(rtnBuf,1,bytesRead);
 rbPtr = addr(contentIn);
 call parseIt( rbPtr, addr(myPtr) );

 /* get expensive/cheap   */
 tagname = 'price';
 call gTag( myPtr, addr(tagName), addr(tagValuePtr) );
 tagPtr = addrdata(tagValuePtr) ;
 currPrice = trim(TagValue);

 /* get the current area */
 tagname = 'area';
 call gTag( myPtr, addr(tagName), addr(tagValuePtr) );
 tagPtr = addrdata(tagValuePtr) ;
 currArea = trim(TagValue);

 /* get the hidden first name */
 tagname = 'fname';
 call gTag( myPtr, addr(tagName), addr(tagValuePtr) );
 tagPtr = addrdata(tagValuePtr) ;
 firstName = trim(TagValue);

 /* get the hidden fromwhere */
 fromwhere = '';
 tagname = 'wherefrom';
 call gTag( myPtr, addr(tagName), addr(tagValuePtr) );
 tagPtr = addrdata(tagValuePtr) ;
 fromWhere = trim(TagValue);

 /* get the list of wines of this variety */
 tagname = 'Data';
 call gTag( myPtr, addr(tagName), addr(tagValuePtr) );
 tagPtr = addrdata(tagValuePtr) ;
 currWine = trim(TagValue);

 fetch gList title('GLIST');
 rtnPtr = gList( tagPtr );

 /* begin writing out the html code for the new web page */
 outrec   = '<HTML><HEAD><TITLE>PL/I CGI Wine Inventory Control</TITLE>';

 /* write out call to JavaScript function for closing debug window */
 outrec ||= '</HEAD><BODY  onunload="closeDbg()"';

 %if RunsOn = 'MVS'        /* If execution environment is MVS        */
   %then
      %do;
 outrec ||='BACKGROUND="http://stplex4b.stl.ibm.com:3091/PUB-BALKBJ/grapesbw.gif"><CENTER>';
     %end;
   %else                   /* If exe environment is Windows          */
      %do;
 outrec ||='BACKGROUND="/images/grapesbw.gif"><CENTER>';
      %end;

 outrec ||='<H2>PL/I - CGI Wine Inventory Sample</H2></CENTER>';
 call w_html ( outrec, stdout );
 outrec   ='<TABLE WIDTH="75%" align="center" BORDER="0" >';
 outrec ||='<TR><TD WIDTH="75%" align="center">';
 outrec ||= "<P>Thank you for your interest in wines from <B>"       ||
             area(currArea) || "</B> valley.  We can see from the "  ||
            "tilt of your hat that you have <B>" || price(currPrice) ||
            "</B> tastes! </P>";
 call w_html ( outrec, stdout );
 outrec   ='</TABLE><TABLE WIDTH="100%" BORDER="0" ><TR>';
 outrec ||='<TD WIDTH="50%" align="CENTER" >';
 call w_html ( outrec, stdout );
 outrec   = "<P>We have created a list of <B>" || trim(currWine)     ||
            "</B> wines currently in our cellar that are ready for " ||
            "your purchase.  Please select a wine from the list "    ||
            "to the right for more information.</P>";
 call w_html ( outrec, stdout );
 outrec   ='<TD WIDTH="50%" align="CENTER">';
 outrec ||= '<FORM METHOD="POST" ';

 /* write out right URL for gInfo executable */
 %if RunsOn = 'MVS'        /* If execution environment is MVS        */
   %then
      %do;
 outrec ||='ACTION="http://stplex4b.stl.ibm.com:3091/CGI-BALKBJ/gInfo">';
     %end;
   %else                   /* If exe environment is Windows          */
      %do;
 outrec ||='ACTION="/cgi-bin/gInfo.exe">';
      %end;

 call w_html ( outrec, stdout );


 /* add the hidden fields */
 outrec   ='<INPUT TYPE="HIDDEN" NAME="fname" ';
 outrec ||='VALUE="'||firstName||'">';
 call w_html ( outrec, stdout );
 outrec   ='<INPUT TYPE="HIDDEN" NAME="wherefrom" ';
 outrec ||='VALUE="'||fromWhere||'">';
 call w_html ( outrec, stdout );

 /* Build the SELECT list */
 outrec   ='<SELECT NAME="Data" SIZE=7 ><BR>';
 call w_html ( outrec, stdout );

 do i = 1 to ( rtnPtr->wineStruct.arraySize );
   if i = 1 then
     do;
       outrec = '<OPTION SELECTED>'|| rtnPtr->wineStruct.wineArray(i);
       call w_html ( outrec, stdout );
     end;
   else
     do;
       outrec = '<OPTION>'||rtnPtr->wineStruct.wineArray(i);
       call w_html ( outrec, stdout );
     end;
 end;

 outrec   = '</SELECT>';
 outrec ||= '<P><INPUT TYPE="submit"></P>';
 outrec ||= '<TD WIDTH="10%" >&nbsp;</TABLE><BR><BR>';
 call w_html ( outrec, stdout );

 /* write out the debug checkbox */
 outrec   = '<TABLE WIDTH="100%" BORDER="1"><TR>';
 outrec ||=
 '<INPUT TYPE="BUTTON" NAME="debug" VALUE="Display Debug Info" onClick="doDebug()" >';
 outrec ||= '</TABLE>';
 call w_html ( outrec, stdout );

 /* Get the type of server from the env var */
 WebSvrName = trim(getenv('SERVER_SOFTWARE'));

 /* build the footer */
 outrec   ='<TABLE WIDTH="100%" BORDER="1">';
 outrec ||='<TR><TD WIDTH="40%" align="center" ><FONT FACE="Ariel" Size="3">';
 outrec ||='This Web Page Powered by <B>';
 call w_html ( outrec, stdout );
 outrec   ='<A HREF="http://www.software.ibm.com/ad/pli" TARGET="BLANK">PL/I </A></B>';
 outrec ||='<BR> Running on an <B>' ||trim(WebSvrName)||'</B></FONT>';
 call w_html ( outrec, stdout );
 outrec   ='<TD WIDTH="20%" align="center" >';

 %if RunsOn = 'MVS'        /* If execution environment is MVS        */
   %then
      %do;
 outrec ||='<img src="http://stplex4b.stl.ibm.com:3091/PUB-BALKBJ/vapli390.jpg"';
     %end;
   %else                   /* If exe environment is Windows          */
      %do;
 outrec ||='<img src="/images/vapli390.jpg"';
      %end;

 outrec ||='width=120 height=100 border=0 ';
 outrec ||=' alt="VisualAge PL/I for OS/390!">';
 outrec ||='<TD WIDTH="40%" align="center" >';
 outrec ||='<FONT FACE="Ariel" Size="3">';
 call w_html ( outrec, stdout );
 outrec   ='Let us know how you<A HREF="mailto:balk@us.ibm.com?subject=Ain''t this neat?">';
 outrec ||=' feel.</A><BR><BR>';

 %if RunsOn = 'MVS'        /* If execution environment is MVS        */
   %then
      %do;
 outrec ||='View the <A HREF="http://stplex4b.stl.ibm.com:3091/PUB-BALKBJ/gVariety.txt"';
     %end;
   %else                   /* If exe environment is Windows          */
      %do;
 outrec ||='View the <A HREF="http://localhost/gVariety.txt"';
      %end;

 outrec ||='TARGET="BLANK">PL/I Source.</A></FONT></TABLE>';
 call w_html ( outrec, stdout );

 /* add JavaScript to display debug window */
 call addDebug;

 outrec   ='</BODY></HTML>';
 call w_html ( outrec, stdout );

 close file ( stdout );

 end gVariety;

 /*******************************************************************/
 /* addDebug                                                        */
 /*******************************************************************/

 addDebug: proc( ) options( nodescriptor );


 /* write out the javascript function */
 outrec    = '<SCRIPT LANGUAGE="JavaScript">';
 call w_html ( outrec, stdout );
 outrec    = '<!-- hide it from other browsers ';
 call w_html ( outrec, stdout );
 outrec    = 'var myw = null;';
 call w_html ( outrec, stdout );
 outrec   = '  function doDebug() {';
 call w_html ( outrec, stdout );
 outrec   =
 ' myw = window.open("","windowName","height=200,width=600,screenX=200,screenY=400");';
 call w_html ( outrec, stdout );
 outrec   =
 '  myw.document.writeln("<TITLE>Debug Variables from gVariety.pli: </TITLE>");';
 call w_html ( outrec, stdout );
 outrec   = '  myw.document.writeln("<B>bytesRead  = </B>'||bytesRead||'<BR>");';
 call w_html ( outrec, stdout );
 outrec   =
 '  myw.document.writeln("<B>contentIn  = </B>'||substr(contentIn,1,bytesRead)||'<BR>");';
 call w_html ( outrec, stdout );
 outrec   = '  myw.document.writeln("<B>currWine   = </B>'||trim(currWine)||'<BR>");';
 call w_html ( outrec, stdout );
 outrec   = '  myw.document.writeln("<B>currPrice  = </B>'||trim(currPrice)||'<BR>");';
 call w_html ( outrec, stdout );
 outrec   = '  myw.document.writeln("<B>currArea   = </B>'||trim(currArea)||'<BR>");';
 call w_html ( outrec, stdout );
 outrec   = '  myw.document.writeln("<B>fromWhere  = </B>'||trim(fromWhere)||'<BR>");';
 call w_html ( outrec, stdout );
 outrec   = '  myw.document.writeln("<B>firstName  = </B>'||trim(firstName)||'<BR>");';
 call w_html ( outrec, stdout );
 outrec   = '  myw.document.close();';
 call w_html ( outrec, stdout );
 outrec   = '  }';
 call w_html ( outrec, stdout );
 outrec   = '  function closeDbg() {';
 call w_html ( outrec, stdout );
 /* outrec   ='  myw.window.close();';*/
 outrec   ='  if (( myw == null) || (myw.closed)) {';
 call w_html ( outrec, stdout );
 outrec   ='       return;';
 call w_html ( outrec, stdout );
 outrec   ='     } else {';
 call w_html ( outrec, stdout );
 outrec   ='       myw.window.close();';
 call w_html ( outrec, stdout );
 outrec   ='     }';
 call w_html ( outrec, stdout );
 outrec   = '  }';
 call w_html ( outrec, stdout );
 outrec    = '// unhide it -->';
 call w_html ( outrec, stdout );
 outrec    = '</SCRIPT>';
 call w_html ( outrec, stdout );


   return;

 end addDebug;


 /*******************************************************************/
 /* w_html                                                          */
 /*******************************************************************/

 w_html: proc( outstr, outfile )
         options( nodescriptor );

   dcl outfile          file;
   dcl outstr           char(*) var nonasgn;

   write file( outfile ) from ( outstr );

   return;

 end w_html;


 end CGI_pkg;

