OS/2 Professional Developers Kit 1992 November

home *** CD-ROM | disk | FTP | other *** search

/ OS/2 Professional Developers Kit 1992 November / Disc01 / Disc01.mdf / prodtool / epm / e_macros / stdprocs.e < prev next >

Wrap

Text File | 1992-08-27 | 53.2 KB | 1,622 lines

; A useful subroutine: asks "Are you sure (Y/N)?" (same as DOS's prompt ; after "erase *.*") and returns uppercase keystroke. ; If called with a string parameter, displays it at start of prompt, e.g. ; usersays = askyesno("About to erase.") ; ==> "About to erase. Are you sure (Y/N)? " ; EPM 5.12B: Now enabled for EPM, using entrybox(). Optional second argument ; is a flag to prevent the "Are you sure" from being appended. ; EPM 5.15: Now uses WinMessageBox to get Yes, No buttons. [\toolktxx\c\include\pmwin.h] defproc askyesno prompt=arg(1) compile if EVERSION < 5 if not arg(2) then prompt=prompt || ARE_YOU_SURE_YN__MSG endif return upcase(mgetkey(prompt)) /* Accept key from macro. */ compile else if not arg(2) then prompt=prompt\13 || ARE_YOU_SURE__MSG endif return substr(YES_CHAR || NO_CHAR, winmessagebox('', prompt, 16388) - 5, 1) -- YESNO + MOVEABLE compile endif compile if EVERSION >= 4 ; Does an atol of its argument, then a word reversal and returns the result. defproc atol_swap(num) hwnd=atol(num) compile if EVERSION >= '5.17' return rightstr(hwnd,2) || leftstr(hwnd,2) compile else return substr(hwnd,3,2) || substr(hwnd,1,2) compile endif compile endif defproc checkmark() /* Common routine, save space. from Jim Hurley.*/ if marktype()='' then compile if EPM sayerror NO_MARK_HERE__MSG compile else sayerror NO_MARK__MSG compile endif stop endif ; Routine to tell if a mark is visible on the screen. (Actually, only on the ; current window; if the window is less than full size, a mark could be visible ; in an inactive window without our being able to tell.) Also, if a character ; mark begins above the top of the window and ends below the bottom, and the ; window contains only blank lines, then this routine will return 1 (since the ; mark spans the window) even though no sign of the mark will be visible. defproc check_mark_on_screen = if marktype() = '' then return 0; endif -- If no mark, then not on screen. getmark first_mark_line, last_mark_line, first_mark_col, last_mark_col first_screen_line = .line - .cursory + 1 last_screen_line = .line - .cursory + .windowheight if last_mark_line < first_screen_line then return 0; endif if first_mark_line > last_screen_line then return 0; endif no_char_overlap = marktype()<>'CHAR' or first_mark_line=last_mark_line if last_mark_col < .col - .cursorx + 1 and (no_char_overlap or last_mark_line=first_screen_line) then return 0; endif if first_mark_col > .col - .cursorx + .windowwidth and (no_char_overlap or first_mark_line=last_screen_line) then return 0; endif return 1 ; Tests whether the "filename" is actually a printer ; device, so we'll know whether to test printer readiness first. ; Called by savefile() in SAVELOAD.E. Returns 0 if not, else printer number. defproc check_for_printer(name) if not name then return 0; endif compile if EVERSION >= '5.50' if leftstr(name,1)='"' & rightstr(name,1)='"' then name=substr(name,2,length(name)-2) endif compile endif compile if EVERSION >= '5.17' if rightstr(name,1) = ':' then -- a device name = leftstr(name,length(name)-1) compile else if substr(name,length(name),1) = ':' then -- a device name = substr(name,1,length(name)-1) compile endif else -- Might be a full pathspec, C:\EDIT\PRN, and still go to a device! indx = lastpos('\',name) if not indx then indx = lastpos(':',name) endif if indx then name=substr(name,indx+1) endif indx = pos('.',name) if indx then name=substr(name,1,indx-1) endif endif if upcase(name)='PRN' then return 1; endif compile if EVERSION >= 4 -- Check_for_printer always returns true, so we don't need to distinguish COMn. return (4+pos('.'upcase(name)'.','.LPT1.LPT2.LPT3.LPT4.LPT5.LPT6.LPT7.LPT8.LPT9.COM1.COM2.COM3.COM4.')) % 5 compile else return (4+pos('.'upcase(name)'.','.LPT1.LPT2.LPT3.')) % 5 compile endif compile if WANT_WINDOWS ; This proc is called only by DEFC EDIT in messy-desk mode. defproc create_window_for_each_file(emptyfileid) fileidlist='' activatefile emptyfileid /* Start list at beginning so we get 'em all. */ nextfile /* Except first one, can leave one in each ring. */ loop nextfile .box=1 getfileid fileid if fileid=emptyfileid then leave endif fileidlist=fileidlist fileid endloop rest=fileidlist loop parse value rest with fileid rest if fileid='' then leave endif rc=0 newwindow fileid if rc then leave endif getfileid cur_fileid activatefile fileid quitview activatefile cur_fileid endloop compile endif COMPILE IF EVERSION >= 4 defproc dec_to_string(string) -- for dynalink usage line = '' for i = 1 to length(string) line= line || asc(substr(string,i,1)) || ' ' endfor return line COMPILE ENDIF define compile if EVERSION >= '5.20' -- 5.20 adds a HINI to the *Profile calls. HINI_PARM = 'HINI_PROFILE,' compile else HINI_PARM = ' ' compile endif defproc default_printer compile if defined(my_printer) return MY_PRINTER compile elseif EPM parse value queryprofile($HINI_PARM 'PM_SPOOLER', 'PRINTER') with printername ';' if printername<>'' then parse value queryprofile($HINI_PARM 'PM_SPOOLER_PRINTER', printername) with dev ';' if dev<>'' then return dev; endif endif compile endif return 'LPT1' ; Returns DOS version number, multiplied by 100 so we can treat ; it as an integer string. That is, DOS 3.2 is reported as "320". ; Needed by DEFPROC SUBDIR. defproc dos_version() compile if E3 parse value int86x(DOS_INT,DOS_GET_VERSION,'') with ax . major = ax // 256 /* AL = major version number */ ; minor = (ax - major) % 256 return 100*major + (ax - major) % 256 compile else verbuf = 'nn' res= dynalink('DOSCALLS', /* dynamic link library name */ '#92', /* ordinal for DOSGETVERSION */ selector(verbuf) || /* string selector */ offset(verbuf)) /* string offset */ ; major = asc(substr(verbuf,2,1)) ; minor = asc(substr(verbuf,1,1)) return 100*asc(substr(verbuf,2,1)) + asc(substr(verbuf,1,1)) compile endif compile if WANT_ET_COMMAND -- Let user omit ET command. defproc ec_position_on_error(tempfile) /* load file containing error */ 'xcom e 'tempfile if rc then -- Unexpected error. sayerror ERROR_LOADING__MSG tempfile if rc=-282 then 'xcom q'; endif -- sayerror('New file') return endif if .last<=4 then getline msg,.last 'xcom q' else getline msg,2 compile if EPM if leftstr(msg,3)='(C)' then -- 5.20 changed output getline msg,4 endif compile endif getline temp,.last parse value temp with 'col= ' col getline temp,.last-1 parse value temp with 'line= ' line getline temp,.last-2 parse value temp with 'filename=' filename 'xcom q' 'e 'filename -- not xcom here, respect user's window style if line<>'' and col<>'' then compile if EPM .cursory=min(.windowheight%2,.last) compile else .cursory=15 compile endif if col>0 then .col=col line else .line=line-1 /* sometimes the compiler is off by 1 */ getline s .col=length(s) /* position cursor at end of previous line */ endif endif endif sayerror msg compile endif defproc einsert_line insert up getline line parse value pmargins() with leftcol . paracol . if line='' or not .line then .col=paracol else call pfirst_nonblank() if .col=paracol then .col=leftcol; endif endif down compile if ENHANCED_ENTER_KEYS defproc enter_common(action) compile if WANT_STREAM_MODE = 'SWITCH' universal stream_mode if stream_mode then compile endif compile if WANT_STREAM_MODE if .line then split .col=1 down else insert .col=1 endif return compile endif compile if WANT_STREAM_MODE = 'SWITCH' endif compile endif compile if WANT_STREAM_MODE <> 1 if .line = .last & (action=3 | action=5) then -- 'ADDATEND' | 'DEPENDS+' call einsert_line() down -- This keeps the === Bottom === line visible. return endif ; 'NEXTLINE' 'ADDATEND' 'DEPENDS' 'DEPENDS+' if action=2 | action=3 | (not insert_state() & (action=4 | action=5)) then down -- go to next line begin_line return endif if action=6 then call splitlines() call pfirst_nonblank() down ;; refresh return endif call einsert_line() -- insert a line compile endif -- WANT_STREAM_MODE <> 1 compile endif ; Erasetemp erases a file quietly (no "File not found" message) on both DOS ; and OS/2. Thanks to Larry Margolis. Returns 0 if successful erase, or ; the error code (if on DOS) which will usually be 2 for 'file not found'. defproc erasetemp(filename) asciiz = filename\0 compile if E3 call free() -- Keep variables from moving around before int86x. parse value int86x(DOS_INT,DOS_UNLINK 0 0 ofs(asciiz), seg(asciiz)) with ax . . . . . cf ',' . -- Most callers will ignore error code, don't care file doesn't exist. -- if cf then sayerror 'DOS error code' ax endif if cf then return ax; endif compile else return dynalink('DOSCALLS', /* dynamic link library name */ '#60', /* ordinal value for DOSDELETE */ selector(asciiz) || /* string selector */ offset(asciiz) || /* string offset */ atoi(0)|| /* reserved */ atoi(0)) /* reserved */ compile endif compile if EPM defproc find_token(var startcol, var endcol) -- find a token around the cursor. if arg(3)='' then token_separators = ' ~`!#%^&*()-+=][{}|\:;?/><,.''' else token_separators = arg(3) endif getline line len = length(line) endcol = verify(line, token_separators, 'M', .col) if endcol = .col | .col>len then return endif if endcol then endcol = endcol - 1 else endcol = len endif startcol = verify(reverse(line), token_separators, 'M', len - .col + 1) if startcol then startcol = len - startcol + 2 else startcol = 1 endif return 1 compile endif ; Note on a speed trick: The following routine is used to both verify that ; an external program exists, and to get its path. After that first search, ; the exact path location of the routine is known; it can be remembered so that ; all future calls can supply the exact location to avoid the path search. ; See SUBDIR for an example of its use. defproc find_routine(utility) -- Split from SUBDIR parse arg util opts -- take first word, so can pass options too. findfile fully_qualified,util,'PATH','P' if rc then return -1 endif compile if E3 if dos_version() < 300 then return utility --DOS 2 can't handle the path endif --in front of the command. compile endif return fully_qualified opts compile if EVERSION >='5.50' -- For GPI version, we must manage the cursor ourself defproc fixup_cursor() compile if UNDERLINE_CURSOR cursorh = 3 - 67*insert_state() -- 0 -> 3; 1 -> -64 cursorw = '-128' compile else cursorw = 2 - 130*(not insert_state()) -- 0 -> -128; 1 -> 2 cursorh = '-128' compile endif cursor_dimensions cursorw, cursorh compile endif compile if EVERSION < 5 defproc init_operation_on_commandline universal comsfileid,oldline if command_state() then activatefile comsfileid oldline=.line getcommand line,col,scrollpos insertline line,.last+1 .cursorx=col-scrollpos+1 .col=col bottom endif compile endif ; Returns true if parameter given is a number. ; Leading and trailing spaces are ignored. defproc isnum zzi=pos('-',arg(1)) -- Optional minus sign? if zzi then -- If there is one, parse arg zz1 '-' zz zz2 -- zz1 <- before it, zz <- number, zz2 <- after else parse arg zz zz1 zz2 -- zz <- number; zz1, zz2 <- after it endif zz=strip(zz) -- Delete leading & trailing spaces. if zz1||zz2 <> '' or -- If there were more tokens on the line zz=='' -- or if the result is null then return 0 endif -- then not a number. compile if EVERSION >= 4 -- OS/2 version - real numbers if pos(DECIMAL,zz) <> lastpos(DECIMAL,zz) then return 0 endif -- Max. of one decimal point. return not verify(zz,'0123456789'DECIMAL) compile else -- DOS version - integers only return not verify(zz,'0123456789') compile endif defproc isoption(var cmdline,optionletter) i=pos(argsep||upcase(optionletter),upcase(cmdline)) if i then compile if EPM cmdline=delstr(cmdline,i,2) compile else cmdline=substr(cmdline,1,i-1)||substr(cmdline,i+2) compile endif return 1 endif defproc joinlines() if .line<.last and .line then compile if EPM -- Can't use REPLACELINE because it wipes out attributes. oldcol = .col down -- ensure one space at start of second line call pfirst_nonblank() col2 = .col .col = 1 getsearch savesearch if col2 > 2 then -- Shift line left 'xcom c/'copies(' ',col2-2)'//' -- Change first n-1 blanks to null elseif col2=1 then -- Shift line right 'xcom c/^/ /g' -- insert a space at beginning of line endif setsearch savesearch up -- ensure no spaces at end of first line .col = length(strip(textline(.line),'T')) + 1 erase_end_line .col = oldcol compile else -- E3 and EOS2 can still use the old, simple way. /* remove all but one trailing space of current line */ getline line replaceline strip(line,'T')' ' /* remove all leading spaces of next line */ getline line,.line+1 replaceline strip(line),.line+1 compile endif join endif compile if EVERSION < 5 defproc leave_last_command if (not arg() or arg(2)) and arg(1) then cursor_command up for i = 1 to arg(1)-1 right endfor endif compile endif compile if WANT_LAN_SUPPORT defproc lock(file) newhandle='??' actiontaken=atoi(1) -- File exists file=file\0 result = dynalink('DOSCALLS', '#70', /* dosopen */ selector(file)|| offset(file)|| selector( newhandle )|| offset( newhandle )|| selector( actiontaken )|| offset( actiontaken )|| atol(0)|| -- file size atoi(0)|| -- file attribute atoi(17)|| -- open flag; open if exists, else create atoi(146)|| -- openmode; deny Read/Write atol(0)) if result then ; 'quit' /* quit since the file could not be locked */ messageNwait('DOSOPEN' ERROR__MSG result NOT_LOCKED__MSG) return result endif if newhandle = \0\0 then -- Handle of 0 - bad news newhandle2=atoi(65535) result = dynalink('DOSCALLS', '#61', /* DosDupHandle */ newhandle || selector( newhandle2 )|| offset( newhandle2 )) call dynalink('DOSCALLS', -- Free the original handle '#59', -- dosclose newhandle) if result then messageNwait('DosDupHandle' ERROR__MSG result NOT_LOCKED__MSG) return result endif newhandle = newhandle2 endif .lockhandle=itoa(newhandle,10) compile endif defproc max(a,b) -- Support as many arguments as E3 will allow. maximum=a do i=2 to arg() if maximum<arg(i) then maximum=arg(i); endif end return maximum compile if E3 definit /* Keep this definit close to the proc it serves. */ universal lines_entered lines_entered=0 defproc maybe_autosave -- For E3 users, this routine increments the autosave universal autosave,lines_entered -- counter, and does an autosave if necessary. if autosave then lines_entered = lines_entered +1 if lines_entered >= autosave then 'xcom save' MakeTempName() -- Don't worry about HPFS files in E3. if rc=-2 then -- sayerror('File not found') -> Invalid filename 'xcom save' MakeTempName('BAD-NAME') endif .modify=1 /* Reraise the modify flag. */ lines_entered =0 endif endif compile endif compile if BACKUP_PATH <> '' ; Procedure to pick a filename for backup purposes, like STDPROCS.E$. defproc MakeBakName name = arg(1) -- Change name as little as possible, but enough to identify it as -- a noncritical file. Replace the last character with '$'. ext = filetype(name) if length(ext)=3 then ext = substr(ext,1,2)'$' else ext = ext'$' endif -- We still use MakeTempName() for its handling of host names. bakname = MakeTempName(name) i=lastpos('\',bakname) -- but with a different directory if i then bakname = substr(bakname,i+1) endif parse value bakname with fname'.'. bakname = BACKUP_PATH || fname'.'ext return bakname compile endif ; Procedure to pick a temporary filename like ORIGNAME.$$1. ; First argument is the filename, 2nd is the fileid. Both are optional, ; default to the current filename and fileid if absent. ; Revised by BTTUCKER to catch all cases and work with E3EMUL. defproc MakeTempName universal vAUTOSAVE_PATH TempName = arg(1) extension = arg(2) if TempName = '' then /* if no arg given, default to current filename */ TempName = .filename endif if TempName = '' then TempName = '$' /* new file? o.k. then $ */ else /* We want only PC file name, VM filename, or MVS firstname */ /* These next statements will strip everything else off... */ p = lastpos('\',TempName) /* PC filename with path */ if p then TempName=substr(TempName,p+1) endif p = pos('.',TempName) /* PC or MVS filename */ if p then TempName=substr(TempName,1,p-1) endif p = pos(' ',TempName) /* VM filename (or HPFS) */ if p then TempName=substr(TempName,1,p-1) endif p = pos(':',TempName) /* VM or MVS filename */ if p then TempName=substr(TempName,p+1) endif p = pos("'",TempName) /* MVS filename */ if p then TempName=substr(TempName,p+1) endif if length(tempname)>8 then tempname=substr(tempname,1,8); endif /* HPFS names */ endif -- TempName might still be blank, as for '.Unnamed file'. if TempName='' then TempName='$'; endif TempName = vAUTOSAVE_PATH || TempName if extension='' then /* default is current fileid */ getfileid extension endif compile if EVERSION < 5 extension = '$$' || extension compile else /* In EPM we can have the same filename in multiple edit windows without * knowing it, because different edit windows are actually separate * instances of the editor. So try to make the tempname unique by * combining the window handle with the fileid. Combine two middle * digits of the window handle with the last digit of the fileid. */ extension = substr(getpminfo(EPMINFO_EDITCLIENT),2,2) || extension compile endif if length(extension)>3 then /* could be >one digit, or something else */ extension=substr(extension,2,3) endif return TempName'.'extension defproc message getfileid fileid sayerror arg(1) activatefile fileid ; Print message and wait for a key press. ; Preserve active file and activate ring. ; Note: There is no need to use "call" to invoke this procedure, since it ; returns the null string. Execution of a null string does nothing defproc messageNwait getfileid zzfileid compile if EPM display -4 -- Force a messagebox popup from the SAYERROR compile endif sayerror arg(1) compile if EVERSION < 5 call getkey() compile else display 4 compile endif activatefile zzfileid compile if EVERSION < 5 ; Mgetkey() acts the same as a call to getkey(), but first checks ; whether we're in mid-execution of a key-string (Ctrl-R/Ctrl-T). ; If so it gets the next key from the string. Call this in place of ; getkey() if you want the user to be able to record the response. ; Don't call this for unusual inputs, such as messageNwait after errors. ; Optional argument is prompt string, will be displayed on status line. defproc mgetkey() universal Kstring,inKstring /* See c_r in STDKEYS.E. */ prompt=arg(1) if prompt<>'' and inKstring<=0 then sayerror prompt endif if inKstring=0 then /* If not recording or replaying, normal input. */ k=getkey() elseif inKstring=-1 then /* If recording, stash key in string. */ k=getkey() Kstring=Kstring||k /* Trust that it doesn't get longer than 255. */ else /* inKstring>0 ==> replaying; get next key from Kstring. */ k=substr(Kstring,inKstring,1) ksize=1 if k==substr(esc,1,1) then /* extended key ? */ k=substr(Kstring,inKstring,2) /* Yes, 2 bytes for extended key. */ ksize=2 endif inKstring=inKstring+ksize /* bump index AFTER execution */ endif if prompt<>'' and inKstring<=0 then sayerror 0 endif return k compile endif defproc min(a,b) -- Support as many arguments as E3 will allow. minimum=a do i=2 to arg() if minimum>arg(i) then minimum=arg(i); endif end return minimum compile if EVERSION < 5 defproc move_results_to_commandline universal oldline if command_state() then getline line deleteline setcommand line,.col,.col-.cursorx+1 oldline endif compile endif ; The following two routines (from Larry Margolis) let the ; user decide what action should be taken when the Enter and Ctrl-Enter ; keys are pressed. The possible values for the action constants are ; defined in STDCNF. compile if C_ENTER_ACTION & not ENHANCED_ENTER_KEYS -- If null, don't define - user will supply. defproc my_c_enter compile if C_ENTER_ACTION = 'ADDATEND' | C_ENTER_ACTION = 'DEPENDS+' if .line = .last then -- If we're on the last line, then add a line. compile if EVERSION < '4.12' call maybe_autosave() compile endif call einsert_line() down -- This keeps the === Bottom === line visible. else compile endif compile if C_ENTER_ACTION = 'DEPENDS' | C_ENTER_ACTION = 'DEPENDS+' if insert_state() then -- DEPENDS means if insertstate() then ... compile endif compile if C_ENTER_ACTION = 'NEXTLINE' | C_ENTER_ACTION = 'DEPENDS' | C_ENTER_ACTION = 'ADDATEND' | C_ENTER_ACTION = 'DEPENDS+' down -- go to next line begin_line compile endif compile if C_ENTER_ACTION = 'DEPENDS' | C_ENTER_ACTION = 'DEPENDS+' else -- otherwise ... compile endif compile if C_ENTER_ACTION = 'ADDLINE' | C_ENTER_ACTION = 'DEPENDS' | C_ENTER_ACTION = 'DEPENDS+' compile if EVERSION < '4.12' call maybe_autosave() compile endif call einsert_line() -- insert a line compile endif compile if C_ENTER_ACTION = 'DEPENDS' | C_ENTER_ACTION='ADDATEND' | C_ENTER_ACTION = 'DEPENDS+' endif compile endif compile if C_ENTER_ACTION = 'DEPENDS+' endif compile endif compile if C_ENTER_ACTION = 'STREAM' call splitlines() call pfirst_nonblank() down compile if EPM refresh compile endif compile endif compile endif compile if not ENHANCED_ENTER_KEYS & ENTER_ACTION -- If null, don't define - user will supply. defproc my_enter compile if WANT_STREAM_MODE = 'SWITCH' universal stream_mode compile endif compile if EVERSION < 5 if command_state() then execute compile else if 0 then -- EPM has no command_state() compile endif compile if WANT_STREAM_MODE = 'SWITCH' elseif stream_mode then compile endif compile if WANT_STREAM_MODE if .line then split .col=1 down else insert .col=1 endif return compile endif compile if WANT_STREAM_MODE <> 1 compile if ENTER_ACTION = 'ADDATEND' | ENTER_ACTION = 'DEPENDS+' elseif .line = .last then -- If we're on the last line, then add a line. compile if EVERSION <= '4.12' call maybe_autosave() compile endif call einsert_line() down -- This keeps the === Bottom === line visible. compile endif else compile if ENTER_ACTION = 'DEPENDS' | ENTER_ACTION = 'DEPENDS+' if insert_state() then -- DEPENDS means if insertstate() then ... compile endif compile if ENTER_ACTION = 'ADDLINE' | ENTER_ACTION = 'DEPENDS' | ENTER_ACTION = 'DEPENDS+' compile if EVERSION < '4.12' call maybe_autosave() compile endif call einsert_line() -- insert a line compile endif compile if ENTER_ACTION = 'DEPENDS' | ENTER_ACTION = 'DEPENDS+' else -- otherwise ... compile endif compile if ENTER_ACTION = 'NEXTLINE' | ENTER_ACTION = 'DEPENDS' | ENTER_ACTION = 'ADDATEND' | ENTER_ACTION = 'DEPENDS+' down -- go to next line begin_line compile endif compile if ENTER_ACTION = 'DEPENDS' | ENTER_ACTION = 'DEPENDS+' endif compile endif compile if ENTER_ACTION = 'STREAM' if .line then if .col<=length(textline(.line)) then split .col=1 else split call pfirst_nonblank() endif down else insert .col=1 endif compile if EPM refresh compile endif compile endif compile endif -- WANT_STREAM_MODE <> 1 endif compile endif ; A common routine to parse an argument string containing a mix of ; options and DOS file specs. The DOS file specs can contain an "=" for the ; path or the fileid, which will be replaced by the corresponding part of the ; previous file (initially, the current filename). defproc parse_file_n_opts(argstr) prev_filename = .filename output = '' do while argstr<>'' compile if EVERSION >= '5.50' parse value argstr with filename rest if leftstr(filename,1)='"' then parse value argstr with '"' filename '"' argstr filename = '"'filename'"' else argstr = rest endif compile else parse value argstr with filename argstr compile endif if substr(filename,1,1)<>'/' then call parse_filename(filename,prev_filename) prev_filename = filename endif output = output filename end return substr(output,2) ; A common routine to parse a DOS file name. Optional second argument ; gives source for = when used for path or fileid. RC is 0 if successful, or ; position of "=" in first arg if no second arg given but was needed. defproc parse_filename(var filename) compile if EVERSION >= '5.50' if leftstr(filename,1)='"' & rightstr(filename,1)='"' then return 0 endif compile endif sourcefile = strip(arg(2)) if sourcefile='' then return pos('=',filename) endif if filename='=' then filename=sourcefile; return 0; endif lastsep = lastpos('\',sourcefile) if not lastsep & substr(sourcefile,2,1) = ':' then lastsep=2; endif /* E doesn't handle the = prefix if it's on the first file given on */ /* the E command line. This replaces = with path of current file. LAM */ if substr(filename,1,1) = '=' & lastsep then if substr(filename,2,1) = '.' then filename='='filename endif filename=substr(sourcefile,1,lastsep) || substr(filename,2) endif /* Also accept '=' after the pathspec, like 'c:\bat\=', */ /* or c:\bat\=.bat or c:\doc\new.= */ p = pos('=',filename) if p > 1 then sourcefileid=substr(sourcefile,max(lastsep+1,1)) parse value sourcefileid with sourcefilename '.' sourcefileext lastsep2 = lastpos('\',filename) if not lastsep2 & substr(filename,2,1) = ':' then lastsep2=2; endif dot1=pos('.',filename,max(lastsep2,1)) firstpart=substr(filename,1,p-1) if dot1 then if dot1<p then -- filename.= filename= firstpart || sourcefileext else -- =.ext filename= firstpart || sourcefilename || substr(filename,dot1) endif else -- d:\path\ || filename.ext filename= firstpart || sourcefileid endif -- dot1 endif -- p > 1 return 0 ; This proc is called by DEFC EDIT. ; Does *not* assume all options are specified before filenames. defproc parse_leading_options(var rest,var options) options='' loop parse value rest with wrd more if substr(wrd,1,1)='/' then options = options wrd rest = more else leave endif endloop ; PBEGIN_MARK: this procedure moves the cursor to the first character of the ; mark area. If the mark area is not in the active file, the marked file is ; activated. defproc pbegin_mark call checkmark() getmark firstline,lastline,firstcol,lastcol,fileid activatefile fileid compile if EVERSION < 5 cursor_data compile endif firstline if marktype()<>'LINE' then .col=firstcol endif ; PBEGIN_WORD: moves the cursor to the beginning of the word if the cursor is on ; this word. If it's not on a word, it's moved to the beginning of the first ; word on the left. If there is no word on the left it's moved to the beginning ; of the word on the right. If the line is empty the cursor doesn't move. defproc pbegin_word getline line,.line if substr(line,.col,1)=' ' then p=verify(line,' ') /* 1st case: the cursor on a space */ if p>=.col then .col=p else if p then q=p loop p=verify(line,' ','M',p) if not p or p>.col then leave endif p=verify(line,' ','',p) if not p or p>.col then leave endif q=p endloop .col=q endif endif else if .col<>1 then /* 2nd case: not on a space */ .col=lastpos(' ',line,.col)+1 endif endif ; PBLOCK_REFLOW: reflow the text in the marked area. Then the destination block ; area must be selected and a second call to this procedure reflow the source ; block in the destination block. The source block is fill with spaces. ; option=0 saves the marked block in temp file ; option=1 reflow temp file text and copies it to marked area defproc pblock_reflow(option,var spc,var tempofid) call checkmark() if not option then usedmk=marktype() getmark firstline1,lastline1,firstcol1,lastcol1,fileid1 /* move the source mark to a temporary file */ compile if EPM 'xcom e 'argsep'q 'argsep'n .tempo' .visible = 0 -- Make hidden compile else 'xcom e 'argsep'q 'argsep'n 'argsep'h .tempo' sayerror 1 compile endif getfileid tempofid activatefile tempofid call pcopy_mark() activatefile fileid1 compile if EVERSION < 5 cursor_data compile endif call pset_mark(firstline1,lastline1,firstcol1,lastcol1,usedmk,fileid1) if usedmk='LINE' then begin_line endif spc=usedmk firstline1 lastline1 firstcol1 lastcol1 fileid1 return 0 else if marktype() <> 'BLOCK' then sayerror NEED_BLOCK_MARK__MSG /* release tempo */ getfileid fid rc=0 activatefile tempofid if rc then return rc; endif .modify=0 'xcom q' activatefile fid return 1 endif parse value spc with usedmk firstline1 lastline1 firstcol1 lastcol1 fileid1 getmark firstline2,lastline2,firstcol2,lastcol2,fileid2 /* fill source with space */ if usedmk='LINE' then for i = firstline1 to lastline1 replaceline '',i,fileid2 endfor else call pset_mark(firstline1,lastline1,firstcol1,lastcol1,usedmk,fileid1) call pfill_mark(' ') endif call pset_mark(firstline2,lastline2,firstcol2,lastcol2,'BLOCK',fileid2) delete_mark /* let's reflow in the hidden file */ activatefile tempofid width = lastcol2+1-firstcol2 height = lastline2+1-firstline2 compile if EVERSION < '4.12' savemargins= pmargins() compile endif 'xcom ma 1 'width unmark; mark_line; bottom; mark_line reflow compile if EVERSION < '4.12' 'xcom ma 'savemargins compile endif nbl = .last /* go back to the destination */ activatefile fileid2 if nbl > height then fix = nbl-height getline line,lastline2 for i = 1 to fix insertline line,lastline2+1 endfor elseif nbl < height then fix=0 for i = nbl+1 to height insertline '',tempofid.last+1,tempofid endfor nbl=height else fix=0 endif call pset_mark(1,nbl,1,width,'BLOCK',tempofid) firstline2; .col=firstcol2; copy_mark; unmark call pset_mark(firstline2,lastline2+fix,firstcol2,lastcol2,'BLOCK',fileid2) /* release tempo */ activatefile tempofid .modify=0 'xcom q' activatefile fileid2 sayerror 1 endif ; PCENTER_MARK: center the strings between the block marks defproc pcenter_mark if marktype() = 'BLOCK' then getmark firstline,lastline,firstcol,lastcol,fileid elseif marktype() = 'LINE' then getmark firstline,lastline,firstcol,lastcol,fileid parse value pmargins() with firstcol lastcol . elseif marktype() = '' then getfileid fileid parse value pmargins() with firstcol lastcol . firstline=.line;lastline=.line else sayerror CHAR_INVALID__MSG stop endif sz = lastcol+1-firstcol for i=firstline to lastline getline line,i,fileid inblock=strip(substr(line,firstcol,sz)) if inblock='' then iterate endif compile if EPM replaceline strip(overlay(center(inblock, sz), line, firstcol),'T'), i, fileid compile else replaceline substr(line,1,firstcol-1) || substr(substr('',1,(sz-length(inblock))%2)||inblock,1,sz) || substr(line,lastcol+1) ,i,fileid compile endif endfor compile if EVERSION < 5 ; A built-in function command_state() is now provided for better ; efficiency. This defproc is kept only for compatibility with older macros. ; Please use command_state() instead. defproc pcommand_state return command_state() ; PCOMMON_TAB_MARGIN: subroutine common to ptabs and pmargins defproc pcommon_tab_margin(TabOrMargins) ; the tricky stuff: execute ma (or tabs) and get the result from coms.e file getcommand oldcmd,oldcol,oldscroll -- Save old cmdline status TabOrMargins -- Execute the command getcommand setting -- Get current setting from cmdline setcommand oldcmd,oldcol,oldscroll -- Restore old cmdline status parse value setting with . val -- Get the stuff we want return val compile endif compile if 0 -- The following two routines are unused; why waste space?? LAM ; PDISPLAY_MARGINS: put the margins mark on the current line defproc pdisplay_margins() i=insert_state() if i then insert_toggle endif call psave_pos(save_pos) insert parse value pmargins() with lm rm pm . .col=lm;keyin'L';.col=pm;keyin'P';.col=rm;keyin'R' begin_line call prestore_pos(save_pos) if i then insert_toggle endif return 0 ; PDISPLAY_TABS: put the tab stops on the current line defproc pdisplay_tabs() i=insert_state() if i then insert_toggle endif call psave_pos(save_pos) insert tabstops = ptabs() do forever parse value tabstops with tabx tabstops if tabx = '' then leave endif .col=tabx keyin'T' end begin_line call prestore_pos(save_pos) if i then insert_toggle endif return 0 compile endif ; PEND_MARK: moves the cursor to the end of the marked area defproc pend_mark call checkmark() getmark firstline,lastline,firstcol,lastcol,fileid activatefile fileid compile if EVERSION < 5 cursor_data compile endif if marktype()<>'LINE' then .col=lastcol endif lastline ; PEND_WORD: moves the cursor to the end of the word if the cursor is on this ; word. If it's not on a word, it's moved to the end of the first word on the ; right. If there is no word on the right it's moved to the end of the word on ; the left. If the line is empty the cursor doesn't move. defproc pend_word getline line,.line if substr(line,.col,1)=' ' then if substr(line,.col)=' ' then if line<> ' ' then for i=.col to 2 by -1 if substr(line,i-1,1)<>' ' then leave endif endfor .col=i-1 endif else p=verify(line,' ','',.col) p=verify(line' ',' ','M',p) .col=p-1 endif else if .col<>MAXCOL then i=pos(' ',line,.col) if i then .col=i-1 else .col=length(line) endif endif endif defproc pfile_exists /* Check if file already exists in ring */ if substr(arg(1),2,1)=':' then /* parse off drive specifier and try again */ getfileid zzfileid,substr(arg(1),3) else getfileid zzfileid,arg(1) endif return zzfileid<>'' defproc pfind_blank_line -- Find first blank line after the current one. Make that the new current -- line. If no such line is found before the end of file, don't change the -- current line. for i = .line+1 to .last getline line,i -- Ver 3.11: Modified to respect GML tags: stop at first blank line -- or first line with a period or a colon (".:") in column 1. if line='' or not verify(substr(line,1,1), ".:" ) then i leave endif endfor defproc pfirst_nonblank /* different from PE */ if not .line then .col=1 else getline line .col=max(1,verify(line,' ')) endif ; PLOWERCASE: force to lowercase the marked area defproc plowercase call checkmark() /* invoke pinit_extract, pextract_string, pput_string_back to do the job */ call psave_pos(save_pos) call pinit_extract() do forever code = pextract_string(string) if code = 1 then leave; endif if code = 0 then string = lowcase(string) call pput_string_back(string) endif end call prestore_pos(save_pos) ; PMARGINS: return the current margins setting. (Uses pcommon_tab_margin) defproc pmargins compile if EVERSION < 5 return pcommon_tab_margin('ma') compile else return .margins compile endif ; PMARK: mark at the cursor position (mark type received as argument). Used by ; pset_mark defproc pmark(mt) if mt= 'LINE' then mark_line elseif mt = 'CHAR' then mark_char else mark_block endif ; PMARK_WORD: mark the word pointed at by the cursor. If the cursor is on a ; space, the word at the right is marked. If there is no word on the right, the ; word on the left is marked. defproc pmark_word if marktype()<>'' then sayerror -279 -- 'Text already marked' stop endif call pend_word() mark_block call pbegin_word() mark_block compile if EVERSION > 5 'Copy2SharBuff' /* Copy mark to shared text buffer */ compile endif ; PRESTORE_MARK: restore the current marks (cannot be used as a stack) See also ; psave_mark defproc prestore_mark(savemark) unmark parse value savemark with savefirstline savelastline savefirstcol savelastcol savemkfileid savemt if savemt<>'' then call pset_mark(savefirstline,savelastline,savefirstcol,savelastcol,savemt,savemkfileid) endif ; PRESTORE_POS: restore the cursor position (cannot be used as a stack) See ; also psave_pos() defproc prestore_pos(save_pos) parse value save_pos with svline svcol svcx svcy .cursory = svcy -- set .cursory min(svline, .last) -- set .line .col = MAXCOL; .col = svcol - svcx + 1 -- set left edge of window .col = svcol -- set .col ; Printer_ready( printer_number ) tests whether printer is ready. ; ; Enter with printer_number = 1 for the first printer (LPT1), 2 for LPT2. ; No argument at all defaults to LPT1. ; ; Returns 1 (true) for printer attached and ready. ; Returns 0 (false) for printer not attached or not ready. ; ; Note: Assumes the standard BIOS responses for an IBM PC. ; The BIOS responds with AH=90 hex for printer ready. ; Might not work on clones and other strange machines. ; ; If we're on OS/2 we don't check because the spooler protects us from ; a hang if the printer's off-line. We always return "ready" on OS/2. ; defproc printer_ready compile if EVERSION >= 4 return 1 compile else if arg(1)='' then printer_number=1 elseif not isnum(arg(1)) then sayerror 'Printer_ready: 'INVALID_NUMBER__MSG return 0 else printer_number = arg(1) endif /* Call BIOS interrupt 17 hex with AH=2, printer status query. */ parse value int86x(23,512 0 0 printer_number-1,'') with printer_status . ; IBM PC family returns '90' for printer ready (not busy + selected). ; Some clones return 'D0' (not busy + acknowledge + selected). ; Here, we'll accept either value. ; hex2dec('9000'): hex2dec('D000'): return (printer_status == -28672) or (printer_status == -12288) compile endif ; PSAVE_MARK: save the current marks (cannot be used as a stack) See also ; prestore_pos() defproc psave_mark(var savemark) savemt=marktype() if savemt then getmark savefirstline,savelastline,savefirstcol,savelastcol,savemkfileid unmark savemark=savefirstline savelastline savefirstcol savelastcol savemkfileid savemt else savemark='' endif ; PSAVE_POS: save the cursor position (cannot be used as a stack) See also ; prestore_pos() defproc psave_pos(var save_pos) save_pos=.line .col .cursorx .cursory defproc pset_mark(firstline,lastline,firstcol,lastcol,mt,fileid) compile if EVERSION >= '5.50' setmark firstline,lastline,firstcol,lastcol,wordpos(mt,'LINE CHAR BLOCK CHARG BLOCKG')-1,fileid compile else getfileid actfileid /* preserve current active fileid */ rc = 0 activatefile fileid compile if not E3 if rc=sayerror('Invalid fileid') then stop; endif compile endif call psave_pos(save_pos) unmark if lastcol then .col=lastcol; lastline else lastline-1; .col=MAXCOL endif call pmark(mt) .col=firstcol; firstline call pmark(mt) call prestore_pos(save_pos) activatefile actfileid /* restore the initial active file */ compile endif ; PTABS: return the current tabs setting. (Uses pcommon_tab_margin) defproc ptabs compile if EVERSION < 5 return pcommon_tab_margin('tabs') compile else return .tabs compile endif ; PUPPERCASE: force to uppercase the marked area defproc puppercase call checkmark() /* invoke pinit_extract, pextract_string, pput_string_back to do the job */ call psave_pos(save_pos) call pinit_extract() do forever code = pextract_string(string) if code = 1 then leave endif if code = 0 then string = upcase(string) call pput_string_back(string) endif end call prestore_pos(save_pos) ;defproc remove_trailing_spaces ; /* This is no longer used by any file in standard E. Use strip() */ ; /* instead. But left here for compatibility with older procs. */ ; return strip(arg(1),'T') compile if EPM ; In E3 and EOS2, we can use a_X to enter the value of any key. In EPM, ; we can't, so the following routine is used by KEY and LOOPKEY to convert ; from an ASCII key name to the internal value. It handles shift or alt + ; any letter, or a function key (optionally, with any shift prefix). LAM defproc resolve_key(k) kl=lowcase(k) suffix=\2 -- For unshifted function keys if length(k)>=3 & pos(substr(k,2,1),'_-+') then if length(k)>3 & substr(kl,3,1)='f' then -- Shifted function key suffix=substr(\10\34\18,pos(leftstr(kl,1),'sac'),1) -- Set suffix, kl=substr(kl,3) -- strip shift prefix, and more later... else -- alt+letter or ctrl+letter k=substr(kl,3,1) || substr(' ',pos(leftstr(kl,1),'ac'),1) endif endif if leftstr(kl,1)='f' & isnum(substr(kl,2)) then k=chr(substr(kl,2)+31) || suffix endif return k compile endif compile if EVERSION < 5 defproc restore_command_state(cstate) if command_state()<>cstate then command_toggle endif defproc save_command_state(var cstate) cstate=command_state() cursor_data refresh /* Force E to update the cursor position */ compile endif -- 4.10: Saving with tab compression is built in now. No need for -- the make-do proc savefilewithtabs(). DOS version still needs it for -- people editing MAKE files, but we make it optional via WANT_TABS. compile if E3 & WANT_TABS ; Note: This does not tabify the entire file; it just replaces 8 blanks ; in the first column with a tab character. defproc savefilewithtabs(filename) options=arg(2) call psave_pos(save_pos) getfileid fileid unmark;bottom;markline;top;markline call prestore_pos(save_pos) 'xcom e 'argsep'n .';deleteline if rc and rc<>-282 then -- sayerror("new file") return rc endif rc=0 copymark if rc then return rc endif unmark top;.col=1;markblock;bottom;.col=8;markblock .col=1;top 'c/ /'\t'/m*' /* replace first column 8 spaces with tab */ sayerror 1 /* Turn off pending messages */ unmark savestatus=savefile(filename,options) .modify=0 'xcom q' if savestatus then return savestatus endif activatefile fileid if filename=.filename then .modify=0 endif return 0 compile endif define compile if EVERSION < '5.21' MSGC = '.messagecolor' compile elseif EVERSION < '5.50' MSGC = 'vMESSAGECOLOR' compile else -- GPI version MSGC = 'color' compile endif ; Paste up a message in a box, using SAYAT's. Useful for "Processing..." msgs. defproc sayatbox compile if EVERSION >= '5.21' universal vMESSAGECOLOR compile endif compile if WANT_DBCS_SUPPORT universal ondbcs compile endif compile if EVERSION >= '5.50' -- GPI version; doesn't use background color in SAYATs. color = sayat_color() compile endif compile if WANT_DBCS_SUPPORT if ondbcs then middle = substr('',1,length(arg(1)),\x06) sayat ' '\x01\x06||middle||\x06\x02' ',1,2, $MSGC sayat ' '\x05' 'arg(1)' '\x05' ',2,2, $MSGC sayat ' '\x03\x06||middle\x06\x04' ',3,2, $MSGC else compile endif middle = substr('',1,length(arg(1)),'═') sayat ' ╔═'middle'═╗ ',1,2, $MSGC sayat ' ║ 'arg(1)' ║ ',2,2, $MSGC sayat ' ╚═'middle'═╝ ',3,2, $MSGC compile if WANT_DBCS_SUPPORT endif compile endif compile if EVERSION >= '5.50' defproc sayat_color = -- Pick a color for SAYAT that doesn't conflict w/ foreground or background color. universal vMESSAGECOLOR if vMESSAGECOLOR // 16 <> .textcolor // 16 & vMESSAGECOLOR // 16 <> .textcolor % 16 then return vMESSAGECOLOR -- Preference is the message color. endif if vMESSAGECOLOR // 16 <> LIGHT_RED then return LIGHT_RED -- Second choice is light red. endif if .textcolor // 16 <> LIGHT_BLUE & .textcolor % 16 <> LIGHT_BLUE then return LIGHT_BLUE -- If that's used, then how about light blue endif return GREEN -- Final fallback is green. compile endif defproc splitlines() if .line then split oldcol=.col call pfirst_nonblank() compile if EPM -- Can't use REPLACELINE because it wipes out attributes. col1 = .col down if textline(.line)<>'' then call pfirst_nonblank() col2 = .col getsearch savesearch .col = 1 if col1 < col2 then -- Shift new line left 'xcom c/'copies(' ',col2-col1)'//' -- Change first n blanks to null elseif col1 > col2 then -- Shift new line right ;; c = substr(textline(.line),1,1) -- LAM: simpler to use GREP ;; if c='/' then d='?'; else d='/'; endif -- Choose delimiter ;; 'xcom c 'd||c||d||substr('',1,col1-col2)||c||d -- Add blanks before 1st char. 'xcom c /^/'copies(' ',col1-col2)'/g' -- Add blanks before 1st char. endif setsearch savesearch endif up compile else -- E3 and EOS2 can still use the old, simple way. getline line,.line+1 replaceline substr('',1,.col-1) || -- indent like previous line strip(line,'L'), -- (remove leading spaces) .line+1 compile endif .col=oldcol endif ; Note on a speed trick: subdir_present is initialized to null at start-up. ; This causes defproc subdir(), the first time it's called, to execute a ; FINDFILE (by way of find_routine) to search the path for the subdir program. ; (See DEFC HELP for another example of findfile.) ; After that first search the exact path location of subdir is known; it's ; remembered in the universal variable subdir_present. All future calls supply ; the exact location (as in "C:\UTIL\SUBDIR.COM") to avoid the path search. definit /* Keep this definit close to the proc it serves. */ universal subdir_present subdir_present='' defproc subdir universal subdir_present if subdir_present='' then -- First time; look for the program compile if E3 subdir_present=find_routine('SUBDIR /Q') compile else subdir_present=find_routine('FILEFIND') compile endif if subdir_present == -1 then -- Not found, try ATTRIB subdir_present=find_routine('ATTRIB /S') endif endif if subdir_present == -1 then sayerror CANT_FIND_PROG__MSG 'ATTRIB' stop endif quietshell subdir_present arg(1) compile if EVERSION >= 4 defproc swapwords(num) return substr(num,3,2) || substr(num,1,2) compile endif compile if E3 or (EPM & not (EVERSION >= '5.17')) ; EOS2 & EPM have a TEXTLINE() function built in. This is added here so that ; E3 macro programmers can use TEXTLINE also, if they like. defproc textline(linenum) getline line,linenum; return line compile endif ; A truncate function to maintain compatibility of macros between this ; version and the OS/2 version which will have floating point. Two ; functions in DOSUTIL.E need this. ; ; If we're passed a floating point number with a decimal point in it, ; like "4.0", drop the decimal part. ; If we're passed an exponential-format number like "6E3", fatal error. defproc trunc(num) if not verify('E',upcase(num)) then sayerror NO_FLOAT__MSG num stop endif parse value num with whole'.'. return whole compile if WANT_LAN_SUPPORT defproc unlock(fileid) if fileid.lockhandle = 0 then sayerror fileid.filename NOT_LOCKED__MSG return 1 endif result = dynalink('DOSCALLS', '#59', /* dosclose */ atoi(fileid.lockhandle)) if result then sayerror 'DOSCLOSE' ERROR_NUMBER__MSG result else fileid.lockhandle = 0 endif return result compile endif