OpenVMS Source-Code Demos

READ_HTML_APACHE

1000	%title "read_html_apache"						!
	%ident                      "version 117.1"				! <<<---+---
	declare string constant k_version = "117.1"			,	! <<<---+				&
	                        k_program = "read_html_apache"			!
	!========================================================================================================================
	! Title  : Read_HTML_Apache_xxx.bas
	! Authors: Neil S. Rieck, Steve Kennel
	! Purpose: Read data from an HTML form then convert to DCL symbols to be read by another program
	! Notes  : 1. this program started as a quick hack to enable us to flip from OSU DECthreads to PSC Purveyor
	!	 : 2. it was later modified for use with Apache
	!	 : 3. see program "MIME_DECODE" to extract information from HTML attachments
	!	 : 4. you do not need to add support for URI-based anchor tags ( eg. ?name1=value1&name2=value2#tag ) because
	!		this information never appears in QUERY_STRING
	!
	! History:
	! ver who when        what
	! --- --- --------    ---------------------------------------------------------------------------------------------------
	! 100 NSR 99.12.08 1. original program
	! 101 NSR 00.03.30 1. added a 'develop' switch
	!		   2. I now assume that we enter this program BEFORE sending an HTML response header
	!     NSR 20110419 3. extended 'max symbol length' from 1024 to 4096
	! 114 abandoned experimental code
	! 115 NSR 20110419 1. now employ wcsm_set_symbol_or_logical
	!		   2. mini cleanup in with respect to external references
	!		   3. replaced dehex with call to external function wcsm_url_decode
	! 116 NSR 20110420 1. dropped the unknown mode handler (only support GET or POST)
	!		   2. rewrote the parser to handle standalone query parameters (not of format: name=value)
	! 117 NSR 20120719 1. now use wcsm_get_symbol to read QUERY_STRING (>970 bytes?)				bf_117.1
	!========================================================================================================================
	option type=explicit							! cuz no kid stuff
	!
	%include "starlet"      %from %library "sys$library:basic$starlet"	! system services (including basic$quadword)
	%include "lib$routines" %from %library "sys$library:basic$starlet"	! lib$
	%include "$jpidef"      %from %library "sys$library:basic$starlet"	! jpi$
	!
	external string		function WCSM_TrnLnm (string,string)		!
	external string		function WCSM_url_decode(string)		!
	external string		function wcsm_dt_stamp				!
	external long		function wcsm_set_symbol_or_logical(string,string)
	external string		function wcsm_get_symbol(string)		!
        external basic$quadword function wcsm_peek_quad(long by value)		!
	external long		function probe_fsp (string,long)		!
	external sub		trace(string)					!
	declare  string	constant dq = "34"C					! double quote
	declare  long constant max_symbol_len%	= 4096				! VMS-7.3 = 1024, VMS-7.3-2 = 4096
	!
	declare string	L$						,	! line						&
			b$						,	! buffer					&
			c$						,	! variable data					&
			junk$						,	!						&
			stdin$						,	! standard in					&
			method$						,	! apache html post or get			&
			my_string$					,	! apache stdin string				&
			www_length$					,	! apache stdin string length			&
			www_string$					,	! apache stdin string (method get) data		&
		long	i%						,	! general purpose				&
			j%						,	!						&
			q%						,	!						&
			temp%						,	!						&
			junk%						,	!						&
			response_sent%					,	!						&
			desired_record_size% 				,	!						&
			trace%						,	!						&
			advanced_features%				,	!						&
			debug%						,	!						&
			www_length%					,	!						&
			rc%						,	! return code					&
			handler%					, 	!						&
			html_x%						,	!						&
			html_y%						,	!						&
			read_counter%					,	!						&
			cur_priority%					,	!						&
			new_priority%						!
	dim string v$(500)						,	! html variables				&
		   d$(500)						,	! html data					&
		   q$(500)							! query chunks
	!
	!========================================================================================================================
	!	Main
	!========================================================================================================================
	Main:									!
	html_x%	= 0								! init pointer into v$() and d$()
	!
	junk$ = WCSM_TrnLnm("CSMIS$DEBUG", "LNM$PROCESS_TABLE")			! this might be set by the calling DCl script
	when error in								!
	    debug% = integer(junk$)						! 0=Off, 1=On(basic), 2=On(extreme)	<<<---***
	use									!
	    debug% = 0								!
	end when								!
	debug% = 0 if debug% < 0						!
	!
	!	if we're going to be debugging this program, then we need a plain text response header
	!
	gosub send_plain_response_header	if debug% > 0			!
	!
	!	drop the priority (do not let Apache processes compete with our other users)
	!
	rc% = lib$getjpi(jpi$_prib,,,cur_priority%,,)				! read our current base priority	bf_110.4
	if (rc% and 7%) <> 1% then						!
	    print "-e- error: "+ str$(rc%) +" during lib$getjpi" if debug% > 0	!
	    cur_priority% = 4							! oops (so default to 4)
	end if									!
	new_priority% = 3							! desired new priority
	if cur_priority% > new_priority% then					!
	    rc% = sys$setpri(,,new_priority% by value,,,)			! don't kill our production system	bf_110.4
	    if (rc% and 7%) <> 1% then						!
		print "-e- error: "+ str$(rc%) +" during sys$setpri" if debug% > 0
	    end if								!
	end if									!

	!==========================================================================================
	!	open a channel and read all the incoming ASCII text
	!==========================================================================================
	when error in								!-------------------------------------------------
	    b$ = ""								! initialize
	    !
	    junk% = lib$get_symbol("REQUEST_METHOD",method$)			! this is set by APACHE
	    print "-i- REQUEST_METHOD: "+ method$	if debug% > 0		!
	    select method$							!
		case "GET"							! GET ---------------------------------------------
!~~~		    junk% = lib$get_symbol("QUERY_STRING",www_string$)		x
		    www_string$ = wcsm_get_symbol("QUERY_STRING")		! could be longer than 970 bytes	bf_117.1
		    b$ = www_string$						!
		case else							! POST --------------------------------------------
		    junk% = lib$get_symbol("CONTENT_LENGTH", www_length$)	!
		    www_length% = integer(www_length$, LONG)			! FUTURE NOTE: may need to change type to QUAD
		    print "www_length "+ str$( www_length% ) if debug% > 0	!
		    if www_length% > 32767 then					! FUTURE NOTE: use an array to store more data
			gosub send_plain_response_header			!
			print "WARNING, www_length$ is too large ("+ www_length$ +")"
		    end if							!
		    !
		    stdin$ = WCSM_TrnLnm("SYS$COMMAND", "LNM$PROCESS_TABLE")	!
		    temp% = pos(stdin$, "_", 0)					! is there an underscore in the BG device
		    stdin$ = right$(stdin$, temp% + 1)    if temp% > 0		! yes, so get rid of it
		    temp% = pos(stdin$, ":", 0)					! is there an underscore?
		    stdin$ = stdin$ +":"	if temp% = 0 			! nope, so append one
		    !
		    desired_record_size% = probe_fsp(stdin$, debug%)            ! diagnostic (to determine record size)
		    select desired_record_size%					!
			case 0, > 32767						!
			    desired_record_size% = 32767			!
		    end select							!
		    !
		    open stdin$ for input as #1					&
			,organization sequential variable			&
			,recordtype none					&
			,recordsize desired_record_size%			!
		    !
		    !	write the raw data received to a temp file for analysis
		    !
		    if debug% >= 3 then						! if uber-debugging
			when error in						!
			    declare string constant hex_digits$ = "0123456789ABCDEF"
			    map (wcsm_create_uid_map)	basic$octaword octa_buff!
			    map (wcsm_create_uid_map)	byte	yada(0 to 15)	! 16 byte buffer for system call
		            rc% = sys$create_uid(octa_buff)			!
			    !
			    !	now convert to hex
			    !
			    junk$ = ""						!
			    for i% = 0 to 15					! 16 pairs
				temp% = yada(i%)				! grab a byte
				temp% = 256 + temp% if temp% < 0		!
				junk$ = junk$ + mid$(hex_digits$, (temp%   / 16%) +1, 1)    ! high nibble
				junk$ = junk$ + mid$(hex_digits$, (temp% and 15%) +1, 1)    ! low  nibble
			    next i%						!
			    !
			    junk$ =	seg$(junk$, 1, 8)	+"-"+		! 4x2= 8        &
					seg$(junk$, 9,12)	+"-"+		! 2x2= 4        &
					seg$(junk$,13,16)	+"-"+		! 2x2= 4        &
					seg$(junk$,17,20)	+"-"+		! 2x2= 4        &
					seg$(junk$,21,32)			! 6x2=12
			    open "csmis$tmp:read_html_apache-debug-"+ junk$ +".txt" for output as #2
			use							!
			end when						!
		    end if							!
		    !
		    !	read from standard i/o
		    !
	   	    while 1							!
			wait 2							! this must not take longer than 2 seconds
	    		linput #1, L$						! read from browser
			wait 0							! cancel timer
			print "-i-current size of L$ = "+ str$(len(L$))	if debug% > 0
			read_counter% = read_counter% + 1			!
			if read_counter% > 100 then				! oops					bf_107.1
			    gosub send_plain_response_header			!
			    print "WARNING, we executed too many loops"		!
			    rc% = 2						! VMS-e-
			    goto fini						!
			end if							!
			if (len(b$) + len(L$)) > 32767 then			! if we are about to overflow
			    gosub send_plain_response_header			!
			    print "WARNING, B$ was about to overflow"		!
			    rc% = 4						! VMS-f-
			    goto fini						!
			end if							!
	 		b$ = b$ + L$						! concat
			print #2, L$;	if debug% > 2				! write 'just read' raw dat to debug file
			print "-i-current size of B$ = "+ str$(len(B$))	if debug% > 0
		    next							!
	    end select								!
	    handler% = 0							! cool
	use									! -------------------------------------------------
	    handler% = err							! oops
	end when								! -------------------------------------------------
	!
	select handler%								!
	    case 252								! FILE ACP failure (input)
	    case 11								! EOF (from while-next on channel #1)
	    case 0								! no error (fell thru from cool)
	    case else								! this should never happen
		gosub send_plain_response_header				!
		print "<pre>"							!
		print "module     -> "+ k_program +"_"+ k_version		!
		print "basic error-> "+ str$(handler%)				!
		print "www_length$-> "+	www_length$				!
		print "www_length%-> "+	str$(www_length%)			!
		print " method$   -> "+	method$			+" <--"		!
		print " stdin     -> "+	stdin$			+" <--"		!
		print " L$        -> "+	L$			+" <--"		!
		print " b$        -> "+	b$			+" <--"		!
	end select								!
	!
	!	probably got here by EOF so continue
	!
	when error in								!
	    close #1								!
	use									!
	end when								!
	!=======================================================================
	!	at this point, the data to analyze is in b$
	!=======================================================================
	print "-i-debug >>> whole data line >>>";b$;"<<<"	if debug% > 0	!
	if pos( edit$(b$,32), "EXPRESSVU_PUBLIC", 1) > 0 then			!
	    trace% = 1								! enable tracing
	    call trace("1>"+ wcsm_dt_stamp +"|"+ k_version +"|"+ b$)		! let's see what's happening here	<<<<<<<<
	end if									!
	!
	if b$ = "" then								! if no data
	    junk% = lib$set_symbol("READ_APACHE_STATUS","BLANK",1%)		!
	    rc% = 1								! VMS -s-
	    goto fini								!
	end if									!
	!=======================================================================
	!	<<< extract the data >>>
	!
	!	caveat1: b$ must be of this format:	name1=value1&name2=value2&name3=value3		name/data pair
	!			or this format2:	value1&value2&value3				just data
	!		 but never a mixture of the two
	!
	!	caveat2: the data may not contain an equals character "=" (it will be escaped)
	!=======================================================================
	j% = pos( b$, "=", 1	)						! find '='
	if j% = 0 then								! this must be a GET with no form fields, so...
	    c$ = wcsm_url_decode(b$)						! ...decode whole line
	    junk% = lib$set_symbol("POST_GET_INFO",c$,1)			! set symbol
	    goto main_exit							! adios
	end if									!------------------------------------------------
	!
	!	<<< Advanced Mode Enable >>>
	!
	!	1. In legacy mode we create the symbols as we encounter them. This is a manditory mode for non-compliant HTML
	!	   applications like TRINITY, EXPRESSVU_PUBLIC_VIEWING, etc.
	!
	!	2. In advanced mode we will allow multiple selects from a <SELECT> by first storing the data into an array
	!	   and then concating the data with broken-bar
	!
	junk$ = edit$(b$,32)							! upcase the whole thing for the next test
	advanced_features% = 1	if pos(junk$, "ICSISADVANCEDFEATURES=1",1) > 0	! 1
	advanced_features% = 1	if pos(junk$, "ICSISADVANCEDFEATURES=T",1) > 0	! T/RUE
	advanced_features% = 1	if pos(junk$, "ICSISADVANCEDFEATURES=Y",1) > 0	! Y/ES
	!
	!	format1a	: "msg=whatever"
	!	format1b	: "first=Neil&last=Rieck&msg=whatever"
	!	format2		: "first=Neil&amp;last=Rieck&amp;msg=whatever"
	!	format3a	: "whatever"			(will yield: whatever=true)
	!	format3b	: "one&msg=whatever&two"	(will yield: one=true, msg=whatever, two=true)
	!
	unescape_amper:								!
	junk% = pos(b$, "&amp;", 1)						! do we see this HTML entity?
	if junk% > 0 then							! yes
	    b$ = left$(b$, junk%-1) + "&" + seg$(b$, junk%+5, len(b$))		!					bf_111.2
	    goto unescape_amper							!
	end if									!
	!
	!	<<< now read b$ to create symbols of the form (FORM_FLD_???) >>>
	!
	when error in								!
	    !
	    !	scan the data line looking for parameters (delimited by ampersands)
	    !
	    i% = 1								! init starting pointer
	    q% = 0								! init storage pointer
	    while i% <= len(b$)							! <= cuz maybe there is only one character there?
		j% = pos( b$, '&', i%	)					! find ampersand
		if j% = 0 then							! if not found (we are on the last chunk)
		    q% = q% + 1							! prep for insert
		    q$(q%) = seg$( b$, i%, len(b$))				! store final chunk
		    i% = len(b$) + 1						! force WHILE-NEXT to exit
		else								!
		    q% = q% + 1							! prep for insert
		    q$(q%) = seg$( b$, i%, j%-1)				! store intermediate chunk
		    i% = j% + 1							! advance starting pointer past current amper
		end if								!
		print "neil3>"+ str$(q%) +" "+ q$(q%)	if debug% > 0		! display query chunks
	    next								!
	    !
	    !	now analyze the chunks and only process them
	    !		if they are of the form: "name=value" then process as normal
	    !		if they are of the form: "name" then process as "name=TRUE"
	    !
	    i% = 1								! init retrieval pointer
	    while i% <= q%							!
		print "neil4>"+ str$(i%) +" "+ q$(i%)	if debug% > 0		!
		j% = pos( q$(i%), "=", 1   )					! locate first equals (=)		bf_110.3
		if j% > 0 then							! if found
		    L$ = left$(q$(i%), j%-1)					! isolate the variable name
		    c$ = seg$( q$(i%), j%+1, len(q$(i%)) )			! isolate the variable data
		    c$ = wcsm_url_decode(c$)					!
		    gosub selectively_store_html				!
		else								!
		    L$ = q$(i%)							!
		    c$ = "TRUE"							! alternatively we could set c$ = L$
		    gosub selectively_store_html				!
		end if								!
		i% = i% + 1							! advance
	    next								!
	use									!
	    junk% = lib$set_symbol("READ_APACHE_STATUS","ERROR",1%)		!
	end when								!
	!
	!	in advanced mode, we need to scan our capture array and create symbols
	!
	if  advanced_features% = 1	and					! if legacy mode is enabled	and		&
	    html_x% > 0								! we have extracted something
	then									!
	    for i% = 1 to html_x% 						!
		print "neil6>"+ str$(i%) +" "+ v$(i%) +" "+ d$(i%)	if debug% > 0
		junk% = lib$set_symbol("FORM_FLD_"+ v$(i%), d$(i%), 1)		!
		if ((junk% and 7%) <> 1%) and debug% > 0 then			!
		    print "-e-"+ str$(junk%) +" lib$set_symbol a="+ L$ +" c="+ c$
		end if								!
	    next i%								!
	end if									!
	!
	main_exit:								!
	rc% = 1									! VMS -s- (success)
	goto fini								!

	!----------------------------------------------------------------------------------------------------
	!	<<< store html variables and data into v$() and d$() >>>
	!
	!	entry:	L$	= variable
	!		c$	= data
	!----------------------------------------------------------------------------------------------------
	selectively_store_html:
	L$ = edit$(L$, 32)							! always upcase the variable name
	call trace("2>"+ wcsm_dt_stamp +"|"+ L$ +"|"+ c$) if trace% = 1		! let's see what's happening here	<<<<<<<<
	!
	if advanced_features% = 0 then						! if in legacy mode
  %let %hack = 1%								! enable new way
  %if  %hack = 0% %then								! --- old way
	    if len(c$) > max_symbol_len% then					!					bf_113.2
		c$ = left$(c$,max_symbol_len%)					! truncate data
	    end if 								!
	    print "neil5>  "+ L$ +" "+ c$	if debug% > 0			!
	    junk% = lib$set_symbol("FORM_FLD_"+ L$, c$, 1%)			! then create the symbol now
	    if ((junk% and 7%) <> 1%) and debug% > 0 then			!
		print "-e-"+ str$(junk%) +" lib$set_symbol a="+ L$ +" c="+c$	!
	    end if								!
  %else										! --- new way
	    print "neil5>  "+ L$ +" "+ c$	if debug% > 0			!
	    junk% = wcsm_set_symbol_or_logical("FORM_FLD_"+ L$, c$)		! then create the symbol now
	    if ((junk% and 7%) <> 1%) and debug% > 0 then			!
		print "-e-"+ str$(junk%) +" lib$set_symbol a="+ L$ +" c="+c$	!
	    end if								!
  %end %if									! -----------
 	    goto selectively_store_html_exit					! and exit
	end if									!
	!
	!	store HTML (in advanced mode only)
	!
	goto html_store_next	if html_x% = 0					! jump if first time thru
	!
	!	since this is not the first time through, we must make sure the variable doesn't already exist
	!
	!	Note: for the current time we will concat with "|" which is ASCII code 124.
	!	In the future we may have to use "broken bar" (&brvbar;) which is ASCII code 166.
	!
	for html_y% = 1 to html_x%						! scan
	    if v$(html_y%) = L$ then						! if our variable is already stored here...
!~~~		d$(html_y%) = d$(html_y%) +"|"+ c$				x then concat with pipe
		d$(html_y%) = d$(html_y%) + chr$(166) + c$			! then concat with broken bar		bf_105.5
		goto selectively_store_html_exit				! and exit
	    end if								!
	next html_y%								!
	!
	html_store_next:
	html_x% = html_x% + 1							! move to next empty location
	v$(html_x%) = L$							! store variable name
	d$(html_x%) = c$							! store variable contents
	!
	selectively_store_html_exit:						!
	return									!
	!-----------------------------------------------------------------------
	!	send plain-text response header
	!-----------------------------------------------------------------------
	send_plain_response_header:						!
	if response_sent% = 0 then						!
	    margin #0, 132							!
	    print "Status: 200"							! start of HTML response header
	    print "Content-type: text/plain"					!
	    print "Content-disposition: inline; filename=";dq;"filename.txt";dq	!
	    print ""								! end of HTML response header
	    print "-i- program: "+ k_program +"_"+ k_version			!
	    print "-i- debug level: "+str$(debug%)				!
	    response_sent% = 1							!
	end if									!
	return									!
	!========================================================================================================================
	!
	!	<<< that's all folks >>>
	!
	fini:									!
	close #2	if debug% >= 2						!
	print "-i- exiting "+ k_program +"_"+ k_version	if debug% > 0		!
31000	end program rc%								!					<<<---***
	!
	!########################################################################################################################
	!
	!=======================================================================
	!	external functions
	!=======================================================================
32100	%include "[.fun]wcsm_trnlnm.fun"					!
	! function string WCSM_TrnLnm(logical_name$, table_name$)
	!
32105	%include "[.fun]wcsm_get_symbol.fun"					!
	!
32110	%include "[.fun]wcsm_dt_stamp.fun"					!
        ! FUNCTION STRING wcsm_dt_stamp
	!
32120	%include "[.fun]wcsm_set_symbol_or_logical.fun"				!
        ! FUNCTION long wcsm_set_symbol_or_logical
	!
32130   %include "[.fun]wcsm_peek_Quad.fun"
	! function basic$quadword function wcsm_peek_quad(long by value)
	!
32140   %include "[.fun]wcsm_url_decode.fun"
	! function string wcsm_url_decode(string)
	!=======================================================================
	!	trace
	!=======================================================================
32150	sub trace(string trace$)						!
	option type=explicit							!
	when error in								!
	    open "csmis$dat:aaa_read_html_apache_trace.txt" as file #5		&
		,access append							&
		,allow modify							&
		,recordsize 132							!
	    print #5, trace$							!
	use									!
	end when								!
	close #5								!
	end sub									!
	!=======================================================================
	! title: probe_fsp
	!=======================================================================
32160	function long probe_fsp(string my_file$, long debug%)			!
	option type=explicit							!
	!
	print "-i-debug-entering: display_fsp"	if debug% > 0			!
	!
	declare long handler_error%
	!
	map(rms_stuff)	string	rms_stuff	= 16		! only needs to be 16 bytes long, not 32
	! as is found in the "HP BASIC Reference Manual"
	map(rms_stuff)					!				&
		byte	rs_org		,		! 1=  1				&
		byte	rs_rat		,		!+1=  2				&
		word	rs_mrs		,		!+2=  4				&
		long	rs_alq		,		!+4=  8				&
		word	rs_bks_bls	,		!+2= 10				&
		word	rs_num_keys	,		!+2= 12				&
		long	rs_mrn		 		!+4= 16
	!
	when error in							!
	    open my_file$ for input as #100				&
		,access read						&
		,recordtype any						&
		,organization undefined					!
	    handler_error% = 0						! cool
	use								!
	    handler_error% = err					! oops
	end when							!
	if handler_error% <> 0 then					!
	    print "-e-probe_fsp error: "+ str$(handler_error%) +" on device: "+ my_file$
	    rs_mrs = 0							!
	    goto fini							!
	end if								!
	!
	rms_stuff = fsp$(100)						!
	goto fini if debug% = 0						!
	print	" file        "; my_file$				!
	print	" org         "; rs_org;				!
	select rs_org							!
	    case    >= 48
		print " (hashed)"
	    case    >= 32
		print " (indexed)"
	    case    >= 16
		print " (relative)"
	    case else
		print " (sequential)"
	end select
	print	" rec attr    "; rs_rat				!
	print	" max rec siz "; rs_mrs				!
!~~~	print	" alloc qty   "; rs_alq				!
!~~~	print	" bucket size "; rs_bks_bls; " (always zero)"	x see "User Manual" about bytes 9-12
!~~~	print	" num of keys "; rs_num_keys; " (always zero)"	x see "User Manual" about bytes 9-12
!~~~	print	" max rec num "; rs_mrn				x not always zero (see relative tests)
	!
	fini:							!
	close #100						!
	print "-i-debug-exiting: probe_fsp"	if debug% > 0	!
	probe_fsp = rs_mrs					!
	end function						!