check_entryname_.pl1 11/11/89 1109.4r 11/11/89 0805.5 14823 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* CHECK_ENTRYNAME_ - See if the entryname x is "troublesome." THVV */ /* Modified 81-02-13 by S. G. Harris (UNCA) to allow slash in an entryname. */ /* Changes merged and edited 03/03/82 S. Herbst */ /* Fixed to call check_star_name_$entry 05/05/82 S. Herbst */ /****^ HISTORY COMMENTS: 1) change(86-08-18,JSLove), approve(86-08-18,MCR7518), audit(86-08-19,Parisek), install(86-10-02,MR12.0-1174): Changed to call check_star_name_, which returns more informative error codes. END HISTORY COMMENTS */ /* format: style3,delnl,linecom */ check_entryname_: proc (x, ec); dcl x char (*), ec fixed bin (35); /* Arguments */ dcl check_star_name_ entry (char (*), bit (36) aligned, fixed bin (2), fixed bin (35)); %page; %include check_star_name; %page; call check_star_name_ (x, CHECK_STAR_ENTRY_DEFAULT | CHECK_STAR_REJECT_WILD, (0), ec); return; end check_entryname_;  edx_util_.pl1 11/11/89 1109.4rew 11/11/89 0805.5 274095 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-02-02,Huen), approve(89-02-02,MCR8057), audit(89-05-24,RWaters), install(89-05-31,MR12.3-1051): Fix Bug 203 in qedx editor - Set up the wakeup table on the user_input switch when entering append mode. END HISTORY COMMENTS */ /* format: off */ /* Utility functions for Multics qedx Editor: handles input streams and manages buffers. */ /* Initial coding by R. C. Daley, August 1970 */ /* Latest change to use the search builtin and for large segments by M. A. Meer, August 1975 */ /* Modified 9/9/81 by E. N. Kittlitz to remove b.default_len, clean up */ /* Modifications to make qx efficient and change buffer operation by T. Oke, June 1980 */ /* Modification to twbuf size to utilize the 512 character buffer length which is available. T. Oke 81-05-19 */ /* Changes merged and edited 03/03/82 S. Herbst */ /* Changed $list_buffers to list only modified buffers for quit query 04/16/82 S. Herbst */ /* Fixed $read_ptr to use whole temp seg and not flush for long_record 04/29/82 S. Herbst */ /* Modified: January 1983 by G. Palter as part of making qedx reentrant (includes using get/release_temp_segment_) */ /* Modified April 1983 by K. Loepere to make run in Bootload Multics */ /* Modified August 1983 by K. Loepere for new bce switches */ /* Modified March 1985 by Keith Loepere to run in bce and Multics. */ /* Modified Feb 1989 by S. Huen to set up the wakeup table on the user_input switch instead of the user_i/o switch when entering append mode. */ /* format: on,style4,delnl,insnl,ifthenstmt,ifthen */ edx_util_: procedure; dcl atp ptr; /* pointer to caller's input buffer */ dcl code fixed bin (35); dcl i fixed bin (21); dcl indx fixed bin (17); /* index for special character after conceal */ dcl j fixed bin (21); dcl k fixed bin (21); dcl ka fixed bin (21); dcl ki fixed bin (21); dcl kik fixed bin (21); dcl kx fixed bin (21); /* check for special characters */ dcl nelem fixed bin (21); /* maximum number of characters to read */ dcl nelemt fixed bin (21); /* number of characters actually read (output) */ dcl p ptr; /* temporary storage */ dcl te fixed bin (21); dcl ti fixed bin (21); dcl tline char (512); /* NOTE: This variable can be no shorter than qedx's iline */ dcl tp ptr; dcl 1 edx_data aligned based (qid.edx_util_data_ptr), 2 cbname character (16), /* current buffer name */ 2 curp pointer, /* -> current input control block */ 2 level fixed binary, /* buffer recursion counter */ 2 top pointer, /* -> top of buffer stack (null for level 0) */ 2 swt aligned like swt_info; /* set_wakeup_table data */ dcl NL char (1) static options (constant) init (" "); dcl special_char_string char (5) static options (constant) aligned init (" \"); /* the string is \012 || \ || \c || \b || \r */ dcl a_string char (sys_info$max_seg_size * 4) based aligned; dcl wstring (sys_info$max_seg_size * 4) char (1) based; /* for use with iox_$put_chars */ dcl error_table_$long_record fixed bin (35) ext; dcl sys_info$max_seg_size fixed bin (18) external; dcl sys_info$service_system bit (1) aligned external; dcl bce_data$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)) external variable; dcl bce_data$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)) external variable; dcl iox_$user_output external ptr; dcl iox_$user_input external ptr; dcl bce_check_abort entry; dcl iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); dcl iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl ( ioa_, ioa_$ioa_switch, com_err_ ) entry options (variable), iox_$control entry (ptr, char (*), ptr, fixed bin (35)), iox_$modes entry (ptr, char (*), char (*), fixed bin (35)), get_temp_segment_ entry (char (*), ptr, fixed bin (35)), release_temp_segment_ entry (char (*), ptr, fixed bin (35)); dcl (addr, divide, index, length, min, null, search, substr, string, unspec) builtin; dcl (program_interrupt, sub_request_abort_) condition; %page; /* Initialize data required by an invocation of edx_util_: also initializes input stream, buffer 0, teletype buffer, and gets the temporary segment used for buffer 0 */ edx_init: entry (P_qid_ptr, atwp, aifp, abp, acode); /* entry to initialize input stream and buffers */ dcl P_qid_ptr pointer, /* -> qedx per-invocation data */ atwp ptr, /* pointer to typewriter buffer (char(512)) */ aifp ptr, /* pointer to buffer input file (output) */ abp ptr, /* pointer to control block for buffer "0" (output) */ acode fixed bin (35); /* error status code (output) */ qid_ptr = P_qid_ptr; allocate edx_data in (editor_area) set (qid.edx_util_data_ptr); call get_temp_segment_ (qid.editor_name, aifp, acode); if acode ^= 0 then do; /* could not create buffer 0 buffer */ call com_err_ (acode, qid.editor_name, "Obtaining temporary space for buffer 0."); return; end; top = null (); /* indicate buffer recursion stack is empty */ level = 0; /* and set buffer level to 0 */ cbname = "0"; /* set initial buffer name */ b0.name = "0"; /* give it a name */ b0.tw_sw = "0"b; b0.next = null (); /* buffer "0" is first and only buffer on chain */ b0.dp = aifp; /* initialize buffer "0" to input buffer file */ b0.lb = 0; /* indicate that no data exists */ if sys_info$service_system then b0.de = 4 * 1024 * 4; /* indicate buffer empty */ else b0.de = 4 * sys_info$max_seg_size; /* in bce, no need to grow buffers */ b0.ft = b0.de + 1; b0.default_path = ""; /* .. */ b0.li = 1; /* no current line either */ b0.le = 0; b0.callers_idx = 0; string (b0.flags) = ""b; curp = addr (tw); /* set console typewriter as current input buffer */ tw.name = "typewriter"; tw.next = null (); tw.dp = atwp; /* initialize pointer to tw buffer */ tw.default_path = ""; /* no default path */ tw.lb = 0; tw.ft = 513; /* no top section */ tw.de = 512; /* maximum tw buffer size */ tw.li = 0; /* not used for tw */ tw.le = 0; /* not used for tw */ tw.ti = 1; /* force read by indicating buffer exhaust condition */ tw.te = 0; /* .. */ tw.tw_sw = "1"b; /* typewriter buffer switch (ON) */ tw.callers_idx = 0; string (tw.flags) = ""b; if sys_info$service_system then do; unspec (swt) = ""b; /* setup for cheap input later */ swt.version = swt_info_version_1; swt.new_table.wake_map (24), /* eb, octal 030 */ swt.new_table.wake_map (25), /* ec, octal 031 */ swt.new_table.wake_map (28), /* ef, octal 034 */ swt.new_table.wake_map (30), /* er, octal 036 */ swt.new_table.wake_map (92) = "1"b; /* backslash, octal 134 */ call iox_$control (iox_$user_input, "set_wakeup_table", addr (swt), code); end; abp = addr (b0); /* return pointer to buffer "0" control block */ acode = 0; /* indicate successful initialization */ return; %page; /* Prime the terminal input buffer from the supplied string: setup length and pointer */ prime: entry (P_qid_ptr, pptr, plen); dcl pptr ptr, /* pointer to string to place in tw input buffer */ plen fixed bin (21); /* length of string to place in tw input buffer */ qid_ptr = P_qid_ptr; substr (tw.dp -> a_string, 1, plen) = substr (pptr -> a_string, 1, plen); /* initialize tw input buffer */ tw.ti = 1; /* .. */ tw.te = plen; /* .. */ tw.lb = plen; /* fill in first section */ tw.ft = tw.de + 1; /* empty top */ return; %page; /* Cleanup all data managed by edx_util_ */ edx_cleanup: entry (P_qid_ptr); qid_ptr = P_qid_ptr; if qid.edx_util_data_ptr = null () then return; /* nothing there */ do while (level ^= 0); /* unwind buffer recursion stack */ p = top; /* get pointer to top of stack */ top = p -> sv.prev; /* find previous level */ curp = p -> sv.bp; /* find previous buffer control block */ free p -> sv in (editor_area); /* release top level of stack */ level = level - 1; /* decrement recursion level count */ end; bp = addr (b0); /* start with buffer 0 */ do while (bp ^= null ()); /* delete auxiliary buffers and free control blocks */ p = b.next; /* pointer to next control block (if any) */ call release_temp_segment_ (qid.editor_name, b.dp, (0)); if bp ^= addr (b0) then free bp -> b in (editor_area); bp = p; /* repeat for next buffer in chain (if any) */ end; if sys_info$service_system then do; swt.new_table = swt.old_table; /* put back old table */ call iox_$control (iox_$user_input, "set_wakeup_table", addr (swt), code); end; free qid.edx_util_data_ptr -> edx_data in (editor_area); qid.edx_util_data_ptr = null (); return; %page; /* Read_ptr is a moderately complex routine which will read data either from the terminal, or from the supplied buffer. Read_ptr will also pop a buffer level with resetread if it empties the buffer. Gap modifications are done to have the buffer divided into a lower and upper half. Initially the lower half is processed, and when this is exhausted, the upper half is tried. */ read_ptr: entry (P_qid_ptr, atp, nelem, nelemt); qid_ptr = P_qid_ptr; tp = atp; /* get pointer to caller's input buffer */ te = nelem; /* also, get maximum characters to be read */ if ^ sys_info$service_system then on condition (sub_request_abort_) begin; call resetread (qid_ptr); go to restart; end; restart: bp = curp; /* get pointer to current buffer control block */ b.modified = b.modified & (b.default_path ^= ""); /* reading makes buffer unmodified if it has no pathname */ ti = 1; /* start input into top of buffer */ retry: if ^ sys_info$service_system then call bce_check_abort; /* stop infinite loop */ if b.ti > b.te then do; /* check if buffer being read is exhausted */ if b.ti > b.lb & b.ti <= b.ft then do; /* move to top half */ b.te = b.de; b.ti = b.ft; if b.ft <= b.de then goto retry; /* continue processing top half */ end; if b.tw_sw then do; /* was input from console typewriter (level 0) */ if sys_info$service_system then call iox_$get_line (iox_$user_input, b.dp, sys_info$max_seg_size * 4, b.te, code); else call bce_data$get_line (addr (bce_data$get_line), b.dp, 256, b.te, code); /* if so, refresh line from typewriter */ if code ^= 0 then if code ^= error_table_$long_record then do; call com_err_ (code, qid.editor_name, "edx_util_$read_ptr"); if sys_info$service_system then call iox_$control (iox_$user_input, "resetread", null (), (0)); b.ti = 1; /* re-start buffer */ b.te = 0; /* setup to read again */ go to retry; end; if b.te > b.de then b.de = 1024 * (divide (b.te, 1024, 21, 0) + 2); b.ft = b.de + 1; /* make top section empty */ b.lb = b.te; /* all text in bottom section */ b.ti = 1; /* reset current read index */ go to retry; /* and try again to read data to caller */ end; else do; /* here on end of buffer */ call end_buffer (qid_ptr, (0)); /* pop buffer recursion level by one */ bp = curp; /* re-establish previous buffer control block */ go to retry; /* resume reading from previous buffer */ end; end; k = search (substr (b.dp -> a_string, b.ti, (b.te - b.ti + 1)), special_char_string); if k = 0 then do; ki = (b.te - b.ti + 1); copy_string: substr (tp -> a_string, ti, ki) = substr (b.dp -> a_string, b.ti, ki); ti = ti + ki; /* update input index */ b.ti = b.ti + ki; /* update output index */ if ki < k then go to end_read; /* end of input buffer */ else go to retry; /* get more */ end; if ti + k - 1 > te then do; ki = te - ti + 1; go to copy_string; end; kx = index (special_char_string, substr (b.dp -> a_string, b.ti + k - 1, 1)); /* found which one */ go to rd_case (kx); rd_case (1): /* found an new line */ substr (tp -> a_string, ti, k) = substr (b.dp -> a_string, b.ti, k); /* copy thru new line */ ti = ti + k - 1; /* update input index */ b.ti = b.ti + k; /* update output index */ nelemt = ti; return; rd_case (2): /* found an escape character "\" */ if b.ti + k <= b.te then do; ka = 1; /* possible two character symbol */ kik = index ("cbrCBR", substr (b.dp -> a_string, b.ti + k, 1)); /* if so, what is second character */ if kik = 0 then do; ki = k; go to copy_string; end; go to rd_action (kik); /* go take appropriate action */ end; else go to past_end_of_input; rd_case (3): /* single character conceal */ ka = 0; rd_action (1): rd_action (4): rd_conceal: if b.ti + k + ka > b.te then do; /* beyond end of input */ past_end_of_input: k = 0; ki = b.te - b.ti + 1; /* ignore action */ go to copy_string; end; indx = index (special_char_string, substr (b.dp -> a_string, b.ti + k + ka, 1)); if indx = 2 then do; /* found \ */ /* is this a two character special */ if index ("bcfrBCFR", substr (b.dp -> a_string, b.ti + k + ka + 1, 1)) ^= 0 then ki = k + ka + 1; /* set for two character special */ else ki = k + ka; /* not a special */ go to copy_string; end; else if indx = 3 then do; /* single character conceal */ ki = k + ka + 1; /* keep it */ go to copy_string; end; else if indx ^= 0 /* some other special ? */ then go to add_special; /* single character special */ else do; /* no special */ ki = k + ka; /* set copy length */ go to copy_string; end; add_special: substr (tp -> a_string, ti, k) = substr (b.dp -> a_string, b.ti, k - 1) || substr (b.dp -> a_string, b.ti + k + ka, 1); /* copy thru special character */ b.ti = b.ti + k + ka + 1; /* update input index */ ti = ti + k; /* update output index */ go to retry; /* try for more */ rd_case (4): /* insert contents of buffer */ ka = 0; rd_action (2): rd_action (5): rd_exp_buff: substr (tp -> a_string, ti, k - 1) = substr (b.dp -> a_string, b.ti, k - 1); /* copy up to buffer expansion */ ti = ti + k - 1; /* update output index */ b.ti = b.ti + k + ka; /* update input index */ rd_buff: call find_buffer (b.dp, b.ti, b.te, p, "0"b); /* try to find named buffer */ if p = null () then do; /* error if named buffer does not already exist */ rd_err: call resetread (qid_ptr); /* reset back to typewriter level (level 0) */ go to restart; /* and restart this call from scratch */ end; if level > 500 then go to rd_err; /* check buffer recursion level */ level = level + 1; /* bump recursion level */ curp = p; /* make new buffer control block the current block */ allocate sv in (editor_area) set (p); /* save current level of buffer recursion */ p -> sv.prev = top; /* save current ptr to top of stack */ p -> sv.bp = bp; /* save ptr to current buffer control block */ p -> sv.ti = b.ti; /* save current position in current buffer */ p -> sv.te = b.te; /* .. */ top = p; /* push buffer recursion stack */ bp = curp; /* set ptr to new current buffer control block */ b.ti = 1; /* initialize buffer read index */ b.te = b.lb; /* set index of last character in lower half of buffer */ b.modified = b.modified & (b.default_path ^= ""); /* reading makes buffer unmodified if it has no pathname */ go to retry; /* resume reading after processing */ rd_case (5): /* read from console one line */ ka = 0; rd_action (3): rd_action (6): rd_read: substr (tp -> a_string, ti, k - 1) = substr (b.dp -> a_string, b.ti, k - 1); /* copy up to special symbol */ b.ti = b.ti + k + ka; /* update input index */ ti = ti + k - 1; /* update output index */ if sys_info$service_system then call iox_$modes (iox_$user_input, "^wake_tbl", "", (0)); /* exit cheap input */ read_one_line: /* NOTE modification here limits amount able to be read to remainder possible in buffer. */ if sys_info$service_system then call iox_$get_line (iox_$user_input, addr (tline), min (length (tline), te - ti + 1), j, code); else call bce_data$get_line (addr (bce_data$get_line), addr (tline), min (length (tline), te - ti + 1), j, code); if code ^= 0 /* error reading from typewriter */ then do; call com_err_ (code, qid.editor_name, "edx_util_$read_ptr read one line - PLEASE RE-ENTER LINE"); if sys_info$service_system then call iox_$control (iox_$user_input, "resetread", null (), (0)); go to read_one_line; end; substr (tp -> a_string, ti, j) = tline; /* move as much as will fit to caller's buffer */ te = ti + j - 1; /* number of characters moved */ go to end_read; /* and terminate the read call */ end_read: nelemt = te; /* here if caller's buffer full, return characters read */ return; /* and return */ %page; /* Pops the buffer recursion level by one and returns the new (old) buffer */ end_buffer: entry (P_qid_ptr, ecode); dcl ecode fixed bin; /* error code, 1= already at level 0, 0= ok */ qid_ptr = P_qid_ptr; if level = 0 then do; /* check recursion level */ ecode = 1; /* error if level already 0 */ return; /* return error condition to caller */ end; level = level - 1; /* decrement recursion level */ p = top; /* pop buffer stack one level */ top = p -> sv.prev; /* .. restore previous level */ curp, bp = p -> sv.bp; /* .. restore previous buffer control block */ b.ti = p -> sv.ti; /* .. restore current line index within buffer */ b.te = p -> sv.te; /* .. */ free p -> sv in (editor_area); /* release current stack level */ ecode = 0; /* indicate that all is ok */ return; /* and return to caller */ %page; /* Flush read-ahead: output unexecuted portion of current buffer (if any), revert input back to the terminal, and perform a resetread on the terminal itself */ resetread: entry (P_qid_ptr); qid_ptr = P_qid_ptr; if level ^= 0 then do; /* if buffer recursion level > 0 */ bp = curp; /* get pointer to current buffer control block */ call ioa_ ("Error in buffer (^a) at level ^d.", b.name, level); if sys_info$service_system then on condition (program_interrupt) go to prskip; else on condition (sub_request_abort_) go to prskip; /* set up program interrupt handler */ if b.ti > b.lb & b.ti < b.ft then b.ti = b.ft; /* move across gap */ if b.de > b.ft then b.te = b.de; else b.te = b.lb; if b.te <= b.lb | b.ti >= b.ft then do; /* portion addressed is purely in bottom or top */ i = b.te - b.ti + 1; if i > 0 then do; call ioa_ ("Unexecuted lines in buffer:"); if sys_info$service_system then call iox_$put_chars (iox_$user_output, addr (b.dp -> wstring (b.ti)), i, code); else call bce_data$put_chars (addr (bce_data$put_chars), addr (b.dp -> wstring (b.ti)), i, code); end; /* print specified portion of buffer on user's console */ end; else if b.ti <= b.lb then do; /* top in top, bottom in bottom */ i = b.te - b.ft + 1 + b.lb - b.ti; if i > 0 then do; call ioa_ ("Unexecuted lines in buffer:"); if sys_info$service_system then do; call iox_$put_chars (iox_$user_output, addr (b.dp -> wstring (b.ti)), b.lb - b.ti + 1, code); call iox_$put_chars (iox_$user_output, addr (b.dp -> wstring (b.ft)), b.te - b.ft + 1, code); end; else do; call bce_data$put_chars (addr (bce_data$put_chars), addr (b.dp -> wstring (b.ti)), b.lb - b.ti + 1, code); call bce_data$put_chars (addr (bce_data$put_chars), addr (b.dp -> wstring (b.ft)), b.te - b.ft + 1, code); end; /* print specified portion of buffer on user's console */ end; /* print specified portion of buffer on user's console */ end; prskip: if sys_info$service_system then revert condition (program_interrupt); else revert condition (sub_request_abort_); do while (level ^= 0); /* release buffer recursion stack */ p = top; /* get pointer to top of stack */ top = p -> sv.prev; /* find previous level */ curp = p -> sv.bp; /* find previous buffer control block */ free p -> sv in (editor_area); /* release top level of stack */ level = level - 1; /* decrement recursion level */ end; call ioa_ ("^/Current buffer is (^a) at level 0. ^/", cbname); end; bp = curp; /* get pointer to level 0 control block */ b.ti = 1; /* reset current line index */ b.te = 0; /* .. to give buffer exhaust and re-read from typwriter */ if sys_info$service_system then call iox_$control (iox_$user_input, "resetread", null (), code); /* reset "user_input" I/O stream */ return; %page; /* Get a buffer from existing buffers or create one */ get_buffer: entry (P_qid_ptr, gtp, gti, gte, gtname, gtbp); dcl gtp ptr, /* pointer to string containing buffer name */ gti fixed bin (21), /* index of first character of buffer name */ gte fixed bin (21), /* index of last character in string */ gtname char (16), /* buffer name (returned) */ gtbp ptr; /* pointer to buffer control block (returned) */ qid_ptr = P_qid_ptr; call find_buffer (gtp, gti, gte, bp, "1"b); /* find (or create) buffer control block */ if bp = null () then do; /* reflect errors to caller if any */ gtbp = null (); /* .. */ return; /* and return */ end; gtbp = bp; /* otherwise, return pointer to buffer control block */ gtname = b.name; /* return buffer name */ cbname = b.name; /* save it here also */ return; %page; /* Locate the specified buffer creating it if necessary */ locate_buffer: entry (P_qid_ptr, gtname, gtbp); qid_ptr = P_qid_ptr; call locate_buffer (gtname, bp, "1"b); /* find (or create) buffer control block */ if bp = null () then do; /* reflect errors to caller if any */ gtbp = null (); /* .. */ return; /* and return */ end; gtbp = bp; /* otherwise, return pointer to buffer control block */ cbname = b.name; /* save it here also */ return; %page; dcl P_current_buffer character (16) parameter; dcl (P_iocb_ptr, P_bp) pointer parameter; dcl list_only_modified bit (1) aligned; /* List status of all buffers */ list_buffers: entry (P_qid_ptr, P_current_buffer, P_iocb_ptr); list_only_modified = "0"b; go to BEGIN_LIST_BUFFERS; /* List status of only those buffers which have been modified since the last write */ list_modified_buffers: entry (P_qid_ptr, P_current_buffer, P_iocb_ptr); list_only_modified = "1"b; go to BEGIN_LIST_BUFFERS; BEGIN_LIST_BUFFERS: qid_ptr = P_qid_ptr; bp = addr (b0); /* get pointer to first buffer control block */ do while (bp ^= null ()); /* list status of all buffers */ call list_one_buffer (); bp = b.next; /* get pointer to next control block (if any) */ end; return; /* return to caller */ %page; /* List status of a single buffer */ list_single_buffer: entry (P_qid_ptr, P_current_buffer, P_iocb_ptr, P_bp); qid_ptr = P_qid_ptr; list_only_modified = "0"b; bp = P_bp; call list_one_buffer (); /* does all the work */ return; /* Internal procedure which lists a single buffer (called by several different entrypoints) */ list_one_buffer: procedure (); dcl (n_lines, start, nl_idx) fixed binary (21); n_lines = 0; if (b.de < b.ft) & (b.lb < 1) then /* don't need to count lines in an empty buffer */ go to DISPLAY_BUFFER_STATUS; start = 1; /* count lines in the buffer */ do while (start <= b.de); if (start > b.lb) & (start < b.ft) then /* switch to upper half of buffer */ start = b.ft; if start >= b.ft then /* search for next newline */ nl_idx = index (substr (b.dp -> a_string, start, (b.de - start)), NL); else nl_idx = index (substr (b.dp -> a_string, start, (b.lb - start)), NL); if nl_idx ^= 0 then /* found a newline: move past it */ start = start + nl_idx; else if start >= b.ft then /* no more newlines in upper half: terminate the loop */ start = b.de + 1; else start = b.ft; /* no more newlines in lower half: move to upper */ n_lines = n_lines + 1; /* count the line */ end; DISPLAY_BUFFER_STATUS: if b.modified | ^list_only_modified then call ioa_$ioa_switch (P_iocb_ptr, "^6d ^[->^;^2x^] ^[mod^;^3x^] (^a) ^[[untrusted] ^]^a", n_lines, (b.name = P_current_buffer), (b.modified & ^list_only_modified), b.name, b.default_untrusted, b.default_path); return; end list_one_buffer; %page; /* Check for modified buffers */ modified_buffers: entry (P_qid_ptr) returns (bit (1)); qid_ptr = P_qid_ptr; bp = addr (b0); /* start with the standard buffer */ do while (bp ^= null ()); if (b.de < b.ft) & (b.lb < 1) then /* ignore empty buffers */ go to IGNORE_THIS_BUFFER; if b.modified then do; /* a candidate... */ if b.callers_idx ^= 0 then if qid.qedx_info_ptr -> qedx_info.buffers (b.callers_idx).auto_write then go to IGNORE_THIS_BUFFER; /* ... but it's gonna get written automaticaly */ return ("1"b); /* ... found one */ end; IGNORE_THIS_BUFFER: /* try next buffer */ bp = b.next; end; return ("0"b); /* can only get here if all not modified */ %page; /* Extract buffer name and find (or create) buffer */ find_buffer: procedure (ftp, fti, fte, fbp, crsw); dcl ftp ptr, /* pointer to string containing buffer name */ fti fixed bin (21), /* index in string to first character of buffer name */ fte fixed bin (21), /* index of last character of string */ fbp ptr, /* pointer to buffer control block if found (returned) */ crsw bit (1), /* create switch ("1"b = create if not found) */ p_name char (16); /* used by locate_buffer entrypoint */ dcl lbp ptr, /* temporary storage */ (i, j, l) fixed bin (21), tch char (1), tname char (16); do fti = fti to fte; /* skip blanks */ tch = substr (ftp -> a_string, fti, 1); /* get a character */ if tch ^= " " then go to get_name; /* jump out on first non-blank character */ end; buf_err: call ioa_ ("Syntax error in buffer name."); fbp = null (); /* indicate error by returning null pointer */ return; /* return to caller */ get_name: if tch ^= "(" /* if one character buffer name given */ then if tch ^= NL then do; tname = tch; /* pick up single character name */ fti = fti + 1; /* skip index over buffer name */ end; else go to buf_err; else do; /* if multiple characters in name */ l = fte - fti; /* find end of buffer name */ if l < 2 then go to buf_err; /* by looking for matching ")" */ i = fti + 1; /* start search next character after " (" */ j = index (substr (ftp -> a_string, i, l), ")"); /* look for ")" */ if j < 2 then go to buf_err; /* error if not found or null buffer name */ fti = i + j; /* move line index after ")" */ tname = substr (ftp -> a_string, i, (j - 1));/* pick up buffer name */ end; go to SKIP_LOCATE_BUFFER_ENTRY; /* Locates the buffer whose name is given */ locate_buffer: entry (p_name, fbp, crsw); tname = p_name; SKIP_LOCATE_BUFFER_ENTRY: fbp = addr (b0); /* search existing buffers for buffer name */ do while (fbp ^= null ()); /* .. */ if fbp -> b.name = tname then return; /* if found, return pointer to buffer's control block */ lbp = fbp; /* save pointer to this control block */ fbp = fbp -> b.next; /* and move to next buffer (if any) in list */ end; if ^crsw then do; /* not found, take error return if crsw = "0"b */ call ioa_ ("Buffer (^a) not found.", tname); return; /* return with control block ptr (fbp) = null */ end; allocate b in (editor_area) set (fbp); /* otherwise, try to create new buffer */ call get_temp_segment_ (qid.editor_name, fbp -> b.dp, code); if code ^= 0 then do; /* if failed to create buffer */ free fbp -> b in (editor_area); /* free buffer control block */ call com_err_ (code, qid.editor_name, "Obtaining temporary space for buffer ^a.", tname); fbp = null (); /* indicate failure by returning null pointer to caller */ return; /* return to caller */ end; lbp -> b.next = fbp; /* buffer created, thread with previous control block */ fbp -> b.name = tname; /* initialize new buffer control block */ fbp -> b.next = null (); /* .. (now last block in chain) */ fbp -> b.lb = 0; /* buffer is empty low */ if sys_info$service_system then fbp -> b.de = 4 * 4 * 1024; /* .. current buffer size */ else fbp -> b.de = 4 * sys_info$max_seg_size; /* don't grow bce segs */ fbp -> b.li = 1; /* .. current line index */ fbp -> b.ft = fbp -> b.de + 1; /* buffer is empty high */ fbp -> b.le = 0; /* .. current line end */ fbp -> b.tw_sw = "0"b; /* .. current typewriter switch */ fbp -> b.default_path = ""; /* .. current default pathname */ fbp -> b.callers_idx = 0; /* .. don't know if caller asked us to create it yet */ string (fbp -> b.flags) = ""b; /* .. all flags are off in the default state */ return; end find_buffer; %page; %include qedx_internal_data; %page; %include qedx_info; %page; %include set_wakeup_table_info; end edx_util_;  get_addr_.pl1 11/11/89 1109.4rew 11/11/89 0804.6 142605 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-05,Huen), approve(89-04-05,MCR8093), audit(89-05-24,RWaters), install(89-05-31,MR12.3-1051): Fix Bug 209 in qedx editor - Extend the ignoring of leading spaces to include character. END HISTORY COMMENTS */ /* format: off */ /* get_addr_ .......... subroutine to find address portion of qedx request and locate addressed line in buffer */ /* Initial coding by R. C. Daley, August 1970 */ /* Modified for gapped buffer by T. Oke, June 1980 */ /* Changes merged and edited 03/03/82 S. Herbst */ /* Modified: January 1983 by G. Palter as part of making qedx reentrant */ /* Modified: March 1989 by S Huen - Extend the ignoring of leading spaces to include character. (209) */ /* format: on,style4,delnl,insnl,ifthenstmt,ifthen */ get_addr_: procedure (aqidp, atp, ati, ate, afp, alb, aft, afe, ali, ale, api, ape, acode); dcl aqidp ptr, /* pointer to qedx per-invocation data */ atp ptr, /* pointer to current typewriter input request line */ ati fixed bin (21), /* index of first unprocessed character in tw line */ ate fixed bin (21), /* index of last character in tw line */ afp ptr, /* pointer to current buffer file */ alb fixed bin (21), /* index of last character in lower half */ aft fixed bin (21), /* index of first character in upper half */ afe fixed bin (21), /* index of last character in buffer file */ ali fixed bin (21), /* index of first character of current line */ ale fixed bin (21), /* index of last character of current line */ api fixed bin (21), /* index of first character of addressed line (output) */ ape fixed bin (21), /* index of last character of addressed line (output) */ acode fixed bin; /* status code, 0= null address, 1= single address, 2= address pair expected (comma seen), 3= address pair expected (semi-colon seen), 4= search failed, 5= other error */ dcl (tp, fp) ptr, /* temporary storage */ (ti, te, lb, ft, fe, li, le, i, j, num, code) fixed bin (21), temp_reg fixed bin init (0), digit fixed bin (9), (relsw, negsw, evalsw) bit (1) init ("0"b), (ch, nl) char (1); dcl last_index fixed bin (21); /* used in last_line scan */ dcl 1 t based (tp) aligned, /* structure to treat tw line as character array */ 2 c (1048576) char (1) unaligned; dcl 1 f based (fp) aligned, /* structure to treat buffer file as character array */ 2 c (1048576) char (1) unaligned; dcl string char (1048576) based aligned; /* based character string for use with substr and index */ dcl ioa_ entry options (variable), /* external procedures used by get_addr_ */ qx_search_file_ entry (ptr, ptr, fixed bin (21), fixed bin (21), ptr, fixed bin (21), fixed bin (21), fixed bin (21), fixed bin (21), fixed bin (21), fixed bin (21), fixed bin (21)); dcl (fixed, index, reverse, substr, unspec) builtin; %page; tp = atp; /* pointer to tw line buffer */ ti = ati; /* index to next character in tw line */ te = ate; /* index of last character in tw line */ fp = afp; /* pointer to input file */ lb = alb; /* index of last character of bottom half */ ft = aft; /* index of first character of top half */ fe = afe; /* index of last character in input file */ li = ali; /* index of first character of current line */ le = ale; /* index of last character of current line */ acode = 0; /* initialize acode to indicate null address */ unspec (nl) = "000001010"b; /* initialize nl character */ go to scan2; /* begin (or resume) scan of tw input line */ scan: acode = 1; /* resume scan after processing address component */ relsw = "1"b; /* number are relative after first address component */ scan1: ti = ti + 1; /* bump tw input character index */ scan2: if ti > te then do; /* check for end of line */ bad_addr: call ioa_ ("Address syntax error."); go to fail; end; ch = t.c (ti); /* pick up next character from tw input line */ /* Bug 209: Extend the ignoring of leading spaces to include the char */ if (ch = " " | ch = " ") then go to scan1; /* ignore whitespace at this level */ if ch = "/" then go to reg; /* "/" indicates start of regular expression */ if ch = "$" then go to last; /* "$" go to end of input file */ if ch = "-" then go to neg; /* "-" note minus sign seen */ if ch = "+" then go to pos; /* "+" note plus sign seen */ if ch = "." then go to scan; /* ignore "." for compatability */ if ch >= "0" then if ch <= "9" then go to get_num; /* check for integer 0-9 */ if ch = "," then do; /* "," delimits line addresses */ ti = ti + 1; /* bump tw input line index */ acode = 2; /* indicate second address expected ("," seen) */ end; if ch = ";" then do; /* ";" also delimits line addresses */ ti = ti + 1; /* bump tw input line index */ acode = 3; /* indicate second address expected (";" seen) */ end; if evalsw then call eval; /* if numerically addressed line, get begin and end indices */ if li > lb & li < ft then api = ft; else api = li; /* exit from scan on comma or unrecognized character */ if le > lb & le < ft then ape = ft; else ape = le; /* return current line address */ ati = ti; /* update caller's tw line index to point after address */ return; /* normal return to caller (acode= 0, 1 or 2) */ reg_fail: acode = 4; /* here if regular expression search failed */ return; fail: acode = 5; /* here on any other failure during address scan */ return; %page; reg: if evalsw then call eval; /* if numerically addressed line, get begin and end indices first */ i = ti + 1; /* look for regular expression */ do ti = i to te; /* scan expression and try to find matching "/" */ if t.c (ti) = "/" then go to reg1; /* found match */ if t.c (ti) = "" then ti = ti + 1; /* skip next if conceal character */ else if t.c (ti) = "\" then if te > ti then if t.c (ti + 1) = "c" then ti = ti + 2; /* two character conceal symbol */ end; call ioa_ ("Syntax error in regular expression.");/* error if no terminal "/" found */ go to fail; reg1: j = ti - i; /* compute length of regular expression */ /* Processing is broken into two parts, starting in the top, and starting in the bottom. Processing then enters into a string of part processing. If in the bottom, we either search to whole bottom, or part of the bottom. If searching the bottom, and we were in the top then we quit, else we search the top next. Sounds complex (and it is) but perservere and the mud thins */ if le + 1 <= lb then do; /* we are starting in the bottom */ call search_section ((le + 1), (lb), (ft), (fe), (1), (le)); /* search rest bot, top, bot */ end; else do; call search_section ((le + 1), (fe), (1), (lb), (ft), (le)); end; goto scan; last: if ft > fe & lb < 1 then go to scan; /* here after "$" found, find last line */ if fe < ft then le = lb; /* look in the bottom */ else le = fe; /* set current line end to last character in buffer */ /* Modified last_line search to use index function across gapped buffer. */ li = le - 1; /* miss current nl */ retry: if li >= ft then do; last_index = index (reverse (substr (fp -> string, ft, li - ft + 1)), nl); /* search upper */ if last_index = 0 then if lb > 0 then do; /* move across gap to lower and re-try search */ li = lb; goto retry; end; else do; /* this must be the first line */ li = ft; goto scan; /* limit to section for line */ end; end; else do; /* search lower section */ if li < 1 then do; /* limit to 1st line */ li = 1; goto scan; end; if li > lb then li = lb; /* force across gap */ last_index = index (reverse (substr (fp -> string, 1, li)), nl); if last_index = 0 then do; /* not found - force to 1st character */ li = 1; goto scan; /* continue address scan */ end; end; li = li - last_index + 1; /* setup start index */ /* correct for overstep */ if li = lb then li = ft; /* force up */ else li = li + 1; /* correct for pointing at nl */ go to scan; /* and resume address scan */ neg: negsw = "1"b; /* here after "-" found, note that minus sign seen */ go to scan; /* and continue address scan */ pos: negsw = "0"b; /* here after "+" found, note that plus sign seen */ go to scan; /* and continue address scan */ get_num: num = 0; /* here after digit (0-9) found */ do i = ti to te; /* convert ingeter to binary */ ch = t.c (i); /* pick up first or next digit of integer */ if ch < "0" then go to end_num; /* terminate conversion on first non-digit (0-9) */ if ch > "9" then go to end_num; /* .. */ digit = fixed (unspec (ch) & "000001111"b, 9); /* get numerical portion of ascii digit */ num = (num * 10) + digit; /* convert into binary number */ end; go to bad_addr; /* error if no nl character to terminate conversion */ end_num: ti = i - 1; /* here after non-digit found, re-adjust line index */ evalsw = "1"b; /* set switch to later evaluate */ if ^relsw then do; /* if line number address is absolute */ li, le = 0; /* reset line indexes to beginning of buffer */ if num = 0 then li = 1; /* special case for 0th line of buffer (li=1, le=0) */ end; if negsw then do; /* backup */ negsw = "0"b; /* first turn off sw */ temp_reg = temp_reg - num; /* then subtract */ end; else temp_reg = temp_reg + num; /* else go forward */ go to scan; /* continue address scan */ eval: proc; /* Internal proceedure to evaluate numerical addresses and return character indices of beginning and end of addressed line. */ evalsw = "0"b; /* numerical address evaluated */ if fe = 0 then if temp_reg ^= 0 then do; /* check for empty buffer */ call ioa_ ("Buffer empty."); go to fail; end; if temp_reg > 0 /* if positive address then go forward */ then do i = 1 to temp_reg; /* skip foreward temp_reg lines in buffer */ if le + 1 > lb & le + 1 < ft then /* move to upper half */ le = ft - 1; retry_forward: if le = fe then do; /* check if already at end of buffer */ call ioa_ ("Address out of buffer (too big)."); go to fail; end; li = le + 1; /* move line index foreward one line */ if li <= lb then do; /* search in bottom */ j = index (substr (fp -> string, li, (lb - li + 1)), nl); /* find end of line */ if j = 0 & ft <= fe then do; j = index (substr (fp -> string, ft, (fe - ft + 1)), nl); /* find end of line split */ le = ft - 1; /* jump last end of line to start of top */ end; end; else j = index (substr (fp -> string, li, (fe - li + 1)), nl); /* find end of line in top */ if j = 0 then le = fe; /* worry about buffer with no nl on last line */ else le = le + j; /* otherwise, adjust index to last char of line in file */ end; else do i = 1 to -temp_reg; /* loop to move backward temp_reg lines in buffer */ if li - 1 < ft & li - 1 > lb then /* move to lower buffer */ li = lb + 1; if li = 1 then do; /* check if already at first line */ call ioa_ ("Address out of buffer (negative address)."); go to fail; end; le = li - 1; /* set current line end back one line */ /* Modified last_line search to use index function across gapped buffer. */ li = le - 1; /* miss current nl */ retry: if li >= ft then do; last_index = index (reverse (substr (fp -> string, ft, li - ft + 1)), nl); /* search upper */ if last_index = 0 then if lb > 0 then do; /* move across gap to lower and re-try search */ li = lb; goto retry; end; else do; /* this must be the first line */ li = ft; go to bk_next; end; end; else do; /* search lower section */ if li < 1 then do; li = 1; /* limit to 1st line */ go to bk_next; end; if li > lb then li = lb; /* force across gap */ last_index = index (reverse (substr (fp -> string, 1, li)), nl); if last_index = 0 then do; /* not found - force to 1st character */ li = 1; go to bk_next; end; end; li = li - last_index + 1; /* setup start index */ /* correct for overstep */ if li = lb then li = ft; /* force up */ else li = li + 1; /* correct for pointing at nl */ bk_next: end; temp_reg = 0; /* clear temp register before returning */ return; end; %page; /* Search sections of the gapped text buffer. */ search_section: proc (x1, y1, x2, y2, x3, y3); dcl (x1, x2, x3, y1, y2, y3) fixed bin (21); dcl (x, y, xx, yy) fixed bin (21); /* search_section is a recursive searching routine which will search each of up to three sections of text in turn and order. It is passed a series of three indicies governing search extents, and then goes through them to pick out a textual match. This routine is only called after i and j have been setup to limit the search master string extents in the tw buffer. */ /* At the end and return of search_section the values of li and le delimit the matched line. Any other return is a non-local error exit goto. */ if x1 > lb & x1 < ft then x = ft; else x = x1; if y1 > lb & y1 < ft then y = ft; else y = y1; if y > x then do; /* and extent to search */ call qx_search_file_ (aqidp, tp, i, j, fp, x, y, li, le, lb, ft, code); if code = 0 then goto breakout_line; /* string find - delimit line */ if code = 2 then goto fail; /* bad master search string */ end; if x1 = 0 then goto reg_fail; /* couldn't find string in three tries */ call search_section ((x2), (y2), (x3), (y3), (0), (0)); return; breakout_line: le = index (substr (fp -> string, li, (y - li + 1)), nl); /* delimit start and end of line containing text match. */ if le = 0 then do; /* section end without nl */ if x2 > lb & x2 < ft then xx = ft; else xx = x2; if y2 > lb & y2 < ft then yy = ft; else yy = y2; /* search in next section, if it exists, for end of line */ if xx > y then /* search superior section */ le = index (substr (fp -> string, xx, (yy - xx + 1)), nl); if le = 0 then le = y; else le = xx + le - 1; /* find true end of line */ end; else le = li + le - 1; do li = (li - 1) by -1 to x; /* find previous nl */ if f.c (li) = nl then do; li = li + 1; return; /* found and delimited */ end; end; li = x; /* must be start of buffer */ end; end get_addr_;  qedx.pl1 11/11/89 1109.4r w 11/11/89 0805.9 118332 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /* format: off */ /* Multics qedx Editor command interface */ /* Created: January 1983 by G. Palter as part of implementation of qedx_ subroutine interface */ /* format: on,style4,delnl,insnl,ifthenstmt,ifthen */ qedx: qx: procedure () options (variable); dcl argument character (argument_lth) unaligned based (argument_ptr); dcl argument_ptr pointer; dcl argument_lth fixed binary (21); dcl (n_arguments, argument_idx) fixed binary; dcl input_dirname character (168); dcl input_ename character (32); dcl input_component character (32); dcl input_file_ptr pointer; dcl exec_dirname character (168); dcl exec_ename character (32); dcl exec_component character (32); dcl exec_buffer_bc fixed binary (24); dcl exec_buffer_ptr pointer; dcl args_buffer character (4 * sys_info$max_seg_size) based (args_buffer_ptr); dcl args_buffer_used fixed binary (21); dcl args_buffer_ptr pointer; dcl 1 local_qi aligned, /* describes how we want the invocation setup */ 2 header like qedx_info.header, 2 buffers (3) like qedx_info.buffers; /* 0, exec, args */ dcl ok_to_continue bit (1); /* command_query_$yes_no should have used aligned */ dcl (no_rw_path, have_pathname, have_macro_pathname, have_macro_arguments) bit (1) aligned; dcl idx fixed binary; dcl code fixed binary (35); dcl invocation_level fixed binary static initial (0); /* # of active invocations of qedx */ dcl NL character (1) static options (constant) initial (" "); dcl QEDX character (32) static options (constant) initial ("qedx"); dcl 1 RECURSION_EXPLANATION_SECTIONS aligned static options (constant), 2 part1 character (200) unaligned initial ("There ^[are^;is^] ^d suspended invocation^[s^] of the qedx command which you have interrupted (eg: by a quit signal) that are still active. If you answer ""yes"" to this query, you will have an additio"), 2 part2 character (200) unaligned initial ("nal invocation of qedx. Any changes that you have made to files in prior invocations which you have not yet written will not be available to this new qedx. In addition, any changes you make to files "), 2 part3 character (200) unaligned initial ("in this qedx which you are also editing in prior invocations will not be reflected in those prior invocations and could be lost if you later write out the same file in one of those other invocations. "), 2 part4 character (200) unaligned initial (" We suggest that you answer ""no"" to this query and use either the ""start"" or ""program_interrupt"" command to resume one of your previous invocations of qedx or that you use the ""release"" command to abo"), 2 part5 character (200) unaligned initial ("rt those older invocations if you are certain there aren't any modified buffers in them. qedx: Do you wish to continue?"); dcl RECURSION_EXPLANATION character (920) defined (RECURSION_EXPLANATION_SECTIONS.part1) position (1); /* last part is only 120 characters */ dcl sys_info$max_seg_size fixed binary (19) external; /* format: off */ dcl (error_table_$badopt, error_table_$bigarg, error_table_$inconsistent, error_table_$noarg, error_table_$too_many_args) fixed binary (35) external; /* format: on */ dcl com_err_ entry () options (variable); dcl command_query_$yes_no entry () options (variable); dcl cu_$arg_count entry (fixed binary, fixed binary (35)); dcl cu_$arg_ptr entry (fixed binary, pointer, fixed binary (21), fixed binary (35)); dcl expand_pathname_$component entry (character (*), character (*), character (*), character (*), fixed binary (35)); dcl expand_pathname_$component_add_suffix entry (character (*), character (*), character (*), character (*), character (*), fixed binary (35)); dcl get_temp_segment_ entry (character (*), pointer, fixed binary (35)); dcl initiate_file_$component entry (character (*), character (*), character (*), bit (*), pointer, fixed binary (24), fixed binary (35)); dcl pathname_$component entry (character (*), character (*), character (*)) returns (character (194)); dcl qedx_ entry (pointer, fixed binary (35)); dcl release_temp_segment_ entry (character (*), pointer, fixed binary (35)); dcl terminate_file_ entry (pointer, fixed binary (24), bit (*), fixed binary (35)); dcl cleanup condition; dcl (divide, length, index, null, substr, string) builtin; %page; /* qedx: qx: procedure () options (variable); */ call cu_$arg_count (n_arguments, code); if code ^= 0 then do; call com_err_ (code, QEDX); return; end; if invocation_level > 0 then do; /* it would be nice to eliminate this... */ call command_query_$yes_no (ok_to_continue, 0, QEDX, RECURSION_EXPLANATION, "There ^[are^;is^] ^d suspended invocation^[s^;^] of qedx in your process.^/Do you wish to continue?", (invocation_level > 1), invocation_level, (invocation_level > 1)); if ^ok_to_continue then return; end; invocation_level = invocation_level + 1; /* another qedx */ input_file_ptr, /* for cleanup handler */ exec_buffer_ptr, args_buffer_ptr = null (); on condition (cleanup) call cleanup_qedx_invocation (); /* format: off */ /* Process arguments: syntax of the qedx command is -- qedx {-control_args} {macro_path {macro_arguments}} */ /* format: on */ no_rw_path, /* allow r/w with pathnames and R/W */ have_pathname, /* haven't seen -pathname yet */ have_macro_pathname, /* haven't seen first non-control argument yet */ have_macro_arguments = "0"b; /* haven't seen any macro arguments */ do argument_idx = 1 to n_arguments; call cu_$arg_ptr (argument_idx, argument_ptr, argument_lth, code); if code ^= 0 then do; /* sigh */ call com_err_ (code, QEDX, "Fetching argument #^d.", argument_idx); go to RETURN_FROM_QEDX; end; if ^have_macro_pathname then /* no non-control argument yet: can still accept -ca's */ if index (argument, "-") = 1 then /* ... a control argument */ if argument = "-no_rw_path" then no_rw_path = "1"b; else if argument = "-rw_path" then no_rw_path = "0"b; else if (argument = "-pathname") | (argument = "-pn") then if have_pathname then do; call com_err_ (error_table_$too_many_args, QEDX, """-pathname"" may only be specified once for this command."); go to RETURN_FROM_QEDX; end; else do; /* initial contents for buffer 0 ... */ have_pathname = "1"b; if argument_idx = n_arguments then do; call com_err_ (error_table_$noarg, QEDX, "Pathname after ""^a"".", argument); go to RETURN_FROM_QEDX; end; argument_idx = argument_idx + 1; call cu_$arg_ptr (argument_idx, argument_ptr, argument_lth, code); if code ^= 0 then do; call com_err_ (code, QEDX, "Fetching argument #^d.", argument_idx); go to RETURN_FROM_QEDX; end; call expand_pathname_$component (argument, input_dirname, input_ename, input_component, code); if code ^= 0 then do; call com_err_ (code, QEDX, "-pathname ^a", argument); go to RETURN_FROM_QEDX; end; call initiate_file_$component (input_dirname, input_ename, input_component, R_ACCESS, input_file_ptr, (0), code); if code ^= 0 then do; /* the file doesn't exist (sigh) */ call com_err_ (code, QEDX, "-pathname ^a", pathname_$component (input_dirname, input_ename, input_component)); go to RETURN_FROM_QEDX; end; call terminate_file_ (input_file_ptr, 0, TERM_FILE_TERM, (0)); input_file_ptr = null (); end; else do; call com_err_ (error_table_$badopt, QEDX, """^a""", argument); go to RETURN_FROM_QEDX; end; else do; /* first non-control argument: macro pathname */ have_macro_pathname = "1"b; call expand_pathname_$component_add_suffix (argument, QEDX, exec_dirname, exec_ename, exec_component, code); if code ^= 0 then do; call com_err_ (code, QEDX, "Macro file: ^a", argument); go to RETURN_FROM_QEDX; end; call initiate_file_$component (exec_dirname, exec_ename, exec_component, R_ACCESS, exec_buffer_ptr, exec_buffer_bc, code); if code ^= 0 then do; /* the file doesn't exist (sigh) */ call com_err_ (code, QEDX, "Macro file: ^a", pathname_$component (exec_dirname, exec_ename, exec_component)); go to RETURN_FROM_QEDX; end; end; else do; /* Nth non-control argument: a macro argument */ if ^have_macro_arguments then do; /* ... first macro argument */ call get_temp_segment_ (QEDX, args_buffer_ptr, code); if code ^= 0 then do; call com_err_ (code, QEDX, "Obtaining buffer space for macro arguments."); go to RETURN_FROM_QEDX; end; args_buffer_used = 0; have_macro_arguments = "1"b; end; call add_to_args_buffer (argument); call add_to_args_buffer (NL); end; end; if no_rw_path & ^have_pathname then do; call com_err_ (error_table_$inconsistent, QEDX, """-no_rw_path"" must be used with ""-pathname""."); go to RETURN_FROM_QEDX; end; /* Arguments have been validated: setup qedx_info data structure and invoke qedx_ */ local_qi.header.version = QEDX_INFO_VERSION_1; local_qi.header.editor_name = QEDX; string (local_qi.header.flags) = ""b; local_qi.header.no_rw_path = no_rw_path; local_qi.header.query_if_modified = "1"b; /* finally after all these years ... */ local_qi.header.n_buffers = 0; /* no initial buffers yet */ if have_pathname then do; /* include a buffer 0 containing requested file ... */ local_qi.header.n_buffers, idx = 1; local_qi.buffers (idx).buffer_name = "0"; local_qi.buffers (idx).buffer_pathname = pathname_$component (input_dirname, input_ename, input_component); string (local_qi.buffers (idx).flags) = ""b; end; if have_macro_pathname then do; /* exec buffer containing a macro to execute ... */ local_qi.header.n_buffers, idx = local_qi.header.n_buffers + 1; local_qi.buffers (idx).buffer_name = "exec"; local_qi.buffers (idx).buffer_pathname = ""; /* ... no pathname by default */ local_qi.buffers (idx).region_ptr = exec_buffer_ptr; local_qi.buffers (idx).region_max_lth, /* ... get size from the system */ local_qi.buffers (idx).region_initial_lth = divide ((exec_buffer_bc + 8), 9, 21, 0); string (local_qi.buffers (idx).flags) = ""b; local_qi.buffers (idx).read_write_region, local_qi.buffers (idx).execute_buffer = "1"b; end; /* ... get initial content from us but can't write back */ if have_macro_arguments then do; /* a "file" of arguments to the macro ... */ local_qi.header.n_buffers, idx = local_qi.header.n_buffers + 1; local_qi.buffers (idx).buffer_name = "args"; local_qi.buffers (idx).buffer_pathname = ""; /* ... no pathname by default */ local_qi.buffers (idx).region_ptr = args_buffer_ptr; local_qi.buffers (idx).region_max_lth, local_qi.buffers (idx).region_initial_lth = args_buffer_used; string (local_qi.buffers (idx).flags) = ""b; local_qi.buffers (idx).read_write_region = "1"b; end; /* ... get initial content from us but can't write back */ call qedx_ (addr (local_qi), code); /* INVOKE THE EDITOR */ RETURN_FROM_QEDX: call cleanup_qedx_invocation (); return; %page; /* Add a character string to the macro arguments buffer */ add_to_args_buffer: procedure (p_string); dcl p_string character (*) parameter; if (args_buffer_used + length (p_string)) > length (args_buffer) then do; call com_err_ (error_table_$bigarg, QEDX, "Too many macro arguments. First failing argument: ""^a"".", argument); go to RETURN_FROM_QEDX; end; substr (args_buffer, (args_buffer_used + 1), length (p_string)) = p_string; args_buffer_used = args_buffer_used + length (p_string); return; end add_to_args_buffer; /* Cleanup after an invocation of qedx */ cleanup_qedx_invocation: procedure (); if input_file_ptr ^= null () then do; /* a very small window nonetheless ... */ call terminate_file_ (input_file_ptr, 0, TERM_FILE_TERM, (0)); input_file_ptr = null (); end; if exec_buffer_ptr ^= null () then do; call terminate_file_ (exec_buffer_ptr, 0, TERM_FILE_TERM, (0)); exec_buffer_ptr = null (); end; if args_buffer_ptr ^= null () then do; call release_temp_segment_ (QEDX, args_buffer_ptr, (0)); args_buffer_ptr = null (); end; invocation_level = invocation_level - 1; /* all gone */ return; end cleanup_qedx_invocation; %page; %include qedx_info; %page; %include access_mode_values; %include terminate_file; end qedx;  qedx_.pl1 11/11/89 1109.4rew 11/11/89 0803.9 784350 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-02-02,Huen), approve(89-02-02,MCR8057), audit(89-05-24,RWaters), install(89-05-31,MR12.3-1051): Fix Bug 204 in qedx editor - Ignore trailing whitespace after a quit request. END HISTORY COMMENTS */ /* format: off */ /* Multics qedx Editor subroutine interface: the actual editor. */ /* Created: August 1970 by R. C. Daley */ /* Modified: August 1977 by R.J.C. Kissel to fix long entryname and garbage word bugs */ /* Modified: 23 February 1979 by Steve Herbst to fix w and r error messages for MSFs */ /* Modified: 4 September 1981 by E. N. Kittlitz to add -pathname, -no_rw_path, r request with no pathname, and to eliminate b.default_len */ /* Modified: 14 July 1980 by T. Oke for gapped buffer management */ /* Modified: 3 March 1981 by S. G. Harris (UNCA) for read entry point */ /* Modified: 3 March 1982 by S. Herbst to merge all of above changes */ /* Modified: 16 April 1982 by S. Herbst to add quit query for modified buffers (subsequently removed, sigh) */ /* Modified: 5 May 1982 by S. Herbst to check that it has not been recursively interrupted */ /* Modified: 7 October 1982 by S. Herbst to fix "Substitution failed." bug inside recursed buffer */ /* Modified: 3 November 1982 by S. Herbst to fix ".a" bug in empty buffer */ /* Modified: January 1983 by G. Palter to make reentrant, convert into qedx_, re-enable quit query if requested by caller, accept the archive component pathname convention on input, rename quit-force to "qf" from "Q", and add trusted pathnames as in ted */ /* Modified April 1983 by Keith Loepere to make work in Bootload Multics */ /* Modified August 1983 by Keith Loepere for new bce switches */ /* Modified March 1985 by Keith Loepere to run in bce and Multics. */ /* Modified Jan 1989 by Huen (204) - Allow whitespace after a "q" request (such as q, Q, qf, etc) */ /* format: on,style4,delnl,insnl,ifthenstmt,ifthen */ qedx_: procedure (P_qedx_info_ptr, P_code); dcl P_qedx_info_ptr pointer parameter; /* -> caller's initial buffers, etc. */ dcl P_code fixed binary (35) parameter; dcl a_real_file bit (1) aligned; dcl b0_bp ptr; dcl b0_ifp ptr; dcl buffer_idx fixed binary; dcl callers_io_region_ptr pointer; dcl ch char (1); dcl cht char (1); dcl code fixed bin (35); dcl curbuf char (16) init ("0"); dcl delim char (1); dcl error_sw ptr; /* for "special" errors */ dcl explicit_pathname bit (1) aligned; dcl fe fixed bin (21); dcl fle fixed bin (21); dcl fli fixed bin (21); dcl flsw bit (1); dcl fp ptr; dcl have_truncated_buffers bit (1) aligned; dcl i fixed bin (21); dcl ife fixed bin (21); /* index of last char in file */ dcl ifp ptr; /* pointer to current file buffer */ dcl ift fixed bin (21); dcl ignore_result bit (1) aligned; dcl il fixed bin (21); dcl ilb fixed bin (21); dcl iline char (512); dcl intsw bit (1); dcl j fixed bin (21); dcl je fixed bin (21); dcl k fixed bin (21); dcl ka fixed bin (21); dcl kx fixed bin (21); dcl l fixed bin (21); dcl le fixed bin (21); /* index of last char of current line */ dcl li fixed bin (21); /* index of first char of current line */ dcl lle fixed bin (21); /* index of last char of addressed line */ dcl lli fixed bin (21); /* index of first char of addressed line */ dcl llsw bit (1); dcl 1 local_qbii aligned like qedx_buffer_io_info; dcl 1 local_qid aligned like qid; /* describes this invocation */ dcl me fixed bin (21); dcl mi fixed bin (21); dcl ml fixed bin (21); dcl new_modes char (256); /* for call to iox_$modes */ dcl old_modes char (256); dcl output_routine entry (ptr, ptr, fixed bin (21), fixed bin (35)) variable; dcl output_sw ptr; /* bce/iox_ switch for "special" output */ dcl pfs fixed bin (35) init (0); dcl pi_label label; dcl pi_sw bit (1); dcl process_type fixed bin; dcl quit_force_sw bit (1); dcl saved_current_buffer character (16); dcl saved_ift fixed bin (21); /* copy of ift during call to "promote" */ dcl sdsw bit (1); dcl subsw bit (1); dcl sub_comp_string character (3) aligned init (" "); dcl tbp ptr; dcl te fixed bin (21); /* index of last character in tw line */ dcl 1 the_buffer aligned like qedx_info.buffers based (the_buffer_ptr); dcl the_buffer_ptr pointer; dcl the_pathname character (256); dcl ti fixed bin (21); /* index of first unprocessed char in tw line */ dcl tik fixed bin (21); dcl tname char (16); dcl tp ptr; /* pointer to current typewriter input request line */ dcl twbuff char (512); dcl was_empty bit (1) aligned; dcl xsw bit (1); dcl yes_sw bit (1); /* ilb_offset is used for post-deletion of text during string substitution. Post deletion is necessary so the the string search /^ // on line 1 will not kill all spaces since first line anchoring tests for nothing before and pre-deletion to next search will ensure a re-match for ^ . */ dcl ilb_offset fixed bin (21); dcl COMMANDS character (19) static options (constant) initial ("psaicdbmrwqg=xevn""Q"); dcl command_index fixed binary; /* current command being executed */ dcl QEDX_ character (32) static options (constant) initial ("qedx_"); dcl QEDX_INFO_VERSION_0 character (8) static options (constant) initial ("qxi_0001"); dcl MODIFIED_BUFFERS_EXPLANATION character (104) static options (constant) initial ("If you quit now, your latest changes to the above buffers will not be saved. Do you still wish to quit?"); dcl TRUNCATED_BUFFERS_EXPLANATION character (100) static options (constant) initial ("If you quit now, some of the contents of the above buffers will be lost. Do you still wish to quit?"); dcl TRUSTED_PATHNAMES_EXPLANATION character (198) static options (constant) initial ("More than one pathname has been used with the read and write requests in this buffer. Do you want to ^a this buffer using the pathname ^a which I consider to be the correct default for this buffer?"); dcl 1 t based (tp) aligned, /* structure to treat request line as character array */ 2 c (sys_info$max_seg_size * 4) char (1) unaligned; dcl 1 f based aligned, /* structure to treat any file as character array */ 2 c (sys_info$max_seg_size * 4) char (1) unaligned; dcl a_string char (sys_info$max_seg_size * 4) based aligned; dcl CHASE fixed binary (1) static options (constant) initial (1); dcl EC character (1) static options (constant) initial (""); /* ancient conceal character = ASCII 031 */ dcl NL character (1) static options (constant) initial (" "); /* format: off */ dcl (error_table_$archive_component_modification, error_table_$archive_pathname, error_table_$bigarg, error_table_$dirseg, error_table_$fatal_error, error_table_$inconsistent, error_table_$moderr, error_table_$no_r_permission, error_table_$no_w_permission, error_table_$pathlong, error_table_$recoverable_error, error_table_$unimplemented_version) fixed binary (35) external; /* format: on */ dcl sys_info$max_seg_size fixed binary (19) external; dcl sys_info$service_system bit (1) aligned external; dcl (cleanup, program_interrupt, sub_request_abort_) condition; dcl bce_data$console_put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)) external variable; dcl bce_data$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)) external variable; dcl iox_$user_output ptr ext; /* pointer to iocb for user_output */ dcl iox_$user_io ptr ext; /* pointer to iocb for user_io */ dcl bce_check_abort entry; dcl bce_query$yes_no entry options (variable); dcl bootload_fs_$flush_sys entry; dcl bootload_fs_$get_ptr entry (char (*), ptr, fixed bin (21), fixed bin (35)); dcl bootload_fs_$put_ptr entry (char (*), fixed bin (21), bit (1) aligned, ptr, fixed bin (35)); dcl check_entryname_ entry (char (*), fixed bin (35)); dcl com_err_ entry () options (variable); dcl command_query_$yes_no entry options (variable); dcl cu_$cp entry (ptr, fixed bin (21), fixed bin (35)); dcl edx_util_$edx_cleanup entry (ptr); dcl edx_util_$edx_init entry (ptr, ptr, ptr, ptr, fixed bin (35)); dcl edx_util_$end_buffer entry (ptr, fixed bin (35)); dcl edx_util_$get_buffer entry (ptr, ptr, fixed bin (21), fixed bin (21), char (16), ptr); dcl edx_util_$list_buffers entry (ptr, char (16), ptr); dcl edx_util_$list_modified_buffers entry (pointer, character (16), pointer); dcl edx_util_$list_single_buffer entry (pointer, character (16), pointer, pointer); dcl edx_util_$locate_buffer entry (ptr, char (16), ptr); dcl edx_util_$modified_buffers entry (ptr) returns (bit (1)); dcl edx_util_$prime entry (ptr, ptr, fixed bin (21)); dcl edx_util_$read_ptr entry (ptr, ptr, fixed bin (21), fixed bin (21)); dcl edx_util_$resetread entry (ptr); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl expand_pathname_$component entry (char (*), char (*), char (*), char (*), fixed bin (35)); dcl get_addr_ entry (ptr, ptr, fixed bin (21), fixed bin (21), ptr, fixed bin (21), fixed bin (21), fixed bin (21), fixed bin (21), fixed bin (21), fixed bin (21), fixed bin (21), fixed bin (35)); dcl get_system_free_area_ entry () returns (ptr); dcl get_temp_segment_ entry (char (*), ptr, fixed bin (35)); dcl hcs_$status_minf entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35)); dcl initiate_file_$component entry (char (*), char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35)); dcl initiate_file_$create entry (char (*), char (*), bit (*), ptr, bit (1) aligned, fixed bin (24), fixed bin (35)); dcl ioa_ entry () options (variable); dcl ioa_$ioa_switch entry () options (variable); dcl iox_$modes entry (ptr, char (*), char (*), fixed bin (35)); dcl iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl mrl_ entry (ptr, fixed bin (21), ptr, fixed bin (21)); dcl pathname_ entry (char (*), char (*)) returns (char (168)); dcl pathname_$component entry (char (*), char (*), char (*)) returns (char (194)); dcl qx_search_file_ entry (ptr, ptr, fixed bin (21), fixed bin (21), ptr, fixed bin (21), fixed bin (21), fixed bin (21), fixed bin (21), fixed bin (21), fixed bin (21), fixed bin (35)); dcl qx_search_file_$cleanup entry (ptr); dcl qx_search_file_$init entry (ptr); dcl release_temp_segment_ entry (char (*), ptr, fixed bin (35)); dcl sub_err_ entry () options (variable); dcl terminate_file_ entry (ptr, fixed bin (24), bit (*), fixed bin (35)); dcl user_info_$process_type entry (fixed bin); dcl (addr, divide, index, min, null, search, substr, length, reverse, rtrim, string) builtin; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* qedx_: procedure (P_qedx_info_ptr, P_code); */ if sys_info$service_system then do; output_routine = iox_$put_chars; output_sw = iox_$user_output; error_sw = iox_$user_io; end; else do; output_routine = bce_data$put_chars; error_sw = addr (bce_data$console_put_chars); output_sw = addr (bce_data$put_chars); end; qedx_info_ptr = P_qedx_info_ptr; if (qedx_info.version ^= QEDX_INFO_VERSION_0) & (qedx_info.version ^= QEDX_INFO_VERSION_1) then do; P_code = error_table_$unimplemented_version; return; end; /* Initialize per-invocation data */ qid_ptr = addr (local_qid); /* use the one in automatic */ qid.editor_name = qedx_info.editor_name; qid.editor_area_ptr = get_system_free_area_ (); qid.qedx_info_ptr = qedx_info_ptr; /* edx_util_, etc. may need it */ qid.flags = qedx_info.header.flags, by name; /* all the same flags */ qid.edx_util_data_ptr, /* for cleanup handler */ qid.regexp_data_ptr, callers_io_region_ptr = null (); on condition (cleanup) call cleanup_invocation_data (); call edx_util_$edx_init (qid_ptr, addr (twbuff), b0_ifp, b0_bp, code); if code ^= 0 then do; call com_err_ (code, qid.editor_name, "Unable to initialize edx_util_."); P_code = error_table_$fatal_error; return; end; call get_buffer_state (b0_bp); /* let buffer "0" be current (for now) */ call qx_search_file_$init (qid_ptr); if qedx_info.caller_does_io then do; /* need an I/O buffer */ call get_temp_segment_ (qid.editor_name, callers_io_region_ptr, code); if code ^= 0 then do; call com_err_ (code, qid.editor_name, "Obtaining I/O buffer."); P_code = error_table_$fatal_error; go to RETURN_FROM_QEDX_; end; end; /* Initialize buffers to those supplied by the caller */ do buffer_idx = 1 to qedx_info.n_buffers; the_buffer_ptr = addr (qedx_info.buffers (buffer_idx)); call edx_util_$locate_buffer (qid_ptr, the_buffer.buffer_name, bp); if bp = null () then do; /* error already printed */ P_code = error_table_$fatal_error; go to RETURN_FROM_QEDX_; end; call get_buffer_state (bp); b.callers_idx = buffer_idx; /* need to keep track of it */ if the_buffer.read_write_region then do; /* read/write from caller's character string */ if the_buffer.region_ptr = null () then do; call sub_err_ (error_table_$inconsistent, QEDX_, ACTION_CANT_RESTART, null (), 0, "Input/output area required for buffer ^a was not supplied.", the_buffer.buffer_name); P_code = error_table_$fatal_error; go to RETURN_FROM_QEDX_; end; else if qedx_info.caller_does_io then do; call sub_err_ (error_table_$inconsistent, QEDX_, ACTION_CANT_RESTART, null (), 0, "Input/output area can not be used for buffer ^a when caller performs I/O.", the_buffer.buffer_name); P_code = error_table_$fatal_error; /* ... caller I/O only works with pathnames */ go to RETURN_FROM_QEDX_; end; else do; /* ... and it's actually there */ a_real_file = "0"b; /* ... ...don't terminate it */ the_pathname = the_buffer.buffer_pathname; b.default_was_region = "1"b; the_buffer.region_final_lth = the_buffer.region_initial_lth; end; end; else do; /* read/write from the specified file */ if the_buffer.buffer_pathname = "" then do; call sub_err_ (error_table_$inconsistent, QEDX_, ACTION_CANT_RESTART, null (), 0, "Default pathname not specified for buffer ^a.", the_buffer.buffer_name); P_code = error_table_$fatal_error; go to RETURN_FROM_QEDX_; end; else do; /* ... and there is a pathname given */ a_real_file = "1"b; the_pathname = the_buffer.buffer_pathname; b.default_was_region = "0"b; end; end; fle = ife; /* put it at the end (of the empty buffer) */ if ^perform_read (a_real_file, the_pathname, "1"b) then do; P_code = error_table_$fatal_error; /* ... didn't work (sigh) */ go to RETURN_FROM_QEDX_; end; if qedx_info.version = QEDX_INFO_VERSION_1 then b.default_locked = the_buffer.locked_pathname; else b.default_locked = ^the_buffer.locked_pathname; /* version 0 structure: this flag had the opposite meaning */ call save_buffer_state (); /* save it */ end; /* Initialize everything else ... */ pi_sw = "0"b; /* set switch to ignore program interrupts */ if sys_info$service_system then on condition (program_interrupt) call interrupt (); /* establish handler for program interrupt */ else on condition (sub_request_abort_) call interrupt (); /* establish handler for request abort */ tp = addr (iline); /* initialize pointer to input line buffer */ substr (iline, 1, 3) = "b0 "; /* move to buffer zero */ te = 3; do buffer_idx = 1 to qedx_info.n_buffers; /* insure we execute all request buffers */ the_buffer_ptr = addr (qedx_info.buffers (buffer_idx)); if the_buffer.execute_buffer then do; if (te + length ("\b() ") + length (rtrim (the_buffer.buffer_name))) > length (iline) then do; call com_err_ (error_table_$bigarg, qid.editor_name, "Preparing to execute buffer ^a.", the_buffer.buffer_name); P_code = error_table_$fatal_error; go to RETURN_FROM_QEDX_; end; substr (iline, (te + 1), (length ("\b() ") + length (rtrim (the_buffer.buffer_name)))) = "\b(" || rtrim (the_buffer.buffer_name) || ") "; te = te + length ("\b() ") + length (rtrim (the_buffer.buffer_name)); end; end; substr (iline, te, 1) = NL; /* makes sure initial requests are executed properly */ call edx_util_$prime (qid_ptr, tp, te); /* prime input stream to read in and execute macro */ %page; /* **** Start of working Code **** qedx returns here to process each new command line, from either the macro file, or the terminal, if qedx is executing multiple commands from a single line, re-entry is made to the label next:, rather than nx_line:. At this point the basic command is cracked and addressing is determined. */ nx_line: ti = 1; /* read next request line from input stream */ call edx_util_$read_ptr (qid_ptr, tp, length (iline), te); next: if ^sys_info$service_system then do; intsw = "0"b; call bce_check_abort; if intsw = "1"b then go to RETURN_FROM_QEDX_; end; call save_buffer_state (); /* save current buffer state */ if ti >= te then go to nx_line; /* check after each request if request line exhausted */ intsw = "0"b; /* reset previous program_interrupt (if any) */ call get_addr_ (qid_ptr, tp, ti, te, ifp, ilb, ift, ife, li, le, fli, fle, code); /* find first address if any */ if code = 0 then flsw, llsw = "0"b; /* code = 0, no address found (use default) */ else if code = 1 then do; /* code = 1, */ flsw = "1"b; /* single address found, */ llsw = "0"b; /* use default for second address if needed */ end; else if code < 4 then do; /* code 2 or 3, */ flsw, llsw = "1"b; /* both addresses found */ if code = 2 then call get_addr_ (qid_ptr, tp, ti, te, ifp, ilb, ift, ife, li, le, lli, lle, code); /* code 2 = "," */ else call get_addr_ (qid_ptr, tp, ti, te, ifp, ilb, ift, ife, fli, fle, lli, lle, code); /* code 3 = ";" */ if code = 4 then go to reg_err; /* check for failure to match on regular expression */ if code > 4 then go to rq_err; /* check for other error */ end; else if code = 4 then do; /* code = 4, */ reg_err: call edx_util_$end_buffer (qid_ptr, code); /* failure to match reg. expression, pop buffer stack */ if code ^= 0 then do; /* if already at highest buffer level (0) */ call ioa_ ("Search failed."); /* print error message */ go to rq_err; /* treat as normal error */ end; else go to nx_line; /* resume input from next higher level */ end; else if code > 4 then do; /* code > 4, error detected in get_addr_ */ rq_err: call edx_util_$resetread (qid_ptr); /* reset buffer push down stack and tw input buffer */ go to nx_line; /* read next line from console typewriter (level=0) */ end; ch = t.c (ti); /* pick up first character after address */ ti = ti + 1; /* bump request line character index */ if ch = NL then /* check for new-line character */ if flsw then go to print1; /* print line pointed to by "." if address found */ else go to nx_line; /* otherwise, ignore NL and read next request line */ command_index = index (COMMANDS, ch); /* which command given */ pi_label = ACTION (0); /* assume we will be an error */ go to ACTION (command_index); /* go do it */ ACTION (0): /* here if unrecognized */ call ioa_ ("^a: ^a not recognized as a request.", qid.editor_name, ch); /* here if request not understood */ go to rq_err; /* treat as any other error */ %page; /* **** read request **** Read in specified file after addressed line in current buffer file. Current line is left at the end of the readin section. Operation is performed by splitting the buffer under where the readin should occur and reading appending to the bottom of the top section. This leaves the gap below the readin section, which is where it will tend to speed initial editing commands on the readin section. */ ACTION (9): read: call determine_file ("0"b, a_real_file, the_pathname, explicit_pathname); if ^flsw then fle = ife; /* no address: append to end of file */ if perform_read (a_real_file, the_pathname, explicit_pathname) then go to nx_line; /* successfull read */ else go to rq_err; %page; /* **** write request **** Write out the specified contents of the current buffer into the spec file. This operation is done without gap movement by calculating if the data is split across the gap, or entirely contained within either the top or bottom sections of the buffer. If the data is contiguous, then a single substr is used, otherwise the section within the bottom, and the section within the top are separately written, with the top write appended on the bottom. The current line position is not altered by writing. */ ACTION (10): write: call defaults (1, ife); /* supply default addresses (1,$) if necessary */ pi_label = wr_quit; /* in case of quit */ pi_sw = "1"b; /* activate quit handler and label */ call determine_file ("1"b, a_real_file, the_pathname, explicit_pathname); /* firgure out where it goes */ if ^perform_write (a_real_file, the_pathname, explicit_pathname, "1"b) then go to rq_err; /* didn't work */ wr_quit: pi_sw = "0"b; /* turn of pi handler */ go to nx_line; /* go pick up next qedx request line */ %page; /* * * * * quit request .......... clean up and exit from qedx editor (i.e., return to caller) * * * * * * * * */ ACTION (19): /* Q request: don't worry about modified buffers */ quit_force_sw = "1"b; go to DO_QUIT_REQUEST; ACTION (11): /* q/qf request */ if t.c (ti) = "f" then do; /* ... it's qf: don't worry about modified buffers */ quit_force_sw = "1"b; ti = ti + 1; end; else quit_force_sw = "0"b; /* ... it's q: may query if modified buffers exist */ DO_QUIT_REQUEST: if (flsw) then do; /* special syntax check for quit request */ call ioa_ ("Syntax error in quit request."); go to rq_err; end; /* Bug_204 : Ignore trailing whitespace after a quit request */ if (t.c (ti) ^= NL) then do; ti = ti + verify (substr (iline, ti), " ") - 1; if (t.c (ti) ^= NL) then do; call ioa_ ("Syntax error in quit request."); go to rq_err; end; end; /* Check for modified buffers if caller so desires */ if qid.query_if_modified & ^quit_force_sw then /* ... but only if user doesn't want out */ if edx_util_$modified_buffers (qid_ptr) then do; if sys_info$service_system then call user_info_$process_type (process_type); else process_type = 1; if process_type = 1 then do; /* ... and only if interactive */ call ioa_$ioa_switch (error_sw, "Modified buffers exist:"); call edx_util_$list_modified_buffers (qid_ptr, (b.name), error_sw); if sys_info$service_system then call command_query_$yes_no (yes_sw, 0, qid.editor_name, MODIFIED_BUFFERS_EXPLANATION, "Do you still wish to quit and lose these changes?"); else call bce_query$yes_no (yes_sw, MODIFIED_BUFFERS_EXPLANATION); if yes_sw then /* ... is equivalent to using Q */ quit_force_sw = "1"b; else go to rq_err; /* ... no: back to request loop */ end; end; if quit_force_sw then go to SET_OUTPUT_VALUES; /* quit force: don't update anything requesting auto_write */ /* Update any buffers with auto-write and query if there are truncated buffers */ saved_current_buffer = b.name; /* in case user doesn't want to quit */ call save_buffer_state (); have_truncated_buffers = "0"b; /* need this locally */ do buffer_idx = 1 to qedx_info.n_buffers; the_buffer_ptr = addr (qedx_info.buffers (buffer_idx)); call edx_util_$locate_buffer (qid_ptr, the_buffer.buffer_name, bp); call get_buffer_state (bp); /* switch buffers */ if the_buffer.read_write_region then do; /* check this buffer and/or write it */ if the_buffer.auto_write then do; /* ... write it */ fli = 1; /* ... ... setup to write entire buffer */ lle = ife; ignore_result = perform_write ("0"b, "", "0"b, "0"b); end; /* put it back without error messages */ if the_buffer.region_final_lth > the_buffer.region_max_lth then do; if ^have_truncated_buffers then do;/* ... first truncated buffer */ call ioa_$ioa_switch (error_sw, "Buffers which will be truncated:"); have_truncated_buffers = "1"b; end; call edx_util_$list_single_buffer (qid_ptr, saved_current_buffer, output_sw, bp); end; end; end; if have_truncated_buffers then do; /* need permission for this ... */ if sys_info$service_system then call command_query_$yes_no (yes_sw, 0, qid.editor_name, TRUNCATED_BUFFERS_EXPLANATION, "Do you still wish to quit?"); else call bce_query$yes_no (yes_sw, TRUNCATED_BUFFERS_EXPLANATION); if ^yes_sw then do; /* ... user got scared */ call edx_util_$locate_buffer (qid_ptr, saved_current_buffer, bp); call get_buffer_state (bp); /* ... back to where user thinks he is */ go to rq_err; end; end; /* Set output parameters in query_info structure and P_code */ SET_OUTPUT_VALUES: qedx_info.quit_forced = quit_force_sw; /* let caller know */ qedx_info.buffers_truncated = "0"b; /* until following check proves otherwise */ do buffer_idx = 1 to qedx_info.n_buffers; the_buffer_ptr = addr (qedx_info.buffers (buffer_idx)); if the_buffer.read_write_region then /* ... only check those not using a file */ if the_buffer.region_final_lth > the_buffer.region_max_lth then qedx_info.buffers_truncated, the_buffer.truncated = "1"b; end; if qedx_info.quit_forced | qedx_info.buffers_truncated then P_code = error_table_$recoverable_error; /* caller beware */ else P_code = 0; /* Control arrives here when it is time to exit qedx (with P_code already set) */ RETURN_FROM_QEDX_: call cleanup_invocation_data (); return; %page; /* **** Print value of current addressed line **** This entry is used to print a line from a single address, such as dot, relative or absolute. The line addressed by lli,lle is printed. New input line is forced by mating ti and te. */ print1: ti = te; /* force nx_line call through next label */ /* **** print request print out specified portion of current buffer **** This code is directly the same as used in write, with the character stream going to the terminal, rather than the output file. */ ACTION (1): print: call defaults (li, le); /* supply default addresses (.,.) if necessary */ pi_label = end_pr; /* allow printing to be aborted */ pi_sw = "1"b; /* by means of a program interrupt */ if lle <= ilb | fli >= ift then do; /* portion addressed is purely in bottom or top */ i = lle - fli + 1; call output_routine (output_sw, addr (ifp -> f.c (fli)), i, code); end; /* print specified portion of buffer on user's console */ else if fli <= ilb then do; /* top in top, bottom in bottom */ i = lle - ift + 1 + ilb - fli; call output_routine (output_sw, addr (ifp -> f.c (fli)), ilb - fli + 1, code); /* print specified portion of buffer on user's console */ call output_routine (output_sw, addr (ifp -> f.c (ift)), lle - ift + 1, code); /* print specified portion of buffer on user's console */ end; pi_sw = "0"b; /* turn off program interrupt handling */ end_pr: call last_line (lle); /* set current line to last line printed */ go to next; /* go pick up next qedx request */ %page; /* **** delete request delete specified lines from current buffer *** */ ACTION (6): delete: call defaults (li, le); /* supply default addresses (.,.) if necessary */ call delete_text (); /* flush the text */ call next_line (ift); /* reposition at line after last line deleted (if any) */ b.modified = "1"b; /* deletion is a modification */ go to next; /* get next qedx request */ /* Actually deletes text (used also by the change request) */ delete_text: procedure (); /* deletion is done to make gap movement minimized. Three situations are considered. 1. Bottom of range is above gap. Then only undeleted chars are moved and ift is moved to delete. 2. Top of range is below gap. Then only undeleted chars are moved and ilb is moved down to delete. 3. Range spans gap. The ift and ilb are updated and fli -> ift. */ if lle <= ilb then do; /* move chars up til end of range */ call open_gap (lle); ilb = fli - 1; /* set lower bound of delete */ end; else if fli >= ift then do; /* move chars down from bottom of range */ call open_gap ((fli - 1)); /* open gap in front of section to delete */ ift = lle + 1; /* set upper bound of delete */ end; else do; /* range spans gap */ ilb = fli - 1; /* delete lower end */ ift = lle + 1; /* delete upper end */ fli = ift; /* clear range */ end; return; end delete_text; %page; /* **** append, insert or change request, append after, insert before or replace addressed text. **** All actions are performed by calculating a split point for the buffer and then opening the gap at that point. For change, one also moves the lower section top pointer to delete text before reading in the new text. Space allocation for reading of new text is done by input calling for possible buffer promotion prior to each line of input being moved from the working line buffer, to the temporary file buffer. The current line position is left at the last line input. */ ACTION (3): /* append text after addressed line */ append: if ^flsw | /* if no address given or */ fle > ife then /* addres is "." and buffer empty then */ fle = le; /* append after current line */ call open_gap ((fle)); /* open gap after current line */ go to in_mode; /* join common console input code */ ACTION (4): /* insert text before addressed line */ insert: if ^flsw then fli = li; /* insert before current line if no address given */ fle = fli - 1; /* back up one line (.-1) */ call open_gap ((fle)); /* open the gap before the current line */ go to in_mode; /* join common console input code */ ACTION (5): /* replace addressed lines with input from console */ change: call defaults (li, le); call delete_text (); /* get rid of the old text */ b.modified = "1"b; /* buffer is modified even if nothing is input here */ in_mode: /* attempt to enter cheap input mode */ if sys_info$service_system then do; new_modes = "wake_tbl"; call iox_$modes (iox_$user_io, new_modes, old_modes, code); end; was_empty = (ilb < 1) & (ift > ife); /* remember whether buffer was empty or not */ pi_label = in_mode; /* setup recovery info for promote */ call input (ifp, ilb); /* input from console, append to input buffer file */ pi_label = nx_line; /* kill input flag to promote */ /* If we have added a line which does not end in a newline then the gap spans within a line and violates standards. Compact the line by finding the start and end of the last line entered and opening the gap before it. */ call last_line (ilb); /* position at last line input from console */ call open_gap ((li - 1)); /* compact the possible split line */ call next_line (li); /* find end of current line (may be across gap) */ if sys_info$service_system then do; new_modes = "^wake_tbl"; /* turn off cheap input */ call iox_$modes (iox_$user_io, new_modes, old_modes, code); end; if was_empty then /* if buffer was empty, can no longer trust default path */ b.default_untrusted = ^b.default_locked & (b.default_path ^= ""); go to next; /* get next qedx request */ %page; /* **** substitute request s/string1/string2/ replaces all occurrences of string1 with string2 **** This operation is done through constant and non-standard buffer gap moves. This is the only operation in which the buffer gap would not be at a line boundary. Moves are done as the scan through the line is done, with processed characters left in the bottom section and unprocessed characters in the top. As processing continues characters move down to the bottom section. This permits all additions to the buffer to be done by appending to the lower section, and deletions to be done by moving the top pointer of the bottom section, with the one exception being if the last substitution has been done such that fli>lle, then the lower pointer of the upper section is moved. This is due to the action of the sdsw increment of fli to bypass the NL, and the requirement to delete immediately, since post deletion is not possible. Post deletion of text is used where the replacing string is null, or contains &'s. In the case of null replacement the construct s/^.// would replace the entire line with null, unless post deletion was done. In the case of & replacement, we have to retain the original source matched by the & to replace, therefore post deletion is necessary. Otherwise immediate deletion is done to retain the ability to edit an entire segment. Post deletion of text is accomplished by setting up an ilb correction factor to be applied after the next qx_search_file_. This is to prevent /^.// from matching all characters, since deletion immediately would result in the end of line moving up and being found again. This post deletion requires substitute to always pass through a final qx_search_file_ which doesn't find the string. When this occurs the correction is already done. The exception is already noted above, and only occurs if fli is incremented when the string ended in *$. */ ACTION (2): pi_label = sub_done; /* say we are a substitute */ substitute: call defaults (li, le); /* provide default addresses in needed */ delim = t.c (ti); /* pick up string delimiter */ intsw = "0"b; /* trap interrupts in long substitutes */ subsw = "0"b; /* set switch for first string */ sdsw = "0"b; /* initiate star-dollar match switch */ ilb_offset = 0; /* no post-deletion needed */ tik = ti + 1; /* set index to first char of string1 */ i = tik; /* and hold it. */ sub_comp_string = delim || EC || "\"; /* set compare for delim conceal two char conceal */ sub_search: k = search (substr (tp -> a_string, tik, te - tik + 1), sub_comp_string); /* search for delim or conceal char */ if k = 0 then do; /* syntax error -- no delimiter */ sub_err: call ioa_ ("Syntax error in substitute request."); go to rq_err; end; kx = index (sub_comp_string, t.c (tik + k - 1)); /* which character was found? */ go to sub_case (kx); /* process case found */ sub_case (1): if ^subsw then do; /* working on first string */ j = tik + k; /* set index, first char string2 */ il = j - 1 - i; /* save length of string1 */ if substr (tp -> a_string, j - 3, 2) = "*$" /* check last chars of string1 for star dollar */ then if substr (tp -> a_string, j - 4, 1) ^= EC /* check for conceal character */ then if (substr (tp -> a_string, j - 5, 2)) ^= "\c" then if (substr (tp -> a_string, j - 5, 2)) ^= "\C" then sdsw = "1"b; /* found star dollar */ tik = j; subsw = "1"b; /* working on second string, string2 */ go to sub_search; end; else go to sub2; /* found end of string2 */ sub_case (2): if (ti + k) < te then do; /* is there a char after the concealed char? */ tik = (tik + k) + 1; /* skip concealed char */ go to sub_search; /* and continue scan */ end; else go to sub_err; /* no delimiter found */ sub_case (3): if (tik + k) > te then go to sub_err; /* there is no char after the escape, 134 */ if (t.c (tik + k) = "C") | (t.c (tik + k) = "c") /* is this conceal symbol */ then if (tik + k) + 1 < te /* is more after concealed char */ then do; tik = tik + k + 2; /* start at next char */ go to sub_search; end; else go to sub_err; /* no delimiter */ else do; /* this was not a conceal symbol */ tik = tik + k; /* search continues at next char */ go to sub_search; end; sub2: ti = tik + k; /* set index to next character after substitue request */ je = tik + k - 2; /* get index of last character in strin2 */ call open_gap ((fli - 1)); /* setup buffer for substitution */ subsw = "0"b; /* initialize switch to indicate nothing found yet */ sub_loop: call qx_search_file_ (qid_ptr, tp, i, il, ifp, fli, lle, mi, me, ilb, ift, code); /* try to match on string1 */ ilb = ilb - ilb_offset; /* post-delete previous stuff */ ilb_offset = 0; /* and don't delete more til we are ready */ if ^sys_info$service_system then call bce_check_abort; if intsw then do; /* interrupt in substitution */ call ioa_ ("^a: Interrupt during substitute, remainder unprocessed.", qid.editor_name); intsw = "0"b; goto sub_done; end; if code ^= 0 then goto sub_done; /* if nothing found, all done */ ml = me - mi + 1; /* otherwise, get length of string found */ subsw = "1"b; /* indicate something found */ il = 0; /* use canned regular expression next time thru */ l = mi - fli; /* copy buffer up to char(mi) */ if l > 0 then /* .. (if anything to copy) */ fli = fli + l; /* set point of copy */ /* **** This is the only point at which the gap is part way through a line **** */ call open_gap ((fli - 1)); l = j; /* set index to beginning of input string */ sub_string_search: /* search input string for special symbols */ k = search (substr (tp -> a_string, l, je - l + 1), "&\"); /* search for special symbol &, conceal = 031, "\" */ if k = 0 then do; /* no special symbols */ if je >= j then /* only process if sub string not null */ if ml ^= 0 then do; call promote ((je - l + 1 - ml)); /* make sure space exists */ /* Check here to prevent inadvertant deletion of matched string */ ift = ift + ml; /* immediate delete since no & present */ ml = -1; /* indicate already deleted */ end; saved_ift = ift; call promote ((je - l + 1)); /* make sure space exists */ substr (ifp -> a_string, ilb + 1, (je - l + 1)) = substr (tp -> a_string, l, (je - l + 1)); /* insert string */ ilb = ilb + je - l + 1; /* update output buffer length */ b.modified = "1"b; /* substitute is a modify */ go to sub_next; /* see if more substitution */ end; kx = index ("&\", t.c (l + k - 1)); /* which one found/ */ go to do_sub (kx); /* go process it */ do_sub (1): /* found &, insert matched string here */ if k > 1 then do; /* input non special chars before special */ call promote ((k - 1)); /* ensure space exists */ substr (ifp -> a_string, ilb + 1, k - 1) = substr (tp -> a_string, l, k - 1); /* copy nonspecial chars */ ilb = ilb + k - 1; /* update output coount */ b.modified = "1"b; /* substitute is a modify */ end; /* Insertion of the original matched text is done by copying from the top to the bottom sections. This permits multiple inclusions of text. This operation is safe since data is moved from the top to the bottom, and buffer promotion ensures that the gap is big enough to prevent overlap. */ if ml > 0 then do; /* length of matched string */ call promote ((ml)); /* ensure space exists */ substr (ifp -> a_string, ilb + 1, ml) = substr (ifp -> a_string, mi, ml); /* copy section */ ilb = ilb + ml; /* update end of bottom */ b.modified = "1"b; /* substitute is a modify */ end; l = l + k; /* update index into input string */ go to sub_string_search; /* and continue search */ do_sub (2): /* found conceal character 031 */ ka = 0; /* single character conceal symbol */ do_sub_conceal: /* append string to here plus concealed character */ call promote ((k)); /* ensure space exists */ substr (ifp -> a_string, ilb + 1, k) = substr (tp -> a_string, l, k - 1) || t.c (l + k + ka); ilb = ilb + k; /* update output string index */ b.modified = "1"b; /* substitute is a modify */ l = l + k + ka + 1; /* update input string index */ go to sub_string_search; /* and continue search */ do_sub (3): /* found "\" so check for following "c" */ if (t.c (k + l) = "C") | (t.c (k + l) = "c") then do; /* if two character conceal symbol */ ka = 1; /* then set special character counter */ go to do_sub_conceal; /* found two character conceal symbol */ end; else do; /* some other character */ call promote ((k)); /* ensure space exists */ substr (ifp -> a_string, ilb + 1, k) = substr (tp -> a_string, l, k); /* copy up to and including "\" */ ilb = ilb + k; /* update output buffer index */ b.modified = "1"b; /* substitute is a modify */ l = l + k; /* set input index */ go to sub_string_search; /* and continue search */ end; sub_next: if ml = 0 then /* if matched string was null */ fli = fli + 1; /* ensure we find a different null string next time */ else do; /* if matched string not null, resume search */ fli = me + 1; /* set index after last matched character */ if sdsw /* for star dollar match, step over new line. */ then fli = fli + 1; /* update search index */ if ml < 0 then ilb_offset = 0; else if fli > lle then ift = ift + ml; /* delete text if we will quit */ else ilb_offset = ml; /* post-delete matched section from buffer */ end; /* This gap opening is necessary due to post-deletion. If we opened the gap purely at fli-1 then .*$ would cause us to post-delete the 'NL'. By opening the gap at the end of the matched string everything is okay. */ if sdsw then /* Check if fli is overstepped */ call open_gap ((fli - 2)); else call open_gap ((fli - 1)); if fli <= lle then go to sub_loop; /* until end of addressed portion of buffer reached */ sub_done: call last_line (min (fli, lle)); /* find start of this line */ call open_gap ((li - 1)); /* fixup gap to line boundary */ call next_line (lle); /* set current line to end of range */ /* The following call to last_line is necessary to find the true beginning of the current line, since last_line and next_line both set the other end of the line, one must have at least one of them supplied with a true end. The above next_line truely sets up the end of the line, the following last_line truely sets up the beginning. */ call last_line (le); /* **** After this point buffer is again following line gap standards **** */ if ^subsw then do; /* error if nothing found */ call edx_util_$end_buffer (qid_ptr, code); /* attempt to pop buffer recursion stack */ if code = 0 then go to nx_line; /* and continue execution in calling buffer */ call ioa_ ("Substitution failed."); /* print error message if at recursion level 0 */ go to rq_err; /* and treat as normal error */ end; else go to next; /* go pick up next request */ %page; /* * * * * execute request ... pass remainder of line to command processor (i.e. escape to command system) * */ ACTION (15): execute: substr (tp -> a_string, 1, (ti - 1)) = " "; /* blank out preceding portion of request line */ pi_label = nx_line; /* allow command to be aborted */ if sys_info$service_system then do; pi_sw = "1"b; /* by means of a program interrupt */ call cu_$cp (tp, te, code); /* pass request line to command processor */ pi_sw = "0"b; /* disable program interrupt upon return */ end; else call ioa_ ("^a: Escape to command level not allowed.", qid.editor_name); go to nx_line; /* get fresh request line from input stream */ /* * * * * buffer request ..... change working buffer after saving status of current buffer * * * * * * * * * */ ACTION (7): buffer: call save_buffer_state (); /* save previous buffer's state */ call edx_util_$get_buffer (qid_ptr, tp, ti, te, tname, tbp); /* pick up pointer to control block of new buffer */ if tbp = null then go to rq_err; call get_buffer_state (tbp); /* instantiate new one */ go to next; %page; /* **** move request move addressed lines from current buffer into auxilliary buffer **** This move is directly borrowed from write, and print. It does not alter the current line, or move the gap. */ ACTION (8): move: call defaults (li, le); /* provide default addresses in needed */ call edx_util_$get_buffer (qid_ptr, tp, ti, te, tname, tbp); /* get pointer to control block of specified buffer */ if tbp = null then go to rq_err; fp = tbp -> b.dp; /* get pointer to buffer file */ if lle <= ilb | fli >= ift then do; /* portion addressed is purely in bottom or top */ fe = lle - fli + 1; if fe > sys_info$max_seg_size * 4 then do; move_overflow: call ioa_ ("^a: Buffer full!! Move not performed.", qid.editor_name); goto rq_err; end; substr (fp -> a_string, 1, fe) = substr (ifp -> a_string, fli, fe); /* copy specified portion of buffer into new buffer */ end; else if fli <= ilb then do; /* top in top, bottom in bottom */ fe = lle - ift + 1 + ilb - fli + 1; if fe > sys_info$max_seg_size * 4 then goto move_overflow; substr (fp -> a_string, 1, ilb - fli + 1) = substr (ifp -> a_string, fli, ilb - fli + 1); substr (fp -> a_string, ilb - fli + 2, lle - ift + 1) = substr (ifp -> a_string, ift, lle - ift + 1); end; if fe < 4 * 4 * 1024 then i = 4 * 4 * 1024; else if fe < 16 * 4 * 1024 then i = 16 * 4 * 1024; else if fe < 64 * 4 * 1024 then i = 64 * 4 * 1024; else i = 255 * 4 * 1024; i = min (i, sys_info$max_seg_size * 4); tbp -> b.lb = fe; tbp -> b.de = i; /* update buffer status */ tbp -> b.ft = i + 1; /* upper buffer is empty */ tbp -> b.li = 1; /* .. */ tbp -> b.le = index (substr (fp -> a_string, 1, fe), NL); if tbp -> b.le = 0 then tbp -> b.le = fe; /* set to last line */ if tbp -> b.le = 0 then tbp -> b.le = ilb; /* if no new line then set to end of buffer */ tbp -> b.modified = "1"b; /* target buffer is now modified */ tbp -> b.default_untrusted = ^tbp -> b.default_locked & (tbp -> b.default_path ^= ""); /* target's pathname is no longer trusted */ go to delete; /* now delete addressed lines from current buffer */ %page; /* * * * * status ("x") request ..... list status of all buffers (current and auxiliary) * * * * * * * * * * * */ ACTION (14): status: call save_buffer_state (); call edx_util_$list_buffers (qid_ptr, curbuf, output_sw); go to next; /* and go pick up next qedx request */ %page; /* **** print current line number ("=") request prints out line number of current line in buffer **** This is one of the grottier pieces of code, not due to poor coding, but due to poor design for a paging system. = must read the entire temp file, and count line feeds until the current character index of the current line is reached. The modifications done here are entirely to account for the gap in the middle of the buffer. */ ACTION (13): cur_line: call defaults (li, le); /* provide default addresses if necessary */ call last_line (lle); /* set current line to addressed line */ if ifp -> f.c (lle) = NL then j = 0; /* watch out for last line with no new-line character */ else j = 1; /* .. */ i = 1; /* start with first character */ do while (i <= lle); /* up to last character of current line */ if i > ilb & i < ift then i = ift; /* fixup gap entry */ retry_top: if i >= ift then k = index (substr (ifp -> a_string, i, lle - i + 1), NL); /* find a new line */ else do; k = index (substr (ifp -> a_string, i, ilb - i + 1), NL); /* find a new line */ if k = 0 & ift <= ife then do; /* move to upper and continue line */ i = ift; goto retry_top; end; end; if k = 0 then i = lle + 1; /* done */ else j = j + 1; /* add to count of new lines */ i = i + k; /* start with next character */ end; call ioa_ ("^d", j); /* print out line number */ go to next; /* get next qedx request */ %page; /* **** global/exclude request repeat given request for lines containing (or not containing) reg. exp **** This command may move the gap, for deletion, if it finds a line which must be deleted. At this point the gap will be opened below the next line to be processed. This means all operations will execute on a contiguous buffer. Deletion is done simply by moving the ift pointer up to indicate that the line no longer exists in the buffer. */ ACTION (16): exclude: xsw = "1"b; /* exclude request */ go to gb1; /* set switch and join common code */ ACTION (12): global: xsw = "0"b; /* global request */ gb1: call defaults (1, ife); /* provide default addresses (1,$) if necessary */ if ti > te then go to gb_err; /* error if nothing follows g or v request */ ch = t.c (ti); /* get request following global request */ if ch ^= "p" then if ch ^= "d" then if ch ^= "=" then do; /* check for valid global request */ gb_err: call ioa_ ("Syntax error in global request."); go to rq_err; end; delim = t.c (ti + 1); /* pick up regular expression delimiter */ i = ti + 2; /* get index of first character of regular expression */ do ti = i to te; /* find end of regular expression */ cht = t.c (ti); /* pickup one character */ if cht = delim then go to gb2; /* found end of string */ else if cht = EC then ti = ti + 1; /* escape in one character */ else if cht = "\" then if ti < te then if (t.c (ti + 1) = "C") | (t.c (ti + 1) = "c") then ti = ti + 2; /* ... */ end; go to gb_err; /* error if end cannot be found */ gb2: il = ti - i; /* get length of regular expression */ ti = ti + 1; /* leave request line index pointing to next character */ l = 0; /* initialize line counter */ if ch ^= "=" then go to gb_loop; /* count lines only for "=" request */ do j = 1 to (fli - 1); /* for "=" request up to starting line number */ if j > ilb & j < ift then j = ift; /* move across gap */ if j <= fli - 1 then if ifp -> f.c (j) = NL then l = l + 1; /* .. */ end; gb_loop: l = l + 1; /* increment line counter */ if fli > ilb & fli < ift then fli = ift; /* move across gap */ if fli > lle then goto gb_quit; le = index (substr (ifp -> a_string, fli, (lle - fli + 1)), NL); /* find end of next line */ if le = 0 then le = lle; /* worry about no new-line at end of buffer */ else le = fli + le - 1; /* get index of end of line (NL character) */ call qx_search_file_ (qid_ptr, tp, i, il, ifp, fli, le, mi, me, ilb, ift, code); /* search line for regular expression */ if code > 1 then go to gb_quit; /* bad regular expression */ il = 0; /* null regular expression to form // */ if xsw then if code ^= 0 then go to gb_test; /* check for match on exclude request */ if ^xsw then if code = 0 then go to gb_test; /* check for match on global request */ fli = le + 1; /* no match (global or exclude) skip to next line */ go to gb_end; /* .. */ gb_test: if ch = "p" then do; /* match found, check for global print (p) request */ j = le - fli + 1; /* compute number of characters in line to print */ pi_label = gb_quit; /* in case of a quit */ pi_sw = "1"b; /* activate the label */ call output_routine (output_sw, addr (ifp -> f.c (fli)), j, code); /* print line */ pi_sw = "0"b; /* disable the label */ fli = le + 1; /* move to next line */ if ^sys_info$service_system then call bce_check_abort; if intsw then go to gb_quit; /* abort request if program interrupt has occurred */ end; else if ch = "d" then do; /* check for global delete (d) request */ call open_gap ((fli - 1)); /* open gap below delete point */ ift = le + 1; /* start of good text */ fli = ift; /* move up index */ b.modified = "1"b; /* deletion is a modification */ if ^sys_info$service_system then call bce_check_abort; if intsw then go to gb_quit; /* abort request if program interrupt has occurred */ end; else if ch = "=" then do; /* check for global "=" request (print line number) */ call ioa_ ("^d", l); /* print line number */ fli = le + 1; /* move to next line */ if ^sys_info$service_system then call bce_check_abort; if intsw then go to gb_quit; /* abort request if program interrupt has occurred */ end; gb_end: if fli <= lle then go to gb_loop; /* check for last line processed */ gb_quit: if ch = "p" then call ioa_ (""); call last_line (lle); /* when done, leave current line at last line processed */ go to next; /* and pick up next qedx request */ %page; /* * * * * null request .......... change value of "." and get next request from input line */ ACTION (17): nullrq: if ^flsw then go to next; /* ignore request if no address given */ call defaults (li, le); /* provide default addresses if necessary */ call last_line (lle); /* change "." to last line addressed */ go to next; /* * * * * comment delimiter (") found ..... change value of "." to last line addressed and ignore rest of line */ ACTION (18): comment: if ^flsw then go to nx_line; /* ignore completely if no address given */ call defaults (li, le); /* provide default addresses if necessary */ call last_line (lle); /* change "." to last line addressed */ go to nx_line; /* ignore remainder of this request line */ %page; /* * * * * * * * * * * * * * * * * * * * INTERNAL PROCEDURES * * * * * * * * * * * * * * * * * * * */ /* Cleans up the data structures used by this invocation of qedx_ */ cleanup_invocation_data: procedure (); if callers_io_region_ptr ^= null () then do; call release_temp_segment_ (qid.editor_name, callers_io_region_ptr, (0)); callers_io_region_ptr = null (); end; call edx_util_$edx_cleanup (qid_ptr); call qx_search_file_$cleanup (qid_ptr); return; end cleanup_invocation_data; %page; /* Saves the current buffer's state variables */ save_buffer_state: procedure (); b.dp = ifp; b.de = ife; b.lb = ilb; b.ft = ift; b.li = li; b.le = le; return; end save_buffer_state; /* Restores the state of the specifier buffer causing it to be current */ get_buffer_state: procedure (p_bp); dcl p_bp pointer parameter; bp = p_bp; /* switch to new buffer */ curbuf = b.name; /* ... */ ifp = b.dp; /* pointer to buffer file */ ife = b.de; /* index of last character in buffer */ ilb = b.lb; ift = b.ft; li = b.li; /* index of first character of current line */ le = b.le; /* index of last character of current line */ return; end get_buffer_state; %page; /* Determine the "file" to be read/written: only used by actual read/write requests */ determine_file: procedure (write_request, a_real_file, the_pathname, explicit_pathname); dcl write_request bit (1) aligned parameter; /* an output operation */ dcl a_real_file bit (1) aligned parameter; /* set ON => using a "file" rather than caller's buffer */ dcl the_pathname character (256) parameter; /* set to the name of the "file" */ dcl explicit_pathname bit (1) aligned parameter; /* set ON => user supplied a pathname to the request */ dcl l fixed binary (21); if b.callers_idx = 0 then /* not a buffer known to our caller */ the_buffer_ptr = null (); else the_buffer_ptr = addr (qedx_info.buffers (b.callers_idx)); do ti = ti to te while (t.c (ti) = " "); /* skip leading blanks in path name */ end; l = te - ti; /* compute length of path name */ if l > 0 then do; /* have a pathname ... */ explicit_pathname = "1"b; if qid.no_rw_path then do; /* user specified path but is not allowed to do so */ call ioa_ ("A pathname cannot be specified with the ^[w^;r^] request", write_request); go to rq_err; end; if l > length (the_pathname) then do; call com_err_ (error_table_$pathlong, qid.editor_name, "^a", substr (tp -> a_string, ti, l)); b.default_untrusted = ^b.default_locked & (b.default_path ^= ""); go to rq_err; end; a_real_file = "1"b; /* will be reading from a segment all right */ the_pathname = substr (tp -> a_string, ti, l); end; /* save the input pathname */ else do; /* determine source/destination */ explicit_pathname = "0"b; a_real_file = ^b.default_is_region; /* ... check if reading/writing a file */ if the_buffer_ptr ^= null () then /* ... check that user may use default "pathname" */ if the_buffer.read_write_region & b.default_is_region then if (write_request & ^the_buffer.default_write_ok) | (^write_request & ^the_buffer.default_read_ok) then do; call ioa_ ("No pathname given."); go to rq_err; end; if ^write_request & b.default_is_region then /* can only read back original if buffer's empty */ if ^((ift > ife) & (ilb < 1)) then do; call ioa_ ("Cannot restore original text unless buffer is empty."); go to rq_err; end; if a_real_file then /* verify that we have a pathname ... */ if b.default_path ^= "" then the_pathname = b.default_path; else do; call ioa_ ("No pathname given."); go to rq_err; end; end; return; end determine_file; %page; /* Read the "file" into the buffer: returns "1"b if successfull */ perform_read: procedure (a_real_file, the_pathname, explicit_pathname) returns (bit (1) aligned); dcl a_real_file bit (1) aligned parameter; /* ON => reading from a real "file" vs. caller's buffer */ dcl the_pathname character (256) parameter; /* the file to be read */ dcl explicit_pathname bit (1) aligned; /* ON => above pathname given by the user */ dcl file_ptr pointer; dcl dirname character (168); dcl (ename, component) character (32); dcl (was_empty, read_ok) bit (1) aligned; dcl trust_the_pathname bit (1); dcl (code, status_code) fixed binary (35); dcl file_bc fixed binary (24); dcl file_lth fixed binary (21); /* Establish pointer/length of the "file" */ if b.callers_idx = 0 then /* our caller doesn't care about this buffer */ the_buffer_ptr = null (); else the_buffer_ptr = addr (qedx_info.buffers (b.callers_idx)); if qedx_info.caller_does_io then do; /* let the caller get the file for us */ local_qbii.version = QEDX_BUFFER_IO_INFO_VERSION_1; local_qbii.editor_name = qid.editor_name; local_qbii.pathname = the_pathname; local_qbii.buffer_ptr = callers_io_region_ptr; local_qbii.buffer_max_lth = 4 * sys_info$max_seg_size; local_qbii.direction = QEDX_READ_FILE; string (local_qbii.flags) = ""b; local_qbii.default_pathname = ^explicit_pathname; call qedx_info.buffer_io (addr (local_qbii), read_ok); if ^read_ok then do; /* caller will print any error messages */ if explicit_pathname then b.default_untrusted = ^b.default_locked & (b.default_path ^= ""); return ("0"b); end; file_ptr = callers_io_region_ptr; file_lth = local_qbii.buffer_lth; end; else if a_real_file then do; /* get it from an honest to God file */ if sys_info$service_system then do; call expand_pathname_$component (the_pathname, dirname, ename, component, code); if code ^= 0 then do; call com_err_ (code, qid.editor_name, "^a", the_pathname); if explicit_pathname then b.default_untrusted = ^b.default_locked & (b.default_path ^= ""); return ("0"b); end; call initiate_file_$component (dirname, ename, component, R_ACCESS, file_ptr, file_bc, code); if code ^= 0 then do; /* can't get it */ if code = error_table_$dirseg then do; call hcs_$status_minf (dirname, ename, CHASE, 0, file_bc, status_code); if (status_code = 0) & (file_bc ^= 0) then call com_err_ (0, qid.editor_name, "This operation is not allowed for an MSF. ^a", pathname_$component (dirname, ename, component)); else call com_err_ (code, qid.editor_name, "^a", pathname_$component (dirname, ename, component)); end; else call com_err_ (code, qid.editor_name, "^a", pathname_$component (dirname, ename, component)) ; if explicit_pathname & (code ^= error_table_$moderr) & (code ^= error_table_$no_r_permission) then b.default_untrusted = ^b.default_locked & (b.default_path ^= ""); return ("0"b); end; file_lth = divide ((file_bc + 8), 9, 21, 0); end; else do; call bootload_fs_$get_ptr (the_pathname, file_ptr, file_lth, code); if code ^= 0 then do; call com_err_ (code, qid.editor_name, "^a", the_pathname); if explicit_pathname then b.default_untrusted = ^b.default_locked & (b.default_path ^= ""); return ("0"b); end; end; end; else do; /* read from the caller's buffer */ file_ptr = the_buffer.region_ptr; file_lth = min (the_buffer.region_final_lth, the_buffer.region_max_lth); end; /* Check if reading with an untrustworthy default pathname and ask for permission if so */ if b.default_untrusted & ^explicit_pathname then do; if sys_info$service_system then call command_query_$yes_no (trust_the_pathname, 0, qid.editor_name, TRUSTED_PATHNAMES_EXPLANATION, "Do you wish to ^a with the untrustworthy default pathname ^a?", "read", the_pathname); else call bce_query$yes_no (trust_the_pathname, TRUSTED_PATHNAMES_EXPLANATION); if trust_the_pathname then ; /* user says it's OK ... */ else go to rq_err; /* ... punt */ end; else trust_the_pathname = "0"b; /* be sure it's initialized */ /* Move the data into the buffer */ was_empty = (ilb < 1) & (ift > ife); /* remember whether buffer was empty or not */ call open_gap ((fle)); /* open a gap to add after */ call promote (file_lth); /* ensure space exists */ le = ift - 1; /* mark end of buffer */ ift = ift - file_lth; /* setup location where we will read */ substr (ifp -> a_string, ift, file_lth) = substr (file_ptr -> a_string, 1, file_lth); /* copy file */ file_lth = le; /* remember position of end of last line */ call next_line (ift); /* get end of first line of new data */ call last_line (le); /* get start of first line of data (and maybe more) */ call open_gap ((li - 1)); /* open gap at start of line (which might be in lower) */ call last_line (file_lth); /* end of buffer has last line */ call next_line (li); /* ensure a whole line */ /* Set default pathname if necessary and cleanup */ if b.default_locked then do; /* pathname is locked */ b.default_untrusted = "0"b; b.modified = ^was_empty | explicit_pathname; /* ... make sure 1,$dr works right */ end; else if was_empty then do; /* empty and not locked: set new default pathname */ if sys_info$service_system then if a_real_file & ^qedx_info.caller_does_io then b.default_path = pathname_$component (dirname, ename, component); else b.default_path = the_pathname; /* ... if not from a file it wasn't expanded */ else b.default_path = the_pathname; b.default_is_region = ^a_real_file; /* ... might have been caller's buffer */ b.default_untrusted = "0"b; /* ... we trust the pathname again */ b.modified = "0"b; /* ... and this buffer is no longer modified */ end; else do; /* buffer wasn't empty */ b.default_untrusted = (b.default_path ^= "");/* ... we can't trust the default anymore (if there is one) */ b.modified = "1"b; /* ... and the buffer is modified */ end; if sys_info$service_system then if a_real_file & ^qedx_info.caller_does_io then /* terminate it when done */ call terminate_file_ (file_ptr, 0, TERM_FILE_TERM, (0)); return ("1"b); /* success */ end perform_read; %page; /* Write the specified portion of the buffer into the "file": returns "1"b if successful */ perform_write: procedure (a_real_file, the_pathname, explicit_pathname, issue_truncation_warning) returns (bit (1) aligned); dcl a_real_file bit (1) aligned parameter; /* ON => writing to a file vs. caller's buffer */ dcl the_pathname character (256) parameter; /* the name of the file */ dcl explicit_pathname bit (1) aligned parameter; /* ON => user specified a pathname to the write request */ dcl issue_truncation_warning bit (1) aligned parameter; /* ON => if it won't fit in caller's buffer: tell the user */ dcl file_ptr pointer; dcl dirname character (168); dcl ename character (32); dcl (split_data, write_ok, created_file, wrote_whole_buffer) bit (1) aligned; dcl trust_the_pathname bit (1); dcl (code, status_code) fixed binary (35); dcl file_bc fixed binary (24); dcl file_lth fixed binary (21); if b.callers_idx = 0 then /* caller doesn't care about this buffer */ the_buffer_ptr = null (); else the_buffer_ptr = addr (qedx_info.buffers (b.callers_idx)); if (lle <= ilb) | (fli >= ift) then do; /* all data is in one half of the buffer */ split_data = "0"b; file_lth = lle - fli + 1; end; else do; /* data spans the gap */ split_data = "1"b; file_lth = (ilb - fli + 1) + (lle - ift + 1); end; /* Check if writing with an untrustworthy default pathname and ask for permission if so */ if b.default_untrusted & ^explicit_pathname then do; if sys_info$service_system then call command_query_$yes_no (trust_the_pathname, 0, qid.editor_name, TRUSTED_PATHNAMES_EXPLANATION, "Do you wish to ^a with the untrustworthy default pathname ^a?", "write", the_pathname); else call bce_query$yes_no (trust_the_pathname, TRUSTED_PATHNAMES_EXPLANATION); if trust_the_pathname then /* user says it's OK ... */ b.default_untrusted = "0"b; else go to rq_err; /* ... punt */ end; else trust_the_pathname = "0"b; /* be sure this is properly initialized */ if qedx_info.caller_does_io then do; /* Caller does actual I/O: put the portion of the buffer being written into out buffer and have the caller write it */ call put_data (callers_io_region_ptr); local_qbii.version = QEDX_BUFFER_IO_INFO_VERSION_1; local_qbii.editor_name = qid.editor_name; local_qbii.pathname = the_pathname; local_qbii.buffer_ptr = callers_io_region_ptr; local_qbii.buffer_lth = file_lth; local_qbii.direction = QEDX_WRITE_FILE; string (local_qbii.flags) = ""b; local_qbii.default_pathname = ^explicit_pathname; call qedx_info.buffer_io (addr (local_qbii), write_ok); if ^write_ok then do; /* failed: caller has already printed reason */ if explicit_pathname then b.default_untrusted = ^b.default_locked & (b.default_path ^= ""); return ("0"b); end; end; else if a_real_file then do; if sys_info$service_system then do; /* A real file: initiate/create the file and then put the data into it (do not accept archive component pathnames) */ call expand_pathname_ (the_pathname, dirname, ename, code); if code ^= 0 then do; if code = error_table_$archive_pathname then code = error_table_$archive_component_modification; call com_err_ (code, qid.editor_name, "^a", the_pathname); if explicit_pathname & (code ^= error_table_$archive_component_modification) then b.default_untrusted = ^b.default_locked & (b.default_path ^= ""); return ("0"b); end; call initiate_file_$create (dirname, ename, RW_ACCESS, file_ptr, created_file, (0), code); if created_file then do; /* insure that the file just created has an acceptable name */ call check_entryname_ (ename, code); if code ^= 0 then do; /* ... sorry: be sure to delete the unwanted file */ call terminate_file_ (file_ptr, 0, TERM_FILE_DELETE, (0)); call com_err_ (code, qid.editor_name, "^a", pathname_ (dirname, ename)); if explicit_pathname then b.default_untrusted = ^b.default_locked & (b.default_path ^= ""); return ("0"b); end; end; if code ^= 0 then do; /* unable to initiate/create it */ if code = error_table_$dirseg then do; call hcs_$status_minf (dirname, ename, CHASE, 0, file_bc, status_code); if (status_code = 0) & (file_bc ^= 0) then call com_err_ (0, qid.editor_name, "This operation is not allowed for an MSF. ^a", pathname_ (dirname, ename)); else call com_err_ (code, qid.editor_name, "^a", pathname_ (dirname, ename)); end; else call com_err_ (code, qid.editor_name, "^a", pathname_ (dirname, ename)); if explicit_pathname & (code ^= error_table_$moderr) & (code ^= error_table_$no_r_permission) & (code ^= error_table_$no_w_permission) then b.default_untrusted = ^b.default_locked & (b.default_path ^= ""); return ("0"b); end; end; else do; call bootload_fs_$put_ptr (the_pathname, file_lth, "0"b, file_ptr, code); if code ^= 0 then do; call com_err_ (code, qid.editor_name, "^a", the_pathname); if explicit_pathname then b.default_untrusted = ^b.default_locked & (b.default_path ^= ""); return ("0"b); end; end; call put_data (file_ptr); /* do it */ if sys_info$service_system then do; call terminate_file_ (file_ptr, (9 * file_lth), TERM_FILE_TRUNC_BC_TERM, code); if code ^= 0 then do; /* couldn't cleanup */ call com_err_ (code, qid.editor_name, "^a", pathname_ (dirname, ename)); if explicit_pathname then b.default_untrusted = ^b.default_locked & (b.default_path ^= ""); return ("0"b); end; end; else call bootload_fs_$flush_sys; /* force write */ end; else do; /* Using the caller's input/output area: put the data out and issue truncation warning if necessary */ the_buffer.region_final_lth = file_lth; file_lth = min (file_lth, the_buffer.region_max_lth); call put_data (the_buffer.region_ptr); /* stuff it */ if issue_truncation_warning & (the_buffer.region_final_lth > the_buffer.region_max_lth) then call com_err_ (0, qid.editor_name, "Warning: Buffer ^a will be truncated on exit from the editor.", b.name); end; /* Set default pathname and reset modified flag as appropriate */ /* format: off */ wrote_whole_buffer = ((1 > ilb) & ((fli = ift) & (lle = ife))) | ((ift > ife) & ((fli = 1) & (lle = ilb))) | (((1 <= ilb) & (ift <= ife)) & ((fli = 1) & (lle = ife))); /* format: on */ if b.default_locked then do; /* pathname is locked */ b.default_untrusted = "0"b; /* ... stays modified unless the entire buffer was ... */ b.modified = b.modified & (^wrote_whole_buffer | explicit_pathname); end; /* ... ... written to the default pathname */ else if wrote_whole_buffer then do; /* wrote it all and not locked: set new default pathname */ if sys_info$service_system then if a_real_file & ^qedx_info.caller_does_io then b.default_path = pathname_ (dirname, ename); else b.default_path = the_pathname; /* ... not a real file: pathname isn't expanded */ else b.default_path = the_pathname; b.default_is_region = ^a_real_file; /* ... might have been caller's buffer */ b.modified = "0"b; /* ... it's now safe */ b.default_untrusted = "0"b; /* ... and we trust this pathname */ end; else b.default_untrusted = (b.default_path ^= "");/* didn't write everything */ return ("1"b); /* success */ /* Internal to perform_write: actually moves the data from our buffer into the output area */ put_data: procedure (p_file_ptr); dcl p_file_ptr pointer parameter; dcl (part1_lth, part2_lth) fixed binary (21); if split_data then do; /* data spans the gap ... */ part1_lth = min ((ilb - fli + 1), file_lth); part2_lth = min ((lle - ift + 1), (file_lth - part1_lth)); substr (p_file_ptr -> a_string, 1, part1_lth) = substr (ifp -> a_string, fli, part1_lth); if part2_lth > 0 then /* it all really fits */ substr (p_file_ptr -> a_string, (part1_lth + 1), part2_lth) = substr (ifp -> a_string, ift, part2_lth); end; else substr (p_file_ptr -> a_string, 1, file_lth) = substr (ifp -> a_string, fli, file_lth); return; end put_data; end perform_write; %page; /* Locate line ending with specified character (ale) */ last_line: procedure (ale); dcl ale fixed bin (21); /* index of last character of line to be isolated */ dcl i fixed bin (21); /* position returned from index */ if ale < ift & ale > ilb then /* never - never land in the gap */ le = ilb; else le = ale; /* position at last character of line */ /* Modified last_line search to use index function across gapped buffer. */ li = le - 1; /* miss current NL */ retry: if li >= ift then do; i = index (reverse (substr (ifp -> a_string, ift, li - ift + 1)), NL); /* search upper */ if i = 0 then if ilb > 0 then do; /* move across gap to lower and re-try search */ li = ilb; goto retry; end; else do; /* this must be the first line */ li = ift; return; end; end; else do; /* search lower section */ if li < 1 then do; li = 1; /* force to bottom */ return; end; if li > ilb then li = ilb; /* force across gap */ i = index (reverse (substr (ifp -> a_string, 1, li)), NL); if i = 0 then do; /* not found - force to 1st character */ li = 1; return; end; end; li = li - i + 1; /* setup start index */ /* correct for overstep */ if li = ilb then li = ift; /* force up */ else li = li + 1; /* correct for pointing at NL */ return; /* and return */ end last_line; %page; /* Locate line beginning with specified character (ali) */ next_line: procedure (ali); dcl ali fixed bin (21); /* index of first character of line */ if ali <= ife then do; /* if line address within the buffer file */ if ali < ift & ali > ilb then /* never - never land in the gap */ li = ift; else li = ali; /* isolate line within file */ retry_top: if li <= ilb then do; le = index (substr (ifp -> a_string, li, (ilb - li + 1)), NL); /* attempt to find NL char at end of this line */ if le = 0 & ift <= ife then do; li = ift; goto retry_top; end; end; else le = index (substr (ifp -> a_string, li, (ife - li + 1)), NL); /* attempt to find NL char at end of this line */ if le = 0 then le = ife; /* if no NL found, set line end to end of file */ else le = (li - 1) + le; /* otherwise, compute index of NL within entire file */ end; else do; /* if line address is outside of buffer file */ li = ife + 1; /* set line beginning to next char to be added to file */ le = ife; /* indicate address points outside of buffer */ end; return; end next_line; %page; /* Compute default addresses if necessary */ defaults: procedure (afli, alle); dcl afli fixed bin (21), /* default first index for first address */ alle fixed bin (21); /* default last index for last address */ dcl (qfli, qlle) fixed bin (21); if afli > ilb & afli < ift then qfli = ift; /* fixup default in gap */ else qfli = afli; if alle > ilb & alle < ift then qlle = ift; else qlle = alle; if ^flsw then do; /* if no addresses provided */ fli, lli = qfli; /* fill in addresses with given defaults */ fle, lle = qlle; /* .. */ end; else if ^llsw then do; /* if only one addr, make second addr same as first */ if fli > ilb & fli < ift then lli = ift; else lli = fli; /* .. */ if fle > ilb & fle < ift then lle = ift; else lle = fle; /* .. */ end; if (ift > ife) & (ilb < 1) then do; /* check for empty buffer */ call ioa_ ("Buffer empty."); go to rq_err; end; if (fli = 0) | (lle = 0) | (fli > ife) then do; /* check for address outside of buffer */ call ioa_ ("Address out of buffer."); go to rq_err; end; if fli > lle then do; /* check for address wrap-around */ call ioa_ ("Address wrap-around."); go to rq_err; end; if fli > ife then fli = ilb; /* over-range */ if lli > ife then lli = ilb; if fle > ife then fle = ilb; if lle > ife then lle = ilb; return; end defaults; %page; /* **** input data from input stream, append to text **** This command auxilliary for i,a, and c, calls promote to increase the size of the working text file, prior to moving data from the working line buffer. Promote will move the working file to the next aste pool boundary if space is available and is needed, and may abort the input command if no space is available in a 255K segment. */ input: procedure (afp, afe); /* procedure to append data from console to either file */ dcl afp ptr, /* pointer to file to which data is to be appended */ afe fixed bin (21); /* index of (current) last character in file */ if t.c (ti) = NL then go to rd_line; /* check for NL immediately following input request */ if t.c (ti) = " " then ti = ti + 1; /* skip space following input request */ if ti <= te then go to inp_search; /* pick up any remaining characters from current line */ rd_line: call edx_util_$read_ptr (qid_ptr, tp, length (iline), te); /* read a line (or portion of line) from input stream */ ti = 1; /* initialize character index */ inp_search: k = search (substr (tp -> a_string, ti, te - ti + 1), "\"); /* search for end input (034), conceal (031) or escape ("\") */ if k = 0 then do; /* no special symbol found */ k = te - ti + 2; /* set up string length */ inp_move_string: call promote (k - 1); /* ensure space exists */ substr (afp -> a_string, afe + 1, (k - 1)) = substr (tp -> a_string, ti, (k - 1)); afe = afe + (k - 1); /* update output string index */ if (k - 1) > 0 then b.modified = "1"b; go to rd_line; /* get the next line */ end; kx = index ("\", t.c (ti + (k - 1))); /* which symbol was found? */ go to inp_case (kx); /* handle it */ inp_case (1): ka = 0; /* found single character terminate symbol */ inp_act (1): inp_act (2): inp_final: call promote (k - 1); /* ensure space exists */ substr (afp -> a_string, afe + 1, (k - 1)) = substr (tp -> a_string, ti, (k - 1)); /* move last of input */ afe = afe + (k - 1); /* update output string index */ if (k - 1) > 0 then b.modified = "1"b; ti = ti + k + ka; /* update input string index */ return; /* done with input */ inp_case (2): ka = 0; /* found single character conceal */ inp_act (3): inp_act (4): inp_conceal: if (ti + k + ka) > te then go to inp_move_string; /* check length for character to conceal */ call promote (k); /* ensure space xists */ substr (afp -> a_string, afe + 1, k) = substr (tp -> a_string, ti, (k - 1)) || t.c (ti + k + ka); /* move string and concealed character */ afe = afe + k; /* update output string */ if k > 0 then b.modified = "1"b; ti = (ti + k + ka) + 1; /* update input string */ if ti > te then go to rd_line; /* get the next input line */ else go to inp_search; /* continue the search */ inp_case (3): ka = 1; /* escape character found */ kx = index ("fFcC", t.c (ti + k)); /* is this end input or conceal */ if kx = 0 /* it is neither */ then do; call promote (k); /* ensure space exists */ substr (afp -> a_string, afe + 1, k) = substr (tp -> a_string, ti, k); /* copy everything */ afe = afe + k; /* update output string */ if k > 0 then b.modified = "1"b; ti = ti + k; /* update input string */ if ti > te then go to rd_line; else go to inp_search; end; go to inp_act (kx); /* otherwise end input or conceal */ end input; %page; /* **** interrupt handling **** Interrupt handling is done in one of two modes, either we want to be interrupted and the current operation suspended, or we don't. This interrupt processing includes some verbosity to indicate what has happened. */ interrupt: procedure (); /* procedure to handle program interrupts */ if pi_sw then do; /* are we currently accepting program interrupts */ pi_sw = "0"b; /* if so, reset enable switch */ go to pi_label; /* and do a non-local go to specified location */ end; else do; /* if no label assigned to handle interrupt */ intsw = "1"b; /* set switch to indicate interrupt occurred */ return; /* and otherwise ignore the program interrupt */ end; end interrupt; %page; /* **** Promote **** This is an auxilliary routine called each time data is added to the working text buffer. It will check to ensure that the gap is big enough to contain the data. Otherwise it will grow the working file to a size great enough to contain the data. This is done by determining which aste pool size will be needed, and then moving the top section of the working buffer to the top of the new aste size. Pointers are then cleaned up and editing can continue. If there cannot be enough space left in a max len segment, then promote will dump an error message to the terminal, and will abort the current operation. This will mean that the current line will be lost for terminal input, and that the entire read will not be done for reading. */ promote: procedure (string_length); dcl string_length fixed bin (21); dcl (new_fe, new_ft) fixed bin (21); dcl offset_action fixed bin (21); if (ife - ift + 1) + (ilb) + string_length > ife then do; /* determine end of next pool */ new_fe = ife; do while ((ife - ift + 1) + ilb + string_length > new_fe); if new_fe >= sys_info$max_seg_size * 4 then do; /* error on size */ if pi_label = sub_done then do; call ioa_ ("^a: Segment full!! Skipping remaining substitutions.", qid.editor_name); goto sub_done; end; if pi_label = in_mode then call ioa_ ("^a: Segment full!! Last line of input lost - back to command mode.", qid.editor_name); else call ioa_ ("^a: Read will not fit in buffer - read not performed.", qid.editor_name); if pi_label = in_mode then call last_line (ilb); /* fixup last line input for input cleanup */ goto rq_err; end; else new_fe = min (new_fe * 4, sys_info$max_seg_size * 4); end; new_ft = ift - ife + new_fe; if ife - ift >= 0 then do; /* top exists and must be moved */ call mrl_ (addr (substr (ifp -> a_string, ift)), (ife - ift + 1), addr (substr (ifp -> a_string, new_ft)), (ife - ift + 1)); end; /* update current line pointers if they fall within the upper part. */ offset_action = new_ft - ift; if lle >= ift then lle = lle + offset_action; if lli >= ift then lli = lli + offset_action; if le >= ift then le = le + offset_action; if li >= ift then li = li + offset_action; if mi >= ift then mi = mi + offset_action; if me >= ift then me = me + offset_action; if fli >= ift then fli = fli + offset_action; if b.ti >= ift then do; b.ti = b.ti + offset_action; b.te = b.te + offset_action; end; ife = new_fe; ift = new_ft; end; end promote; %page; /* Open_gap is used to open a processing gap in the text buffer at the point of the current line. This may require text to be moved up or down at the current gap. When data has been moved appropriate pointers are cleaned up and moved if they were in the section of text which was moved. */ open_gap: procedure (gap_index); /* gap is opened after the specified index */ dcl gap_index fixed bin (21); dcl offset_action fixed bin (21); dcl gap fixed bin (21); if ilb ^= gap_index & ift - 1 ^= gap_index then do; /* gap not at current index */ if gap_index <= ilb then do; /* index in bottom, move upper bottom up */ gap = ilb - gap_index; call mrl_ (addr (substr (ifp -> a_string, gap_index + 1)), gap, addr (substr (ifp -> a_string, ift - gap)), gap); offset_action = -gap_index + ift - gap - 1; /* form offset for index movement */ if li <= ilb & li > gap_index then li = li + offset_action; if le <= ilb & le > gap_index then le = le + offset_action; if lli <= ilb & lli > gap_index then lli = lli + offset_action; if lle <= ilb & lle > gap_index then lle = lle + offset_action; if fli <= ilb & fli > gap_index then fli = fli + offset_action; if fle <= ilb & fle > gap_index then fle = fle + offset_action; if b.ti <= ilb & b.ti > gap_index then b.ti = b.ti + offset_action; ift = ift - gap; ilb = ilb - gap; if b.ti <= ilb then b.te = ilb; else b.te = ife; end; else do; gap = gap_index - ift + 1; substr (ifp -> a_string, ilb + 1, gap) = substr (ifp -> a_string, ift, gap); offset_action = -ift + ilb + 1; /* offset for index move */ if li >= ift & li <= gap_index then li = li + offset_action; if le >= ift & le <= gap_index then le = le + offset_action; if lli >= ift & lli <= gap_index then lli = lli + offset_action; if lle >= ift & lle <= gap_index then lle = lle + offset_action; if b.ti >= ift & b.ti <= gap_index then b.ti = b.ti + offset_action; if fli >= ift & fli <= gap_index then fli = fli + offset_action; if fle >= ift & fle <= gap_index then fle = fle + offset_action; ilb = ilb + gap; ift = ift + gap; if b.ti <= ilb then b.te = ilb; else b.te = ife; end; end; end open_gap; %page; %include qedx_internal_data; %page; %include qedx_info; %page; %include qedx_buffer_io_info; %page; %include access_mode_values; %include sub_err_flags; %include terminate_file; end qedx_;  search_file_.pl1 11/11/89 1109.4r 11/11/89 0805.5 214929 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: off */ /* search_file_ ... qedx utility procedure to search addressed portion of buffer with specified regular expression */ /* This procedure parses a regular expression and stores an executable version of same in its internal storage. A regular expression can contain up to 132 characters and up to 20 subexpressions as defined below. Certain special cases are recognized and optimized. The follow subexpressions are currently supported: Type Meaning 0 The first string search of the regular expression. 1 The first string search of the regular expression has an initial newline. Anchor search to the beginning of a line. 2 A string search following a dot-star subexpression. 3 A string search following a star or dot subexpression. 4 A star subexpression. 5 A dot subexpression. */ /* The following non-standard error codes are returned by search_file_: 1 Search failed. 2 Invalid syntax in a regular expression. (A message is always printed.) */ /* Initial coding by R. C. Daley, August 1970 */ /* Recoded in V2 PL/I by D. S. Levin, August 1974 */ /* Modified for gapped buffer first line detection by T. Oke 80-07-14. */ /* Changes merged and edited 03/03/82 S. Herbst */ /* Fixed argument reference bug 11/03/82 S. Herbst */ /* Added $silent 11/12/82 S. Herbst */ /* Modified: January 1983 by G. Palter to make reentrant and always return standard codes for $silent entrypoint */ /* format: on,style4,delnl,insnl,ifthenstmt,ifthen */ /* Previous compatability entry point for mail system use */ search_file_: proc (atp, ati, atl, afp, afi, afe, ami, ame, acode); dcl atp ptr, /* Pointer to string containing regular expression. */ ati fixed bin (21), /* Index of first character of regular expression. */ atl fixed bin (21), /* Length of regular expression. */ afp ptr, /* Pointer to buffer file to be searched. */ afi fixed bin (21), /* Index of first character to be searched. */ afe fixed bin (21), /* Index of last character to be searched. */ ami fixed bin (21), /* Index of first character of string matched (Output). */ ame fixed bin (21), /* Index of last character of string matched (Output). */ alb fixed bin (21), /* start of lower buffer */ aft fixed bin (21), /* start of upper buffer */ acode fixed bin (35), /* Error status code (Output) */ P_qid_ptr pointer parameter; /* -> qedx internal data */ dcl (tp, fp) ptr, /* Automatic storage. */ silent_sw bit (1), /* ON for search_file_$silent */ (lb, ft, ti, tl, te, fi, fe, j) fixed bin (21), match_start (20) fixed bin (21), /* Index of first character of match. */ reentry_point (20) fixed bin (21), /* Restart or reentry stack. Reenter if element ^= 0. */ (i, l, type, st, last_string, last_star) fixed bin; dcl 1 rd aligned based (rd_ptr), /* completely describes a regular expression */ 2 reg_info (20), 3 search_char char (1) unal, 3 len fixed bin (8) unaligned, 3 start fixed bin (8) unaligned, 3 search_type fixed bin (8) unaligned, 2 regl fixed binary (21), /* length of the regular expression */ 2 omit_newline bit (1) aligned, /* differentiates between $ and \cNL */ 2 reg character (132); /* string accumulator */ dcl rd_ptr pointer; dcl 1 external_rd static aligned like rd; /* for use by non-qedx entrypoints */ dcl first_call bit (1) aligned static initial ("1"b); /* ... so non-qedx entrypoints can initialize above */ dcl /* Constants. */ special_char char (5) aligned internal static initial (".*\$"), /* 5th character is \c. */ nl char (1) aligned internal static initial (" "); dcl exp char (te) based aligned; dcl text char (fe) based aligned; dcl error_table_$nomatch fixed binary (35) external; dcl error_table_$regexp_invalid_star fixed bin (35) ext; dcl error_table_$regexp_too_complex fixed bin (35) ext; dcl error_table_$regexp_too_long fixed bin (35) ext; dcl error_table_$regexp_undefined fixed bin (35) ext; dcl ioa_ entry options (variable); dcl (hbound, index, length, search, substr, unspec, verify) builtin; %page; silent_sw = "0"b; /* normal entry point prints error messages */ go to RETAINED_COMMON; silent: entry (atp, ati, atl, afp, afi, afe, ami, ame, acode); silent_sw = "1"b; RETAINED_COMMON: lb = afe; /* presets lb and ft for single buffer */ ft = lb + 1; /* first section full, second section empty */ rd_ptr = addr (external_rd); /* use non-qedx saved expression (if any) */ if first_call then do; /* ... need to initialize the expression */ first_call = "0"b; rd.regl = 0; /* ... no initial saved expression */ end; go to COMMON; /* qedx only */ qx_search_file_: entry (P_qid_ptr, atp, ati, atl, afp, afi, afe, ami, ame, alb, aft, acode); silent_sw = "0"b; /* qedx relies on this entrypoint to print error messages */ lb = alb; ft = aft; qid_ptr = P_qid_ptr; /* get saved regular expression (if any) */ rd_ptr = qid.regexp_data_ptr; COMMON: tp = atp; /* Pointer to string containing regular expression. */ ti = ati; /* Index of first character of regular expression. */ tl = atl; /* Length of regular expression. */ fp = afp; /* Pointer to buffer area to be searched. */ fi = afi; /* Index of first character of area to be searched. */ fe = afe; /* Index of last character of area to be searched. */ if tl = 0 /* Check for null regular expression "//". */ then if rd.regl > 0 /* "//" given, use previous regular expression if any. */ then go to match; else do; if silent_sw then acode = error_table_$regexp_undefined; else call ioa_ ("// undefined in regular expression."); /* Error, // and no previous regular expression. */ fatal: rd.regl = 0; /* No previous regular expression. */ if ^silent_sw then acode = 2; /* Fatal error. Cannot be retried. */ return; end; te = ti + tl - 1; /* Get index of last character of regular expression. */ st = 1; /* Initialize string accumulator length to zero. */ l = 0; /* Initialize sub-expression string length to zero. */ type = 0; /* Assume simple expression until we know otherwise. */ if substr (tp -> exp, ti, 1) = "^" /* Anchor to the beginning of line? */ then do; /* Yes, make first character a newline. */ type = 1; /* String must begin at newline. */ ti = ti + 1; /* Get next character. */ substr (rd.reg, 1, 1) = nl; /* First character is a newline. */ st = st + 1; /* Length does not include newline. */ end; rd.regl = 0; /* Initialize to no subexpressions. */ last_string = 0; /* Index to immediately previous string search. */ last_star = 0; /* Index to immediately previous star subexpression. */ rd.omit_newline = "0"b; /* No "$" found. Do not shorten matched string. */ parse_expression: /* Parse the regular expression, forming subexpressions. */ tl = te - ti + 1; /* Get the length of the remainder of the RE. */ if tl <= 0 then goto expression_parsed; /* No more regular expr. Go execute what we have. */ i = search (substr (tp -> exp, ti, tl), special_char) - 1; /* Find first special character. */ if i < 0 then i = tl; /* None found. Get number of remaining characters. */ if i > 0 /* If count is nonzero, add those characters to string. */ then do; if st + l + i > length (rd.reg) then go to long_string; /* Can't store all those characters. */ substr (rd.reg, st + l, i) = substr (tp -> exp, ti, i); /* Add the characters to the string. */ l = l + i; /* Bump the string length. */ ti = ti + i; /* Skip those characters in the regular expression. */ if ti > te then go to expression_parsed; /* If no special characters then done parsing. */ end; go to special_case (index (special_char, substr (tp -> exp, ti, 1))); /* Go to appropriate routine. */ special_case (1): /* Period or dot. */ call end_sub_expression; /* Previous string search must be terminated. */ i = 0; /* Initialize to only one occurance of dot. */ tl = te - ti + 1; /* Get the length of the remainder of the RE. */ if tl - 1 > 0 then i = verify (substr (tp -> exp, ti + 1, tl - 1), "."); /* Count all following dots. */ if i = 0 then i = tl; /* This equals the total number of dots. */ ti = ti + i; /* Skip over all the dots. */ if ti <= te then if substr (tp -> exp, ti, 1) = "*" /* Last dot is part of ".*". */ then do; type = 2; /* Indicates next string search is preceeded by ".*". */ ti = ti + 1; /* Skip over "*". */ i = i - 1; /* Reduce dot count by one. */ end; if i > 0 then call builder (5, i); /* Dot subexpression. Dot-star stored by end_sub_expression */ if type ^= 2 then type = 3; /* No dot-star, just a normal string search. */ go to parse_expression; /* Continue. */ special_case (2): /* Asterisk or star. */ if l = 0 /* No character precedes the star. */ then do; if silent_sw then acode = error_table_$regexp_invalid_star; else call ioa_ ("Invalid use of * in regular expression."); go to fatal; end; l = l - 1; /* The character must be removed from previous string. */ ti = ti + 1; /* Skip the star. */ call end_sub_expression; /* Build search subexpression for previous string. */ if type = 2 then go to parse_expression; /* Do not build if star preceded by dot-star. */ if rd.regl > 0 & rd.regl = last_star /* Do not build if previous subexpression is identical. */ then if rd.reg_info (last_star).search_char = substr (rd.reg, st, 1) then go to parse_expression; call builder (4, 0); /* A star subexpression. */ last_star = rd.regl; /* This is now the most recent star subexpression. */ rd.reg_info (last_star).search_char = substr (rd.reg, st, 1); /* Store character for star subexpression. */ type = 3; /* No dot-star, just a normal string search. */ go to parse_expression; /* Continue the parse. */ special_case (3): /* Backslash. Could be part of \c or \C. */ if ti = te then go to store_char; /* Obviously no character follows it. */ if substr (tp -> exp, ti + 1, 1) ^= "c" & substr (tp -> exp, ti + 1, 1) ^= "C" then go to store_char; ti = ti + 1; /* Found "\c" or "\C". Skip the backslash. */ special_case (5): /* Backslash-c as single character. */ ti = ti + 1; /* Skip the "\c", or skip "c" from above. */ store_char: /* Add a single character to the string being created. */ if st + l = length (rd.reg) /* Check for string overflow. */ then do; long_string: /* Expression has too many characters. */ if silent_sw then acode = error_table_$regexp_too_long; else call ioa_ ("Regular expression is too long."); go to fatal; end; substr (rd.reg, st + l, 1) = substr (tp -> exp, ti, 1); /* Add the character. */ ti = ti + 1; /* Continue scan with next character. */ l = l + 1; /* Bump string length. */ go to parse_expression; /* Continue parse. */ special_case (4): /* Dollar sign or end of line anchor. */ if ti ^= te then go to store_char; /* Special meaning only at end of expression. */ rd.omit_newline = "1"b; /* Found a "$". Omit newline at end of string. */ if st + l = length (rd.reg) then go to long_string; /* No room. */ substr (rd.reg, st + l, 1) = nl; /* Store a newline to provide the anchor. */ l = l + 1; /* Adjust string length. */ ti = ti + 1; /* Now we are done. */ /* End of parsing loop. */ expression_parsed: call end_sub_expression; /* Create final search subexpression, if any. */ if type = 2 then call builder (2, 0); /* Dot-star is last subexpression of RE. */ %page; match: if fe = 0 | fi > fe then go to fail; /* Search fails on empty buffer. */ do i = 1 to rd.regl; /* Reset the reentry stack to no reentry points. */ reentry_point (i) = 0; end; restart_search: /* Match the entire regular expression. */ match_start (1) = fi; /* Assume expression is anchored. */ i = 1; /* Initialize to first subexpression. */ st = 1; /* Start at the beginning of the string accumulator. */ te = fi - 1; /* Initialize to zero length string. */ search_loop: tl = fe - fi + 1; /* Get length of remainder of the text buffer. */ l = rd.reg_info (i).len; /* Get length field. */ go to string_search (rd.reg_info (i).search_type);/* Execute the subexpression. */ string_search (0): /* Initial search without initial newline. */ if l > tl then go to fail; /* Not enough characters to satisfy the match. */ j = index (substr (fp -> text, fi, tl), substr (rd.reg, 1, l)) - 1; /* Find occurance of the string. */ if j < 0 then go to fail; /* Not there. Search fails. */ st = st + l; /* Skip over string in accumulator. */ go to found_first_match; /* Go save all information about first match. */ string_search (1): /* Initial search with initial newline. */ if fi > 1 & (lb > 0 | fi ^= ft) then do; /* not first line of buffer */ if (lb > 0 & fi = ft) then do; /* pointers will be valid for check */ if substr (fp -> text, lb, 1) = nl then goto nl_found; /* nl end of first section */ end; else if substr (fp -> text, fi - 1, 1) = nl then goto nl_found; /* nl is previous char */ j = index (substr (fp -> text, fi, tl), nl); /* Search for newline. */ if j = 0 then go to fail; /* No more lines. Search fails. */ fi = fi + j; /* Go to first character after newline. */ tl = tl - j; /* Reduce the buffer length. */ if tl <= 0 then go to fail; /* That newline was the last character in buffer. */ end; nl_found: st = st + l + 1; /* Point to next string. Skip this string and newline. */ j = 0; /* Offset if string matches the current line. */ if l = 0 then go to found_first_match; /* Just had to find the beginning of a line. */ if l > tl then go to fail; /* Not enough characters to satisfy the match. */ if substr (fp -> text, fi, l) ^= substr (rd.reg, 2, l) /* Check this line but omit newline. */ then do; /* Not in current line. Search remainder of buffer. */ j = index (substr (fp -> text, fi, tl), substr (rd.reg, 1, l + 1)); /* Include the newline in the search. */ if j = 0 then go to fail; /* Not found in buffer. Search fails. */ end; found_first_match: match_start (1) = fi + j; /* This is first search. The match starts here. */ go to found_field; /* Get next subexpression. */ string_search (2): /* Dot-star string search. Match as few characters as possible. */ if l = 0 /* If length is zero, then RE ends with ".*". */ then do; /* Treat like ".*$". */ te = fi + index (substr (fp -> text, fi, tl), nl) - 2; /* Find end of the current line, without newline. */ if te < fi - 1 then te = fe; /* No newline, take the rest of the buffer. */ go to next_field; /* Pretend there is something next. */ end; if l > tl then go to fail_reset; /* Must have enough characters for the match. */ j = index (substr (fp -> text, fi, tl), substr (rd.reg, st, l)) - 1; /* Find a match. */ if j < 0 then go to fail_reset; /* None found. Could be someone else's fault. */ te = 0; /* If offset is zero, there is no newline. */ if j > 0 then te = index (substr (fp -> text, fi, j), nl); /* Dot does not match a newline. */ if te > 0 /* At least one intervening newline. */ then do; /* Advance one line and try again. */ fi = fi + te; /* Point to next line. */ reentry_point (i) = 0; /* Remove from stack until needed. */ go to restart_search; /* Try to match entire RE. */ end; reentry_point (i) = fi + j + 1; /* Stack a reentry point if future subexpression fails. */ st = st + l; /* Advance string offset pointer. */ go to found_field; /* Tell everyone we found something. */ string_search (3): /* Search subexpression. Match string at current buffer position. */ if l > tl then go to fail_retry; /* Cannot match if not enough characters. */ j = 0; /* Offset if the following is a match. */ if substr (fp -> text, fi, l) ^= substr (rd.reg, st, l) then go to fail_retry; /* Do they match? */ st = st + l; /* Skip over string in accumulator. */ go to found_field; /* Get next subexpression. */ string_search (4): /* Star subexpression. Match as many of a particular character as possible. */ reentry_point (i) = 0; /* Assume a match on zero length string. */ if tl <= 0 then go to next_field; /* Match a zero length string. */ match_start (i) = fi; /* Match starts at current buffer position. */ l = verify (substr (fp -> text, fi, tl), rd.reg_info (i).search_char) - 1; /* Count the occurances. */ if l < 0 then l = tl; /* Rest of buffer is a match. */ if l = 0 then go to next_field; /* Matches a zero length string. */ reentry_point (i) = fi + l - 1; /* Restart point matches one fewer characters. */ j = 0; /* String offset for the match. */ go to found_field; string_search (5): /* Dots. */ if tl < l then go to fail_retry; /* Must have enough characters. */ j = 0; /* Offset. */ if index (substr (fp -> text, fi, l), nl) ^= 0 /* Dot does not match a newline. */ then go to fail_retry; /* Dot does not match a newline. */ found_field: /* Code to store a match. */ fi = fi + j + l; /* Next search will begin immediately after match. */ te = fi - 1; /* Address of last matched character. */ next_field: /* Get next subexpression. */ i = i + 1; /* Bump subexpression counter. */ if i <= rd.regl then go to search_loop; /* Execute next subexpression or match SUCCEEDS! */ if rd.omit_newline /* If last char is "$", do not match final newline. */ then te = te - 1; /* Match the line without the newline character. */ ami = match_start (1); /* Return index of first character matched. */ ame = te; /* Return index of last character matched. */ acode = 0; return; fail_reset: /* A reentry point is no longer valid. Reset it. */ reentry_point (i) = 0; fail_retry: /* A subexpression failed. Iterate if possible. */ i = i - 1; /* Try previous subexpression. */ if i <= 0 then do; match_start (1) = match_start (1) + 1; /* Restart one character further in. */ if match_start (1) > fe /* Search fails on empty buffer. */ then do; fail: /* Regular expression cannot be matched. */ if silent_sw then acode = error_table_$nomatch; /* always return standard codes for search_file_$silent */ else acode = 1; return; end; fi = match_start (1); /* Get new starting offset. */ go to restart_search; end; fi = reentry_point (i); /* Pick up a potential restart point. */ if fi = 0 then go to fail_retry; /* Must be a useful restart point. */ st = rd.reg_info (i).start; /* It's OK. Reset the string accumulator offset. */ if rd.reg_info (i).search_type = 2 then go to search_loop; /* It's ".*". Go find next occurrence of string. */ if reentry_point (i) < match_start (i) then go to fail_reset; /* It's "a*". No restart if no a's matched. */ reentry_point (i) = reentry_point (i) - 1; /* Decrement number of a's matched. */ go to next_field; %page; /* Initializes qedx per-invocation regular expression data */ init: entry (P_qid_ptr); qid_ptr = P_qid_ptr; allocate rd in (editor_area) set (rd_ptr); rd.regl = 0; /* no saved regular expression yet */ qid.regexp_data_ptr = rd_ptr; return; /* Terminates qedx per-invocation regular expression data */ cleanup: entry (P_qid_ptr); qid_ptr = P_qid_ptr; if qid.regexp_data_ptr ^= null () then do; free qid.regexp_data_ptr -> rd in (editor_area); qid.regexp_data_ptr = null (); end; return; %page; /* Creates current search subexpression */ end_sub_expression: procedure (); dcl (dot_count, ir) fixed bin; if l > 0 | type = 1 /* If current search string subexpression outstanding. */ then do; if type = 2 /* A string search preceded by ".*". */ then do; dot_count = 0; /* initialize to no dots. */ do ir = rd.regl to last_string + 1 by -1; /* Scan the RE. */ if rd.reg_info (ir).search_type = 5/* A dot subexpressionn. */ then dot_count = dot_count + rd.reg_info (ir).len; /* Add in its count. */ else if rd.reg_info (ir).search_type ^= 4 /* A star subexpression. */ then go to done_dot_star; rd.regl = rd.regl - 1; /* Remove dot or star subexpression from RE. */ end; done_dot_star: if dot_count > 0 then call builder (5, dot_count); /* Build dot subexpression if necessary. */ last_star = 0; /* Forget about those star subexpressions. */ end; if last_string = rd.regl - 1 & last_star = rd.regl /* Optimize ab*b to abb*. Also b*b to bb*. */ then do; ir = verify (substr (rd.reg, st, l), rd.reg_info (last_star).search_char) - 1; if ir < 0 then ir = l; /* Entire string matches the character. */ if ir > 0 /* Move the matches to the previous string. */ then do; if last_string = 0 /* Oops, there was really no previous string. */ then do; /* Guess we'll have to make one. */ last_string = 1; /* String search is first subexpression. */ unspec (rd.reg_info (2)) = unspec (rd.reg_info (1)); /* Copy star subexpression. */ last_star = last_star + 1; /* Remember that. */ rd.reg_info (2).start = ir + 1; /* Set the correct accumulator offset. */ rd.reg_info (1).search_type = 0; /* First subexpression is a string search. */ rd.regl = 2; /* Now there are two subexpressions. */ end; rd.reg_info (last_string).len = rd.reg_info (last_string).len + ir; /* Add to previous string length. */ st = st + ir; /* Bump offset pointer. */ l = l - ir; /* Reduce string length. */ if l = 0 then return; /* String is eliminated. */ end; end; call builder (type, l); /* Any type of search string subexpression. */ type = 3; /* Set to 3 in case it was 0, 1, or 2. */ last_string = rd.regl; /* Remember position of last string. */ st = st + l; /* Bump accumulator offset. */ l = 0; /* Initialize string length to zero. */ end; return; end end_sub_expression; %page; /* Creates any subexpression */ builder: procedure (id, size); dcl (id, size) fixed bin; if rd.regl = hbound (rd.reg_info, 1) /* Insure we have not exceeded the stack. */ then do; if silent_sw then acode = error_table_$regexp_too_complex; else call ioa_ ("Regular expression is too complex."); go to fatal; end; rd.regl = rd.regl + 1; /* Bump stack size. */ rd.reg_info (rd.regl).search_type = id; /* Store type of subexpression. */ rd.reg_info (rd.regl).len = size; /* Store length of the subexpression. */ rd.reg_info (rd.regl).start = st; /* Store accumulator offset. */ return; end builder; %page; %include qedx_internal_data; end search_file_; bull_copyright_notice.txt 08/30/05 1008.4r 08/30/05 1007.3 00020025 ----------------------------------------------------------- Historical Background This edition of the Multics software materials and documentation is provided and donated to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. as a contribution to computer science knowledge. This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology, Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull and Bull HN Information Systems Inc. to the development of this operating system. Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970), renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for managing computer hardware properly and for executing programs. Many subsequent operating systems incorporated Multics principles. Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. . ----------------------------------------------------------- Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without fee is hereby granted,provided that the below copyright notice and historical background appear in all copies and that both the copyright notice and historical background and this permission notice appear in supporting documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining to distribution of the programs without specific prior written permission. Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc. Copyright 2006 by Bull HN Information Systems Inc. Copyright 2006 by Bull SAS All Rights Reserved