OpenVMS Source Code Demos

Apache Application Demo

This application does not require a DCL (glue) script. Here are two ways to deploy the application

  1. 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 firendly.
     
  2. 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@sympatico.ca - http://www3.sympatico.ca/n.rieck )
	! 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-width: 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-width: 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-width: 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: &lt;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&#013;&#010;"									+	&
	    '<font color="#ff0000">Copyright &copy; 2000-2006 by:</font>&#013;&#010;&#013;&#010;Neil S. Rieck'	+	&
	    '&#013;&#010;Kitchener/Waterloo/Cambrige,&#013;&#010;Ontario, Canada.</font></b>&#013;&#010;'	+	&
	    '&#013;&#010;web: <a href="http://www3.sympatico.ca/n.rieck">www3.sympatico.ca/n.rieck</a>'		+	&
	    '&#013;&#010;eml: <a href="mailto:n.rieck@sympatico.ca">n.rieck@sympatico.ca</a>'			+	&
	    "&#013;&#010;&#013;&#010;Released into the public domain for educational purposes&#013;&#010;</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 &copy; 2000-2006 by Neil S. Rieck'	+	&
	    '</font></b>'									+cr+lf+	&
	    'Kitchener/Waterloo/Cambrige, 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 OpenVMS
Back to Home
Neil Rieck
Kitchener - Waterloo - Cambridge, Ontario, Canada.