!++
! FACILITY:
!	Text Processing Utility (VAXTPU)
!
! ABSTRACT:
!	This is the VAXTPU source program for the EDTplus emulator interface
!
!	compile this by
!		EDIT/TPU/SECTION=EDTSECINI/Command=EDTPLUS.TPU
!	then invoke TPU by
!		EDIT/TPU/SEC=yourdir:EDTPLUS filename
!
! ENVIRONMENT:
!	VAX/VMS (need to recompile for vms 4.4)
!
! CREATION DATE: 16-Oct-1985    original version - Portia R. Shao
! MODIFICATIONS: 22-Oct-1985	do not map more than one DCL window
!		 26-Nov-1985	ask for alternate file name if can't write
!				in write_current_buffer
!		 18-Feb-1986	fix end-of range for 1 character range in
!				replace
!		 16-May-1986	added rectangular cut and paste - Fred Kamgar
!                10-Jul-1986    added option to display line # at - FK
!                23-Jul-1986    added mark checking in rectangular cut - FK
!		 06-Feb-1987	added untab, redefine_tab, better scolling
!				using kp8, etc - PRS
!		 16-Apr-1987	modified Gold-W to ask for file name - PRS
!		 23-Jun-1987	replaced list_buffers -Dave S. Wallace
!		 06-Jul-1987	modified do_dcl_command with $set noon -PRS
!--
Procedure include_file
LOCAL file;
  file:=read_line('Include file:');
  read_file(file);
endProcedure;	!include_file
Procedure goto_file
LOCAL file,buff,buffer_ptr;                     
  file:=read_line('Goto file:');
  buff:=file;
  buffer_ptr:=edt$find_buffer(buff);
  if buffer_ptr=0 then
    buffer_ptr:=create_buffer(buff,file);
  endif;
  map(current_window,buffer_ptr);
  show_status_line;
endProcedure;	!goto_file
Procedure goto_readonly_file
LOCAL file,buff,buffer_ptr,window_ptr;
  file:=read_line('Goto file <readonly>:');
  buff:=file;
  buffer_ptr:=edt$find_buffer(buff);
  if buffer_ptr=0 then
    buffer_ptr:=create_buffer(buff,file);
  endif;
  window_ptr:=half_window;
  set(scrolling,window_ptr,ON,0,0,0);
  map(window_ptr,buffer_ptr);
  set(NO_WRITE,current_buffer,ON);
  show_status_line;
endProcedure;	!goto_readonly_file
Procedure visit_file
LOCAL file,buff,buffer_ptr,window_ptr;
  file:=read_line('Visit file:');
  buff:=file;
  buffer_ptr:=edt$find_buffer(buff);
  if buffer_ptr=0 then
    buffer_ptr:=create_buffer(buff,file);
  endif;
  window_ptr:=half_window;
  set(scrolling,window_ptr,ON,0,0,0);
  map(window_ptr,buffer_ptr);
  show_status_line;
endProcedure;	!visit_file
Procedure write_current_buffer
LOCAL nowrite,file;
on_error
  file:=read_line('Enter another filename:');
  write_file(current_buffer,file);
endon_error;
  nowrite:=get_info(current_buffer,'no_write');
  if nowrite=1
  then
    file:=read_line('Buffer is READONLY, enter another filename:');
    write_file(current_buffer,file);
  else                                     
    file:=read_line('Enter filename (or <CR> for default):');
    if file='' then 
      write_file(current_buffer);
    else
      write_file(current_buffer,file);
    endif;
  endif;
endProcedure;	!write_current_buffer
Procedure update_all_files
LOCAL buf;
  buf:=get_info(buffers,'first');
  loop
    exitif buf=0;
    if (get_info(buf,'modified')=1) AND (get_info(buf,'file_name')<>'')
       AND (get_info(buf,'no_write')=0)
    then
      write_file(buf);
    endif;
    buf:=get_info(buffers,'next');
  endloop;
endProcedure;	!update_all_files
Procedure map_to_buffer(buff)
LOCAL buffer_ptr;
  buffer_ptr:=edt$find_buffer(buff);
  if buffer_ptr=0
  then
    buffer_ptr:=create_buffer(buff);
  endif;
  map(current_window,buffer_ptr);
  show_status_line;
endProcedure;	!map_to_buffer
Procedure goto_buffer
LOCAL buff;
  buff:=read_line('Goto buffer:');
  map_to_buffer(buff);
endProcedure;	!goto_buffer
Procedure goto_main_buffer
LOCAL buff;
  buff:='MAIN';
  map_to_buffer(buff);
endProcedure;	!goto_main_buffer
Procedure next_window
LOCAL window_ptr;
  window_ptr:=current_window;
  loop
    window_ptr:=get_info(window_ptr,'next');
    exitif window_ptr=0;
    if get_info(window_ptr,'visible')=1
    then
      position(window_ptr);
      exitif;
    endif;
  endloop;
  if window_ptr=0
  then
    message('No next window');
  endif;
endProcedure;	!next_window
Procedure previous_window
LOCAL window_ptr;
  window_ptr:=current_window;
  loop
    window_ptr:=get_info(window_ptr,'previous');
    exitif window_ptr=0;
    if get_info(window_ptr,'visible')=1
    then
      position(window_ptr);
      exitif;
    endif;
  endloop;
  if window_ptr=0
  then
    message('No previous window');
  endif;
endProcedure;	!previous_window
Procedure window_half
LOCAL window_ptr;
  window_ptr:=half_window;
  set(scrolling,window_ptr,ON,0,0,0);
  map(window_ptr,current_buffer);
  show_status_line;
endProcedure;	! window_half
Procedure window_top
LOCAL cur_row,vtop,n;
  cur_row:=current_row;
  vtop:=get_info(current_window,'visible_top');
  n:=cur_row-vtop;
  scroll(current_window,n);
  cursor_vertical(-n);
endProcedure;	!window_top
Procedure window_bottom
LOCAL cur_row,vbot,n;
  cur_row:=current_row;
  vbot:=get_info(current_window,'visible_bottom');
  n:=vbot-cur_row;
  scroll(current_window,-n);
  cursor_vertical(n);
endProcedure;	!window_bottom
Procedure only_window
LOCAL vtop,vbot,tmp_pos;
  tmp_pos:=mark(none);
  vtop:=get_info(current_window,'visible_top');
  vbot:=get_info(current_window,'visible_bottom');
  adjust_window(current_window,1-vtop,20-vbot);
  position(tmp_pos);
  update(current_window);
endProcedure;	! only_window
Procedure grow_window
LOCAL vtop,vbot,n_lines;
  vtop:=get_info(current_window,'visible_top');
  vbot:=get_info(current_window,'visible_bottom');
  if vtop>1
  then
    adjust_window(current_window,-1,0);
  else
    adjust_window(current_window,0,1);
  endif;
endProcedure;	!grow_window
Procedure shrink_window
LOCAL vtop,vbot,n_lines;
  vtop:=get_info(current_window,'visible_top');
  vbot:=get_info(current_window,'visible_bottom');
  n_lines:=get_info(current_window,'visible_length')-1;
  if n_lines=2
  then
    message('Can not shrink more');
    return;
  endif;
  if vtop>1
  then
    adjust_window(current_window,1,0);
  else
    adjust_window(current_window,0,-1);
  endif;
endProcedure;	!shrink_window
Procedure change_window_width
LOCAL current_width;
  current_width:=get_info(current_window,'WIDTH');
  if current_width<=80
  then 
    set(width,current_window,132);
  else
    set(width,current_window,80);
  endif;
endProcedure;	!change_window_width
Procedure scroll_sect !kp8 (section)
LOCAL n;
  n := get_info(current_window,'visible_length');
  if get_info(current_buffer,'direction') = forward
  then
    scroll(current_window,n-2)
  else
    scroll(current_window,- n+2)
  endif;
endprocedure;	!scroll_sect
Procedure pick_range
LOCAL tmp_pos;
  edt$select_range;
  if edt$x_select_range<>0
  then
    tmp_pos:=mark(none);
    pick_buffer:=edt$find_buffer('PICK');
    if pick_buffer=0
    then
      pick_buffer:=create_buffer('PICK');
      set(NO_WRITE,pick_buffer,ON);
      set(eob_text,pick_buffer,'[End of Pick]');
      set(system,pick_buffer);
    else
      erase(pick_buffer);
    endif;
    position(pick_buffer);
    split_line;
    move_vertical(-1);
    copy_text(edt$x_select_range);
    position(tmp_pos);
    edt$x_select_range:=0;
  else
    message('No Select Active');
    edt$x_repeat_count:=1;
  endif;
endProcedure;	!pick_range
Procedure put_range
  if (beginning_of(pick_buffer)<>end_of(pick_buffer))
  then
    copy_text(pick_buffer);
    append_line;
  endif;
endProcedure;	!put_range
Procedure insert_rect
LOCAL col,counter,end_ins,extract_buff,ins_mark,llen,numlines,numlines_added,
  start_ins,tabs,tabsearch,temp,tflag;
  on_error
  endon_error;
  set (bell,all,on);
  extract_buff:=edt$find_buffer("EXTRACT");
  if (extract_buff<>0) then 
    numlines:=get_info(extract_buff,"record_count");
    if (numlines<>0) then 
      col:=current_column;
      move_horizontal(1-col);
      tflag:=0; ! flag to indicate inserting text at end of buffer
      if (mark(none)=end_of(current_buffer)) then
        tflag:=1;
        split_line;
        move_vertical(-1);
      endif;
      start_ins:=mark(none);
      counter:=0;
      numlines_added:=0;
      loop
        exitif (counter=numlines);
        if (mark(none)=end_of(current_buffer)) then
          split_line;
          numlines_added:=numlines_added+1;
        else
          move_vertical(+1);
        endif;
        counter:=counter+1;
      endloop;
      end_ins:=mark(none);
      if tflag=1 then
        move_vertical(-1);
        erase_line;
      endif;
      position(beginning_of(extract_buff));
      position(start_ins);
      tabsearch:=search(ascii(9),forward);
      if tabsearch=0 then 
        tabs:=0;
      else
        if beginning_of(tabsearch)>=end_ins then
          tabs:=0;
        else
          tabs:=1;
        endif;
      endif;
      if (tabs=0) then !no tabs in inserting range
        counter:=0;
        loop
          exitif (counter=numlines);
          llen:=length(current_line);
          if (llen<(col-1)) then !extend line with blanks if necessary
            move_horizontal(llen-get_info(current_buffer,"offset_column")+1);
            nb:=(col-llen-1);
            pad_w_nb_blanks;
          else
            move_horizontal(col-get_info(current_buffer,"offset_column"));
          endif;
          ins_mark:=mark(none);
          position(extract_buff);
          temp:=mark(none);
          move_vertical(+1);
          move_horizontal(-2);
          ins_range:=create_range(temp,mark(none),none);
          move_horizontal(+2);
          position(ins_mark);
          copy_text(ins_range);
          move_vertical(+1);
          counter:=counter+1;
        endloop;
      else
        message('cannot insert because tabs are imbedded in the text');
        position(end_ins);
        counter:=0;
        loop  ! delete extra lines added
          exitif (counter=numlines_added);
          move_vertical(-1);
          erase_line;
          counter:=counter+1;
        endloop;
      endif;
      position(start_ins);
      move_horizontal(col-1);
    else
      message("EXTRACT buffer empty");
    endif;
  else
    message("no data to insert");
  endif;
  set (bell,all,off);
  set (bell,broadcast,on);
endProcedure;  !insert_rect
Procedure overlay_rect
LOCAL col,counter,end_ins,extract_buff,ins_mark,linelen,llen,numlines,
  numlines_added,start_ins,tabs,tabsearch,temp,temp_range,tflag;
  on_error
  endon_error
  set (bell,all,on);
  extract_buff:=edt$find_buffer("EXTRACT");
  if (extract_buff<>0) then 
    numlines:=get_info(extract_buff,"record_count");
    if (numlines<>0) then 
      col:=current_column;
      move_horizontal(1-col);
      tflag:=0;
      if (mark(none)=end_of(current_buffer)) then
        tflag:=1;
        split_line;
        move_vertical(-1);
      endif;
      start_ins:=mark(none);
      counter:=0;
      numlines_added:=0;
      loop
        exitif (counter=numlines);
        if (mark(none)=end_of(current_buffer)) then
          split_line;
          numlines_added:=numlines_added+1;
        else
          move_vertical(+1);
        endif;
        counter:=counter+1;
      endloop;
      end_ins:=mark(none);
      if tflag=1 then
        move_vertical(-1);
        erase_line;
      endif;
      position(beginning_of(extract_buff));
      linelen:=length(current_line);
      position(start_ins);
      tabsearch:=search(ascii(9),forward);
      if tabsearch=0 then 
        tabs:=0;
      else
        if beginning_of(tabsearch)>=end_ins then
          tabs:=0;
        else
          tabs:=1;
        endif;
      endif;
      if (tabs=0) then !no tabs in inserting range
        counter:=0;
        loop
          exitif (counter=numlines);
          llen:=length(current_line);
          if ((llen-col+1)<linelen) then !extend line with blanks if necessary
            move_horizontal(llen-get_info(current_buffer,"offset_column")+1);
            nb:=(linelen+col-llen-1);
            pad_w_nb_blanks;
          endif;
          move_horizontal(col-get_info(current_buffer,"offset_column"));
          temp:=mark(none);
          move_horizontal(linelen-1);
          temp_range:=create_range(temp,mark(none),none);
          erase(temp_range);
          ins_mark:=mark(none);
          position(extract_buff);
          temp:=mark(none);
          move_vertical(+1);
          move_horizontal(-2);
          ins_range:=create_range(temp,mark(none),none);
          move_horizontal(+2);
          position(ins_mark);
          copy_text(ins_range);
          move_vertical(+1);
          counter:=counter+1;
        endloop;
      else
        message('cannot overlay because tabs are imbedded in the text');
        position(end_ins);
        counter:=0;
        loop  ! delete extra lines added
          exitif (counter=numlines_added);
          move_vertical(-1);
          erase_line;
          counter:=counter+1;
        endloop;
      endif;
      position(start_ins);
      move_horizontal(col-1);
    else
      message("EXTRACT buffer empty");
    endif;
  else
    message("no data to insert");
  endif;
  set (bell,all,off);
  set (bell,broadcast,on);
endProcedure;  !overlay_rect
Procedure mark_it
  mark_1:=mark(reverse);
  col_1:=current_column;
endProcedure;   !mark_it
Procedure extract_rect
LOCAL col_2,dummy_buff,dumb,end_ext,ext_range,extract_buff,flag,last_line,
  leftcolm,llen,rect_width,ret_mark,tabs,temp; 
  on_error  !suppress WARNING error messages
  endon_error
  mark_2:=mark(none);
  set (bell,all,on);
  col_2:=current_column;
  if not(mark_1) then 
    message("no marker set");
  else
    if (mark_1<>mark_2) then
      if (mark_1<mark_2) then 
        flag:=1; !flag used for cursor placement after extract
        position(mark_1);
        move_horizontal(1-col_1); !beginning of line
        start_ext:=mark(none);
        position(mark_2);
        move_horizontal(length(current_line)-col_2+1); !end of line 
        end_ext:=mark(none);
      else
        position(mark_2);
        move_horizontal(1-col_2); !beginning of line
        start_ext:=mark(none);
        if (start_ext=beginning_of(current_buffer)) then
          flag:=2;
        else
          flag:=3;
          move_horizontal(-1);
          ret_mark:=mark(none);
        endif;
        position(mark_1);
        move_horizontal(length(current_line)-col_1+1); !end of line
        end_ext:=mark(none);
      endif;
      position(end_ext);
      ext_range:=create_range(start_ext,end_ext,none);
      dummy_buff:=create_buffer('DUMMY');
      set(no_write,dummy_buff,on);
      set(system,dummy_buff);
      position(dummy_buff);
      copy_text(ext_range);
      tabs:=search(ascii(9),REVERSE);
      if tabs=0 then 
        extract_buff:=edt$find_buffer('EXTRACT');
        if extract_buff=0 then 
          extract_buff:=create_buffer('EXTRACT');
          set(no_write,extract_buff,on);
          set(eob_text,extract_buff,'[End of Extract]');
          set(system,extract_buff);
        else
          erase(extract_buff);
        endif;
        erase(ext_range);
        leftcolm:=col_1;
        if col_1>col_2 then 
          leftcolm:=col_2;
          col_2:=col_1;
          col_1:=leftcolm;
        endif;
        rect_width:=col_2-col_1+1;
        position(beginning_of(dummy_buff));
        numlines:=get_info(current_buffer,"record_count");
        dumb:=1;
        loop
          llen:=length(current_line);
          if llen<col_2 then 
            move_horizontal(llen-get_info(current_buffer,"offset_column")+1);
            nb:=(col_2-llen);
            pad_w_nb_blanks;
          endif;
          exitif (dumb=numlines);
          dumb:=dumb+1;
          move_vertical(1);
        endloop;      
        dumb:=1;
        position(beginning_of(dummy_buff));
        loop
          move_horizontal(col_1-get_info(current_buffer,"offset_column"));
          temp:=mark(none);
          move_horizontal(rect_width-1);
          ext_range:=create_range(temp,mark(none),none);
          position(extract_buff);
          move_text(ext_range);
          split_line;
          position(dummy_buff);
          exitif (dumb=numlines);
          dumb:=dumb+1;
          move_vertical(1);
        endloop;
        position(extract_buff);
        erase_line;
        position(start_ext);
        move_text(dummy_buff);
        delete(dummy_buff);
        if (flag=1) then
          move_vertical(-1);
        else 
          if (flag=2) then 
            position(beginning_of(current_buffer));
          else 
            position(ret_mark);
            move_horizontal(+1);
          endif;
        endif;
        move_horizontal(leftcolm-1);
      else 
        message('cannot extract rectangle if tabs are imbedded in text');
        position(mark_2);
        delete(dummy_buff);
      endif; !tab check
    endif; ! if mark_1<>mark_2
    delete(mark_1);
  endif; ! if mark_1 exists
  set (bell,all,off);
  set (bell,broadcast,on);
endProcedure;  !extract_rect
Procedure pad_w_nb_blanks
LOCAL n,loc,blanks_range,end_pad;
  if (nb<>0) then 
    loc:=mark(none);
    blanks_buff:=edt$find_buffer('BLANKS');
    if blanks_buff=0 then 
      blanks_buff:=create_buffer('BLANKS');
      set(no_write,blanks_buff,on);
      set(system,blanks_buff);
      position(blanks_buff);  !insert 132 blanks in blanks_buff for padding
      n := 0;
      loop
        copy_text(' ');
        n := n+1;
        exitif n=132;
      endloop;
      position(loc);
    endif;
    position(beginning_of(blanks_buff));
    move_horizontal(nb-1);
    end_pad:=mark(none);
    blanks_range:=create_range(beginning_of(blanks_buff),end_pad,none);
    position(loc);
    copy_text(blanks_range);
  endif;
endProcedure;  !pad_w_nb_blanks
Procedure copy_rect
LOCAL col_2,dummy_buff,dumb,end_ext,ext_range,extract_buff,
      last_line,llen,rect_width,tabs,temp; 
  on_error  !suppress WARNING error messages
  endon_error
  set (bell,all,on);
  mark_2:=mark(none);
  col_2:=current_column;
  if not(mark_1) then 
    message("no marker set");
  else
    if (mark_1<>mark_2) then
      if (mark_1<mark_2) then 
        position(mark_1);
        move_horizontal(1-col_1); !beginning of line
        start_ext:=mark(none);
        position(mark_2);
        move_horizontal(length(current_line)-col_2+1); !end of line 
        end_ext:=mark(none);
      else
        position(mark_2);
        move_horizontal(1-col_2); !beginning of line
        start_ext:=mark(none);
        position(mark_1);
        move_horizontal(length(current_line)-col_1+1); !end of line
        end_ext:=mark(none);
      endif;
      position(end_ext);
      ext_range:=create_range(start_ext,end_ext,none);
      dummy_buff:=create_buffer('DUMMY');
      set(no_write,dummy_buff,on);
      set(system,dummy_buff);
      position(dummy_buff);
      copy_text(ext_range);
      tabs:=search(ascii(9),reverse); !search for any imbedded tabs -
      if tabs=0 then  ! this routine will not work with imbedded tabs
        extract_buff:=edt$find_buffer('EXTRACT');
        if extract_buff=0 then 
          extract_buff:=create_buffer('EXTRACT');
          set(no_write,extract_buff,on);
          set(eob_text,extract_buff,'[End of Extract]');
          set(system,extract_buff);
        else
          erase(extract_buff);
        endif;
        if col_1>col_2 then 
          dumb :=col_1;
          col_1:=col_2;
          col_2:=dumb;
        endif;
        rect_width:=col_2-col_1+1;
        position(beginning_of(dummy_buff));
        numlines:=get_info(current_buffer,"record_count");
        dumb:=1;
        loop
          llen:=length(current_line);
          if llen<col_2 then 
            move_horizontal(llen-get_info(current_buffer,"offset_column")+1);
            nb:=(col_2-llen);
            pad_w_nb_blanks;
          endif;
          exitif (dumb=numlines);
          dumb:=dumb+1;
          move_vertical(1);
        endloop;      
        dumb:=1;
        position(beginning_of(dummy_buff));
        loop
          move_horizontal(col_1-get_info(current_buffer,"offset_column"));
          temp:=mark(none);
          move_horizontal(rect_width-1);
          ext_range:=create_range(temp,mark(none),none);
          position(extract_buff);
          move_text(ext_range);
          split_line;
          position(dummy_buff);
          exitif (dumb=numlines);
          dumb:=dumb+1;
          move_vertical(1);
        endloop;
        position(extract_buff);
        erase_line;
      else 
        message('cannot copy a rectangle if tabs are imbedded in text');
      endif; ! if tab 
      position(mark_2);
      delete(dummy_buff);
    endif; ! if mark_1<>mark_2
    delete(mark_1);
  endif;
  set (bell,all,off);
  set (bell,broadcast,on);
endProcedure;  !copy_rect
Procedure replacement_log
LOCAL msg_text;
  case n from 0 to 1
  [0]: msg_text:='No replacements made';
  [1]: msg_text:='Replaced 1 occurrence';
  [outrange]:   msg_text:=FAO('Replaced !UL occurrences',n);
  endcase;
  erase(message_buffer);
  message(msg_text);
  position(here);
  update(current_window);
endProcedure;	!replacement_log
Procedure replace
LOCAL from_string,to_string,action,src_range;
!GLOBAL here, n
on_error
  replacement_log;
  return;
endon_error;
  n:=0;
  action:=' ';
  here:=mark(none);
  from_string:=read_line('replace old string> ');
  to_string:=read_line('with new string> ');
  loop
    src_range:=search(from_string,FORWARD);
    erase(message_buffer);
    message(
"' '->change,'!'->change all '.'->change and stop 'n'->don't change 's'->stop");
    position(src_range);
    update(current_window);
    loop
      action:=read_char;
      command_index := index(' !.nNsS',action);
      exitif command_index<>0;
    endloop;
    case command_index from 1 to 7
    [1]: ! change this occurrence
	 erase(src_range);
	 position(end_of(src_range));
	 copy_text(to_string);
	 n:=n+1;
    [2]: ! change all
	 loop
	   erase(src_range);
	   position(end_of(src_range));
	   copy_text(to_string);
	   n:=n+1;
	   src_range:=search(from_string,FORWARD);
	 endloop;
	 exitif;	!exit loop for each occurrence
    [3]: ! change and stop
	 erase(src_range);
	 position(end_of(src_range));
	 copy_text(to_string);
	 n:=n+1;
	 exitif;
    [4,5]:! don't change this one
	 if length(from_string)=1
	 then
	   move_horizontal(1)
	 else
	   position(end_of(src_range))
	 endif;
    [6,7]:! don't change and stop
	 exitif;
    endcase;
  endloop;
  replacement_log;
endProcedure;	!replace
Procedure settabs
LOCAL tabs,n;
  message('Enter actual tab stops separated by spaces or ');
  message('just one number for interval');
  tabs := read_line ('tabs:');
  edit(tabs,COMPRESS,TRIM);
  n := index(tabs,' ');
  if n = 0 then
    set(tab_stops,current_buffer,int(tabs));
  else
    set(tab_stops,current_buffer,tabs);
  endif;
endProcedure;     !settabs
Procedure untab ! Turn TABs to spaces
LOCAL target,n;
  loop
    target := search(ascii(9), FORWARD);
    exitif (target = 0);
    position(beginning_of(target));
    erase_character(1);
    n := current_offset;
    tab_indent;
endloop;
endProcedure;   !eliminate_tabs
Procedure tab_indent
LOCAL n,b,tab_pos,this_pos,blanks;
  blanks := '                                                       ';
  n := current_offset;
  tab_pos := get_info(current_buffer,'tab_stops');
  if get_info(tab_pos,'type') = integer then
    n := tab_pos - n + ( tab_pos * (n/ tab_pos) );
    copy_text(substr(blanks,1,n));
  else
    loop
      b := index(tab_pos,' ');
      if b = 0 then
        this_pos := int(tab_pos);
      else
        this_pos := int(substr(tab_pos,1,b-1));
      endif;
      exitif (this_pos > n+1) or (b = 0);
      tab_pos := substr(tab_pos,b+1,length(tab_pos)-b);
    endloop;
    if this_pos > n+1 then  ! important to check this first
      copy_text(substr(blanks,1,this_pos-n-1));
    else
      message('no further tabs are defined');
    endif;
  endif;
endProcedure;   !tab_indent
Procedure redefine_tab
  define_key('tab_indent',tab_key,'indent spaces');
endProcedure;      !redefine_tab
Procedure transpose
LOCAL char;
  char:=erase_character(1);
  move_horizontal(-1);
  copy_text(char);
endProcedure;	!transpose
procedure switch_case		!gold kp1 (change case)
LOCAL	 character,what_case,command_index;
  edt$select_range;	!check for active select
  if edt$x_select_range <> 0 
  then
    what_case:=read_line('change to Upper/Lower or Invert? [U/L/I]',1);
    command_index:=index('UuLlIi',what_case);
    case command_index from 1 to 6
    [1,2]:      change_case(edt$x_select_range,UPPER);
    [3,4]:      change_case(edt$x_select_range,LOWER);
    [5,6]:      change_case(edt$x_select_range,INVERT);
    [OUTRANGE]: change_case(edt$x_select_range,INVERT);
    endcase;
    edt$x_select_range:=0;
    return;
  endif;
  if current_character <> edt$x_empty	!change case of current character
  then
    character :=current_character;
    change_case(character,invert);
    erase_character(1);
    copy_text(character);
    if current_direction <> forward
    then
      move_horizontal(-2);
    endif;
    return;
  endif;
endprocedure;	!switch_case
Procedure change_mode
LOCAL current_mode;
  current_mode:=get_info(current_buffer,'MODE');
  if current_mode=INSERT
  then
    set(overstrike,current_buffer);
  endif;
  if current_mode=OVERSTRIKE
  then
    set(insert,current_buffer);
  endif;
  show_status_line;
endProcedure;	!change_mode
Procedure refresh_screen
  erase(message_buffer);
  refresh;
endProcedure;	!refresh_screen
Procedure start_learn;
  message('Remembering...');
  learn_begin(EXACT);
endProcedure;	!start_learn
Procedure end_learn;
  learned:=learn_end;
  message('Done remembering...');
endProcedure;	!end_learn
Procedure save_cursor
  save_buf:=current_buffer;
  save_cur:=mark(none);
  message('Saved current position');
endProcedure;	!save_cursor
Procedure goto_saved_cursor
  map(current_window,save_buf);
  position(save_cur);
  update(current_window);
endProcedure;	!goto_saved_cursor
Procedure display_row_column
LOCAL row_num,col_num;
  row_num:=get_info(current_window,'current_row');
  col_num:=get_info(current_window,'current_column');
  message(FAO('Cursor is at Row !UL Column !UL',row_num,col_num));
endProcedure;	!display_row_column
Procedure linenum !determine what line at in a file
LOCAL num_lines,temp,total_lines;
  temp:=mark(none);
  move_horizontal(1-get_info(current_buffer,"offset_column"));!pos @ beg of line
  total_lines:=get_info(current_buffer,"record_count");
  num_lines:=total_lines+1;
  loop !count how many lines to end_of(current_buffer)
    exitif (mark(none)=end_of(current_buffer));
    move_vertical(+1);
    num_lines:=num_lines-1;
  endloop;
  position(temp);
  message(FAO('you are at line !UL of !UL',num_lines,total_lines));
endProcedure;  !linenum
Procedure goto_line
LOCAL line_num;
  line_num:=int(read_line('Goto line number:'));
  position(beginning_of(current_buffer));
  move_vertical(line_num-1);
endProcedure;	!goto_line
Procedure list_buffers

LOCAL cur_buf,buf,main_pos;

  save_pos:=current_window;
  cur_buf:=current_buffer;
  erase(show_buffer);
  position(show_buffer);
  set(tab_stops,show_buffer,'21 33');
  copy_text('   buffer name');
  copy_text(ascii(9));
  copy_text('lines');
  copy_text(ascii(9));
  copy_text('file');
  split_line;
  copy_text('   -----------');
  copy_text(ascii(9));
  copy_text('-----'); 
  copy_text(ascii(9));
  copy_text('----');
  split_line;
  buf:=get_info(buffers,'first');

  loop exitif buf=0;
    if get_info(buf,'modified')=1
    then
      copy_text('M');
    else
      copy_text(' ');
    endif;
    if get_info(buf,'system')=1 then
      copy_text('S');
    else
      copy_text(' ');
    endif;
    if buf=cur_buf then
      copy_text('=');
    else
      copy_text(' ');
    endif;
    copy_text(get_info(buf,'name'));
    copy_text(ascii(9));              ! insert a tab
    copy_text(str(get_info(buf,'record_count')));
    copy_text(ascii(9));              ! insert a tab
    copy_text(get_info(buf,'file_name'));
    split_line;
    buf:=get_info(buffers,'next');
  endloop;
          
  set(width,info_window,get_info(screen,'width'));
  set(video,info_window,none);
  map(info_window,show_buffer);
  set(status_line,info_window,reverse,
    'Position cursor on buffer with arrow keys and press ENTER');
  position(beginning_of(show_buffer));
  main_pos:=search("=",forward);
  position(main_pos);
  move_horizontal(-2);
  update(info_window);
  define_key('redefine_cr',enter);

endprocedure;	!list_buffers

Procedure redefine_cr

LOCAL file_line,i;

  file_line := current_line;
  file_line := substr(file_line,4,60);
  i := 0;
  loop 
     i := i + 1;
     exitif(substr(file_line,i,1)=ascii(9)); 
     exitif(substr(file_line,i,1)=' '); 
     exitif(i=60);
  endloop;
  i := i - 1;
  file_line := substr(file_line,1,i);
  map_to_buffer(file_line);
  undefine_key (enter);
  
endprocedure;   !redefine_cr
Procedure half_window
LOCAL vtop,vbot,half,window_ptr;
  vtop:=get_info(current_window,'visible_top');
  vbot:=get_info(current_window,'visible_bottom');
  half:=(vbot-vtop)/2+1;
  window_ptr:=create_window(vtop,half,ON);
  return window_ptr;
endProcedure;	!half_window
Procedure do_DCL_command
LOCAL DCLcmd,buff,buffer_ptr;
!GLOBAL DCL_proc,DCL_window
on_error
  if error = tpu$_createfail then
    message ("DCL subprocess could not be created");
    return (0);
  endif;
  DCL_window:=half_window;
  set(scrolling,DCL_window,ON,0,0,0);
  map(DCL_window,buffer_ptr);
  show_status_line;
endon_error;
  DCLcmd:=read_line('DCL command:');
  buff:='DCL';
  buffer_ptr:=edt$find_buffer(buff);
  if buffer_ptr=0 then
    buffer_ptr:=create_buffer(buff);
    set(NO_WRITE,buffer_ptr,ON);
    DCL_proc:=create_process(buffer_ptr,"$ set noon");
    DCL_window:=half_window;
    set(scrolling,DCL_window,ON,0,0,0);
  endif;
  send(DCLcmd,DCL_proc);
  map(DCL_window,buffer_ptr);
  show_status_line;
endProcedure;	!do_DCL_command
Procedure show_status_line
LOCAL buff,file,mode,status;
  buff:=get_info(current_buffer,'NAME');
  file:=get_info(current_buffer,'FILE_NAME');
  mode:=get_info(current_buffer,'MODE');
  if mode=INSERT
  then
    status:='<I>';
  else
    status:='<O>';
  endif;
  if get_info(current_buffer,'NO_WRITE')=1
  then
    status:=status+'<Readonly>';
  endif;
  status:=status+' Buffer:'+buff;
  if file<>''
  then
    status:=status+' File:'+file;
  endif;
  set(status_line,current_window,reverse,status);
endProcedure;	!show_status_line
Procedure show_ascii_table
LOCAL cur_buf,buf;                   
  save_pos:=current_window;
  cur_buf:=current_buffer;
  erase(show_buffer);
  position(show_buffer);
  copy_text('	0	1	2	3	4	5	6	7');
  split_line;
  copy_text(
'    ----+-------+-------+-------+-------+-------+-------+-------+------');
  split_line;
  copy_text(
'    0	NUL  0	DLE  16	SP  32	0  48	@  64	P  80	`   96	p   112');
  split_line;
  copy_text(
'    1	SOH  1	DC1  17	!   33	1  49	A  65	Q  81	a   97	q   113');
  split_line;
  copy_text(
'    2	STX  2	DC2  18	"   34	2  50	B  66	R  82	b   98	r   114');
  split_line;
  copy_text(
'    3	ETX  3	DC3  19	#   35	3  51	C  67	S  83	c   99	s   115');
  split_line;
  copy_text(
'    4	EOT  4	DC4  20	$   36	4  52	D  68	T  84	d  100	t   116');
  split_line;
  copy_text(
'    5	ENQ  5	NAK  21	%   37	5  53	E  69	U  85	e  101	u   117');
  split_line;
  copy_text(
'    6	ACK  6	SYN  22	&   38	6  54	F  70	V  86	f  102	v   118');
  split_line;
  copy_text(
"    7	BEL  7	ETB  23	'   39	7  55	G  71	W  87	g  103	w   119");
  split_line;
  copy_text(
'    8	BS   8	CAN  24	(   40	8  56	H  72	X  88	h  104	x   120');
  split_line;
  copy_text(
'    9	HT   9	EM   25	)   41	9  57	I  73	Y  89	i  105	y   121');
  split_line;
  copy_text(
'    A	LF  10	SUB  26	*   42	:  58	J  74	Z  90	j  106	z   122');
  split_line;
  copy_text(
'    B	VT  11	ESC  27	+   43	;  59	K  75	[  91	k  107	{   123');
  split_line;
  copy_text(
'    C	FF  12	FS   28	,   44	<  60	L  76	\  92	l  108	|   124');
  split_line;
  copy_text(
'    D	CR  13	GS   29	-   45	=  61	M  77	]  93	m  109	}   125');
  split_line;
  copy_text(
'    E	SO  14	RS   30	.   46	>  62	N  78	^  94	n  110	~   126');
  split_line;
  copy_text(
'    F	SI  15	US   31	/   47	?  63	O  79	_  95	o  111	DEL 127');
  split_line;
  set(width,info_window,get_info(screen,'width'));
  set(video,info_window,none);
  map(info_window,show_buffer);
  set(tab_stops,show_buffer,'8 16 24 32 40 48 56 64 72');
  set(status_line,info_window,reverse,
    'Press CTRL-F to remove INFO_WINDOW and resume editing');
  position(beginning_of(show_buffer));
  update(info_window);
endProcedure;	!show_ascii_table
Procedure help_key
LOCAL which_key,key_info;
  erase(message_buffer);
  set(video,message_window,none);
  set(video,message_window,blink);
  message('Press the (shift/control) key you want help on');
  set(video,message_window,none);
  which_key:=read_key;
  key_info:=lookup_key(which_key,COMMENT);
  if key_info<>''
  then
    message('Comment for key is: '+key_info);
  else
    message('There is no comment for this key');
  endif;
endProcedure;	!help_key
Procedure define_edt_plus_keys
  define_key('include_file',key_name('i',shift_key),
    'include file before current line');
  define_key('goto_file',key_name('c',shift_key),
    'use current window to display another file');
  define_key('goto_readonly_file',key_name('v',shift_key),
    'use current window to display another file READONLY');
  define_key('visit_file',key_name('f',shift_key),
    'visit file in another window');
  define_key('write_current_buffer',key_name('w',shift_key),
    'save current file');
  define_key('update_all_files',key_name('u',shift_key),
    'update all modified files on disk');
  define_key('goto_buffer',key_name('b',shift_key),
    'display buffer in current window');
  define_key('goto_main_buffer',key_name('m',shift_key),
    'return to main buffer');
  define_key('next_window',key_name('n',shift_key),'next window');
  define_key('previous_window',key_name('p',shift_key),'previous window');
  define_key('window_half',key_name('+',shift_key),
    'split current window in half');
  define_key('delete(current_window)',key_name('-',shift_key),
    'unmap current window');
  define_key('window_top',key_name(UP,shift_key),
    'move current line to top of window');
  define_key('window_bottom',key_name(DOWN,shift_key),
    'move current line to bottom of window');
  define_key('only_window',key_name('o',shift_key),
    'make this the only window');
  define_key('grow_window',key_name('g',shift_key),
    'grow current window by one line');
  define_key('shrink_window',key_name('s',shift_key),
    'shrink current window by one line');
  define_key('change_window_width',key_name(TAB_KEY,shift_key),
    'toggle window width');
  define_key('shift(current_window,8)',key_name(LEFT,shift_key),
    'shift window left');
  define_key('shift(current_window,-8)',key_name(RIGHT,shift_key),
    'shift window left');
  define_key('scroll_sect',key_name(kp8),'scroll section');
  define_key('pick_range',KP9,'Copy selected range to Pick buffer');
  define_key('put_range',key_name(KP9,shift_key),
    'put contents of Pick buffer here');
  define_key('mark_it',key_name('.',shift_key),'mark corner of rectangle');
  define_key('insert_rect',key_name('>',shift_key),'insert rectangle');
  define_key('extract_rect',key_name('<',shift_key),'extract rectangle');
  define_key('overlay_rect',key_name(')',shift_key),'paste over rectangle');
  define_key('copy_rect',key_name('(',shift_key),'take a copy rectangle');
  define_key('replace',key_name('r',shift_key),'replace string');
  define_key('copy_text(ascii(int(read_line('+
    '"Enter ASCII code in decimal: "))))',
    key_name(KP3,shift_key),'special insert');
  define_key('copy_text(read_char)',ctrl_v_key,'Quote next character');
  define_key('settabs',key_name('&',shift_key),'set tab stops');
  define_key('transpose',key_name('t',shift_key),'transpose two characters');
  define_key('switch_case',key_name(KP1,shift_key),'switch case');
  define_key('change_mode',ctrl_a_key,'insert/overstrike toggle');
  define_key('refresh_screen',ctrl_w_key,
    'erase message buffer and refresh screen');
  define_key('start_learn',key_name('[',shift_key),'Start learn sequence');
  define_key('execute(learned)',key_name('x',shift_key),
    'Execute learn sequence');
  define_key('end_learn',key_name(']',shift_key),'End learn sequence');
  define_key('save_cursor',key_name('=',shift_key),'save current location');
  define_key('goto_saved_cursor',key_name('^',shift_key),'goto saved location');
  define_key('display_row_column',key_name('?',shift_key),'display row,column');
  define_key('goto_line',key_name('#',shift_key),'goto line specified');
  define_key('linenum',ctrl_n_key,'display line number currently at');
  define_key('list_buffers',key_name('l',shift_key),'list buffers');
  define_key('do_dcl_command',key_name('d',shift_key),'do DCL command');
  define_key('show_ascii_table',key_name('a',shift_key),'show ascii table');
  define_key('help_key',key_name('h',shift_key),
    'display comment on key definitions');
  define_key('attach',key_name('z',shift_key),'Attach to parent process');
  define_key('quit',key_name('q',shift_key),'quit');
  define_key('exit',key_name('e',shift_key),'exit');
endProcedure;	!define_edt_plus_keys
Procedure tpu$local_init
  edt$x_word:=' '+ascii(9)+ascii(12)+ascii(13)+ascii(11)+"!@()_-+={}[]:;'"+
              '"<>,.?/|\';
  set(prompt_area,(get_info(SCREEN,'VISIBLE_LENGTH')-2),1,NONE);
  set(scrolling,main_window,ON,0,0,0);
  set(informational,on);
  set(bell,broadcast,ON);
  show_status_line;
endProcedure;
define_edt_plus_keys;
compile('procedure define_edt_plus_keys endprocedure');
save('sys$disk:[]edtplus');
quit;
!------------------------ end of edtplus.tpu -----------------------------