1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48 qedx_:
49 procedure (P_qedx_info_ptr, P_code);
50
51
52 dcl P_qedx_info_ptr pointer parameter;
53 dcl P_code fixed binary (35) parameter;
54
55 dcl a_real_file bit (1) aligned;
56 dcl b0_bp ptr;
57 dcl b0_ifp ptr;
58 dcl buffer_idx fixed binary;
59 dcl callers_io_region_ptr pointer;
60 dcl ch char (1);
61 dcl cht char (1);
62 dcl code fixed bin (35);
63 dcl curbuf char (16) init ("0");
64 dcl delim char (1);
65 dcl error_sw ptr;
66 dcl explicit_pathname bit (1) aligned;
67 dcl fe fixed bin (21);
68 dcl fle fixed bin (21);
69 dcl fli fixed bin (21);
70 dcl flsw bit (1);
71 dcl fp ptr;
72 dcl have_truncated_buffers bit (1) aligned;
73 dcl i fixed bin (21);
74 dcl ife fixed bin (21);
75 dcl ifp ptr;
76 dcl ift fixed bin (21);
77 dcl ignore_result bit (1) aligned;
78 dcl il fixed bin (21);
79 dcl ilb fixed bin (21);
80 dcl iline char (512);
81 dcl intsw bit (1);
82 dcl j fixed bin (21);
83 dcl je fixed bin (21);
84 dcl k fixed bin (21);
85 dcl ka fixed bin (21);
86 dcl kx fixed bin (21);
87 dcl l fixed bin (21);
88 dcl le fixed bin (21);
89 dcl li fixed bin (21);
90 dcl lle fixed bin (21);
91 dcl lli fixed bin (21);
92 dcl llsw bit (1);
93 dcl 1 local_qbii aligned like qedx_buffer_io_info;
94 dcl 1 local_qid aligned like qid;
95 dcl me fixed bin (21);
96 dcl mi fixed bin (21);
97 dcl ml fixed bin (21);
98 dcl new_modes char (256);
99 dcl old_modes char (256);
100 dcl output_routine entry (ptr, ptr, fixed bin (21), fixed bin (35)) variable;
101 dcl output_sw ptr;
102 dcl pfs fixed bin (35) init (0);
103 dcl pi_label label;
104 dcl pi_sw bit (1);
105 dcl process_type fixed bin;
106 dcl quit_force_sw bit (1);
107 dcl saved_current_buffer character (16);
108 dcl saved_ift fixed bin (21);
109 dcl sdsw bit (1);
110 dcl subsw bit (1);
111 dcl sub_comp_string character (3) aligned init (" ");
112 dcl tbp ptr;
113 dcl te fixed bin (21);
114 dcl 1 the_buffer aligned like qedx_info.buffers based (the_buffer_ptr);
115 dcl the_buffer_ptr pointer;
116 dcl the_pathname character (256);
117 dcl ti fixed bin (21);
118 dcl tik fixed bin (21);
119 dcl tname char (16);
120 dcl tp ptr;
121 dcl twbuff char (512);
122 dcl was_empty bit (1) aligned;
123 dcl xsw bit (1);
124 dcl yes_sw bit (1);
125
126
127
128
129
130
131 dcl ilb_offset fixed bin (21);
132
133 dcl COMMANDS character (19) static options (constant) initial ("psaicdbmrwqg=xevn""Q");
134 dcl command_index fixed binary;
135
136 dcl QEDX_ character (32) static options (constant) initial ("qedx_");
137
138 dcl QEDX_INFO_VERSION_0 character (8) static options (constant) initial ("qxi_0001");
139
140 dcl MODIFIED_BUFFERS_EXPLANATION character (104) static options (constant)
141 initial ("If you quit now, your latest changes to the above buffers will not be
142 saved. Do you still wish to quit?");
143
144 dcl TRUNCATED_BUFFERS_EXPLANATION character (100) static options (constant)
145 initial ("If you quit now, some of the contents of the above buffers will be
146 lost. Do you still wish to quit?");
147
148 dcl TRUSTED_PATHNAMES_EXPLANATION character (198) static options (constant)
149 initial ("More than one pathname has been used with the read and write requests
150 in this buffer. Do you want to ^a this buffer using the pathname ^a
151 which I consider to be the correct default for this buffer?");
152
153 dcl 1 t based (tp) aligned,
154 2 c (sys_info$max_seg_size * 4) char (1) unaligned;
155
156 dcl 1 f based aligned,
157 2 c (sys_info$max_seg_size * 4) char (1) unaligned;
158
159 dcl a_string char (sys_info$max_seg_size * 4) based aligned;
160
161 dcl CHASE fixed binary (1) static options (constant) initial (1);
162
163 dcl EC character (1) static options (constant) initial ("^Y");
164
165
166 dcl NL character (1) static options (constant) initial ("
167 ");
168
169
170 dcl (error_table_$archive_component_modification, error_table_$archive_pathname, error_table_$bigarg, error_table_$dirseg,
171 error_table_$fatal_error, error_table_$inconsistent, error_table_$moderr, error_table_$no_r_permission,
172 error_table_$no_w_permission, error_table_$pathlong, error_table_$recoverable_error,
173 error_table_$unimplemented_version)
174 fixed binary (35) external;
175
176 dcl sys_info$max_seg_size fixed binary (19) external;
177 dcl sys_info$service_system bit (1) aligned external;
178
179 dcl (cleanup, program_interrupt, sub_request_abort_) condition;
180
181 dcl bce_data$console_put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)) external variable;
182 dcl bce_data$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)) external variable;
183 dcl iox_$user_output ptr ext;
184 dcl iox_$user_io ptr ext;
185
186 dcl bce_check_abort entry;
187 dcl bce_query$yes_no entry options (variable);
188 dcl bootload_fs_$flush_sys entry;
189 dcl bootload_fs_$get_ptr entry (char (*), ptr, fixed bin (21), fixed bin (35));
190 dcl bootload_fs_$put_ptr entry (char (*), fixed bin (21), bit (1) aligned, ptr, fixed bin (35));
191 dcl check_entryname_ entry (char (*), fixed bin (35));
192 dcl com_err_ entry () options (variable);
193 dcl command_query_$yes_no entry options (variable);
194 dcl cu_$cp entry (ptr, fixed bin (21), fixed bin (35));
195 dcl edx_util_$edx_cleanup entry (ptr);
196 dcl edx_util_$edx_init entry (ptr, ptr, ptr, ptr, fixed bin (35));
197 dcl edx_util_$end_buffer entry (ptr, fixed bin (35));
198 dcl edx_util_$get_buffer entry (ptr, ptr, fixed bin (21), fixed bin (21), char (16), ptr);
199 dcl edx_util_$list_buffers entry (ptr, char (16), ptr);
200 dcl edx_util_$list_modified_buffers entry (pointer, character (16), pointer);
201 dcl edx_util_$list_single_buffer entry (pointer, character (16), pointer, pointer);
202 dcl edx_util_$locate_buffer entry (ptr, char (16), ptr);
203 dcl edx_util_$modified_buffers entry (ptr) returns (bit (1));
204 dcl edx_util_$prime entry (ptr, ptr, fixed bin (21));
205 dcl edx_util_$read_ptr entry (ptr, ptr, fixed bin (21), fixed bin (21));
206 dcl edx_util_$resetread entry (ptr);
207 dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
208 dcl expand_pathname_$component entry (char (*), char (*), char (*), char (*), fixed bin (35));
209 dcl get_addr_
210 entry (ptr, ptr, fixed bin (21), fixed bin (21), ptr, fixed bin (21), fixed bin (21), fixed bin (21),
211 fixed bin (21), fixed bin (21), fixed bin (21), fixed bin (21), fixed bin (35));
212 dcl get_system_free_area_ entry () returns (ptr);
213 dcl get_temp_segment_ entry (char (*), ptr, fixed bin (35));
214 dcl hcs_$status_minf entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35));
215 dcl initiate_file_$component entry (char (*), char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35));
216 dcl initiate_file_$create entry (char (*), char (*), bit (*), ptr, bit (1) aligned, fixed bin (24), fixed bin (35));
217 dcl ioa_ entry () options (variable);
218 dcl ioa_$ioa_switch entry () options (variable);
219 dcl iox_$modes entry (ptr, char (*), char (*), fixed bin (35));
220 dcl iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35));
221 dcl mrl_ entry (ptr, fixed bin (21), ptr, fixed bin (21));
222 dcl pathname_ entry (char (*), char (*)) returns (char (168));
223 dcl pathname_$component entry (char (*), char (*), char (*)) returns (char (194));
224 dcl qx_search_file_
225 entry (ptr, ptr, fixed bin (21), fixed bin (21), ptr, fixed bin (21), fixed bin (21), fixed bin (21),
226 fixed bin (21), fixed bin (21), fixed bin (21), fixed bin (35));
227 dcl qx_search_file_$cleanup entry (ptr);
228 dcl qx_search_file_$init entry (ptr);
229 dcl release_temp_segment_ entry (char (*), ptr, fixed bin (35));
230 dcl sub_err_ entry () options (variable);
231 dcl terminate_file_ entry (ptr, fixed bin (24), bit (*), fixed bin (35));
232 dcl user_info_$process_type entry (fixed bin);
233
234 dcl (addr, divide, index, min, null, search, substr, length, reverse, rtrim, string) builtin;
235 %page;
236
237
238
239
240 if sys_info$service_system then do;
241 output_routine = iox_$put_chars;
242 output_sw = iox_$user_output;
243 error_sw = iox_$user_io;
244 end;
245 else do;
246 output_routine = bce_data$put_chars;
247 error_sw = addr (bce_data$console_put_chars);
248 output_sw = addr (bce_data$put_chars);
249 end;
250
251 qedx_info_ptr = P_qedx_info_ptr;
252
253 if (qedx_info.version ^= QEDX_INFO_VERSION_0) & (qedx_info.version ^= QEDX_INFO_VERSION_1) then do;
254 P_code = error_table_$unimplemented_version;
255 return;
256 end;
257
258
259
260
261 qid_ptr = addr (local_qid);
262
263 qid.editor_name = qedx_info.editor_name;
264 qid.editor_area_ptr = get_system_free_area_ ();
265 qid.qedx_info_ptr = qedx_info_ptr;
266
267 qid.flags = qedx_info.header.flags, by name;
268
269 qid.edx_util_data_ptr,
270 qid.regexp_data_ptr, callers_io_region_ptr = null ();
271
272 on condition (cleanup) call cleanup_invocation_data ();
273
274 call edx_util_$edx_init (qid_ptr, addr (twbuff), b0_ifp, b0_bp, code);
275 if code ^= 0 then do;
276 call com_err_ (code, qid.editor_name, "Unable to initialize edx_util_.");
277 P_code = error_table_$fatal_error;
278 return;
279 end;
280
281 call get_buffer_state (b0_bp);
282
283 call qx_search_file_$init (qid_ptr);
284
285 if qedx_info.caller_does_io then do;
286 call get_temp_segment_ (qid.editor_name, callers_io_region_ptr, code);
287 if code ^= 0 then do;
288 call com_err_ (code, qid.editor_name, "Obtaining I/O buffer.");
289 P_code = error_table_$fatal_error;
290 go to RETURN_FROM_QEDX_;
291 end;
292 end;
293
294
295
296
297 do buffer_idx = 1 to qedx_info.n_buffers;
298 the_buffer_ptr = addr (qedx_info.buffers (buffer_idx));
299
300 call edx_util_$locate_buffer (qid_ptr, the_buffer.buffer_name, bp);
301 if bp = null () then do;
302 P_code = error_table_$fatal_error;
303 go to RETURN_FROM_QEDX_;
304 end;
305
306 call get_buffer_state (bp);
307 b.callers_idx = buffer_idx;
308
309 if the_buffer.read_write_region then do;
310 if the_buffer.region_ptr = null () then do;
311 call sub_err_ (error_table_$inconsistent, QEDX_, ACTION_CANT_RESTART, null (), 0,
312 "Input/output area required for buffer ^a was not supplied.", the_buffer.buffer_name);
313 P_code = error_table_$fatal_error;
314 go to RETURN_FROM_QEDX_;
315 end;
316 else if qedx_info.caller_does_io then do;
317 call sub_err_ (error_table_$inconsistent, QEDX_, ACTION_CANT_RESTART, null (), 0,
318 "Input/output area can not be used for buffer ^a when caller performs I/O.",
319 the_buffer.buffer_name);
320 P_code = error_table_$fatal_error;
321 go to RETURN_FROM_QEDX_;
322 end;
323 else do;
324 a_real_file = "0"b;
325 the_pathname = the_buffer.buffer_pathname;
326 b.default_was_region = "1"b;
327 the_buffer.region_final_lth = the_buffer.region_initial_lth;
328 end;
329 end;
330
331 else do;
332 if the_buffer.buffer_pathname = "" then do;
333 call sub_err_ (error_table_$inconsistent, QEDX_, ACTION_CANT_RESTART, null (), 0,
334 "Default pathname not specified for buffer ^a.", the_buffer.buffer_name);
335 P_code = error_table_$fatal_error;
336 go to RETURN_FROM_QEDX_;
337 end;
338 else do;
339 a_real_file = "1"b;
340 the_pathname = the_buffer.buffer_pathname;
341 b.default_was_region = "0"b;
342 end;
343 end;
344
345 fle = ife;
346 if ^perform_read (a_real_file, the_pathname, "1"b) then do;
347 P_code = error_table_$fatal_error;
348 go to RETURN_FROM_QEDX_;
349 end;
350
351 if qedx_info.version = QEDX_INFO_VERSION_1 then
352 b.default_locked = the_buffer.locked_pathname;
353 else b.default_locked = ^the_buffer.locked_pathname;
354
355
356 call save_buffer_state ();
357 end;
358
359
360
361
362 pi_sw = "0"b;
363
364 if sys_info$service_system then on condition (program_interrupt) call interrupt ();
365
366 else on condition (sub_request_abort_) call interrupt ();
367
368
369 tp = addr (iline);
370 substr (iline, 1, 3) = "b0 ";
371 te = 3;
372
373 do buffer_idx = 1 to qedx_info.n_buffers;
374 the_buffer_ptr = addr (qedx_info.buffers (buffer_idx));
375 if the_buffer.execute_buffer then do;
376 if (te + length ("\b() ") + length (rtrim (the_buffer.buffer_name))) > length (iline) then do;
377 call com_err_ (error_table_$bigarg, qid.editor_name, "Preparing to execute buffer ^a.",
378 the_buffer.buffer_name);
379 P_code = error_table_$fatal_error;
380 go to RETURN_FROM_QEDX_;
381 end;
382 substr (iline, (te + 1), (length ("\b() ") + length (rtrim (the_buffer.buffer_name)))) =
383 "\b(" || rtrim (the_buffer.buffer_name) || ") ";
384 te = te + length ("\b() ") + length (rtrim (the_buffer.buffer_name));
385 end;
386 end;
387
388 substr (iline, te, 1) = NL;
389
390 call edx_util_$prime (qid_ptr, tp, te);
391 %page;
392
393
394
395
396
397
398
399
400
401
402 nx_line:
403 ti = 1;
404 call edx_util_$read_ptr (qid_ptr, tp, length (iline), te);
405
406 next:
407 if ^sys_info$service_system then do;
408 intsw = "0"b;
409 call bce_check_abort;
410 if intsw = "1"b then go to RETURN_FROM_QEDX_;
411 end;
412 call save_buffer_state ();
413 if ti >= te then go to nx_line;
414 intsw = "0"b;
415
416 call get_addr_ (qid_ptr, tp, ti, te, ifp, ilb, ift, ife, li, le, fli, fle, code);
417
418 if code = 0 then flsw, llsw = "0"b;
419 else if code = 1 then do;
420 flsw = "1"b;
421 llsw = "0"b;
422 end;
423 else if code < 4 then do;
424 flsw, llsw = "1"b;
425 if code = 2 then
426 call get_addr_ (qid_ptr, tp, ti, te, ifp, ilb, ift, ife, li, le, lli, lle, code);
427
428 else call get_addr_ (qid_ptr, tp, ti, te, ifp, ilb, ift, ife, fli, fle, lli, lle, code);
429
430 if code = 4 then go to reg_err;
431 if code > 4 then go to rq_err;
432 end;
433 else if code = 4 then do;
434 reg_err:
435 call edx_util_$end_buffer (qid_ptr, code);
436 if code ^= 0 then do;
437 call ioa_ ("Search failed.");
438 go to rq_err;
439 end;
440 else go to nx_line;
441 end;
442 else if code > 4 then do;
443 rq_err:
444 call edx_util_$resetread (qid_ptr);
445 go to nx_line;
446 end;
447
448 ch = t.c (ti);
449 ti = ti + 1;
450 if ch = NL then
451 if flsw then
452 go to print1;
453 else go to nx_line;
454 command_index = index (COMMANDS, ch);
455 pi_label = ACTION (0);
456 go to ACTION (command_index);
457
458 ACTION (0):
459 call ioa_ ("^a: ^a not recognized as a request.", qid.editor_name, ch);
460
461 go to rq_err;
462 %page;
463
464
465
466
467
468
469
470
471
472
473
474
475 ACTION (9):
476 read:
477 call determine_file ("0"b, a_real_file, the_pathname, explicit_pathname);
478
479 if ^flsw then fle = ife;
480
481 if perform_read (a_real_file, the_pathname, explicit_pathname) then
482 go to nx_line;
483 else go to rq_err;
484 %page;
485
486
487
488
489
490
491
492
493
494
495
496
497
498 ACTION (10):
499 write:
500 call defaults (1, ife);
501 pi_label = wr_quit;
502 pi_sw = "1"b;
503
504 call determine_file ("1"b, a_real_file, the_pathname, explicit_pathname);
505
506
507 if ^perform_write (a_real_file, the_pathname, explicit_pathname, "1"b) then go to rq_err;
508
509
510 wr_quit:
511 pi_sw = "0"b;
512 go to nx_line;
513 %page;
514
515
516 ACTION (19):
517 quit_force_sw = "1"b;
518 go to DO_QUIT_REQUEST;
519
520 ACTION (11):
521 if t.c (ti) = "f" then do;
522 quit_force_sw = "1"b;
523 ti = ti + 1;
524 end;
525 else quit_force_sw = "0"b;
526
527 DO_QUIT_REQUEST:
528 if (flsw) then do;
529 call ioa_ ("Syntax error in quit request.");
530 go to rq_err;
531 end;
532
533 if (t.c (ti) ^= NL) then do;
534 ti = ti + verify (substr (iline, ti), " ") - 1;
535 if (t.c (ti) ^= NL) then do;
536 call ioa_ ("Syntax error in quit request.");
537 go to rq_err;
538 end;
539 end;
540
541
542
543
544 if qid.query_if_modified & ^quit_force_sw then
545 if edx_util_$modified_buffers (qid_ptr) then do;
546
547 if sys_info$service_system then
548 call user_info_$process_type (process_type);
549 else process_type = 1;
550 if process_type = 1 then do;
551 call ioa_$ioa_switch (error_sw, "Modified buffers exist:");
552 call edx_util_$list_modified_buffers (qid_ptr, (b.name), error_sw);
553
554 if sys_info$service_system then
555 call command_query_$yes_no (yes_sw, 0, qid.editor_name, MODIFIED_BUFFERS_EXPLANATION,
556 "Do you still wish to quit and lose these changes?");
557 else call bce_query$yes_no (yes_sw, MODIFIED_BUFFERS_EXPLANATION);
558 if yes_sw then
559 quit_force_sw = "1"b;
560 else go to rq_err;
561 end;
562 end;
563
564 if quit_force_sw then go to SET_OUTPUT_VALUES;
565
566
567
568
569 saved_current_buffer = b.name;
570 call save_buffer_state ();
571
572 have_truncated_buffers = "0"b;
573
574 do buffer_idx = 1 to qedx_info.n_buffers;
575 the_buffer_ptr = addr (qedx_info.buffers (buffer_idx));
576 call edx_util_$locate_buffer (qid_ptr, the_buffer.buffer_name, bp);
577 call get_buffer_state (bp);
578
579 if the_buffer.read_write_region then do;
580
581 if the_buffer.auto_write then do;
582 fli = 1;
583 lle = ife;
584 ignore_result = perform_write ("0"b, "", "0"b, "0"b);
585 end;
586
587 if the_buffer.region_final_lth > the_buffer.region_max_lth then do;
588 if ^have_truncated_buffers then do;
589 call ioa_$ioa_switch (error_sw, "Buffers which will be truncated:");
590 have_truncated_buffers = "1"b;
591 end;
592 call edx_util_$list_single_buffer (qid_ptr, saved_current_buffer, output_sw, bp);
593 end;
594 end;
595 end;
596
597 if have_truncated_buffers then do;
598 if sys_info$service_system then
599 call command_query_$yes_no (yes_sw, 0, qid.editor_name, TRUNCATED_BUFFERS_EXPLANATION,
600 "Do you still wish to quit?");
601 else call bce_query$yes_no (yes_sw, TRUNCATED_BUFFERS_EXPLANATION);
602 if ^yes_sw then do;
603 call edx_util_$locate_buffer (qid_ptr, saved_current_buffer, bp);
604 call get_buffer_state (bp);
605 go to rq_err;
606 end;
607 end;
608
609
610
611
612 SET_OUTPUT_VALUES:
613 qedx_info.quit_forced = quit_force_sw;
614 qedx_info.buffers_truncated = "0"b;
615
616 do buffer_idx = 1 to qedx_info.n_buffers;
617 the_buffer_ptr = addr (qedx_info.buffers (buffer_idx));
618 if the_buffer.read_write_region then
619 if the_buffer.region_final_lth > the_buffer.region_max_lth then
620 qedx_info.buffers_truncated, the_buffer.truncated = "1"b;
621 end;
622
623 if qedx_info.quit_forced | qedx_info.buffers_truncated then
624 P_code = error_table_$recoverable_error;
625 else P_code = 0;
626
627
628
629
630 RETURN_FROM_QEDX_:
631 call cleanup_invocation_data ();
632
633 return;
634 %page;
635
636
637
638
639
640
641 print1:
642 ti = te;
643
644
645
646
647
648
649 ACTION (1):
650 print:
651 call defaults (li, le);
652 pi_label = end_pr;
653 pi_sw = "1"b;
654 if lle <= ilb | fli >= ift then do;
655 i = lle - fli + 1;
656 call output_routine (output_sw, addr (ifp -> f.c (fli)), i, code);
657 end;
658 else if fli <= ilb then do;
659 i = lle - ift + 1 + ilb - fli;
660 call output_routine (output_sw, addr (ifp -> f.c (fli)), ilb - fli + 1, code);
661
662 call output_routine (output_sw, addr (ifp -> f.c (ift)), lle - ift + 1, code);
663
664 end;
665 pi_sw = "0"b;
666 end_pr:
667 call last_line (lle);
668 go to next;
669 %page;
670
671
672 ACTION (6):
673 delete:
674 call defaults (li, le);
675 call delete_text ();
676 call next_line (ift);
677 b.modified = "1"b;
678 go to next;
679
680
681
682
683
684 delete_text:
685 procedure ();
686
687
688
689
690
691
692
693
694
695
696 if lle <= ilb then do;
697 call open_gap (lle);
698 ilb = fli - 1;
699 end;
700 else if fli >= ift then do;
701 call open_gap ((fli - 1));
702 ift = lle + 1;
703 end;
704 else do;
705 ilb = fli - 1;
706 ift = lle + 1;
707 fli = ift;
708 end;
709
710 return;
711
712 end delete_text;
713 %page;
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728 ACTION (3):
729 append:
730 if ^flsw |
731 fle > ife then
732 fle = le;
733 call open_gap ((fle));
734 go to in_mode;
735
736 ACTION (4):
737 insert:
738 if ^flsw then fli = li;
739 fle = fli - 1;
740 call open_gap ((fle));
741 go to in_mode;
742
743 ACTION (5):
744 change:
745 call defaults (li, le);
746 call delete_text ();
747 b.modified = "1"b;
748
749
750 in_mode:
751 if sys_info$service_system then do;
752 new_modes = "wake_tbl";
753 call iox_$modes (iox_$user_io, new_modes, old_modes, code);
754 end;
755
756 was_empty = (ilb < 1) & (ift > ife);
757
758 pi_label = in_mode;
759 call input (ifp, ilb);
760 pi_label = nx_line;
761
762
763
764
765
766
767 call last_line (ilb);
768 call open_gap ((li - 1));
769 call next_line (li);
770
771 if sys_info$service_system then do;
772 new_modes = "^wake_tbl";
773 call iox_$modes (iox_$user_io, new_modes, old_modes, code);
774 end;
775
776 if was_empty then
777 b.default_untrusted = ^b.default_locked & (b.default_path ^= "");
778
779 go to next;
780 %page;
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814 ACTION (2):
815 pi_label = sub_done;
816 substitute:
817 call defaults (li, le);
818 delim = t.c (ti);
819 intsw = "0"b;
820 subsw = "0"b;
821 sdsw = "0"b;
822
823 ilb_offset = 0;
824
825 tik = ti + 1;
826 i = tik;
827 sub_comp_string = delim || EC || "\";
828
829 sub_search:
830 k = search (substr (tp -> a_string, tik, te - tik + 1), sub_comp_string);
831
832
833 if k = 0 then do;
834 sub_err:
835 call ioa_ ("Syntax error in substitute request.");
836 go to rq_err;
837 end;
838
839 kx = index (sub_comp_string, t.c (tik + k - 1));
840 go to sub_case (kx);
841
842 sub_case (1):
843 if ^subsw then do;
844 j = tik + k;
845 il = j - 1 - i;
846 if substr (tp -> a_string, j - 3, 2) = "*$"
847 then
848 if substr (tp -> a_string, j - 4, 1) ^= EC
849
850 then
851 if (substr (tp -> a_string, j - 5, 2)) ^= "\c" then
852 if (substr (tp -> a_string, j - 5, 2)) ^= "\C" then sdsw = "1"b;
853
854 tik = j;
855 subsw = "1"b;
856 go to sub_search;
857 end;
858 else go to sub2;
859
860 sub_case (2):
861 if (ti + k) < te then do;
862 tik = (tik + k) + 1;
863 go to sub_search;
864 end;
865 else go to sub_err;
866
867 sub_case (3):
868 if (tik + k) > te then go to sub_err;
869 if (t.c (tik + k) = "C") | (t.c (tik + k) = "c")
870 then
871 if (tik + k) + 1 < te
872 then do;
873 tik = tik + k + 2;
874 go to sub_search;
875 end;
876 else go to sub_err;
877 else do;
878 tik = tik + k;
879 go to sub_search;
880 end;
881
882 sub2:
883 ti = tik + k;
884 je = tik + k - 2;
885 call open_gap ((fli - 1));
886
887 subsw = "0"b;
888 sub_loop:
889 call qx_search_file_ (qid_ptr, tp, i, il, ifp, fli, lle, mi, me, ilb, ift, code);
890
891 ilb = ilb - ilb_offset;
892 ilb_offset = 0;
893 if ^sys_info$service_system then call bce_check_abort;
894 if intsw then do;
895 call ioa_ ("^a: Interrupt during substitute, remainder unprocessed.", qid.editor_name);
896 intsw = "0"b;
897 goto sub_done;
898 end;
899
900 if code ^= 0 then goto sub_done;
901 ml = me - mi + 1;
902 subsw = "1"b;
903 il = 0;
904 l = mi - fli;
905 if l > 0 then
906 fli = fli + l;
907
908
909 call open_gap ((fli - 1));
910
911 l = j;
912 sub_string_search:
913 k = search (substr (tp -> a_string, l, je - l + 1), "&^Y\");
914
915 if k = 0 then do;
916 if je >= j then
917 if ml ^= 0 then do;
918 call promote ((je - l + 1 - ml));
919
920 ift = ift + ml;
921 ml = -1;
922 end;
923
924 saved_ift = ift;
925 call promote ((je - l + 1));
926
927 substr (ifp -> a_string, ilb + 1, (je - l + 1)) = substr (tp -> a_string, l, (je - l + 1));
928
929 ilb = ilb + je - l + 1;
930 b.modified = "1"b;
931 go to sub_next;
932 end;
933
934 kx = index ("&^Y\", t.c (l + k - 1));
935 go to do_sub (kx);
936
937 do_sub (1):
938 if k > 1 then do;
939 call promote ((k - 1));
940 substr (ifp -> a_string, ilb + 1, k - 1) = substr (tp -> a_string, l, k - 1);
941
942 ilb = ilb + k - 1;
943 b.modified = "1"b;
944 end;
945
946
947
948
949
950
951 if ml > 0 then do;
952 call promote ((ml));
953 substr (ifp -> a_string, ilb + 1, ml) = substr (ifp -> a_string, mi, ml);
954
955 ilb = ilb + ml;
956 b.modified = "1"b;
957 end;
958
959 l = l + k;
960
961 go to sub_string_search;
962
963 do_sub (2):
964 ka = 0;
965 do_sub_conceal:
966 call promote ((k));
967 substr (ifp -> a_string, ilb + 1, k) = substr (tp -> a_string, l, k - 1) || t.c (l + k + ka);
968 ilb = ilb + k;
969 b.modified = "1"b;
970 l = l + k + ka + 1;
971 go to sub_string_search;
972
973 do_sub (3):
974 if (t.c (k + l) = "C") | (t.c (k + l) = "c") then do;
975
976 ka = 1;
977 go to do_sub_conceal;
978 end;
979 else do;
980 call promote ((k));
981 substr (ifp -> a_string, ilb + 1, k) = substr (tp -> a_string, l, k);
982
983 ilb = ilb + k;
984 b.modified = "1"b;
985 l = l + k;
986 go to sub_string_search;
987 end;
988
989 sub_next:
990 if ml = 0 then
991 fli = fli + 1;
992 else do;
993 fli = me + 1;
994 if sdsw
995 then
996 fli = fli + 1;
997 if ml < 0 then ilb_offset = 0;
998 else if fli > lle then ift = ift + ml;
999 else ilb_offset = ml;
1000 end;
1001
1002
1003
1004
1005
1006
1007 if sdsw then
1008 call open_gap ((fli - 2));
1009 else call open_gap ((fli - 1));
1010 if fli <= lle then go to sub_loop;
1011 sub_done:
1012 call last_line (min (fli, lle));
1013 call open_gap ((li - 1));
1014 call next_line (lle);
1015
1016
1017
1018
1019
1020
1021
1022 call last_line (le);
1023
1024
1025
1026 if ^subsw then do;
1027 call edx_util_$end_buffer (qid_ptr, code);
1028 if code = 0 then go to nx_line;
1029
1030 call ioa_ ("Substitution failed.");
1031 go to rq_err;
1032 end;
1033 else go to next;
1034 %page;
1035
1036
1037 ACTION (15):
1038 execute:
1039 substr (tp -> a_string, 1, (ti - 1)) = " ";
1040 pi_label = nx_line;
1041 if sys_info$service_system then do;
1042 pi_sw = "1"b;
1043 call cu_$cp (tp, te, code);
1044 pi_sw = "0"b;
1045 end;
1046 else call ioa_ ("^a: Escape to command level not allowed.", qid.editor_name);
1047 go to nx_line;
1048
1049
1050
1051
1052
1053 ACTION (7):
1054 buffer:
1055 call save_buffer_state ();
1056 call edx_util_$get_buffer (qid_ptr, tp, ti, te, tname, tbp);
1057
1058 if tbp = null then go to rq_err;
1059 call get_buffer_state (tbp);
1060 go to next;
1061 %page;
1062
1063
1064
1065
1066
1067 ACTION (8):
1068 move:
1069 call defaults (li, le);
1070 call edx_util_$get_buffer (qid_ptr, tp, ti, te, tname, tbp);
1071
1072 if tbp = null then go to rq_err;
1073 fp = tbp -> b.dp;
1074 if lle <= ilb | fli >= ift then do;
1075 fe = lle - fli + 1;
1076 if fe > sys_info$max_seg_size * 4 then do;
1077 move_overflow:
1078 call ioa_ ("^a: Buffer full!! Move not performed.", qid.editor_name);
1079 goto rq_err;
1080 end;
1081 substr (fp -> a_string, 1, fe) = substr (ifp -> a_string, fli, fe);
1082
1083 end;
1084 else if fli <= ilb then do;
1085 fe = lle - ift + 1 + ilb - fli + 1;
1086 if fe > sys_info$max_seg_size * 4 then goto move_overflow;
1087 substr (fp -> a_string, 1, ilb - fli + 1) = substr (ifp -> a_string, fli, ilb - fli + 1);
1088 substr (fp -> a_string, ilb - fli + 2, lle - ift + 1) = substr (ifp -> a_string, ift, lle - ift + 1);
1089 end;
1090 if fe < 4 * 4 * 1024 then i = 4 * 4 * 1024;
1091 else if fe < 16 * 4 * 1024 then i = 16 * 4 * 1024;
1092 else if fe < 64 * 4 * 1024 then i = 64 * 4 * 1024;
1093 else i = 255 * 4 * 1024;
1094 i = min (i, sys_info$max_seg_size * 4);
1095
1096 tbp -> b.lb = fe;
1097 tbp -> b.de = i;
1098 tbp -> b.ft = i + 1;
1099 tbp -> b.li = 1;
1100 tbp -> b.le = index (substr (fp -> a_string, 1, fe), NL);
1101 if tbp -> b.le = 0 then tbp -> b.le = fe;
1102 if tbp -> b.le = 0 then tbp -> b.le = ilb;
1103 tbp -> b.modified = "1"b;
1104 tbp -> b.default_untrusted = ^tbp -> b.default_locked & (tbp -> b.default_path ^= "");
1105
1106 go to delete;
1107 %page;
1108
1109
1110 ACTION (14):
1111 status:
1112 call save_buffer_state ();
1113 call edx_util_$list_buffers (qid_ptr, curbuf, output_sw);
1114 go to next;
1115 %page;
1116
1117
1118
1119
1120
1121
1122
1123
1124 ACTION (13):
1125 cur_line:
1126 call defaults (li, le);
1127 call last_line (lle);
1128 if ifp -> f.c (lle) = NL then
1129 j = 0;
1130 else j = 1;
1131 i = 1;
1132 do while (i <= lle);
1133 if i > ilb & i < ift then i = ift;
1134 retry_top:
1135 if i >= ift then
1136 k = index (substr (ifp -> a_string, i, lle - i + 1), NL);
1137
1138 else do;
1139 k = index (substr (ifp -> a_string, i, ilb - i + 1), NL);
1140
1141 if k = 0 & ift <= ife then do;
1142 i = ift;
1143 goto retry_top;
1144 end;
1145 end;
1146 if k = 0 then
1147 i = lle + 1;
1148 else j = j + 1;
1149 i = i + k;
1150 end;
1151 call ioa_ ("^d", j);
1152 go to next;
1153 %page;
1154
1155
1156
1157
1158
1159
1160
1161
1162 ACTION (16):
1163 exclude:
1164 xsw = "1"b;
1165 go to gb1;
1166
1167 ACTION (12):
1168 global:
1169 xsw = "0"b;
1170 gb1:
1171 call defaults (1, ife);
1172 if ti > te then go to gb_err;
1173 ch = t.c (ti);
1174 if ch ^= "p" then
1175 if ch ^= "d" then
1176 if ch ^= "=" then do;
1177 gb_err:
1178 call ioa_ ("Syntax error in global request.");
1179 go to rq_err;
1180 end;
1181 delim = t.c (ti + 1);
1182 i = ti + 2;
1183 do ti = i to te;
1184 cht = t.c (ti);
1185 if cht = delim then go to gb2;
1186 else if cht = EC then ti = ti + 1;
1187 else if cht = "\" then
1188 if ti < te then
1189 if (t.c (ti + 1) = "C") | (t.c (ti + 1) = "c") then ti = ti + 2;
1190
1191 end;
1192 go to gb_err;
1193
1194 gb2:
1195 il = ti - i;
1196 ti = ti + 1;
1197 l = 0;
1198 if ch ^= "=" then go to gb_loop;
1199 do j = 1 to (fli - 1);
1200 if j > ilb & j < ift then j = ift;
1201 if j <= fli - 1 then
1202 if ifp -> f.c (j) = NL then l = l + 1;
1203 end;
1204 gb_loop:
1205 l = l + 1;
1206 if fli > ilb & fli < ift then fli = ift;
1207 if fli > lle then goto gb_quit;
1208 le = index (substr (ifp -> a_string, fli, (lle - fli + 1)), NL);
1209
1210 if le = 0 then
1211 le = lle;
1212 else le = fli + le - 1;
1213 call qx_search_file_ (qid_ptr, tp, i, il, ifp, fli, le, mi, me, ilb, ift, code);
1214
1215 if code > 1 then go to gb_quit;
1216 il = 0;
1217 if xsw then
1218 if code ^= 0 then go to gb_test;
1219 if ^xsw then
1220 if code = 0 then go to gb_test;
1221 fli = le + 1;
1222 go to gb_end;
1223
1224 gb_test:
1225 if ch = "p" then do;
1226 j = le - fli + 1;
1227 pi_label = gb_quit;
1228 pi_sw = "1"b;
1229 call output_routine (output_sw, addr (ifp -> f.c (fli)), j, code);
1230
1231 pi_sw = "0"b;
1232 fli = le + 1;
1233 if ^sys_info$service_system then call bce_check_abort;
1234 if intsw then go to gb_quit;
1235 end;
1236 else if ch = "d" then do;
1237 call open_gap ((fli - 1));
1238 ift = le + 1;
1239 fli = ift;
1240 b.modified = "1"b;
1241 if ^sys_info$service_system then call bce_check_abort;
1242 if intsw then go to gb_quit;
1243 end;
1244 else if ch = "=" then do;
1245 call ioa_ ("^d", l);
1246 fli = le + 1;
1247 if ^sys_info$service_system then call bce_check_abort;
1248 if intsw then go to gb_quit;
1249 end;
1250 gb_end:
1251 if fli <= lle then go to gb_loop;
1252 gb_quit:
1253 if ch = "p" then call ioa_ ("");
1254 call last_line (lle);
1255 go to next;
1256 %page;
1257
1258
1259 ACTION (17):
1260 nullrq:
1261 if ^flsw then go to next;
1262 call defaults (li, le);
1263 call last_line (lle);
1264 go to next;
1265
1266
1267
1268
1269 ACTION (18):
1270 comment:
1271 if ^flsw then go to nx_line;
1272 call defaults (li, le);
1273 call last_line (lle);
1274 go to nx_line;
1275 %page;
1276
1277
1278
1279
1280 cleanup_invocation_data:
1281 procedure ();
1282
1283 if callers_io_region_ptr ^= null () then do;
1284 call release_temp_segment_ (qid.editor_name, callers_io_region_ptr, (0));
1285 callers_io_region_ptr = null ();
1286 end;
1287
1288 call edx_util_$edx_cleanup (qid_ptr);
1289
1290 call qx_search_file_$cleanup (qid_ptr);
1291
1292 return;
1293
1294 end cleanup_invocation_data;
1295 %page;
1296
1297
1298 save_buffer_state:
1299 procedure ();
1300
1301 b.dp = ifp;
1302 b.de = ife;
1303 b.lb = ilb;
1304 b.ft = ift;
1305 b.li = li;
1306 b.le = le;
1307
1308 return;
1309
1310 end save_buffer_state;
1311
1312
1313
1314
1315 get_buffer_state:
1316 procedure (p_bp);
1317
1318 dcl p_bp pointer parameter;
1319
1320 bp = p_bp;
1321 curbuf = b.name;
1322
1323 ifp = b.dp;
1324 ife = b.de;
1325 ilb = b.lb;
1326 ift = b.ft;
1327 li = b.li;
1328 le = b.le;
1329
1330 return;
1331
1332 end get_buffer_state;
1333 %page;
1334
1335
1336 determine_file:
1337 procedure (write_request, a_real_file, the_pathname, explicit_pathname);
1338
1339 dcl write_request bit (1) aligned parameter;
1340 dcl a_real_file bit (1) aligned parameter;
1341 dcl the_pathname character (256) parameter;
1342 dcl explicit_pathname bit (1) aligned parameter;
1343 dcl l fixed binary (21);
1344
1345 if b.callers_idx = 0 then
1346 the_buffer_ptr = null ();
1347 else the_buffer_ptr = addr (qedx_info.buffers (b.callers_idx));
1348
1349 do ti = ti to te while (t.c (ti) = " ");
1350 end;
1351 l = te - ti;
1352
1353 if l > 0 then do;
1354 explicit_pathname = "1"b;
1355 if qid.no_rw_path then do;
1356 call ioa_ ("A pathname cannot be specified with the ^[w^;r^] request", write_request);
1357 go to rq_err;
1358 end;
1359 if l > length (the_pathname) then do;
1360 call com_err_ (error_table_$pathlong, qid.editor_name, "^a", substr (tp -> a_string, ti, l));
1361 b.default_untrusted = ^b.default_locked & (b.default_path ^= "");
1362 go to rq_err;
1363 end;
1364 a_real_file = "1"b;
1365 the_pathname = substr (tp -> a_string, ti, l);
1366 end;
1367
1368 else do;
1369 explicit_pathname = "0"b;
1370 a_real_file = ^b.default_is_region;
1371
1372 if the_buffer_ptr ^= null () then
1373 if the_buffer.read_write_region & b.default_is_region then
1374 if (write_request & ^the_buffer.default_write_ok)
1375 | (^write_request & ^the_buffer.default_read_ok) then do;
1376 call ioa_ ("No pathname given.");
1377 go to rq_err;
1378 end;
1379
1380 if ^write_request & b.default_is_region then
1381 if ^((ift > ife) & (ilb < 1)) then do;
1382 call ioa_ ("Cannot restore original text unless buffer is empty.");
1383 go to rq_err;
1384 end;
1385
1386 if a_real_file then
1387 if b.default_path ^= "" then
1388 the_pathname = b.default_path;
1389 else do;
1390 call ioa_ ("No pathname given.");
1391 go to rq_err;
1392 end;
1393 end;
1394
1395 return;
1396
1397 end determine_file;
1398 %page;
1399
1400
1401 perform_read:
1402 procedure (a_real_file, the_pathname, explicit_pathname) returns (bit (1) aligned);
1403
1404 dcl a_real_file bit (1) aligned parameter;
1405 dcl the_pathname character (256) parameter;
1406 dcl explicit_pathname bit (1) aligned;
1407
1408 dcl file_ptr pointer;
1409 dcl dirname character (168);
1410 dcl (ename, component) character (32);
1411 dcl (was_empty, read_ok) bit (1) aligned;
1412 dcl trust_the_pathname bit (1);
1413 dcl (code, status_code) fixed binary (35);
1414 dcl file_bc fixed binary (24);
1415 dcl file_lth fixed binary (21);
1416
1417
1418
1419
1420 if b.callers_idx = 0 then
1421 the_buffer_ptr = null ();
1422 else the_buffer_ptr = addr (qedx_info.buffers (b.callers_idx));
1423
1424 if qedx_info.caller_does_io then do;
1425 local_qbii.version = QEDX_BUFFER_IO_INFO_VERSION_1;
1426 local_qbii.editor_name = qid.editor_name;
1427 local_qbii.pathname = the_pathname;
1428 local_qbii.buffer_ptr = callers_io_region_ptr;
1429 local_qbii.buffer_max_lth = 4 * sys_info$max_seg_size;
1430 local_qbii.direction = QEDX_READ_FILE;
1431 string (local_qbii.flags) = ""b;
1432 local_qbii.default_pathname = ^explicit_pathname;
1433 call qedx_info.buffer_io (addr (local_qbii), read_ok);
1434 if ^read_ok then do;
1435 if explicit_pathname then b.default_untrusted = ^b.default_locked & (b.default_path ^= "");
1436 return ("0"b);
1437 end;
1438 file_ptr = callers_io_region_ptr;
1439 file_lth = local_qbii.buffer_lth;
1440 end;
1441
1442 else if a_real_file then do;
1443 if sys_info$service_system then do;
1444 call expand_pathname_$component (the_pathname, dirname, ename, component, code);
1445 if code ^= 0 then do;
1446 call com_err_ (code, qid.editor_name, "^a", the_pathname);
1447 if explicit_pathname then b.default_untrusted = ^b.default_locked & (b.default_path ^= "");
1448 return ("0"b);
1449 end;
1450 call initiate_file_$component (dirname, ename, component, R_ACCESS, file_ptr, file_bc, code);
1451 if code ^= 0 then do;
1452 if code = error_table_$dirseg then do;
1453 call hcs_$status_minf (dirname, ename, CHASE, 0, file_bc, status_code);
1454 if (status_code = 0) & (file_bc ^= 0) then
1455 call com_err_ (0, qid.editor_name, "This operation is not allowed for an MSF. ^a",
1456 pathname_$component (dirname, ename, component));
1457 else call com_err_ (code, qid.editor_name, "^a",
1458 pathname_$component (dirname, ename, component));
1459 end;
1460 else call com_err_ (code, qid.editor_name, "^a", pathname_$component (dirname, ename, component))
1461 ;
1462 if explicit_pathname & (code ^= error_table_$moderr) & (code ^= error_table_$no_r_permission)
1463 then
1464 b.default_untrusted = ^b.default_locked & (b.default_path ^= "");
1465 return ("0"b);
1466 end;
1467 file_lth = divide ((file_bc + 8), 9, 21, 0);
1468 end;
1469 else do;
1470 call bootload_fs_$get_ptr (the_pathname, file_ptr, file_lth, code);
1471 if code ^= 0 then do;
1472 call com_err_ (code, qid.editor_name, "^a", the_pathname);
1473 if explicit_pathname then b.default_untrusted = ^b.default_locked & (b.default_path ^= "");
1474 return ("0"b);
1475 end;
1476 end;
1477 end;
1478
1479 else do;
1480 file_ptr = the_buffer.region_ptr;
1481 file_lth = min (the_buffer.region_final_lth, the_buffer.region_max_lth);
1482 end;
1483
1484
1485
1486
1487 if b.default_untrusted & ^explicit_pathname then do;
1488 if sys_info$service_system then
1489 call command_query_$yes_no (trust_the_pathname, 0, qid.editor_name, TRUSTED_PATHNAMES_EXPLANATION,
1490 "Do you wish to ^a with the untrustworthy default pathname ^a?", "read", the_pathname);
1491 else call bce_query$yes_no (trust_the_pathname, TRUSTED_PATHNAMES_EXPLANATION);
1492 if trust_the_pathname then
1493 ;
1494 else go to rq_err;
1495 end;
1496
1497 else trust_the_pathname = "0"b;
1498
1499
1500
1501
1502 was_empty = (ilb < 1) & (ift > ife);
1503
1504 call open_gap ((fle));
1505 call promote (file_lth);
1506
1507 le = ift - 1;
1508 ift = ift - file_lth;
1509
1510 substr (ifp -> a_string, ift, file_lth) = substr (file_ptr -> a_string, 1, file_lth);
1511
1512
1513 file_lth = le;
1514 call next_line (ift);
1515 call last_line (le);
1516 call open_gap ((li - 1));
1517 call last_line (file_lth);
1518 call next_line (li);
1519
1520
1521
1522
1523 if b.default_locked then do;
1524 b.default_untrusted = "0"b;
1525 b.modified = ^was_empty | explicit_pathname;
1526 end;
1527
1528 else if was_empty then do;
1529 if sys_info$service_system then
1530 if a_real_file & ^qedx_info.caller_does_io then
1531 b.default_path = pathname_$component (dirname, ename, component);
1532 else b.default_path = the_pathname;
1533 else b.default_path = the_pathname;
1534 b.default_is_region = ^a_real_file;
1535 b.default_untrusted = "0"b;
1536 b.modified = "0"b;
1537 end;
1538
1539 else do;
1540 b.default_untrusted = (b.default_path ^= "");
1541 b.modified = "1"b;
1542 end;
1543
1544 if sys_info$service_system then
1545 if a_real_file & ^qedx_info.caller_does_io then
1546
1547 call terminate_file_ (file_ptr, 0, TERM_FILE_TERM, (0));
1548
1549 return ("1"b);
1550
1551 end perform_read;
1552 %page;
1553
1554
1555 perform_write:
1556 procedure (a_real_file, the_pathname, explicit_pathname, issue_truncation_warning) returns (bit (1) aligned);
1557
1558 dcl a_real_file bit (1) aligned parameter;
1559 dcl the_pathname character (256) parameter;
1560 dcl explicit_pathname bit (1) aligned parameter;
1561 dcl issue_truncation_warning bit (1) aligned parameter;
1562
1563 dcl file_ptr pointer;
1564 dcl dirname character (168);
1565 dcl ename character (32);
1566 dcl (split_data, write_ok, created_file, wrote_whole_buffer) bit (1) aligned;
1567 dcl trust_the_pathname bit (1);
1568 dcl (code, status_code) fixed binary (35);
1569 dcl file_bc fixed binary (24);
1570 dcl file_lth fixed binary (21);
1571
1572
1573 if b.callers_idx = 0 then
1574 the_buffer_ptr = null ();
1575 else the_buffer_ptr = addr (qedx_info.buffers (b.callers_idx));
1576
1577 if (lle <= ilb) | (fli >= ift) then do;
1578 split_data = "0"b;
1579 file_lth = lle - fli + 1;
1580 end;
1581 else do;
1582 split_data = "1"b;
1583 file_lth = (ilb - fli + 1) + (lle - ift + 1);
1584 end;
1585
1586
1587
1588
1589 if b.default_untrusted & ^explicit_pathname then do;
1590 if sys_info$service_system then
1591 call command_query_$yes_no (trust_the_pathname, 0, qid.editor_name, TRUSTED_PATHNAMES_EXPLANATION,
1592 "Do you wish to ^a with the untrustworthy default pathname ^a?", "write", the_pathname);
1593 else call bce_query$yes_no (trust_the_pathname, TRUSTED_PATHNAMES_EXPLANATION);
1594 if trust_the_pathname then
1595 b.default_untrusted = "0"b;
1596 else go to rq_err;
1597 end;
1598
1599 else trust_the_pathname = "0"b;
1600
1601
1602 if qedx_info.caller_does_io then do;
1603
1604
1605
1606 call put_data (callers_io_region_ptr);
1607
1608 local_qbii.version = QEDX_BUFFER_IO_INFO_VERSION_1;
1609 local_qbii.editor_name = qid.editor_name;
1610 local_qbii.pathname = the_pathname;
1611 local_qbii.buffer_ptr = callers_io_region_ptr;
1612 local_qbii.buffer_lth = file_lth;
1613 local_qbii.direction = QEDX_WRITE_FILE;
1614 string (local_qbii.flags) = ""b;
1615 local_qbii.default_pathname = ^explicit_pathname;
1616
1617 call qedx_info.buffer_io (addr (local_qbii), write_ok);
1618 if ^write_ok then do;
1619 if explicit_pathname then b.default_untrusted = ^b.default_locked & (b.default_path ^= "");
1620 return ("0"b);
1621 end;
1622 end;
1623
1624
1625 else if a_real_file then do;
1626 if sys_info$service_system then do;
1627
1628
1629
1630 call expand_pathname_ (the_pathname, dirname, ename, code);
1631 if code ^= 0 then do;
1632 if code = error_table_$archive_pathname then code = error_table_$archive_component_modification;
1633 call com_err_ (code, qid.editor_name, "^a", the_pathname);
1634 if explicit_pathname & (code ^= error_table_$archive_component_modification) then
1635 b.default_untrusted = ^b.default_locked & (b.default_path ^= "");
1636 return ("0"b);
1637 end;
1638
1639 call initiate_file_$create (dirname, ename, RW_ACCESS, file_ptr, created_file, (0), code);
1640 if created_file then do;
1641 call check_entryname_ (ename, code);
1642 if code ^= 0 then do;
1643 call terminate_file_ (file_ptr, 0, TERM_FILE_DELETE, (0));
1644 call com_err_ (code, qid.editor_name, "^a", pathname_ (dirname, ename));
1645 if explicit_pathname then b.default_untrusted = ^b.default_locked & (b.default_path ^= "");
1646 return ("0"b);
1647 end;
1648 end;
1649
1650 if code ^= 0 then do;
1651 if code = error_table_$dirseg then do;
1652 call hcs_$status_minf (dirname, ename, CHASE, 0, file_bc, status_code);
1653 if (status_code = 0) & (file_bc ^= 0) then
1654 call com_err_ (0, qid.editor_name, "This operation is not allowed for an MSF. ^a",
1655 pathname_ (dirname, ename));
1656 else call com_err_ (code, qid.editor_name, "^a", pathname_ (dirname, ename));
1657 end;
1658 else call com_err_ (code, qid.editor_name, "^a", pathname_ (dirname, ename));
1659 if explicit_pathname & (code ^= error_table_$moderr) & (code ^= error_table_$no_r_permission)
1660 & (code ^= error_table_$no_w_permission) then
1661 b.default_untrusted = ^b.default_locked & (b.default_path ^= "");
1662 return ("0"b);
1663 end;
1664 end;
1665 else do;
1666 call bootload_fs_$put_ptr (the_pathname, file_lth, "0"b, file_ptr, code);
1667 if code ^= 0 then do;
1668 call com_err_ (code, qid.editor_name, "^a", the_pathname);
1669 if explicit_pathname then b.default_untrusted = ^b.default_locked & (b.default_path ^= "");
1670 return ("0"b);
1671 end;
1672 end;
1673
1674 call put_data (file_ptr);
1675
1676 if sys_info$service_system then do;
1677 call terminate_file_ (file_ptr, (9 * file_lth), TERM_FILE_TRUNC_BC_TERM, code);
1678 if code ^= 0 then do;
1679 call com_err_ (code, qid.editor_name, "^a", pathname_ (dirname, ename));
1680 if explicit_pathname then b.default_untrusted = ^b.default_locked & (b.default_path ^= "");
1681 return ("0"b);
1682 end;
1683 end;
1684 else call bootload_fs_$flush_sys;
1685 end;
1686
1687
1688 else do;
1689
1690
1691
1692 the_buffer.region_final_lth = file_lth;
1693 file_lth = min (file_lth, the_buffer.region_max_lth);
1694
1695 call put_data (the_buffer.region_ptr);
1696
1697 if issue_truncation_warning & (the_buffer.region_final_lth > the_buffer.region_max_lth) then
1698 call com_err_ (0, qid.editor_name, "Warning: Buffer ^a will be truncated on exit from the editor.",
1699 b.name);
1700 end;
1701
1702
1703
1704
1705
1706 wrote_whole_buffer = ((1 > ilb) & ((fli = ift) & (lle = ife))) |
1707 ((ift > ife) & ((fli = 1) & (lle = ilb))) |
1708 (((1 <= ilb) & (ift <= ife)) & ((fli = 1) & (lle = ife)));
1709
1710
1711 if b.default_locked then do;
1712 b.default_untrusted = "0"b;
1713 b.modified = b.modified & (^wrote_whole_buffer | explicit_pathname);
1714 end;
1715
1716 else if wrote_whole_buffer then do;
1717 if sys_info$service_system then
1718 if a_real_file & ^qedx_info.caller_does_io then
1719 b.default_path = pathname_ (dirname, ename);
1720 else b.default_path = the_pathname;
1721 else b.default_path = the_pathname;
1722 b.default_is_region = ^a_real_file;
1723 b.modified = "0"b;
1724 b.default_untrusted = "0"b;
1725 end;
1726
1727 else b.default_untrusted = (b.default_path ^= "");
1728
1729 return ("1"b);
1730
1731
1732
1733
1734
1735 put_data:
1736 procedure (p_file_ptr);
1737
1738 dcl p_file_ptr pointer parameter;
1739 dcl (part1_lth, part2_lth) fixed binary (21);
1740
1741 if split_data then do;
1742 part1_lth = min ((ilb - fli + 1), file_lth);
1743 part2_lth = min ((lle - ift + 1), (file_lth - part1_lth));
1744 substr (p_file_ptr -> a_string, 1, part1_lth) = substr (ifp -> a_string, fli, part1_lth);
1745 if part2_lth > 0 then
1746 substr (p_file_ptr -> a_string, (part1_lth + 1), part2_lth) =
1747 substr (ifp -> a_string, ift, part2_lth);
1748 end;
1749
1750 else substr (p_file_ptr -> a_string, 1, file_lth) = substr (ifp -> a_string, fli, file_lth);
1751
1752 return;
1753
1754 end put_data;
1755
1756 end perform_write;
1757 %page;
1758
1759
1760 last_line:
1761 procedure (ale);
1762
1763 dcl ale fixed bin (21);
1764
1765 dcl i fixed bin (21);
1766
1767 if ale < ift & ale > ilb then
1768 le = ilb;
1769 else le = ale;
1770
1771
1772 li = le - 1;
1773
1774 retry:
1775 if li >= ift then do;
1776 i = index (reverse (substr (ifp -> a_string, ift, li - ift + 1)), NL);
1777
1778 if i = 0 then
1779 if ilb > 0 then do;
1780 li = ilb;
1781 goto retry;
1782 end;
1783 else do;
1784 li = ift;
1785 return;
1786 end;
1787 end;
1788 else do;
1789 if li < 1 then do;
1790 li = 1;
1791 return;
1792 end;
1793 if li > ilb then li = ilb;
1794 i = index (reverse (substr (ifp -> a_string, 1, li)), NL);
1795 if i = 0 then do;
1796 li = 1;
1797 return;
1798 end;
1799 end;
1800 li = li - i + 1;
1801
1802
1803
1804 if li = ilb then
1805 li = ift;
1806 else li = li + 1;
1807 return;
1808
1809 end last_line;
1810 %page;
1811
1812
1813 next_line:
1814 procedure (ali);
1815
1816 dcl ali fixed bin (21);
1817
1818 if ali <= ife then do;
1819 if ali < ift & ali > ilb then
1820 li = ift;
1821 else li = ali;
1822 retry_top:
1823 if li <= ilb then do;
1824 le = index (substr (ifp -> a_string, li, (ilb - li + 1)), NL);
1825
1826 if le = 0 & ift <= ife then do;
1827 li = ift;
1828 goto retry_top;
1829 end;
1830 end;
1831 else le = index (substr (ifp -> a_string, li, (ife - li + 1)), NL);
1832
1833 if le = 0 then
1834 le = ife;
1835 else le = (li - 1) + le;
1836 end;
1837 else do;
1838 li = ife + 1;
1839 le = ife;
1840 end;
1841 return;
1842
1843 end next_line;
1844 %page;
1845
1846
1847 defaults:
1848 procedure (afli, alle);
1849
1850 dcl afli fixed bin (21),
1851 alle fixed bin (21);
1852
1853 dcl (qfli, qlle) fixed bin (21);
1854
1855 if afli > ilb & afli < ift then
1856 qfli = ift;
1857 else qfli = afli;
1858
1859 if alle > ilb & alle < ift then
1860 qlle = ift;
1861 else qlle = alle;
1862
1863
1864 if ^flsw then do;
1865 fli, lli = qfli;
1866 fle, lle = qlle;
1867 end;
1868 else if ^llsw then do;
1869 if fli > ilb & fli < ift then
1870 lli = ift;
1871 else lli = fli;
1872 if fle > ilb & fle < ift then
1873 lle = ift;
1874 else lle = fle;
1875 end;
1876 if (ift > ife) & (ilb < 1) then do;
1877 call ioa_ ("Buffer empty.");
1878 go to rq_err;
1879 end;
1880 if (fli = 0) | (lle = 0) | (fli > ife) then do;
1881 call ioa_ ("Address out of buffer.");
1882 go to rq_err;
1883 end;
1884 if fli > lle then do;
1885 call ioa_ ("Address wrap-around.");
1886 go to rq_err;
1887 end;
1888 if fli > ife then fli = ilb;
1889 if lli > ife then lli = ilb;
1890 if fle > ife then fle = ilb;
1891 if lle > ife then lle = ilb;
1892 return;
1893
1894 end defaults;
1895 %page;
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905 input:
1906 procedure (afp, afe);
1907
1908 dcl afp ptr,
1909 afe fixed bin (21);
1910
1911
1912 if t.c (ti) = NL then go to rd_line;
1913 if t.c (ti) = " " then ti = ti + 1;
1914 if ti <= te then go to inp_search;
1915 rd_line:
1916 call edx_util_$read_ptr (qid_ptr, tp, length (iline), te);
1917
1918 ti = 1;
1919
1920 inp_search:
1921 k = search (substr (tp -> a_string, ti, te - ti + 1), "^\^Y\");
1922
1923
1924 if k = 0 then do;
1925 k = te - ti + 2;
1926 inp_move_string:
1927 call promote (k - 1);
1928 substr (afp -> a_string, afe + 1, (k - 1)) = substr (tp -> a_string, ti, (k - 1));
1929 afe = afe + (k - 1);
1930 if (k - 1) > 0 then b.modified = "1"b;
1931 go to rd_line;
1932 end;
1933
1934 kx = index ("^\^Y\", t.c (ti + (k - 1)));
1935 go to inp_case (kx);
1936
1937 inp_case (1):
1938 ka = 0;
1939 inp_act (1):
1940 inp_act (2):
1941 inp_final:
1942 call promote (k - 1);
1943 substr (afp -> a_string, afe + 1, (k - 1)) = substr (tp -> a_string, ti, (k - 1));
1944
1945 afe = afe + (k - 1);
1946 if (k - 1) > 0 then b.modified = "1"b;
1947 ti = ti + k + ka;
1948 return;
1949
1950 inp_case (2):
1951 ka = 0;
1952 inp_act (3):
1953 inp_act (4):
1954 inp_conceal:
1955 if (ti + k + ka) > te then go to inp_move_string;
1956 call promote (k);
1957 substr (afp -> a_string, afe + 1, k) = substr (tp -> a_string, ti, (k - 1)) || t.c (ti + k + ka);
1958
1959 afe = afe + k;
1960 if k > 0 then b.modified = "1"b;
1961 ti = (ti + k + ka) + 1;
1962 if ti > te then
1963 go to rd_line;
1964 else go to inp_search;
1965
1966 inp_case (3):
1967 ka = 1;
1968
1969 kx = index ("fFcC", t.c (ti + k));
1970
1971 if kx = 0
1972 then do;
1973 call promote (k);
1974 substr (afp -> a_string, afe + 1, k) = substr (tp -> a_string, ti, k);
1975
1976 afe = afe + k;
1977 if k > 0 then b.modified = "1"b;
1978 ti = ti + k;
1979 if ti > te then
1980 go to rd_line;
1981 else go to inp_search;
1982 end;
1983
1984 go to inp_act (kx);
1985
1986
1987 end input;
1988 %page;
1989
1990
1991
1992
1993
1994
1995
1996
1997 interrupt:
1998 procedure ();
1999
2000 if pi_sw then do;
2001 pi_sw = "0"b;
2002 go to pi_label;
2003 end;
2004 else do;
2005 intsw = "1"b;
2006 return;
2007 end;
2008
2009 end interrupt;
2010 %page;
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026 promote:
2027 procedure (string_length);
2028
2029 dcl string_length fixed bin (21);
2030
2031 dcl (new_fe, new_ft) fixed bin (21);
2032
2033 dcl offset_action fixed bin (21);
2034
2035 if (ife - ift + 1) + (ilb) + string_length > ife then do;
2036
2037 new_fe = ife;
2038 do while ((ife - ift + 1) + ilb + string_length > new_fe);
2039 if new_fe >= sys_info$max_seg_size * 4 then do;
2040
2041 if pi_label = sub_done then do;
2042 call ioa_ ("^a: Segment full!! Skipping remaining substitutions.", qid.editor_name);
2043 goto sub_done;
2044 end;
2045
2046 if pi_label = in_mode then
2047 call ioa_ ("^a: Segment full!! Last line of input lost - back to command mode.",
2048 qid.editor_name);
2049 else call ioa_ ("^a: Read will not fit in buffer - read not performed.", qid.editor_name);
2050 if pi_label = in_mode then call last_line (ilb);
2051
2052 goto rq_err;
2053 end;
2054 else new_fe = min (new_fe * 4, sys_info$max_seg_size * 4);
2055 end;
2056 new_ft = ift - ife + new_fe;
2057
2058 if ife - ift >= 0 then do;
2059 call mrl_ (addr (substr (ifp -> a_string, ift)), (ife - ift + 1),
2060 addr (substr (ifp -> a_string, new_ft)), (ife - ift + 1));
2061 end;
2062
2063
2064
2065 offset_action = new_ft - ift;
2066 if lle >= ift then lle = lle + offset_action;
2067 if lli >= ift then lli = lli + offset_action;
2068 if le >= ift then le = le + offset_action;
2069 if li >= ift then li = li + offset_action;
2070
2071 if mi >= ift then mi = mi + offset_action;
2072 if me >= ift then me = me + offset_action;
2073 if fli >= ift then fli = fli + offset_action;
2074
2075 if b.ti >= ift then do;
2076 b.ti = b.ti + offset_action;
2077 b.te = b.te + offset_action;
2078 end;
2079
2080 ife = new_fe;
2081 ift = new_ft;
2082 end;
2083
2084 end promote;
2085 %page;
2086
2087
2088
2089
2090
2091 open_gap:
2092 procedure (gap_index);
2093
2094
2095
2096 dcl gap_index fixed bin (21);
2097
2098 dcl offset_action fixed bin (21);
2099
2100 dcl gap fixed bin (21);
2101
2102 if ilb ^= gap_index & ift - 1 ^= gap_index then do;
2103
2104 if gap_index <= ilb then do;
2105 gap = ilb - gap_index;
2106 call mrl_ (addr (substr (ifp -> a_string, gap_index + 1)), gap,
2107 addr (substr (ifp -> a_string, ift - gap)), gap);
2108 offset_action = -gap_index + ift - gap - 1;
2109
2110 if li <= ilb & li > gap_index then li = li + offset_action;
2111 if le <= ilb & le > gap_index then le = le + offset_action;
2112 if lli <= ilb & lli > gap_index then lli = lli + offset_action;
2113 if lle <= ilb & lle > gap_index then lle = lle + offset_action;
2114 if fli <= ilb & fli > gap_index then fli = fli + offset_action;
2115 if fle <= ilb & fle > gap_index then fle = fle + offset_action;
2116
2117 if b.ti <= ilb & b.ti > gap_index then b.ti = b.ti + offset_action;
2118
2119 ift = ift - gap;
2120 ilb = ilb - gap;
2121
2122 if b.ti <= ilb then
2123 b.te = ilb;
2124 else b.te = ife;
2125 end;
2126 else do;
2127 gap = gap_index - ift + 1;
2128 substr (ifp -> a_string, ilb + 1, gap) = substr (ifp -> a_string, ift, gap);
2129 offset_action = -ift + ilb + 1;
2130 if li >= ift & li <= gap_index then li = li + offset_action;
2131 if le >= ift & le <= gap_index then le = le + offset_action;
2132 if lli >= ift & lli <= gap_index then lli = lli + offset_action;
2133 if lle >= ift & lle <= gap_index then lle = lle + offset_action;
2134
2135 if b.ti >= ift & b.ti <= gap_index then b.ti = b.ti + offset_action;
2136
2137 if fli >= ift & fli <= gap_index then fli = fli + offset_action;
2138 if fle >= ift & fle <= gap_index then fle = fle + offset_action;
2139 ilb = ilb + gap;
2140 ift = ift + gap;
2141 if b.ti <= ilb then
2142 b.te = ilb;
2143 else b.te = ife;
2144
2145 end;
2146 end;
2147
2148 end open_gap;
2149 %page;
2150 %include qedx_internal_data;
2151 %page;
2152 %include qedx_info;
2153 %page;
2154 %include qedx_buffer_io_info;
2155 %page;
2156 %include access_mode_values;
2157
2158 %include sub_err_flags;
2159
2160 %include terminate_file;
2161
2162 end qedx_;