MODULE TPUPlus_UTIL IDENT "900409"
!
! TPUPlus utility procedures module
!
!   PROCEDURE EVE_COUNT (TARGET_STRING)
!   PROCEDURE EVE_COMPRESS_LINE
!   PROCEDURE EVE_DESCRIBE_KEY
!   PROCEDURE EVE_DISPLAY_CHARACTER
!   PROCEDURE EVE_FIX_CRLFS
!   PROCEDURE EVE_INSERT_DATE
!   PROCEDURE EVE_INSERT_RULER
!   PROCEDURE EVE_INSERT_TIME
!   PROCEDURE EVE_LIST_COMMANDS
!   PROCEDURE EVE_MAIL
!   PROCEDURE EVE_NUMBER_LINES
!   PROCEDURE EVE_PAD_LINES (COLUMN_TO_PAD_TO)
!   PROCEDURE EVE_PHONE
!   PROCEDURE EVE_RUN (RUN_STRING)
!   PROCEDURE EVE_SPECIAL_INSERT (DECIMAL_VALUE)
!   PROCEDURE EVE_STAMP_DATE
!   PROCEDURE EVE_TEST_COMPILE (DIRECTIVES)
!   PROCEDURE EVE_TRIM
!   PROCEDURE EVE_TRUNCATE_LINES (TRUNC_LENGTH)
!   PROCEDURE EVE_UNNUMBER_LINES
!   PROCEDURE EVE_WHICH_COLUMN
!

!****************************************
PROCEDURE EVE_COUNT (TARGET_STRING)
!
! procedure to search for and count all occurances of a specified string
!
! modified 910319 - RHS - altered code to handle wildcard searches
!
Local   this_string,
        this_range,
        this_count,
        temp,
        found_flag, 
        old_position,   
        the_direction,
        how_exact,
        leading_whitespace;

old_position    := mark (free_cursor);
this_string     := target_string;

if (current_direction = FORWARD) then
    the_direction := 'Forward ';
else
    the_direction := 'Reverse ';
endif;

if pce$case_sensitive <> "" then
    if pce$case_sensitive then
        how_exact := eve$x_find_exact;
    else
        if pce$case_sensitive = false then
            how_exact := eve$x_find_no_exact;
        endif;
    endif;
endif;

if target_string = '' then
    this_string := read_line ('COUNT - ' +
        the_direction + 'wild-card search: ');
endif;

if this_string = '' then
    message ("No search target specified - operation cancelled");
    return;
endif;

if (eve$$build_pattern (this_string, eve$x_target_pattern,
    leading_whitespace) = 1) then
    eve$x_target := execute ("return (" + eve$x_target_pattern + ")");
else
    eve$x_target := eve$x_target_pattern;
endif;

found_flag := false;
this_count := 0;

loop;
    this_range := search (eve$x_target, current_direction, how_exact);
    exitif this_range = 0;
    if this_range <> 0 then
        found_flag := true;
        position (this_range);
        move_vertical (1);
        move_horizontal (-current_offset);
        this_count := this_count + 1;
    endif;
endloop;

if found_flag then
    message (fao ("Found !SL occurrances of '!AS'", this_count, this_string));
endif;
eve$position_in_middle (old_position);

return;

ENDPROCEDURE;

!****************************************
PROCEDURE EVE_COMPRESS_LINE
!
! procedure to remove multiple whitespace on a line
!
local this_line;

if mark (none) = end_of (current_buffer) then
    message ("Can't compress this line");
    return;
endif;

set (screen_update, off);
move_horizontal (-current_offset);
this_line := erase_line;
edit (this_line, COMPRESS, TRIM);
copy_text (this_line);
split_line;
set (screen_update, on);

ENDPROCEDURE;

!****************************************
PROCEDURE EVE_DESCRIBE_KEY
!
! This procedure will prompt for a key stroke or shift sequence and look
! up the comment that was attributed to the keystroke when  it was defined.
! If there was no comment given, the message "Key Has No Function..." is
! displayed in the message area at the bottom of the screen.  Otherwise,
! the key's function is displayed.  This function assumes that there will
! always be some sort of comment given when keys are defined to user
! procedures.  This may not be an acurate assumption in all circumstances.
! The value of this function depends on the descriptive nature of the names
! of user routines.  It should be noted that this works on DEFINE KEY
! operations also.  So use the whole function name to get the best
! description.
!
LOCAL key_to_describe, key_description;

MESSAGE ("Press Key to Describe:");
key_to_describe := READ_KEY;
key_description := LOOKUP_KEY (key_to_describe,COMMENT);
IF key_description <> "" THEN
    MESSAGE ("Function Description : " + key_description);
ELSE
    MESSAGE ("Key Has No Defined Function...");
ENDIF;

ENDPROCEDURE;

!****************************************
PROCEDURE EVE_DISPLAY_CHARACTER
!
! This procedure writes a one line message describing the current character
! in terms of Octal, Decimal, Hexadecimal and (sometimes ) '^' notation.
!
LOCAL i,cc;

! Handle end-of-buffer condition
IF MARK (NONE) = END_OF (CURRENT_BUFFER) THEN
    MESSAGE ('At end of buffer, no current character.');
    RETURN;
ENDIF;

! Convert the character to an integer the hard way (no builtin yet)
i := 0;
LOOP;
    EXITIF i > 255;
    EXITIF CURRENT_CHARACTER = ASCII (i);
    i := i + 1;
ENDLOOP;

IF i > 255 THEN i := 0; ENDIF; ! On overflow, reset to NULL

! Provide ^ notation for ASCII control characters
IF i < 32 THEN
    cc := ', ^' + ASCII (i + 64);
ELSE
    cc := '';
ENDIF;

! Format and output the results
MESSAGE (FAO ("Current Character is '!AS', Octal=!OB, Decimal=!-!UB, " +
    "Hex=!-!XB!AS", CURRENT_CHARACTER, i, cc ));

ENDPROCEDURE;

!****************************************
PROCEDURE EVE_FIX_CRLFS
!
!    FIX_CRLFS.TPU - Routine to turn CRLFs into line breaks
!            and remove leading CRs and trailing CRLFs
!
LOCAL    the_range;

on_error
    if (ERROR <> TPU$_STRNOTFOUND) then
        message ("Error (" + str (ERROR) + ") at line " + str (ERROR_LINE));
        return;
    endif;
endon_error;

!
! First remove the CRLFs. If they are not at the EOL, add a line break.
!
position (beginning_of (current_buffer));
loop
    the_range := search (ascii (13) + ascii (10), FORWARD);
    exitif (the_range = 0);
    erase (the_range);
    position (beginning_of (the_range));
    if (current_character <> "") then
        split_line;
    endif;
endloop;
!
! Next remove naked LFs. If they are not at the EOL, add a line break.
!
position (beginning_of (current_buffer));
loop
    the_range := search (ascii (10), FORWARD);
    exitif (the_range = 0);
    erase (the_range);
    position (beginning_of (the_range));
    if (current_character <> "") then
        split_line;
    endif;
endloop;
!
! Finally, remove naked CRs. If they are not at the BOL, add a line break.
!
position (beginning_of (current_buffer));
loop
    the_range := search (ascii (13), FORWARD);
    exitif (the_range = 0);
    position (end_of (the_range));
    if (current_offset <> 0) then
        split_line;
    endif;
    erase (the_range);
endloop;

ENDPROCEDURE;

!****************************************
PROCEDURE EVE_INSERT_DATE
!
! insert current date at cursor position
! added - 3-FEB-1988
!
local tim_str;
!
tim_str := FAO ("!%D",0);
tim_str := substr (tim_str,1,11);
edit (tim_str,trim);
move_text (tim_str);

ENDPROCEDURE;

!****************************************
PROCEDURE EVE_INSERT_RULER
!
! insert a ruler before the current line in the buffer
!
local   this_mode,
        ruler80,
        ruler132,
        tab_values,
        next_value,
        this_value,
        beg_col,
        end_col,
        number_of_chars;

ruler80 :=
    '12345678901234567890123456789012345678901234567890' +
    '123456789012345678901234567890';
ruler132 :=
    '12345678901234567890123456789012345678901234567890' +
    '12345678901234567890123456789012345678901234567890' +
    '12345678901234567890123456789012';

this_mode   := get_info (current_buffer, "MODE");
tab_values  := get_info (current_buffer, "TAB_STOPS");
if (get_info (tab_values, "TYPE") = INTEGER) then
    if this_mode = OVERSTRIKE then
        set (insert, current_buffer);
    endif;
    move_horizontal (-current_offset);
    if (get_info (SCREEN, "WIDTH") = 80) then
        copy_text (ruler80);
    else
        copy_text (ruler132);
    endif;
    split_line;
    set (this_mode, current_buffer);
    move_vertical (-1);
    move_horizontal (-current_offset);
    loop
        exitif current_offset >= length (current_line);
        move_horizontal (tab_values);
        copy_text ("T");
    endloop;
else
    if this_mode = OVERSTRIKE then
        set (insert, current_buffer);
    endif;
    move_horizontal (-current_offset);
    if (get_info (SCREEN, "WIDTH") = 80) then
        copy_text (ruler80);
    else
        copy_text (ruler132);
    endif;
    split_line;
    move_vertical (-1);
    move_horizontal (-current_offset);
    beg_col := 1;
    end_col := index (tab_values, " ") - 1;
    if (end_col = -1) then
        return;
    endif;
    number_of_chars := end_col - beg_col + 1;
    set (OVERSTRIKE, current_buffer);
    loop
        exitif current_offset >= length (current_line);
        this_value  := substr (tab_values, 1, number_of_chars);
        edit (this_value, trim);
        next_value  := int (this_value);
        exitif next_value >= length (current_line);
        move_horizontal (-current_offset);
        move_horizontal (next_value - 1);
        copy_text ("T");
        beg_col     := end_col + 2;
        exitif beg_col >= length (tab_values);
        tab_values  := substr (tab_values, beg_col, length (tab_values));
        end_col     := index (tab_values, " ") - 1;
        if (end_col = 0) then
            if (length (tab_values) > 0) then
                end_col := length (tab_values);
            endif;
        endif;
        exitif end_col <= 0;
        number_of_chars := end_col;
    endloop;
    set (this_mode, current_buffer);
    move_horizontal (-current_offset);
endif;

ENDPROCEDURE;

!****************************************
PROCEDURE EVE_INSERT_TIME
!
! insert current time at cursor position
! added - 3-FEB-1988
!
local tim_str;
!
tim_str := FAO ("!%T",0);
edit (tim_str, trim);
move_text (tim_str);

ENDPROCEDURE;

!****************************************
PROCEDURE EVE_LIST_COMMANDS
!
! list all EVE commands sorted alphabetically
!
local   the_names,
        column_width,
        total_width,
        how_many_columns,
        temp;

eve_mark ("my_saved_buffer");
the_names := expand_name ("eve_", procedures) + " ";
position (eve$choice_buffer);
erase (eve$choice_buffer);
message ("Building command list");

loop
    exitif (the_names = "");
    temp := index (the_names, " ");
    if (temp = 0) then
        message ("Can't find space");
        return;
    endif;
    copy_text (substr (the_names, 1, temp - 1));
    the_names := substr (the_names, temp + 1, length (the_names));
    split_line;
    erase_line;
endloop;

position (beginning_of (current_buffer));
loop
    temp := search_quietly (line_begin & "EVE_", FORWARD);
    exitif (temp = 0);
    position (temp);
    erase(temp);
endloop;

position (beginning_of (current_buffer));
loop
    exitif (pce_unconditional_replace (" EVE_", " ") = 0);
endloop;

position (beginning_of (current_buffer));
loop
    temp := search_quietly (" ", FORWARD);
    exitif (temp = 0);
    position (temp);
    erase (temp);
    split_line;
endloop;

position (beginning_of (current_buffer));
loop
    exitif (pce_unconditional_replace ("_", " ") = 0);
endloop;

if (eve$defined_procedure ("eveplus_sort")) then
    message ("Sorting command list");
    execute ('eveplus_sort (current_buffer , "" );');
endif;
eve$format_choices;

set (status_line, info_window, reverse, " Eve commands -- DO will remove this list");
position (show_buffer);
erase (show_buffer);
copy_text (eve$choice_buffer);
position (beginning_of (current_buffer));
set (screen_update, off);
eve_go_to ("my_saved_buffer");
set (screen_update, on);
map (info_window, show_buffer);
message (" ");

ENDPROCEDURE;

!****************************************
PROCEDURE EVE_MAIL
!
! added 870810 - RHS
!
spawn ('mail');

ENDPROCEDURE;

!****************************************
PROCEDURE EVE_NUMBER_LINES
!
! insert line numbers at the beginning of each line
!
local   this_line_number,
        old_mode;

this_line_number := 1;
position (beginning_of (current_buffer));
old_mode := get_info (current_buffer, "mode");
set (insert, current_buffer);

loop
    if (((this_line_number / 250) * 250) = this_line_number) then
        message ("Numbering line " + str (this_line_number));
    endif;
    exitif (mark (none) = end_of (current_buffer));
    copy_text (fao("!6UL  ", this_line_number));
    this_line_number := this_line_number + 1;
    move_horizontal (-current_offset);
    move_vertical (1);
endloop;

set (old_mode, current_buffer);
pce_line_numbers := 1;

ENDPROCEDURE;

!****************************************
PROCEDURE EVE_PAD_LINES (COLUMN_TO_PAD_TO)
!
! pad (add trailing spaces to) lines to the column specified
!
local my_length;

my_length := column_to_pad_to;
if get_info (my_length, "type") <> integer then
    my_length := 0;
endif;
if my_length <= 0 then
    message ("No value given for pad value -- operation cancelled");
    return;
endif;
move_horizontal (-current_offset);

loop
    exitif mark (free_cursor) = end_of (current_buffer);
    if length (current_line) < my_length then
        cursor_horizontal (my_length - 1);
        copy_text (" ");
        move_horizontal (-current_offset);
    endif;
    move_vertical (1);
endloop;

ENDPROCEDURE;

!****************************************
PROCEDURE EVE_PHONE
!
! added 870810 - RHS
!
spawn ('phone');

ENDPROCEDURE;

!****************************************
PROCEDURE EVE_RUN (run_string)
!
! added 900517 - RHS
!
spawn ('run ' + run_string);

ENDPROCEDURE;

!****************************************
PROCEDURE EVE_SPECIAL_INSERT (DECIMAL_VALUE)

local this_value, this_mode;

this_mode := get_info (current_buffer, "mode");

if not (eve$prompt_number (decimal_value, this_value,
    "Decimal value of the ASCII character to insert: ",
    "No value entered -- operation cancelled")) then
    return;
endif;

if this_mode = overstrike then
    set (insert, current_buffer);
endif;
copy_text (ascii (this_value));
set (this_mode, current_buffer);

ENDPROCEDURE;

!****************************************
PROCEDURE EVE_STAMP_DATE

local this_length;

this_length := length (current_line);

if this_length < 75 then
    move_horizontal (-current_offset);
    cursor_horizontal (74);
else
    move_horizontal (-current_offset);
    cursor_horizontal (this_length + 2);
endif;
copy_text ("!");
eve_insert_date;
move_horizontal (-current_offset);

ENDPROCEDURE;

!****************************************
PROCEDURE EVE_TEST_COMPILE (DIRECTIVES)
! ---------------------------------------------------------------------
! Compile the current buffer's source in its language
! ---------------------------------------------------------------------

LOCAL   fname,
        ftype,
        com,
        mod_status,
        mode_status,
        switches,
        i;

switches := directives;

! ----------------------------------------------
! Construct names for the temporary output files
! ----------------------------------------------

fname := GET_INFO (CURRENT_BUFFER, "file_name");

IF fname = 0 THEN
    MESSAGE ('The current buffer is not assigned to a file');
    RETURN;
ENDIF;

i     := INDEX    (fname, ';');
if i <> 0 then
    fname := SUBSTR   (fname, 1, i-1);
endif;
i     := INDEX    (fname, ']');
if i <> 0 then
    fname := SUBSTR   (fname, i+1, 255);
endif;
i     := INDEX    (fname, '.');
if i <> 0 then
    ftype := SUBSTR   (fname, i+1, 255);
    fname := SUBSTR   (fname, 1, i-1);
endif;

! ----------------------
! Build the command line
! ----------------------

IF ftype = 'FOR' THEN
    com := 'FOR' + switches + ' ' + fname;
ELSE
    IF ftype = 'COB' THEN
        com := 'COB' + switches + ' ' + fname;
    ELSE
        IF ftype = 'MAR' THEN
            com := 'MACRO' + switches + ' ' + fname;
        ELSE
            MESSAGE
        ('The file type of the current buffer is not supported');
            RETURN;
        ENDIF;
    ENDIF;
ENDIF;

! -----------------------------------------------------
! Write the contents of the current buffer to that file
! -----------------------------------------------------

mod_status  := GET_INFO   (CURRENT_BUFFER, "modified");
WRITE_FILE (CURRENT_BUFFER);

! -------------------------------------------------------
! If the buffer was modified, writing it out will have
! erased its modification status memory. Reset the flag,
! if appropriate.
! -------------------------------------------------------

IF mod_status = 1 THEN
    mode_status := GET_INFO (CURRENT_BUFFER, "mode");

    IF mode_status = OVERSTRIKE THEN
        SET (INSERT, CURRENT_BUFFER);
    ENDIF;

    copy_text (' ');
    move_horizontal (-1);
    erase_character (1);

    IF mode_status = OVERSTRIKE THEN
        SET (OVERSTRIKE, CURRENT_BUFFER);
    ENDIF;
ENDIF;


! -----------------------
! Perform the compilation
! -----------------------

eve_dcl (com);

ENDPROCEDURE;

!****************************************
PROCEDURE EVE_TRIM
!
! Trim trailing whitespace
!
message ("Trimmimg buffer...");
eve$trim_buffer (current_buffer);
message ("Trimming complete.");

ENDPROCEDURE;

!****************************************
PROCEDURE EVE_TRUNCATE_LINES (TRUNC_LENGTH)
!
! Truncates lines to user specified length
!
! NEW - 870721 - RHS
!
local temp;

if eve$prompt_number (trunc_length, temp, "Length to truncate to:  ",
                       "nothing entered -- truncation cancelled") then
    message (fao ('Truncating lines to !SL characters', temp));

    move_horizontal (-current_offset);
    move_horizontal (temp);

    loop
        eve_erase_end_of_line;
        move_vertical (1);
        exitif mark (none) = end_of (current_buffer);
    endloop;

    message ('Truncation completed');
endif;

ENDPROCEDURE;

!****************************************
PROCEDURE EVE_UNNUMBER_LINES
!
! reverses operation of the eve_number_lines routine
!
local   this_line_number;

if pce_line_numbers = 1 then
    this_line_number := 1;
    position (beginning_of (current_buffer));
    move_horizontal (-current_offset);
    loop
        if (((this_line_number / 250) * 250) = this_line_number) then
            message("UNnumbering line " + str(this_line_number));
        endif;
        exitif (mark (none) = end_of (current_buffer));
        erase_character (8);
        this_line_number := this_line_number + 1;
        move_vertical (1);
    endloop;

    pce_line_numbers := 0;
else
    message ("Lines are not numbered -- file not changed");
endif;

ENDPROCEDURE;

!****************************************
PROCEDURE EVE_WHICH_COLUMN
!
! Display the current character column #
!
Local this_column;

this_column := get_info (current_buffer, "offset_column");
message (fao ("Current column = !SL", this_column));

ENDPROCEDURE;

! procedure arguments
eve$arg1_count          := "string";
eve$arg1_pad_lines      := "integer";
eve$arg1_special_insert := "integer";
eve$arg1_test_compile   := "string";
eve$arg1_truncate_lines := "integer";

ENDMODULE;