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 (https://neilrieck.net/)
! 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 HomeNeil Rieck
Waterloo, Ontario, Canada.