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:n.rieck@bell.net - 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:n.rieck@bell.net">n.rieck@bell.net</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.