OpenVMS Source-Code Demos

SOURCE_CODE_REPORTER.BAS

1000	%title "source_code_reporter_xxx.bas"
	%ident                      "version_104.4"				! <<<---+---***
	declare string constant k_version = "104.4"			,	! <<<---+					&
				k_program = "OpenVMS-BASIC-Source-Code-Reporter"!
	!========================================================================================================================
	! title  : source_code_reporter_xxx.bas
	! author : Neil Rieck (http://www3.sympatico.ca/n.rieck/)
	! notes  : this was a quick hack and is in need of a major rewrite
	!        : this program has no commercial value and has been put into public domain for educational use only
	! history:
	! ver who when   what
	! --- --- ------ --------------------------------------------------------------------------------------------------------
	! 100 NSR 040208 1. original program (portions from SOURCE_CODE_FORMATTER_101.BAS)
	!     NSR 040209 2. added a debug switch
	!		 3. dropped the "/before" parameter
	!     NSR 040210 4. added support for 8 character date stamps (see VDSL_TVGUIDE_111.bas)
	!     NSR 040506 5. fixed a bug in the date comparision logic							bf_100.5
	!     NSR 041211 6. changed program name (replaced Compaq with OpenVMS)
	!     NSR 050806 7. more tweaks
	!     NSR 050909 8. added an illegal month detector								bf_100.8
	!		 9. added an illegal day detector (not accurate)						bf_100.9
	! 101 NSR 060104 1. added another example of line decoration
	!		 2. disabled the early exit feature								bf_101.2
	! 102 NSR 110609 1. added code to look for specific initials
	!		 2. added code to set starting and ending default dates
	!		 3. mini cleanup
	!     NSR 110610 4. added a function VMS_DATE_TO_ICSIS_DATE
	! 103 NSR 110610 1. now parse words differently
	!		 2. major redesign
	!		 3. now do better detection of run-on-comments (with no new initials)
	!     NSR 110611 4. added code to ensure a space in column 2							bf_103.4
	!		 5. now make sure initials are non-numeric							bf_103.5
	!		 6. reduced the number of line words from 5 to 3						bf_103.6
	!		 7. two bug fixes (after comparing selective INI output to total output)
	!     NSR 110613 8. added function unknown_date_to_icsis_date(string)
	!		 9. increased the number of words from 3 to 4 (some of Steve's code requires this)		bf_103.9
	! 104 NSR 110613 1. mini cleanup
	!		 2. added support for searching subsirectories
	!		 3. now also pickup basic functions
	!     NSR 110614 4. bug fix in touched count
	!========================================================================================================================
	option type=explicit							! no kid stuff
	set no prompt								! no ? on input
	!
	%include "lib$routines" %from %library "sys$library:basic$starlet"	! for lib$spawn etc.
	!
	external string function icsis_date_to_vms_date(string)			!
	external string function vms_date_to_icsis_date(string)			!
	external string function unknown_date_to_icsis_date(string)		!
	external string function strip_two_dots_or_dashes(string)		!
	external string function wcsm_dt_stamp					! ccyymmddhhmmss
	!
	declare string constant htab	= '9'C 					! horizontal TAB
	declare	string	fs1$			,				! file spec1					&
			fs2$			,				! file spec2					&
			ip$			,				!						&
			cmp1$			,				! compressed					&
			junk$			,				!						&
			current_ini$		,				!						&
			default$		,				!						&
			file_filter$		,				!						&
			file_spec$		,				!						&
			idate6a$		,				! icsis date-a (6 char)				&
			vdate1$			,				! vms date #1					&
			idate6b$		,				! icsis date-b (6 char)				&
			vdate2$			,				! vms date #2					&
			cmd$			,				! DCL command					&
			junk_word$		,				!						&
			my_day$			,				!						&
			my_month$		,				!						&
			ini_list$		,				!						&
			ini_memory$		,				!						&
			sub_direct$		,				!						&
		long	i%			,				!						&
			j%			,				!						&
			k%			,				!						&
			x%			,				!						&
			w%			,				!						&
			z%			,				!						&
			junk%			,				!						&
			ini_hit%		,				!						&
			dpm%			,				!						&
			comments_start%		,				!						&
			insert%			,				!						&
			in_range%		,				!						&
			rc%			,				!						&
			count%			,				!						&
			remark_count%		,				!						&
			touch_count%		,				!						&
			idate8a%		,				! icsis date-a (8 digits)			&
			idate8b%		,				! icsis date-b (8 digits)			&
			debug_flag%						!
	!
	declare long constant k_lines%  = 1000					! number of comment lines per program
	dim string lines$(k_lines%)						!
	!
	!=======================================================================
	!	<<< main >>>
	!=======================================================================
	main:									!
	print k_program +"_"+ k_version						!
	print string$(len(k_program +"_"+ k_version), ascii("=") )		!
	!
	input "show help now? (default=N) "; junk$				!
	junk$ = edit$(junk$,32+4+2)						! upcase, no controls, no white space
	if left$(junk$,1)="Y" then						!
	    !      12345678901234567890123456789012345678901234567890123456789012345678901234567890
	    print "tips:"
	    print "  1.  this program will scan the comments area of selected BASIC source files"
	    print "  2.  dates in comments should look like this 031231"	!
	    print								!
	end if									!
	!
	input "debug? (Y/N, default=N) "; junk$					!
	select left$(edit$(junk$,32+2),1)					!
	    case "Y"								!
		debug_flag% = 1							!
		print "-i- debug data will be written to the output file"	!
		sleep 1								!
	    case else								!
		debug_flag% = 0							!
	end select								!
	!
	print "file directory build:"						!
	input "enter first few letter(s) of BASIC source file? (default=all) ";file_filter$
	print									!
	file_filter$ = edit$(file_filter$,32+4+2)				! upcase, no controls, no white space
	if pos(file_filter$,"*",1)=0 then					! if no asterisk was provided...
	    file_filter$ = file_filter$ +"*"					! ...then append one
	end if									!
	!
	input "search subdirectories? (y/N) ";sub_direct$			!
	sub_direct$ = left$( edit$(sub_direct$,32+2), 1)			!
	select sub_direct$							!
	    case "Y","N"							!
	    case else								!
		sub_direct$ = "N"						! default to no
	end select								!
	!
	get_dates:								!
	default$ = mid$(wcsm_dt_stamp,3,2) +"0101"				! yy0101
	print "starting date (yymmdd)? (Q/uit, default="+ default$ +") ";	!
	input idate6a$								!
	select left$(edit$(idate6a$,32+2),1)					!
	    case ""								!
		idate6a$ = default$						!
	    case "Q"								!
		goto sortie							!
	end select								!
	vdate1$ = icsis_date_to_vms_date(idate6a$)				! convert to a VMS date
	goto get_dates if vdate1$ = ""						!
	!
	default$ = mid$(wcsm_dt_stamp,3,6)					! yymmdd
	print "ending date   (yymmdd)? (Q/uit, default="+ default$ +") ";	!
	input idate6b$								!
	select left$(edit$(idate6b$,32+2),1)					!
	    case ""								!
		idate6b$ = default$						!
	    case "Q"								!
		goto sortie							!
	end select								!
	vdate2$ = icsis_date_to_vms_date(idate6b$)				! convert to a VMS date
	goto get_dates if vdate2$ = ""						!
	!
	if idate6a$ > idate6b$ then						!
	    print "-e- first date is after second date"				!
	    goto get_dates							! so loop back
	else									!
	    when error in							!
		idate8a% = integer(idate6a$)					!
		select idate8a%							!
		    case >= 910101						! y2k conversion
			idate8a% = idate8a% + 19000000				!
		    case else							!
			idate8a% = idate8a% + 20000000				!
		end select							!
		!
		idate8b% = integer(idate6b$)					!
		select idate8b%							!
		    case >= 910101						! y2k conversion
			idate8b% = idate8b% + 19000000				!
		    case else							!
			idate8b% = idate8b% + 20000000				!
		end select							!
	    use									!
	    end when								!
	end if									!
	!
	if debug_flag% > 0 then							!
	    print "start>";idate6a$;" ";str$(idate8a%)				!
	    print "end  >";idate6b$;" ";str$(idate8b%)				!
	end if									!
	!
	junk% = 0								! init "known extension" test
	junk% = 1	if pos(file_filter$,".BAS",1) > 0			!
	junk% = 1	if pos(file_filter$,".FUN",1) > 0			!
	if junk% = 0 then							!
	    junk$ = file_filter$ +".BAS;,"+ file_filter$ +".FUN;"		!
	else									!
	    junk$ = file_filter$						!
	end if									!
	if sub_direct$ = "Y" then						!
	    file_spec$ = "[...]"+ junk$						!
	else									!
	    file_spec$ = junk$							!
	end if									!
	!
	!	IMPLEMENTATION NOTE: sometimes a source file will be resaved with no modifications. This means that the file
	!	stamp will be much more current than the most recent modification. For this reason, do not use the "/before"
	!	parameter.
	!
	cmd$ = "$dir/nohead/notrail "+ file_spec$				! get a directory of BASIC files	&
		+"/out="+ k_program +".scratch"					!					&
		+"/since="+ vdate1$						!					&
!~~~		+"/before="+ vdate2$						x
	print "executing DCL cmd: "						!
	print "  "+cmd$								!
	rc% = lib$spawn(cmd$)							! let DCL execute this command
	if ((rc% and 7%) <> 1%) then						!
	    print "-e- lib$spawn error: "+ str$(rc%)				!
	    goto sortie								!
	end if									!
	!
	!	now read the directory listing file (to see if we've found any files to process)
	!
	when error in
	    open k_program +".scratch" for input as #1, recordsize 1024		! open file list
	    count% = 0								!
	    while 1								!
		linput #1, junk$						! display the listed file names
		count% = count% + 1						!
		print #3, format$(count%,"#### ")+junk$				!
	    next								!
	use									!
	end when								!
	if count% = 0 then							!
	    print "-e- no files were detected using your search criteria"	!
	    goto sortie								!
	end if									!
	!
	print
	print "optional initials filter:"					!
	print "  examples:"							!
	print "    blank       = accept all initials"				!
	print "    NSR         = only want contributions by NSR"		!
	print "    NSR,XYZ     = only want initials from by anyone in this list"!
	print "    NSR,XYZ,ZZZ = only want initials from by anyone in this list"!
	linput "optional initials filter? (default=all) "; ini_list$		!
	ini_list$ = edit$(ini_list$,32+4+2)					! upcase, no controls, no white space
	ini_list$ = "*"	if ini_list$ = ""					!
	!
	!	now read the directory listing file (again, to dump the filenames into out output file)
	!
	when error in								!
	    open k_program +".txt" for output as #3, recordsize 1024		! open output file
	    print "-i- output file: "+ k_program +".txt"			!
	    junk$ = wcsm_dt_stamp						!
	    print #3, "============================================================"
	    print #3, "Source Code Report "+k_version
	    print #3, "Scope         : "+ idate6a$ +" -> "+ idate6b$ +" ("+ str$(idate8a%) +" -> "+ str$(idate8b%) +")"
	    print #3, "Generated     : "+ left$(junk$,8) +"."+ mid$(junk$,9,6)
	    print #3, "File Filter   : "+ file_filter$
	    print #3, "Search Spec   : "+ file_spec$
	    print #3, "Valid Initials: "+ ini_list$
	    print #3, "Subdirectories: "+ sub_direct$
	    print #3, "Note: 'file includes' and 'function includes' are ignored"
	    print #3, "============================================================"
	    print #3, ""
	    print #3, "Files considered for processing:"
	    reset #1								!
	    count% = 0								!
	    while 1								!
		linput #1, fs1$							! read a file name
		count% = count% + 1						!
		print #3, format$(count%,"#### ")+fs1$				!
	    next								!
	use									!
	end when								!
	print #3, ""								!
	!
	!	now read the directory listing file (again, to process the associated file's contents)
	!
	when error in								!
	    reset #1								!
	    while 1								!
		linput #1, fs1$							! read a file name
		gosub process_src_file						!
	    next								!
	use									!
	end when								!
	print #3, ""								!
	print									!
	print #3, "-i- remarks written: "+ str$(remark_count%)			!
	print     "-i- remarks written: "+ str$(remark_count%)			!
	print #3, "-i- files touched  : "+ str$(touch_count%)			!
	print     "-i- files touched  : "+ str$(touch_count%)			!
	close 1,2,3								!
	goto sortie								!					***--->>>
	!=======================================================================
	!	process source-code file
	!=======================================================================
	process_src_file:							!
	if debug_flag% > 0 then							! in debug mode, print report header now
	    print #3, "======================================================================"
	    print #3, "file: ";fs1$						!
	end if
	comments_start% = 0							! init
	in_range%	= 0							!
	insert%		= 0							!
	when error in								!
	    open fs1$ for input as #2, recordsize 1024				! open source code file
	    while 1								! -------------------------------------------------
		linput #2, ip$							! read a line
 		print #3,"debug-src: ";ip$	if debug_flag% > 0		!
		cmp1$	= edit$(ip$,128+32+16+8)				! no trailing, upcase, compress, no leading
		!
		if left$(cmp1$,1) <> "!" then					! if this is not a comment start line
		    if comments_start% = 0 then					! if we haven't found our first comment
			iterate							! then ignore this line
		    else							! if we have found our first comment
			goto exit_process_src_file				! then exit cuz we're beyond the program header
		    end if							!
		else								!
		    comments_start% = 1						!
		end if								!
		!---------------------------------------------------------------
		! make sure we have a space after the exclamation							bf_103.4
		!
		!	!! 101 NSR 060104 1. bla			okay
		!	!!1001 NSR 060104 1. bla			broken
		!	!! 1001 NSR 060104 1. bla			fixed
		!---------------------------------------------------------------
		select left$(cmp1$,2)						! test first two characters
		    case "!=", "!+", "!-", "!~", "!#", "!$", "!*", "!@", "!_"	! ignore various forms of line decoration
			if insert% = 0 then					! if we haven't seen a target date yet
			    iterate						! then skip this line
			else							! else
			   goto exit_process_src_file 				! quit now (no more)
			end if							!
		    case else							!
			if mid$(cmp1$,2,1) <> " " then				! if character #2 is not a space
			    cmp1$ = "! "+ right$(cmp1$,3)			! then insert one
			    cmp1$ = edit$(cmp1$,128+16)				! compress, trailing
			end if							!
		end select							!
		!---------------------------------------------------------------
		! now scan the line for words that look like 6 or 8-character dates
		! option: look for initials which look like those entered in the list
		!---------------------------------------------------------------
		declare long constant k_words = 4				!					bf_103.9
		w% = 0								! init word counter
		dim string words$(k_words)					!
		j% = pos(cmp1$," ",1)						! locate first space
		k% = pos(cmp1$," ",j%+1)					! locate second space
		while k% > 0							!
		    w% = w% + 1							!
		    words$(w%) = seg$(cmp1$, j%+1, k%-1)			!
		    goto no_more_words if w% = k_words				! exit if no more room
		    j% = k%							!
		    k% = pos(cmp1$," ",j%+1)					! find next space
		next								!
		no_more_words:							!
		iterate if w% = 0						! oops, no words found
		!---------------------------------------------------------------
		!	scan for initials
		!---------------------------------------------------------------
		ini_hit% = 0							! init for each pass through here
		if ini_list$ <> "*" then					! if not a total wild-card situation
		    for x% = 1 to min(w%,3)					! scan the first 3 words
			junk$ = words$(x%)					!
			if len(junk$)=3 then					!
			    for i% = 1 to 3					!
				select mid$(junk$,i%,1)				!
				    case "A" to "Z"				!
				    case else					! not alphabetic
					goto next_word				!
				end select					!
			    next i%						!
			    !
			    if pos(ini_list$,junk$,1)>0 then			! are these characters in our list?
				ini_hit% = 1					! yes
				ini_memory$ = junk$				!
			    else 						!
				ini_memory$ = ""				!
			    end if						!
			end if							!
			next_word:
		    next x%							!
		end if								!
		!---------------------------------------------------------------
		! scan the words looking for a date
		!---------------------------------------------------------------
		for x% = 1 to w%						! -------------------------------------------------
		    !
		    junk_word$ = words$(x%)					! extract word for testing
		    !
		    !	here, we are only looking for a string which appears to be a date (part #1)
		    !
		    select len(junk_word$)					!
			case 8 to 11						! Some of Steve's dates look like this: 01-JAN-2011
										! or this: 2011-jan-01 (11)
										! or this: 1-jan-2011  (10)
										! or this: 01-jan-11   (09)
										! or this: 1-jan-11    (08)
			    junk$ = unknown_date_to_icsis_date(junk_word$)	!
			    when error in					!
				junk% = integer(junk$)				!
			    use							!
				junk% = 0					! oops
			    end when						!
			    select junk%					!
				case 19700101 to 20500101			!
				    goto use_this_date				!
				case else					!
										! else fall thru
			    end select						!
			    !
			    !	if we get here, we could have something like: 99.12.31 or 99-12-31
			    !
			    junk$ = strip_two_dots_or_dashes(junk_word$)	!
			    if  junk_word$ <> junk$ then			! if changes were made
				junk_word$ = junk$				! then prep for retest
			    end if						!
		    end select							!
		    !
		    !	here, we are only looking for a string which appears to be a date (part #2)
		    !
		    retest_word:						!
		    select len(junk_word$)					!
			case < 6						! too short
			    goto test_next_word					!
			case 6							! if this word is 6 chars long
			    when error in					!
				junk% = integer(junk_word$)			! perform numeric test
			    use							!
				junk% = 0					! oops
			    end when						!
			    !
			    select junk%					!
				case 0						!
				    goto test_next_word				!
				case >= 910101					! >= 1991 ?
				    junk% = junk% + 19000000			! century 19
				case >= 010101					!
				    junk% = junk% + 20000000			! century 20
				case else					!
				    goto test_next_word				!
			    end select						!
			    !
			    select mid$(junk_word$,3,2)				! yymmdd				bf_100.8
				case "09","04","06","11"			! sep, apr, jun, nov
				    dpm% = 30					!
				case "02"					! feb
				    dpm% = 29					!			add leap year code here
				case "01","03","05","07","08","10","12"		!
				    dpm% = 31					!
				case else					!
				    print "-e- illegal month in date: ";junk_word$;" in file: ";fs1$
				    goto test_next_word				!
			    end select						!
			    !
			    my_day$ = mid$(junk_word$,5,2)			! yymmdd
			    select integer(my_day$)				!					bf_100.9
				case 1 to dpm%					! cool
				case else					!
				    print "-w- illegal day for this month in this date: ";junk_word$;" in file: ";fs1$
				    goto test_next_word				!
			    end select						!
			case 8							! if this word is 8 chars long
			    when error in					!
				junk% = integer(junk_word$)			! perform numeric test
			    use							!
				junk% = 0					! oops
			    end when						!
			    !
			    select junk%					!
				case 19700101 to 20500101			! if realistic
				case else					!
				    goto test_next_word				! then ignore
			    end select						!
			    !
			    select mid$(junk_word$,5,2)				! ccyymmdd				bf_100.8
				case "09","04","06","11"			! sep, apr, jun, nov
				    dpm% = 30					!
				case "02"					! feb
				    dpm% = 29					! 			add leap year code here
				case "01","03","05","07","08","10","12"		!
				    dpm% = 31					!
				case else					!
				    print "-e- illegal month in date: ";junk_word$;" in file: ";fs1$
				    goto test_next_word				!
			    end select						!
			    my_day$ = mid$(junk_word$,7,2)			! ccyymmdd
			    select integer(my_day$)				!					bf_100.9
				case 1 to dpm%					! cool
				case else					!
				    print "-w- illegal day for this month in this date: ";junk_word$;" in file: ";fs1$
				    goto test_next_word				!
			    end select						!
			case else						! not 6 or 8 chars
			    goto test_next_word					!
		    end select							!
		    !
		    !	if we get here, then junk% contains a valid date to test
		    !
		    use_this_date:						!
		    !
		    !	<<< now do a date range comparison >>>
		    !
		    select junk%						!
			case < idate8a%						! below low range			bf_100.7
			    goto test_next_word					!	so ignore this word
			case idate8a% to idate8b%				! in range
			    in_range% = 1					!	make sure this is set if in range
			    if  (ini_list$ = "*")	or			&
				(ini_hit% = 1)					&
			    then						!
				goto store_line_now				!
			    else						!
				goto test_next_word				!
			    end if						!
			case else						! above range (so we're done)		bf_100.7
			    goto exit_process_src_file				!
		    end select							!
		    test_next_word:						!
		next x%								! -------------------------------------------------
		!
		!	no dates were found for inclusion (or exclusion) so let's see if we've got any previous initials
		!
		if ini_memory$ <> "" then					! if could be running list of changes
		    junk% = 0							!
		    for x% = 1 to w%						!
				junk$ = words$(x%)				!
				junk% = 1	if pos(cmp1$,".",1)>0		! looking for something like "4. bla"
		    next x%							!
		    iterate if junk% = 0					!
		else								! no memory
		    iterate							!
		end if								!
		!
		store_line_now:
		if in_range% = 1 then						! if we've found a date in range
		    insert% = insert% + 1					! the prep to store this line
		    lines$(insert%) = ip$					! store original line data
		end if								!
	    next								!
	use									!
	end when								!
	!
	exit_process_src_file:							!
	if insert% = 0 then							!
	    print #3, "-e- no data found in the range of: "+ idate6a$ +" to: "+ idate6b$	if debug_flag% > 0
	else									!
	    if debug_flag% = 0 then						! if not debug mode, print report header now
		print #3, "======================================================================"
		print #3, "file: ";fs1$						!
	    end if								!
	    touch_count% = touch_count% + 1					!
	    i% = 1								! init for dump
	    while i% <= insert%							!
		print #3, lines$(i%)						!
		i% = i% + 1							!
	    next								!
	    remark_count% = remark_count% + insert%				! tally comments lines written
	end if									!
	return									!
	!=======================================================================
	!	<<< adios >>>
	!=======================================================================
30000	sortie:									!
	close #1								!
	when error in								!
	    while 1								!
		kill k_program+".scratch"					!
	    next								!
	use									!
	end when								!
	!
	end									! <<<---***
	!
	!####################################################################################################
	!
	!	external functions
	!
31000	%include "[.fun]wcsm_dt_stamp.fun"					! returns: ccyymmddhhmmss
	!
	!=======================================================================
	!	icsis_date to vms_date
	!	in (1):	031231
	!	in (2):	20031231
	!	out:	31-dec-2003
	!=======================================================================
31010	function string icsis_date_to_vms_date(string passed_date$)
	option type=explicit							!
	declare string constant k_months$ = "JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC"
	declare string my_day$, my_month$, my_year$, temp_date$,		&
		long   my_day%, my_month%, my_year%, leap%, month_limit%, junk%, handler%
	!
	temp_date$ = passed_date$						! copy original data
	!
	select len(temp_date$)							!
	    case 6								!
		select left$(temp_date$,2)					!
		    case "90" to "99"						!
			temp_date$ = "19"+ temp_date$				!
		    case else							!
			temp_date$ = "20"+ temp_date$				!
		end select							!
	    case 8								!
	    case else								!
		print "-e- date is wrong length"				!
		goto exit_function						!
	end select								!
	!
	!	extract year
	!
	when error in								!
	    my_year$ = seg$(temp_date$,1,4)					!
	    my_year% = integer(my_year$)					!
	    if my_year% = (my_year% / 4% ) * 4% then				!
		leap% = 1							!
	    else								!
		if my_year% = (my_year% / 400% ) * 400% then			!
		    leap% = 1							!
		else								!
		    if my_year% = (my_year% / 100% ) * 100% then		!
			leap% = 1						!
		    end if							!
		end if								!
	    end if								!
	    handler% = 0							! cool
	use									!
	    handler% = err							! oops
	end when								!
	goto function_error_exit if handler% <> 0				!
	!
	!	extract month
	!
	when error in								!
	    my_month$ = seg$(temp_date$,5,6)					!
	    my_month% = integer(my_month$)					!
	    select my_month%							!
		case < 1, > 12							!
		    print "-e- month not legal"					!
		    goto function_error_exit					!
		case else							!
		    my_month$ = mid$(k_months$, ((my_month%-1)*3)+1, 3)		! get name from list
	    end select								!
	use									!
	end when								!
	goto function_error_exit if handler% <> 0				!
	!
	!	compute month limit
	!
	select my_month%							!
	    case 9,4,6,11							!
		month_limit% = 30						!
	    case 2								!
		if leap% = 1 then						!
		    month_limit% = 29						!
		else								!
		    month_limit% = 28						!
		end if								!
	    case else								!
		month_limit% = 31						!
	end select								!
	!
	!	extract day
	!
	when error in								!
	    my_day$ = seg$(temp_date$,7,8)					!
	    my_day% = integer(my_day$)						!
	    select my_day%							!
		case < 1, > month_limit%					!
		    print "-e- day not legal"					!
		    goto function_error_exit					!
	    end select								!
	use									!
	end when								!
	goto function_error_exit if handler% <> 0				!
	!
	icsis_date_to_vms_date = my_day$ +"-"+ my_month$ +"-"+ my_year$		!
	goto exit_function							!
	!
	function_error_exit:							!
	icsis_date_to_vms_date = ""						!
	!
	exit_function:								!
	end function								!
	!
	!=======================================================================
	!	vms_date to icsis_date
	!	in:	31-dec-2003
	!	out:	20031231
	!	note:	since these are human-input dates in free-form text,
	!		we will NOT check if the date is totally legal
	!=======================================================================
31020	function string vms_date_to_icsis_date(string passed_date$)		!
	option type=explicit							!
	declare string	constant k_months$ = "__JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC"
	declare string	temp_date$, result$, junk$,				&
		long	dash1%, dash2%, junk%,					&
			my_day%, my_month%, my_year%, handler_error%		!
	!
	result$ = ""								! assume the worst
	temp_date$ = edit$(passed_date$,32+2)					! copy original data
	!
	dash1% = pos(temp_date$,"-",1)						! locate dash #1
	goto exit_function	if dash1% = 0					! exit without an error message
	dash2% = pos(temp_date$,"-",dash1%+1)					! locate dash #2
	goto exit_function	if dash2% = 0					! exit without an error message
	junk%  = pos(temp_date$,"-",dash2%+1)					! make sure we don't have a third
	goto exit_function	if junk% <> 0					! exit without an error message
	!
	!	the middle word must be a legal month
	!
	junk$ = seg$(temp_date$,dash1%+1,dash2%-1)				!
	junk% = pos(k_months$,junk$,1)						!
	if junk% = 0 then							!
	    print "-e- oops, bad month ("+ temp_date$ +")"			!
	    goto exit_function							!
	end if									!
	my_month% = junk% / 3							!
	!
	when error in								!
	    junk$ = seg$(temp_date$,1,dash1%-1)					!
	    my_day% = integer(junk$)						!
	    select my_day%							!
		case < 1, > 31							!
		    print "-e- oops, bad day ("+ temp_date$ +")"		!
		    cause error 50						!
	    end select								!
	    !
	    junk$ = right$(temp_date$,dash2%+1)					!
	    my_year% = integer(junk$)
	    select my_year%							!
		case 80 to 99							!
		    my_year% = my_year% + 1900%					!
		case 00 to 80							!
		    my_year% = my_year% + 2000%					!
		case 1990 to 2100						!
		case else							!
		    print "-e- oops, bad year ("+ temp_date$ +")"		!
		    goto exit_function						!
	    end select								!
	    !
	    handler_error% = 0							! cool
	use									!
	    handler_error% = err						! oops
	end when								!
	!
	if handler_error% = 0 then						!
	    result$ = str$(my_year%) + format$(my_month%,"<0>#") + format$(my_day%,"<0>#")
	end if									!
	!
	exit_function:								!
	vms_date_to_icsis_date = result$					!
	end function								!
	!
	!=======================================================================
	!	unknown_date to icsis_date
	!	in (1):	31-dec-2003
	!	in (2): 1-dec-2003
	!	in (3):	2003-dec-31
	!	out:	20031231
	!	note:	since these are human-input dates in free-form text,
	!		we will NOT check if the date is totally legal
	!=======================================================================
31030	function string unknown_date_to_icsis_date(string passed_date$)		!
	option type=explicit							!
	declare string	constant k_months$ = "__JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC"
	declare string	temp_date$, result$, junk$,				&
		long	dash1%, dash2%, junk%,					&
			my_day%, my_month%, my_year%, handler_error%, state%	!
	!
	result$ = ""								! assume the worst
	temp_date$ = edit$(passed_date$,32+2)					! copy original data (upcase, no w/s)
	!
	dash1% = pos(temp_date$,"-",1)						! locate dash #1
	goto exit_function	if dash1% = 0					! exit without an error message
	dash2% = pos(temp_date$,"-",dash1%+1)					! locate dash #2
	goto exit_function	if dash2% = 0					! exit without an error message
	junk%  = pos(temp_date$,"-",dash2%+1)					! make sure we don't have a third dash
	goto exit_function	if junk% <> 0					! exit without an error message
	!
	!	the middle word must be a legal month
	!
	junk$ = seg$(temp_date$,dash1%+1,dash2%-1)				!
	junk% = pos(k_months$,junk$,1)						!
	if junk% = 0 then							!
!~~~	    print "-e- oops, bad month ("+ temp_date$ +")"			x
	    goto exit_function							!
	end if									!
	my_month% = junk% / 3							!
	!
	state% = 0								! init to "not sure"
	!
	when error in								!
	    junk$ = seg$(temp_date$,1,dash1%-1)					!
	    my_day% = integer(junk$)						!
	    !
	    junk$ = right$(temp_date$,dash2%+1)					!
	    my_year% = integer(junk$)						!
	    !
	    handler_error% = 0							! cool
	use									!
	    handler_error% = err						! oops
	end when								!
	goto exit_function if handler_error% <> 0				!
	!
	retest:
	select my_year%								!
	    case 100 to 1969, > 2050						!
		goto exit_function						!
	    case 1970 to 2050							! has to be a year
		state%	= 5							! state: locked
	    case 90 to 99							! has to be a short year
		my_year% = 1900 + my_year%					! y2k pivot
		state%	= 5							! state: locked
	    case 0, 32 to 89							! has to be a short year
		my_year% = 2000 + my_year%					! y2k pivot
		state%	= 5							! state: locked
	    case else								!
										!  might be a short year (or a month)
	end select								!
	!
	select my_day%								!
	    case 1 to 31							! my_day% seems okay
		select my_year%							! if year is still short
		    case 1 to 31						!
			my_year% = 2000 + my_year%				! y2k pivot
		end select							!
		state% = 5							! state: locked
	    case else								! oops, my_day% might be a year
		if state% = 0 then						! if never swapped b4
		    state% = state% + 1						!
		    junk% = my_day%						! swap my_day% with my_year%
		    my_day% = my_year%						!
		    my_year% = junk%						!
		    goto retest							! try again
		end if								!
		print "-e- oops, bad date ("+ temp_date$ +")"			!
		goto exit_function						!
	end select								!
	!
	result$ = str$(my_year%) + format$(my_month%,"<0>#") + format$(my_day%,"<0>#")
	!
	exit_function:								!
	unknown_date_to_icsis_date = result$					!
	end function								!
	!
	!=======================================================================
	! function: strip_two_dots_or_dashes
	!	inbound:	return
	!	2011-01-01	20110101
	!	2000-2011	2000-2011 (no change)
	!	2011.01.01	20110101
	!=======================================================================
31040	function string strip_two_dots_or_dashes(string inbound$)		!
	option type=explicit							!
	declare string	local_copy$	,					&
			result$		,					&
		long	i%		,					&
			j%		,					&
			k%							!
	!
	local_copy$ = edit$(inbound$,32+4+2)					! this will change
	!
	for i% = 1 to len(local_copy$)						!
	    select mid$(local_copy$,i%,1)					!
		case "-"							! dash
		    j% = j% + 1							!
		    mid$(local_copy$,i%,1) = " "				!
		case "."							! dot
		    k% = k% + 1							!
		    mid$(local_copy$,i%,1) = " "				!
		case "A" to "Z"							! alpha is okay
		case "0" to "9"							! numeric is okay
		case else							! oops
		    result$ = inbound$						! signal no change
		    goto exit_function						! and exit now
	    end select								!
	next i%									!
	!
	if  (j%=2 and k%=0)	or						! if only two dashes	&
	    (j%=0 and k%=2)							! or only two dots	&
	then									!
		result$ = edit$(local_copy$,2)					! remove w/s
	else									!
		result$ = inbound$						! signal no change
	end if									!
	!
	exit_function:								!
	strip_two_dots_or_dashes = result$					!
	end function								!

Back to OpenVMS
Back to OpenVMS Demo Index
Back to Home
Neil Rieck
Kitchener - Waterloo - Cambridge, Ontario, Canada.