Viewing contents of file '../idllib/astron/contrib/landsman/allpro/mpbasic.pro'
;+
; NAME:
; MPBASIC
; PURPOSE:
; Provides on-line documentation for IDL topics. The style
; is a cross between Unix man pages and VMS on-line help. The
; help is organized in a two level hierarchy --- Level 1 is the
; global subject, and Level 2 supplies help on subjects within
; each global subject. If !D.WINDOW is not -1, (window system in use)
; the mouse is used to prompt for subjects; otherwise, the normal tty
; interface is used.
; This routine is used when in Widget IDL and widgets are not available.
; CATEGORY:
; Help, documentation
; CALLING SEQUENCE:
; MPBASIC [, REQUEST]
; INPUTS:
; REQUEST = A scalar string containing the item for which help is desired.
; This string can contain one or two (whitespace separated) words.
; If only one word is included in REQUEST, it is taken as either the
; global topic or the program name; if there are two words, the first
; is taken as the global topic and the second as the program name.
; Missing words are prompted for.
; OUTPUTS:
; Help text is sent to the standard output.
; RESTRICTIONS:
; The help text is derived from the LaTeX files used to produce
; the reference manual. However, it is not possible to produce
; exactly the same output as found in the manual, due to limitations
; of text-oriented terminals. The text used is therefore considerably
; abbreviated. Always check the manual if the online help is
; insufficient.
;
; Under VMS, MPBASIC now works (since July 1996) for procedures in text
; libraries. However, it will work faster if the procedures are stored
; as separate ASCII files in directories.
; MODIFICATION HISTORY:
; AB, 3, November, 1988
; Added ambiguity resolution, ability to handle
; multiple levels, and support for mouse. January, 1989
;
; Modified and extended to accept a wider range of help requests,
; K.Rhode, STX, June 1990 (Small bug fixed, 9 July 1990)
; Search the current procedures W. Landsman January, 1991
; Renamed to MPBASIC for Widget IDL.
; Modified to match new .HELP file format for IDL 3.1.0 and later.
; Joel D. Offenberg, HSTX, 7/1/93
; Work for VMS text library W. Landsman July 1996
;-
function SELECT_TOPIC, SUBJECT, TOPIC_ARRAY, INITIAL
; Given a subject header and an array of topics, returns a string with
; the requested topic (which may or may not be in TOPIC_ARRAY).
; Initial is the index of the initial selection to be highlighted IF
; a window system menu is used.
on_error,2 ;Return to caller if an error occurs
xx = fstat(-1)
target = ''
if (!d.name eq 'X' or (!d.window ne -1)) then begin ; Use wmenu
index = wmenu([SUBJECT, TOPIC_ARRAY,'***CANCEL***'], title=0, initial=initial)
if (index gt 0) and (index LE N_elements(topic_array)) then $
target = TOPIC_ARRAY(index-1) else return,''
endif else begin ; Use tty
if xx.isatty then begin
openw, 1, filepath(/TERMINAL), /STREAM, /MORE
printf, 1, format = '(/,A,":",/)', SUBJECT
printf, 1, TOPIC_ARRAY
close, 1
endif else begin
print, format = '(/,A,":",/)', SUBJECT
print, TOPIC_ARRAY
endelse
print, format='(/,/)'
read, 'Enter topic for which help is desired: ', target
endelse
target = STRCOMPRESS(STRUPCASE(target),/REMOVE_ALL) ; Upper case & no blanks
return, target
end
;
function TOPIC_MATCH, KEY, TOPIC_ARRAY, FOUND, OUTUNIT,EXACT=exact
; Given a string, TOPIC_MATCH returns an array of indices into
; TOPIC_ARRAY that match into FOUND. If there is an exact match
; only its index is returned, otherwise all elements with the same prefix
; match. The number of elements that matched is returned.
; OUTUNIT is the file unit to which output should be directed.
on_error,2 ;Return to caller if an error occurs
found = [ where(STRTRIM(TOPIC_ARRAY) eq KEY, count) ] ; Match exact string
if (count eq 0) then begin ; No exact match, try to match the prefix
if keyword_set(EXACT) then return,0
FOUND = [ where(strpos(TOPIC_ARRAY, KEY) eq 0, count) ]
if (KEY eq '') then begin
count = -1
printf,outunit, !MSG_PREFIX, 'Nothing matching topic "',KEY,'" found.'
printf,outunit, !MSG_PREFIX, 'Enter "man" for list of available topics.'
endif
if ((count gt 1) and (KEY ne '')) then begin
printf, outunit, format = "(A,'Ambiguous topic ""', A, '"" matches:')",$
!MSG_PREFIX, KEY
printf, OUTUNIT, TOPIC_ARRAY(FOUND)
endif
endif
return, count
end
;
PRO MPBASIC, REQUEST
on_error,2
outunit = (inunit = 0)
xx = fstat(-1)
lv1_topic = (lv2_topic = (sv_lv2_topic = (string = '')))
m = (no_request = (count1 = (count2 = 0)))
;
if (N_ELEMENTS(REQUEST)) then begin
temp = size(request)
if (temp(0) NE 0) then begin
MSG = 'Argument must be scalar.'
goto, FATAL
endif
if (temp(1) NE 7) then begin
MSG = 'Argument must be of type string.'
goto, FATAL
endif
;
lv1_topic = STRUPCASE(STRTRIM(STRCOMPRESS(REQUEST), 2))
sv_lv1_topic = lv1_topic ; Save the original request for later use
;
; Parse into one or two strings - level 1 is the global topic,
; level 2 the program name
TRY_AGAIN:
if (((blank_pos = STRPOS(lv1_topic, ' '))) ne -1) then begin
lv2_topic = STRMID(lv1_topic, blank_pos+1, 10000L)
lv1_topic = STRMID(lv1_topic, 0, blank_pos)
if (m eq 0) then sv_lv1_topic = lv1_topic
endif
endif
;
; lv1_files recieves all help files found through !HELP_PATH.
lv1_dirs = EXPAND_PATH(!HELP_PATH, /ARRAY, COUNT=cnt)
if (cnt eq 0) then begin
MSG = 'No online help files found.'
goto, fatal
endif
for i = 0, cnt-1 do begin
tmp = STRLOWCASE(findfile(filepath('*.help', root_dir=lv1_dirs(i))))
if (i eq 0) then lv1_files = TEMPORARY(tmp) $
else lv1_files=[lv1_files, TEMPORARY(tmp)]
endfor
; lv1_topics gets uppercase version of just the names.
lv1_topics = STRUPCASE(lv1_files)
stlen = strlen(lv1_topics)
if !version.os eq 'windows' then begin
tail = STRPOS(lv1_topics, '.HEL')
endif else if !version.os eq 'vms' then begin
tail = STRPOS(lv1_topics, '.HELP;')
endif else $
tail = STRPOS(lv1_topics, '.HELP')
n = n_elements(lv1_topics)
for i = 0, n-1 do $
lv1_topics(i) = strmid(lv1_topics(i), 0, tail(i))
for i = 0, n-1 do begin ; Strip path part off lv1_topics
case !version.os of
'vms': begin
j = STRPOS(lv1_topics(i), ']')
while (j ne -1) do begin
lv1_topics(i) = strmid(lv1_topics(i), j+1, 32767)
j = STRPOS(lv1_topics(i), ']')
endwhile
end
'windows': begin
j = STRPOS(lv1_topics(i), '\')
while (j ne -1) do begin
lv1_topics(i) = strmid(lv1_topics(i), j+1, 32767)
j = STRPOS(lv1_topics(i), '\')
endwhile
end
'MacOS': begin
j = STRPOS(lv1_topics(i), ':')
while (j ne -1) do begin
lv1_topics(i) = strmid(lv1_topics(i), j+1, 32767)
j = STRPOS(lv1_topics(i), ':')
endwhile
end
else: begin ; Unix otherwise
j = STRPOS(lv1_topics(i), '/')
while (j ne -1) do begin
lv1_topics(i) = strmid(lv1_topics(i), j+1, 32767)
j = STRPOS(lv1_topics(i), '/')
endwhile
end
endcase
endfor
initial = where(lv1_topics eq 'ROUTINES')
; If the initial request was simply "man"...
if (m eq 0) and (lv1_topic eq '') then no_request=1
if (lv1_topic eq '') then $
lv1_topic = SELECT_TOPIC('Help categories', lv1_topics, initial(0)+1)
if lv1_topic eq '' then goto,DONE
if (no_request gt 0) then sv_lv1_topic = lv1_topic
;
if (outunit GT 0) then FREE_LUN, outunit & outunit = 0
if xx.isatty then $
openw, outunit, filepath(/TERMINAL), /STREAM, /MORE, /GET_LUN $
else outunit = -1
count = TOPIC_MATCH(lv1_topic,lv1_topics,found,outunit)
; COUNT tells whether 'lv1_topic' matched any of 'lv1_topics'
if (m eq 0) then count1 = count ; if this is the first run-through...
if (count eq -1) then goto, DONE ; if no success, then end program
;
; If the original request was "man", but global topic then requested
; was not found, then send a message:
if (no_request gt 0) and (count1 eq 0) then goto,COUNT_ZERO
;
;If the user didn't include a global topic in the initial request, this loop
;adds one, then tries again to find the requested procedure in the help files
M_LOOP:
if (m le 0) then begin
if (count eq 0) then begin
lv2_topic=' '
lv1_topic='ROUTINES '+STRUPCASE(request)
m = m + 1
if (outunit GT 0) then free_lun, outunit & outunit = 0
goto,TRY_AGAIN
endif
endif
if (outunit GT 0) then free_lun, outunit & outunit = 0
lv2_subject = (lv1_files(found))(0) ; Use the first element
;
;If COUNT is STILL zero, a message is sent, and MAN_PROC gives up
COUNT_ZERO:
if (count eq 0) then begin
;
if !Version.os EQ "vms" then begin
sep = ','
dirsep = ''
endif else begin
sep = ':'
dirsep = '/'
endelse
;
temp = !PATH ;Get current IDL path of directories
;
; Loop over each directory in !PATH until procedure name found
;
while temp NE '' do begin
dir = gettok(temp,sep)
;
if strmid(dir,0,1) ne '@' then begin ;Text Library?
a = findfile(dir + dirsep +strlowcase(request)+'.pro',COUNT=count)
if count GE 1 then begin ;Found by FINDFILE?
if inunit GT 0 then close,inunit else get_lun,inunit
if outunit GT 0 then close,outunit else get_lun,outunit
OPENR,INUNIT,A(0)
; Open the output file with the /MORE option
;
if xx.isatty then $
openw, outunit, filepath(/TERMINAL), /STREAM, /MORE $
else outunit = -1
LINE = "STRING"
WHILE NOT EOF(INUNIT) DO BEGIN
READF,INUNIT,LINE
IF STRMID(LINE,0,2) EQ ';+' THEN BEGIN
READF,INUNIT,LINE
WHILE NOT EOF(INUNIT) DO BEGIN
READF,INUNIT,LINE
IF STRMID(LINE,0,2) EQ ';-' THEN GOTO,DONE
PRINTF,OUTUNIT,STRTRIM(STRMID(LINE,1,STRLEN(LINE)))
ENDWHILE
ENDIF
ENDWHILE
GOTO,DONE
endif
endif else begin
LibName = strmid( Dir, 1, strlen(Dir)-1 ) ;Remove the "@" symbol
spawn, 'library /list ' + LibName, List
lfound = where( list EQ strupcase(request), Nfound)
if outunit GT 0 then close,outunit else get_lun,outunit
if Nfound GT 0 then begin
openw, outunit, filepath(/TERMINAL), /STREAM, /MORE
spawn,'libr/out=sys$output/extract = ' + request + ' ' + $
libname, outlist
display = 0
for i= 0,N_elements(outlist)-1 do begin
if display then begin
if strmid(outlist(i),0,2) EQ ';-' then $
goto,DONE
printf,outunit,outlist(i)
endif
if strmid(outlist(i),0,2) eq ';+' then display = 1
endfor
endif
endelse
endwhile
endif
if count eq 0 then begin
if (outunit GT 0) then FREE_LUN, outunit & outunit = 0
if xx.isatty then $
openw, outunit, filepath(/TERMINAL), /STREAM, /MORE, /GET_LUN $
else outunit = -1
if (sv_lv2_topic ne '') then string = sv_lv1_topic+' '+sv_lv2_topic $
else string = sv_lv1_topic
printf,outunit,!MSG_PREFIX, 'Nothing matching topic "',string,'" found.'
printf,outunit,!MSG_PREFIX, 'Enter "man" for list of available topics.'
goto,DONE
endif
;
;At this point, a global subject exists - next, process the specific subject
lv2_topics = ''
offset = 0L
if (inunit ne 0) then FREE_LUN, inunit & inunit = 0
;
; Read the specially-formatted .HELP files to look for the requested procedure
lv2_topics = ''
offset = 0L
openr, inunit, lv1_files(found(0)), /GET_LUN
outunit = 0;
n = 0L
tmp=''
readf,inunit,tmp ; Read first line.
; If it's the version tag, parse it.
version = 1L ; Assume old format
if (strmid(tmp, 0, 9) eq '%VERSION:') then begin
reads, tmp, version, format='(9X, I0)'
readf,inunit,tmp ; Read next line.
endif
if (strmid(tmp, 0, 7) eq '%TITLE:') then readf, inunit, tmp ; Skip title
n = long(tmp) ;# of records
if (version ne 1) then begin
; Version 2 format has the number of characters used by all the
; subtopics on the next line. We don't use it, but have to read it
readf,inunit,tmp ; Read next line.
endif
;
; Search the beginning of the .HELP file for a number. Disregard
; all lines before the first number (added for compatibility with
; IDL 3.1.0's new .HELP file format).
;
;WHILE (n eq 0) do BEGIN
; dummy = ""
; readf, inunit, dummy
; dd = byte(strcompress(dummy,/REMOVE_ALL))
;
; ;Is the first character a number (between '0' and '9')?
; IF (dd(0) GE 48 and dd(0) LE 57 ) THEN $
; n = fix(dummy)
;endWHILE
;The following line is no longer needed.
;readf,inunit,n ;Read # of records
lv2_topics = strarr(n) ;Make names
readf,inunit,lv2_topics ;Read entire string to inunit
if (version EQ 1) then begin
offsets = long(strmid(lv2_topics, 15, 30)) ;Extract starting bytes
lv2_topics = strmid(lv2_topics,0,15) ;Isolate names
endif else begin
offsets = lonarr(n)
for i = 0, n-1 do begin
tmp = lv2_topics(i)
colon = strpos(tmp, ':') + 1 ; Find delimiter
offsets(i) = long(strmid(tmp, 0, colon))
lv2_topics(i) = strmid(tmp, colon, 10000000)
endfor
endelse
tmp = fstat(inunit) ; Determine the base of the help text in .HELP files
text_base = tmp.cur_ptr
if text_base eq tmp.size then category = 1 else category =0
;
; If no level 2 topic has been supplied, prompt for one
if lv2_topic eq '' then $
lv2_topic = SELECT_TOPIC(STRUPCASE(lv2_subject), lv2_topics, 1)
if lv2_topic eq '' then goto,DONE
;
if (m eq 0) then sv_lv2_topic = lv2_topic
if (outunit GT 0) then FREE_LUN, outunit & outunit = 0
if xx.isatty then $
openw, outunit, filepath(/TERMINAL), /STREAM, /MORE, /GET_LUN $
else outunit = -1
;
; If count is still zero, and all the ROUTINES have been searched, then quit
if (((count=TOPIC_MATCH(lv2_topic,lv2_topics,found,outunit,/EXACT))) eq 0) $
and (m eq 1) then goto,COUNT_ZERO
count2 = count
;
;If the global topic was found, but the procedure requested doesn't exist, quit
if (count2 eq 0) and (count1 eq 1) then goto,COUNT_ZERO
;
; If all of the ROUTINES been searched, go back to M_LOOP
if (count eq 0) and (m eq 0) then goto,M_LOOP
;
; Print the documentation if the search was successful
str = ''
if (outunit GT 0) then FREE_LUN, outunit & outunit = 0
if category then begin
if (inunit NE 0) then FREE_LUN,inunit & inunit = 0 ;Corrected Sep 91
count = 0 & m= -1
request = lv2_topic
goto,M_LOop
endif
if xx.isatty then $
openw, outunit, filepath(/TERMINAL), /STREAM, /MORE, /GET_LUN $
else outunit = -1
for i=0,(count-1) do begin
index = found(i)
if (count gt 1) then printf, outunit, lv2_topics(index), $
format='("***************",/,A,/,"***************")'
POINT_LUN, inunit, text_base + offsets(index)
readf, inunit, str ; Skip the ";+"
readf, inunit, str
while (STRTRIM(str) NE ";-") do begin
printf, outunit, str, ' '
readf, inunit, str
endwhile
endfor
goto,DONE
;
FATAL: ; The string MSG must be already set
message, MSG
;
DONE:
if (outunit GT 0) then FREE_LUN, outunit & outunit = 0
if (inunit ne 0) then FREE_LUN, inunit & inunit = 0
end