OpenVMS Source Code Demos
Apache Application Demo
This application does not require a DCL (glue) script. Here are two ways to deploy the application
- copy the executable directly into the Apache scripts directory (you may
need to enable 'binary execution' for this directory; you do this by
modifying the Apache config file then restarting Apache). Run the app from a
browser like so (do not enter the file '.exe' extension):
http://whatever.com/scripts/program-name
You may want to rename the file to something a little more friendly.
- In my system, all the executables (web or not) are located in a common
directory. In this instance you create a one-line DCL script and drop it
into the Apache scripts directory. The line reads something like:
$run csmis$exe:program-name.exe
Run the app from a browser like so (do not enter the '.com' file extension):
http://whatever.com/scripts/program-name
You may want to rename the file to something a little more firendly.
Apache_application_demo.bas
1000 %title "vms_basic_apache_demo" %ident "version_101.2" ! declare string constant k_version = "101.2" ! <<<---*** ! !========================================================================================================================= ! Title : vms_basic_apache_demo_xxx.bas ! Author : Neil Rieck ( mailto:[email protected] - https://neilrieck.net ) ! Caveat : This program is intended to be used for educational purposes only. No liabilities will be assumed. ! Created: 2006-04-05 (while on vacation) ! History: ! Ver Who When What ! --- --- ------ --------------------------------------------------------------------------------------------------------- ! 100 NSR 060405 1. original program (to support GET demos) ! NSR 060406 2. added some javascript demos ! NSR 060407 3. added code to support POST demos ! 101 NSR 060408 1. added support for 7 more CGI Environment Variables bf_101.1 ! 2. now dynamically patch "web_address$" with CGI Environment Variables ! 3. now dynamically compute "script_dir$" using CGI Environment Variables ! 4. wrote a better BROWSER-READ routine bf_101.4 !========================================================================================================================= ! Notes: ! 1. This program assumes you've got an Apache script directory called "[.scripts]" ! It may be something else including "[.cgi-bin]" ! 2. This program assumes this executable program is located in the scripts directory or... ! a DCL program titled "VMS_BASIC_APACHE_DEMO.COM" is in the scripts directory and it ! contains the following single line: ! $ run csmis$exe:vms_basic_apache_demo.exe ! 3. This program assumes SYSTEM level logical name WEB_ADDRESS exists and contains the server's URL !========================================================================================================================= option type=explicit ! cuz tricks are for kids... set no prompt ! on error goto trap ! ! declare long constant k_max_params = 15 ! maximum number of extracted parameters declare string constant k_test_db = "csmis$dat:vms_basic_apache_demo.dat" declare string constant k_program = "vms_basic_apache_demo" ! ! ! external declarations ! %include "starlet" %from %library "sys$library:basic$starlet" ! system services %include "lib$routines" %from %library "sys$library:basic$starlet" ! lib$ %include "$libdef" %from %library "sys$library:basic$starlet" ! eg. lib$_normal %include "$ssdef" %from %library "sys$library:basic$starlet" ! ss$ %include "[.inc]device_controls.inc" ! get vt100/vt220 control characters ! ! home brewed functions ! external string function wcsm_trnlnm (string, string) ! external string function wcsm_dt_stamp ! returns ccyymmddhhmmss external string function fix_html_data (string) ! ! ! disk record ! map (disk96) & string d96_whole_record = 100, ! & d96_align = 0 ! force alignment check map (disk96) & string d96_account = 10, ! account & d96_last_name = 20, ! last name & d96_first_name = 15, ! first name & d96_telephone = 10, ! telephone & d96_city = 20, ! device type & d96_status = 1, ! status & d96_stamp = 12, ! ccyymmddhhmm & fill$ = 12, ! room to grow & d96_align = 0 ! force alignment check ! ! local constants ! declare string constant dq = '34'C ! <double quote> ! ! local variables ! declare long i% , !& j% , !& k% , !& debug% , !& mode_bits% , !& line_count% , !& handler_error% , !& junk% , !& param% , !& amper_pos% , !& min_line% , !& max_line% , !& rc% , !& js_enable% , !& www_length% , !& trace% , !& string q_string$ , !& query_string$ , ! set by Apache & server_addr$ , ! '' & server_port$ , ! '' & http_host$ , ! '' & path_translated$ , ! '' & path_info$ , ! '' & script_filename$ , ! '' & path$ , ! '' & stdin$ , !& a$ , !& b$ , !& p$ , !& html_data$ , !& out$ , !& junk$ , !& msg$ , !& txt$ , !& java0$ , !& java1$ , !& java2$ , !& temp1$ , !& temp9$ , !& p_account$ , !& pgm_mode$ , !& event_time$ , !& event_bdt$ , !& event_port$ , !& key_primary$ , !& event_type$ , !& request_method$ , !& title$ , !& limit$ , !& h1$ , !& h2$ , !& web_address$ , !& script_dir$ , !& www_length$ ! dim string param$(k_max_params) ! !==================================================================================================== ! main !==================================================================================================== 2000 main: ! ! Apache Implementation Notes: ! 1. Most of the time, Apache will be set up to produce DCL symbols but it can be set up to use LOCGICAL NAMES ! 2. Sometimes Apache will be set up to produce symbols (or logicals) with a prefix of "WWW_" ! call lib$get_symbol("REQUEST_METHOD",request_method$) ! this is set by Apache ! select request_method$ ! case "GET" ! web mode #1 ------------------------------------- case "POST" ! web mode #2 ------------------------------------- case else ! green-screen mode ------------------------------- request_method$ = "CRT" ! print vt$clear + vt$home + k_program +"_"+ k_version ! print string$( len(k_program +"_"+ k_version), asc("=") ) ! input "ok to init test database? (Y/N) ";junk$ ! gosub db_init_mode if edit$(junk$,32+4+2) = "Y" ! gosub open_file96 ! d96_account = "Account" ! prep to print a title line d96_last_name = "Last Name" ! d96_first_name = "First Name" ! d96_telephone = "Telephone" ! print d96_account;" ";d96_last_name;" ";d96_first_name;" ";d96_telephone when error in ! while 1 ! get #96, regardless ! print d96_account;" ";d96_last_name;" ";d96_first_name;" ";d96_telephone next ! use ! handler_error% = err ! end when ! select handler_error% ! case 11 ! EOF case else ! print "-e-error: "+ str$(handler_error%) ! end select ! close #96 ! goto fini ! adios... end select ! ------------------------------------------------- ! !======================================================================================================================== ! at this point, we are only in web mode !======================================================================================================================== 3000 web_mode: margin #0,999888777 ! this could also be "margin #0,0" ! ! these CGI Environment Variables are created by Apache bf_101.1 ! ! Note: see file "APACHE$COMMON:[000000.CGI-BIN]TEST-CGI-VMS.COM" for more variables. ! call lib$get_symbol("HTTP_HOST" ,http_host$ ) ! eg. kawc15.on.bell.ca call lib$get_symbol("PATH" ,path$ ) ! eg. apache$root:[000000] call lib$get_symbol("PATH_INFO" ,path_info$ ) ! call lib$get_symbol("PATH_TRANSLATED" ,path_translated$ ) ! call lib$get_symbol("QUERY_STRING" ,query_string$) ! ! call lib$get_symbol("SERVER_ADDR" ,server_addr$ ) ! eg. 142.180.39.15 call lib$get_symbol("SERVER_PORT" ,server_port$ ) ! eg. 80 call lib$get_symbol("SCRIPT_FILENAME" ,script_filename$ ) ! eg. /apache$documents/scripts/ ... ! ... VMS_BASIC_APACHE_DEMO.COM ! ! make sure we know the script-directory ! if script_filename$ <> "" then i% = pos(script_filename$,"/",2) ! get first slash after character #1 goto exit_script_dir_parse if i% = 0 ! jump if none ! j% = pos(script_filename$,"/",i%+1) ! get next slash goto exit_script_dir_parse if j% = 0 ! jump if none ! script_dir_parse: ! k% = pos(script_filename$,"/",j%+1) ! get next slash (if any) if k% = 0 then ! jump if none script_dir$ = seg$(script_filename$,i%,j%) ! else ! j% = k% ! goto script_dir_parse ! end if ! exit_script_dir_parse: ! end if ! script_dir$ = "/scripts/" if script_dir$ = "" ! make sure this is never blank ! ! we need "web_address$" for creating certain URLs in dynamically created web pages ! web_address$ = wcsm_trnlnm("WEB_ADDRESS","LNM$SYSTEM_TABLE") ! this logical comes from our legacy software web_address$ = "www.whatever.com" if web_address$ = "" ! don't allow a blank DNS web_address$ = server_addr$ if server_addr$ <> "" ! eg. 142.180.39.15 web_address$ = http_host$ if http_host$ <> "" ! eg. kawc15.on.bell.ca ! ! OK. Now let's look for URL line parameters ! mat param$ = nul$ ! init parameter array param% = 0 ! init ! select request_method$ ! case "GET", "POST" ! ! ! notes: ! 1. contrary to popular belief, it is possible to use QUERY_STRING in both GET + POST modes ! 2. URL: /scripts/vms_basic_apache_demo?a=1&b=2&c=3&d=4 ! +--- args start here ! 3. Args: a=1&b=2&c=3&d=4 ! q_string$ = query_string$ ! copy the Apache data p$ = "GET_" ! (tack on this optional prefix) if q_string$ <> "" then ! if query_string is not blank q_string$ = fix_html_data (q_string$) ! ! get_next_qs_param: param% = param% + 1 if param% < k_max_params ! prep to store the parameter amper_pos% = pos(q_string$,"&",1) ! locate the amper delimiter if amper_pos% = 0 then ! if no amper found param$(param%) = p$+ q_string$ ! else ! param$(param%) = p$+ left$(q_string$, amper_pos%-1) ! save first segment q_string$ = right$(q_string$,amper_pos%+1) ! isolate second segment goto get_next_qs_param ! end if ! end if ! end select ! ! select request_method$ ! case "POST" ! someone clicked SUBMIT on form with method=POST ! ! we want to read from Apache's STDIN device ! junk% = lib$get_symbol("CONTENT_LENGTH",www_length$) ! www_length% = integer(www_length$, long) ! ! stdin$ = WCSM_TrnLnm("SYS$COMMAND", "LNM$PROCESS_TABLE") ! junk% = pos(stdin$, "_", 0%) ! locate the underscore in the BG device stdin$ = right$(stdin$, junk%+1%) ! ! when error in %let %hack=1% ! bf_101.4 %if %hack=0% %then ! what is this stuff all about? if www_length% >= 32767 then ! trace% = 1 ! open stdin$+":" for input as #1 & ,recordsize www_length% ! else ! trace% = 2 ! open stdin$+":" for input as #1 & ,recordsize 999000 ! end if ! %end %if %if %hack=1% %then ! this technique might be better bf_101.4 trace% = 3 ! open stdin$+":" for input as #1 ! connect to browser stream trace% = 4 ! margin #1,0 ! disable implied EOL after 78 characters %end %if ! %if %hack=2% %then ! ! insert code based upon SYS$QIO %end %if ! trace% = 9 ! ! while 1 ! read until EOF linput #1, a$ ! read directly from the browser b$ = b$ + a$ ! question: won't this overflow at 32767 ? next ! use handler_error% = err ! end when select handler_error% ! case 11 ! EOF case 252 ! FILE ACP failure (input) case else ! msg$ = msg$ + & "Error: "+ str$(handler_error%) +" during POST read" +cr+lf+ & "Ert : "+ ert$(handler_error%) +cr+lf+ & "Trace: "+ str$(trace%) +cr+lf goto http_display ! end select ! ! html_data$ = fix_html_data (b$) if b$ <> "" ! ! p$ = "POST_" ! (tack on this optional prefix) if html_data$ <> "" then ! if query_string is not blank ! get_next_hd_param: param% = param% + 1 if param% < k_max_params ! prep to store the parameter amper_pos% = pos(html_data$,"&",1) ! locate the amper delimiter if amper_pos% = 0 then ! if no amper found param$(param%) = p$+ html_data$ ! else ! param$(param%) = p$+ left$(html_data$, amper_pos%-1) ! save first segment html_data$ = right$(html_data$,amper_pos%+1) ! isolate second segment goto get_next_hd_param ! end if ! end if ! end select ! ! ! detect mode bits (and extract more data) ! 4000 mode_bits% = 0 for i% = 1 to k_max_params ! mode_bits% = mode_bits% or 1% if param$(i%) <> "" ! not blank mode_bits% = mode_bits% or 2% if pos(edit$(param$(i%),32),"DEBUG" ,1) > 0 mode_bits% = mode_bits% or 4% if pos(edit$(param$(i%),32),"MODE=LIST" ,1) > 0 mode_bits% = mode_bits% or 8% if pos(edit$(param$(i%),32),"MODE=SINGLEDETAIL" ,1) > 0 mode_bits% = mode_bits% or 16% if pos(edit$(param$(i%),32),"HELP" ,1) > 0 mode_bits% = mode_bits% or 32% if pos(edit$(param$(i%),32),"SUBMIT" ,1) > 0 mode_bits% = mode_bits% or 64% if pos(edit$(param$(i%),32),"MODE=INITDB" ,1) > 0 ! js_enable% = 1 if pos(edit$(param$(i%),32),"ENABLE=JS" ,1) > 0 ! junk$ = edit$(param$(i%),32+2) ! upcase, no-white-space junk% = pos(junk$,"ACCOUNT=",1) ! does this string exists? p_account$ = right$(junk$,9) if junk% > 0 ! if yes, then save data to the right of it next i% ! ! ! set a few more mode bits (if it looks likes someone clicked a submit button) ! select request_method$ ! case "POST" ! someone clicked SUBMIT on form with method=POST mode_bits% = mode_bits% or 1% ! show that this isn't blank mode_bits% = mode_bits% or 2% ! set debug flag case "GET" ! if ((mode_bits% and 32%) = 32%) then ! someone clicked SUBMIT on form with method=POST mode_bits% = mode_bits% or 1% ! show that this isn't blank mode_bits% = mode_bits% or 2% ! set debug flag end if ! end select ! ! ! if javascript was requested, then init the java script variables ! if js_enable% > 0 then ! gosub init_java ! init javascript variables msg$ = msg$ + java2$ +cr+lf ! end if ! ! ! if debug was ever detected ! 5000 if ((mode_bits% and 2%) = 2%) then ! if DEBUG ever detected msg$ = msg$ + ! & "HTTP_HOST : "+ http_host$ +cr+lf+ ! & "PATH : "+ path$ +cr+lf+ ! & "PATH_INFO : "+ path_info$ +cr+lf+ ! & "PATH_TRANSLATED: "+ path_translated$ +cr+lf+ ! & "QUERY_STRING : "+ query_string$ +cr+lf+ ! & "REQUEST_METHOD : "+ request_method$ +cr+lf+ ! & "SERVER_ADDR : "+ server_addr$ +cr+lf+ ! & "SERVER_PORT : "+ server_port$ +cr+lf+ ! & "SCRIPT_FILENAME: "+ script_filename$ +cr+lf+ ! & "web_address$ : "+ web_address$ +cr+lf+ ! & "script_dir$ : "+ script_dir$ +cr+lf ! j% = param% + 1 ! j% = k_max_params if j% > k_max_params ! for i% = 1 to j% ! junk$ = format$( "param"+ str$(i%), "'LLLLLLLLLLLLLL") ! msg$ = msg$ + junk$ + ": "+ param$(i%) +cr+lf ! next i% ! end if ! ! if all parameters were blank... ! 6000 if ((mode_bits% and 1% ) = 0% ) or ! if all parameters are BLANK & ((mode_bits% and 16%) = 16%) then ! or HELP was requested msg$ = msg$ + & "<b>some example paramters:</b>" +cr+lf+ & " "+ script_dir$ +"VMS_BASIC_APACHE_DEMO" +cr+lf+ & " "+ script_dir$ +"VMS_BASIC_APACHE_DEMO?help" +cr+lf+ & " "+ script_dir$ +"VMS_BASIC_APACHE_DEMO?debug" +cr+lf+ & " "+ script_dir$ +"VMS_BASIC_APACHE_DEMO?a=1&debug" +cr+lf+ & " "+ script_dir$ +"VMS_BASIC_APACHE_DEMO?a=1&b=2&debug" +cr+lf+ & " "+ script_dir$ +"VMS_BASIC_APACHE_DEMO?a=1&b=2&c=3&debug" +cr+lf+ & " "+ script_dir$ +"VMS_BASIC_APACHE_DEMO?a=1&b=2&c=3&debug&enable=js" +cr+lf+ & " "+ script_dir$ +"VMS_BASIC_APACHE_DEMO?mode=list" +cr+lf+ & " "+ script_dir$ +"VMS_BASIC_APACHE_DEMO?mode=list&debug" +cr+lf+ & " "+ script_dir$ +"VMS_BASIC_APACHE_DEMO?mode=initdb" +cr+lf+ & cr+lf+ & ! Note: never include the file extension (EXE or COM) in the 'action=' parameter & ! & '<form method="GET" action="'+ script_dir$ +'VMS_BASIC_APACHE_DEMO" name="FORM1" ' + & 'style="border-style: solid; border: 1px; ' + & 'padding-left: 4px; padding-right: 4px; padding-top: 1px; padding-bottom: 1px"> ' +cr+lf+ & '<p>Form1 (method=GET)</p>' +cr+lf+ & '<p><input type="text" name="T1" size="20"> <select size="1" name="D1">' + & '<option selected>Select...</option><option value="ONE">ONE</option>' + & '<option value="TWO">TWO</option><option value="THREE">THREE</option>' + & '</select></p>' +cr+lf+ & '<p><input type="submit" value="Submit" name="BS1"><input type="reset" value="Reset" name="BR1"></p>' +cr+lf+ & '</form>' +cr+lf+ & ! & ! Note: never include the file extension (EXE or COM) in the 'action=' parameter & ! & '<form method="POST" action="'+ script_dir$ +'VMS_BASIC_APACHE_DEMO" name="FORM2" ' + & 'style="border-style: solid; border: 1px; ' + & 'padding-left: 4px; padding-right: 4px; padding-top: 1px; padding-bottom: 1px"> ' +cr+lf+ & '<p>Form2 (method=POST)</p>' +cr+lf+ & '<p><input type="text" name="T2" size="20"> <select size="1" name="D2">' + & '<option selected>Select...</option><option value="ONE">ONE</option>' + & '<option value="TWO">TWO</option><option value="THREE">THREE</option>' + & '</select></p>' +cr+lf+ & '<p><input type="submit" value="Submit" name="BS2"><input type="reset" value="Reset" name="BR2"></p>' +cr+lf+ & '</form>' +cr+lf+ & ! & ! Note: never include the file extension (EXE or COM) in the 'action=' parameter & ! & '<form method="POST" action="'+ script_dir$ +'VMS_BASIC_APACHE_DEMO?debug&a=1" name="FORM3" ' + & 'style="border-style: solid; border: 1px; ' + & 'padding-left: 4px; padding-right: 4px; padding-top: 1px; padding-bottom: 1px"> ' +cr+lf+ & '<p>Form3 (method=POST) but we will also do a GET</p>' +cr+lf+ & '<p><input type="text" name="T3" size="20"> <select size="1" name="D3">' + & '<option selected>Select...</option><option value="ONE">ONE</option>' + & '<option value="TWO">TWO</option><option value="THREE">THREE</option>' + & '</select></p>' +cr+lf+ & '<p><input type="submit" value="Submit" name="BS3"><input type=reset value="Reset" name="BR3"></P>' +cr+lf+ & '</form>' end if ! ! ! if MODE=LIST was ever detected ! 7000 if ((mode_bits% and 4%) = 4%) then ! if MODE=LIST was ever detected gosub open_file96 junk$ = wcsm_dt_stamp junk$ = left$(junk$,8) +"."+ mid$(junk$,9,6) msg$ = msg$ +"Current Time: "+ junk$ +cr+lf+cr+lf line_count% = 0 when error in while 1 get #96, regardless line_count% = line_count% + 1 h1$ = '<a href="http://'+ web_address$ + script_dir$ +'vms_basic_apache_demo?' +& 'Mode=SingleDetail&Account='+ edit$(d96_account,2) +'">' +& 'Account Name: '+ edit$(d96_last_name,2) +', '+ edit$(d96_first_name,2) +& '</a>' msg$ = msg$ + h1$ +cr+lf next use end when goto http_display ! end if ! ! if MODE=SINGLEDETAIL was ever detected ! 8000 if ((mode_bits% and 8%) = 8%) then ! if MODE=SINGLEDETAIL was ever detected gosub open_file96 junk$ = wcsm_dt_stamp junk$ = left$(junk$,8) +"."+ mid$(junk$,9,6) msg$ = msg$ +"Current Time: "+ junk$ +cr+lf+cr+lf line_count% = 0 d96_account = p_account$ ! prep (pad) for lookup junk$ = d96_account when error in get #96, key#0 eq junk$, regardless ! h1$ = & 'Account : '+ d96_account +cr+lf+ & 'Last Name : '+ d96_last_name +cr+lf+ & 'First Name: '+ d96_first_name +cr+lf+ & 'Telephone : '+ d96_telephone +cr+lf+ & 'City : '+ d96_city +cr+lf+ & 'Stamp : '+ d96_stamp msg$ = msg$ + h1$ +cr+lf use handler_error% = err msg$ = msg$ +"rms error: "+ str$(handler_error%) +" lookup key: "+ junk$ end when goto http_display ! end if ! ! if MODE=INITDB was ever detected ! 9000 if ((mode_bits% and 64%) = 64%) then ! if MODE=INITDB was ever detected msg$ = msg$ +"mode: initdb" +cr+lf gosub db_init_mode goto http_display ! end if ! 20000 msg$ = msg$ +"Oops! Mode: <blank> is not supported" ! goto http_display ! ! !============================================================ ! msg$ must be set up before this point !============================================================ http_display: ! temp1$= '<meta http-equiv="Expires" content="Tue, 04 Dec 1993 00:00:00 GMT">' +cr+lf+ ! & '<meta http-equiv="Pragma" content="no-cache">' ! ! msg$ = ! & '<a href="http:'+ script_dir$ +'vms_basic_apache_demo?help">help</a>' +cr+lf+ ! & '<a href="http:'+ script_dir$ +'vms_basic_apache_demo?help?enable=js">help + js</a>'+cr+lf+ ! & msg$ ! ! out$ = "Status: 200" +cr+lf+ ! force a good response & "Content-type: text/html" +cr+lf+ ! & cr+lf+ ! end of response header & "<html><head>" +cr+lf+ ! & java0$ + ! & "<title>VMS_BASIC_APACHE_DEMO: Display</title>" +cr+lf+ ! & temp1$ +cr+lf+ ! & "</head><body>" +cr+lf+ ! & '<font color="#FF0000">' + ! Red & '<b>VMS_BASIC_APACHE_DEMO: Display</b>' +cr+lf+ ! & '</font>' + ! back to Black & "<pre>" +cr+lf+ ! preformatted: ON & msg$ +cr+lf+ ! (plain text) & "</pre>" +cr+lf+ ! preformatted: OFF & java2$ +cr+lf+ ! & "</body></html>" ! print out$ ! bam... ! goto fini ! !======================================================================================================================== ! open file 96 !======================================================================================================================== open_file96: when error in ! open k_test_db as #96 & ,access modify & ,allow modify & ,organization indexed & ,map disk96 & ,primary key d96_account & ,alternate (d96_last_name,d96_first_name) duplicates changes & ,alternate key d96_stamp duplicates changes handler_error% = 0 ! all is well use handler_error% = err ! oops end when return !======================================================================================================================== ! init java !======================================================================================================================== init_java: ! ! create java-script subroutine(s) ! java0$ = & "<script language='javascript'>" +cr+lf+ & "<!--" +cr+lf+ & "var nsrPopupWindow=null;" +cr+lf+ & "function nsrPopup(mypage,myname,w,h,pos,infocus){" +cr+lf+ & "if(pos=='random'){" +cr+lf+ & "LeftPosition=(screen.width)?Math.floor(Math.random()*(screen.width-w)):100;" +cr+lf+ & "TopPosition=(screen.height)?Math.floor(Math.random()*((screen.height-h)-75)):100;}" +cr+lf+ & "if(pos=='center'){" +cr+lf+ & "LeftPosition=(screen.width)?(screen.width-w)/2:100;" +cr+lf+ & "TopPosition=(screen.height)?(screen.height-h)/2:100;}" +cr+lf+ & "else if((pos!='center' && pos!='random') || pos==null){LeftPosition=100;TopPosition=100;}" + & "settings='width='+ w + ',height='+ h +',top=' + TopPosition + ',left=' + LeftPosition +" + & "',location=no,directories=no,menubar=no,toolbar=no,status=no,scrollbars=no,resizable=no,dependent=no';"+ & "nsrPopupWindow=window.open('',myname,settings);" +cr+lf+ & !~~~ "if(infocus=='front'){nsrPopupWindow.focus();nsrPopupWindow.location=mypage;}" +cr+lf+ & "if(infocus=='front'){nsrPopupWindow.focus();" +cr+lf+ & "if(mypage!=''){nsrPopupWindow.location=mypage;};" +cr+lf+ & "}" +cr+lf+ & "}" +cr+lf+ & "function yada(){" +cr+lf+ & "nsrPopup('','title','500','300','','front');" + & "nsrPopupWindow.document.write('<html><head><title>About: VMS_Basic_Apache_Demo</title></head>" + & "<body><pre><b><font size=+1>" + & "VMS_Basic_Apache_Demo
" + & '<font color="#ff0000">Copyright © 2000-2006 by:</font>

Neil S. Rieck' + & '
Waterloo,
Ontario, Canada.</font></b>
' + & '
web: <a href="https://neilrieck.net">neilrieck.net</a>' + & '
eml: <a href="mailto:[email protected]">[email protected]</a>' + & "

Released into the public domain for educational purposes
</pre>"+ & '<input type="button" value="Close Window" style="float: right" onClick="window.close();">' + & "</html>');" + & "}" + & "//-->" +cr+lf+ & "</script>" +cr+lf ! junk$ = & '<b><font color="#ff0000"; size=+1>Copyright © 2000-2006 by Neil S. Rieck' + & '</font></b>' +cr+lf+ & 'Waterloo, Ontario, Canada.' +cr+lf+ & 'All rights reserved.' +cr+lf+ & '</pre>' +cr+lf+ & !~~~ '<input type=";button"; value=";Close"; onClick=";window.close();";>' +cr+lf+ & '</body></html>' ! ! this hyper-link pulls up a static web page into a javascript window ! java1$ = & '<a href="javascript:nsrPopup(' + & "'http://"+ web_address$ +"/nsr_copyright.html" + & "','Copyright_and_Patent_Information','500','300','','front');"+ & '">(NSR intellectual property information)</a>' ! ! ! this hyper-link pulls up a javascript with dynamic content created in this program (see above) ! java2$ = & '<a href="javascript:yada();' + & '">(intellectual property information)</a>' ! return !======================================================================================================================== ! db init mode !======================================================================================================================== db_init_mode: when error in ! while 1 ! kill k_test_db ! delete all versions next ! use ! end when ! ! gosub open_file96 ! ! when error in ! d96_whole_record = "" ! line_count% = 0 ! ! d96_account = "1" ! d96_last_name = "RIECK" ! d96_first_name = "NEIL" ! d96_telephone = "8005551212" ! d96_city = "Kitchener" ! put #96 ! line_count% = line_count% + 1 ! ! d96_account = "2" ! d96_last_name = "OLSON" ! d96_first_name = "KEN" ! d96_telephone = "8885551212" ! d96_city = "Maynard" ! put #96 ! line_count% = line_count% + 1 ! ! d96_account = "3" ! d96_last_name = "GATES" ! d96_first_name = "BILL" ! d96_telephone = "8775551212" ! d96_city = "Redmond" ! put #96 ! line_count% = line_count% + 1 ! use ! txt$ = "-e-error: "+ str$(err) +cr+lf ! end when ! txt$ = txt$ + "Lines written: "+str$(line_count%) +cr+lf ! if request_method$ = "CRT" then ! print txt$ ! sleep 1 ! else ! msg$ = msg$ + txt$ ! end if ! close #96 ! return !======================================================================================================================== ! final error trap !======================================================================================================================== trap: print "Status: 200" +cr+lf+ ! & "Content-type: text/plain" +cr+lf+cr+lf+ ! end of HTTP header & "Error: "+ str$(err) +cr+lf+ ! & "Line : "+ str$(erl) +cr+lf+ ! & "Text : "+ ert$(err) +cr+lf ! resume fini ! !============================================================ ! <<< that's all folks >>> !============================================================ 30000 fini: end ! <<<------*** ! !######################################################################################################################## ! ! <<< external functions >>> ! 30100 %include "[.fun]wcsm_trnlnm.fun" ! FUNCTION STRING WCSM_TRNLNM(LOGICAL_NAME, TABLE_NAME$) ! 30200 %include "[.fun]wcsm_dt_stamp.fun" ! FUNCTION STRING wcsm_dt_stamp ! ! !======================================================================================================================== ! <<< fix html data >>> !======================================================================================================================== 30400 function string fix_html_data(string html_input$) option type=explicit ! no kid stuff declare long x%, y%, z%, handler_error% declare string html$ ! html$ = html_input$ ! copy passed data string ! ! replace plus signs with spaces ! strip_plus_sign: x% = pos(html$, "+", 1) ! locate "+" if x% > 0% then ! if we found one... mid$(html$, x%, 1) = " " ! replace with a space goto strip_plus_sign ! look for more end if ! ! ! dehexify (eg. %0d -> chr$(13)) ! dehexify: declare string constant hex_string$ = "0123456789ABCDEF" x% = pos(html$, "%", 1) ! locate "%" (first time) while x% <> 0 when error in y% = pos(hex_string$, mid$(html$, x%+1, 1) ,1) ! isolate char 1 and enumerate z% = pos(hex_string$, mid$(html$, x%+2, 1), 1) ! isolate char 2 and enumerate goto dehexify_exit if (y% = 0) or (z% = 0) ! danger Wil Robinson... y% = (y% - 1) * 16 ! adjust tens digit z% = (z% - 1) ! adjust ones digit select (y% + z%) ! test the ASCII code case < 32 ! control character? %let %method=2% %if %method=1% %then ! html$ = seg$(html$, 1, x%-1) + seg$(html$, x%+3, len(html$)) ! then ignore all 3 chars %else ! mid$(html$, x%, 1) = " " ! replace "%" with <space> html$ = seg$(html$, 1, x% ) + seg$(html$, x%+3, len(html$)) ! and ignore the next two chars x% = x% + 1 ! advance (incase we just decoded a percent) %end %if ! case else ! not a control character mid$(html$, x%, 1) = chr$(y% + z%) ! replace "%" with replacement character html$ = seg$(html$, 1, x% ) + seg$(html$, x%+3, len(html$)) ! and ignore the next two chars x% = x% + 1 ! advance (incase we just decoded a percent) end select handler_error% = 0 ! all is well use handler_error% = err ! oops end when goto dehexify_exit if handler_error% <> 0 ! x% = pos(html$,"%",x%) ! locate "%" (for next pass) next html$ = edit$(html$, 128+16+8) ! no trail, compress to one, no lead dehexify_exit: ! fix_html_data = html$ ! end function ! !
Back
to HomeNeil Rieck
Waterloo, Ontario, Canada.