Piper's Pit BBS/FTP: ibm 0040 - 0049/ibm0040-0049/ibm0040.tar/ibm0040/DBRIEF.ZIP/SOURCE/COMMON.H

Text File | 1991-03-21 | 20.4 KB | 811 lines

;dBRIEF Common - v3.10
;Copyright (c) 1990 - Global Technologies Corporation
;ALL RIGHTS RESERVED
(macro _frame_component
    (
        (int                component_number
                            frame_x
                            frame_y
                            line_number
                            frame_column
        )
        (string            component_string
                            frame_character
        )
        (get_parm 0 component_number)
        (get_parm 1 frame_x)
        (get_parm 2 frame_y)
        (get_parm 3 frame_character)
        (get_parm 4 line_number)
        (get_parm 5 frame_column)
        (switch component_number
            1
                (sprintf component_string "@ %02d,%02d SAY        \"%s" frame_x frame_y frame_character)
            2
                (sprintf component_string "%s\"\n" frame_character)
            3
                (sprintf component_string "@ %02d,%02d SAY \"%s" frame_x frame_y frame_character)
            4
                (sprintf component_string "@ ROW()+1,%02d SAY \"%s" frame_y frame_character)
            5
                (sprintf component_string "%s\"\n" frame_character)
        )
        (return component_string)
    )
)
(macro _continuation_character
    (
        (return ";")
    )
)
(macro _comment_character
    (
        (int                comment_type
        )
        (get_parm 0 comment_type)
        (switch comment_type
            1
                (if (== dbr_dialect 12)
                    (return "//")
                ;else
                    (return "&&")
                )
            2
                (return "NOTE")
            3
                (if (== dbr_dialect 12)
                    (return "//")
                ;else
                    (return "*")
                )
        )
    )
)
(macro _beg_of_rout_scan
    (
        (return "{FUNC}|{PROC}|{{STAT}|{LOCA}*{FUNC}|{PROC}}|{\\* ROUTINE SECTION}")
    )
)
(macro _beg_of_proc_scan
    (
        (return "{PROCEDURE}|{PROC}|{{STAT}|{LOCA}*{PROC}}|{\\* ROUTINE SECTION}")
    )
)
(macro _beg_of_func_scan
    (
        (return "{FUNCTION}|{FUNC}|{{STAT}|{LOCA}*{FUNC}}|{\\* ROUTINE SECTION}")
    )
)
(macro _end_of_rout_syntax
    (
        (return "RETURN")
    )
)
(macro _execute_command
    (
        (return "DO ")
    )
)
(macro _do_case_syntax
    (
        (int                do_case_command
        )
        (get_parm 0 do_case_command)
        (switch do_case_command
            0
                (return "DO C")
            1
                (return "DO CASE")
            2
                (return "CASE")
            3
                (return (+ (_comment_character 3) " DO ..."))
            4
                (return "OTHERWISE")
            5
                (return "ENDCASE")
        )
    )
)
(macro _do_while_syntax
    (
        (int                do_while_command
        )
        (get_parm 0 do_while_command)
        (switch do_while_command
            0
                (return "DO W")
            1
                (return "DO WHILE .T.")
            2
                (return "ENDDO")
        )
    )
)
(macro memv
    (
        (int                beg_col
        )
        (string            type_code1
                            type_code2
                            field_name
                            dos_line
                            alias
        )
        (if (! (get_parm 0 temp_str "Equal, Store or Replace statements [Esr]: " 1 "E"))
            (return 0)
        )
        (if (! (get_parm 1 alias "Alias name (optional):"))
            (return 0)
        )
        (if (strlen alias)
            (+= alias "->")
        )
        (= temp_str (upper temp_str))
        (if (== temp_str "S")
            (
                (= type_code1 "STORE")
                (= type_code2 "TO")
            )
        ;else
            (
                (= type_code1 "REPLACE")
                (= type_code2 "WITH")
            )
        )
        (inq_position NULL beg_col)
        (while (get_parm 0 field_name "Enter field name, ESC to exit: " 9)
            (if (!= (substr field_name 1 1) " ")
                (
                    (if (== temp_str "E")
                        (
                            (if (strlen dbr_mem_trail)
                                (sprintf dos_line "%s = %s%s" (_pad_right (+ field_name dbr_mem_trail) 10) alias field_name)
                            ;else
                                (sprintf dos_line "%s = %s%s" (_pad_right (+ dbr_mem_lead field_name) 10) alias field_name)
                            )
                        )
                    ;else
                        (
                            (if (strlen dbr_mem_trail)
                                (sprintf dos_line "%s %s %s %s" type_code1 (+ alias (_pad_right field_name 10)) type_code2 (+ field_name dbr_mem_trail))
                            ;else
                                (sprintf dos_line "%s %s %s %s" type_code1 (+ alias (_pad_right field_name 10)) type_code2 (+ dbr_mem_lead field_name))
                            )
                        )
                    )
                    (move_abs 0 beg_col)
                    (insert (+ dos_line "\n"))
                )
            )
        )
        (move_abs 0 beg_col)
    )
)
(macro @
    (
        (int                xx
                            yy
        )
        (string            say_spec
                            stmt
                            prompt_string
        )
        (if (get_parm 0 prompt_string "Starting line & column coordinates [x,y]: ")
            (if (get_parm 1 stmt "SAY or GET [Sg]: " 1 "S")
                (
                    (= xx (atoi (substr prompt_string 1 (- (index prompt_string ",") 1))))
                    (= yy (atoi (substr prompt_string (+ (index prompt_string ",") 1))))
                    (if (== (substr (upper stmt) 1 1) "S")
                        (= stmt "SAY")
                    ;else
                        (= stmt "GET")
                    )
                    (inq_position NULL curr_indent_col)
                    (sprintf prompt_string "ESC to quit  @ %d,%d %s " xx yy stmt)
                    (while (get_parm 3 say_spec prompt_string)
                        (
                            (sprintf prompt_string "@ %0d,%0d %s %s\n" xx yy stmt say_spec)
                            (move_abs 0 curr_indent_col)
                            (insert prompt_string)
                            (++ xx)
                            (sprintf prompt_string "ESC to quit  @ %d,%d %s " xx yy stmt)
                        )
                    )
                    (move_abs 0 curr_indent_col)
                )
            )
        )
    )
)
(macro _cond_insert
    (
        (int                _cond_case
                            _cond_indent_col
                            _cond_tab_col
        )
        (string            _cond_command
                            _cond_match
        )
        (get_parm 0 _cond_command)
        (get_parm 1    _cond_match)
        (get_parm 2 _cond_case)
        (get_parm 3 _cond_indent_col)
        (= _cond_tab_col (- dbr_comment_tab (+ _cond_indent_col (strlen _cond_command))))
        (if dbr_orig_cond_comment
            (
                (if _cond_tab_col
                    (sprintf _cond_command "%s%s%s %s" _cond_command (_replicate " " _cond_tab_col) (_comment_character 1) _cond_match)
                ;else
                    (sprintf _cond_command "%s%s%s %s" _cond_command (_replicate " " 2) (_comment_character 1) _cond_match)
                )
                (_case_insert _cond_command 1 0 _cond_case)
            )
        ;else
            (_case_insert (+ _cond_command "\n") 1 0 _cond_case)
        )
    )
)
(macro _complete_conditional
    (
        (int                temp_line
                            temp_col
                            completion_line
                            prev_indent_col
                            character_case
        )
        (string            token
                            matching_command
                            orig_line
                            _message
        )
        (save_position)
        (search_back "<*\\c[~ \\t\\n]")
        (down)
        (inq_position completion_line prev_indent_col)
        (= temp_col prev_indent_col)
        (= orig_line "XX")
        (while (&& (|| (! (index (_complete_cond_table) (upper (substr orig_line 1 2)))) (>= temp_col prev_indent_col))(!= temp_line 1))
            (
                (up)
                (beginning_of_line)
                (inq_position temp_line NULL)
                (= orig_line (ltrim (read)))
                (beginning_of_line)
                (if (> (strlen orig_line) 0)
                    (
                        (search_back "<*\\c[~ \\t\\n]")
                        (inq_position NULL temp_col)
                    )
                ;else
                    (= orig_line "XX")
                )
            )
        )
        (= token (substr (upper orig_line) 1 4))
        (if (<= (atoi (substr orig_line 1 1) 0) 95)
            (= character_case 1)
        )
        (if (== (substr token 1 3) "IF ")
            (= token (substr token 1 3))
        )
        (if (== dbr_dialect 12)
            (if (&& (index "LOCA~STAT" token) (|| (index (upper orig_line) "FUNC")(index (upper orig_line) "PROC")))
                (if (index (upper orig_line) "FUNC")
                    (= token "FUNC")
                ;else
                    (= token "PROC")
                )
            )
        )
        (move_abs temp_line 1)
        (search_back "<*\\c[~ \\t\\n]")
        (inq_position NULL curr_indent_col)
        (move_abs completion_line curr_indent_col)
        (= matching_command (_matching_conditional token))
        (if (strlen matching_command)
            (_cond_insert (_matching_conditional token) orig_line character_case curr_indent_col)
        ;else
            (
                (_case_insert "\n" 1 0)
                (= curr_indent_col prev_indent_col)
                (move_abs completion_line curr_indent_col)
            )
        )
        (message "")
    )
)
(macro _find_matching_endtext
    (
        (if (search_fwd "<{ @}|{\\t@}endt" 1 0)
            (
                (beginning_of_line)
                (inq_position dbr_curr_line)
                (move_rel 1 0)
                (= dbr_text_flag 1)
            )
        ;else
            (
                (sprintf temp_str "%d" dbr_curr_line)
                (_display_popup_message "ENDTEXT not found to match TEXT at line # %s!" temp_str 0)
                (push_back 65)
            )
        )
    )
)
(macro _comment_conditionals
    (
        (int            cond_last_line
                        cond_temp_buffer
                        cond_stack_buffer
                        cond_line_number
                        cond_current_line
        )
        (string        cond_command_line
                        cond_token
                        cond_new_line
                        cond_line_str
        )
        (= cond_temp_buffer (inq_buffer))
        (save_position)
        (= cond_stack_buffer (create_buffer "stack" NULL 1))
        (set_buffer cond_temp_buffer)
        (attach_buffer cond_temp_buffer)
        (if (inq_marked cond_current_line NULL cond_last_line NULL)
            (
                (raise_anchor)
                (-= cond_current_line 1)
            )
        ;else
            (
                (end_of_buffer)
                (inq_position cond_last_line)
                (top_of_buffer)
                (inq_position cond_current_line)
            )
        )
        (_uncomment_conditionals 0)
        (while (&& (<= cond_current_line cond_last_line)(! (inq_kbd_char)))
            (
                (message "Scanning line: %d" cond_current_line)
                (set_buffer cond_temp_buffer)
                (= cond_command_line (trim (read)))
                (= cond_token (substr (upper (ltrim cond_command_line)) 1 4))
                (if (== (substr cond_token 1 3) "IF ")
                    (= cond_token "IF  ")
                )
                (if (&& (index (_dialect_table) (trim cond_token))(> (strlen (trim cond_token)) 0))
                    (
                        (if (index (_indenting_conditionals) cond_token)
                            (
                                (inq_position cond_line_number NULL)
                                (sprintf cond_line_str " [line: %d]" cond_line_number)
                                (= cond_new_line cond_command_line)
                                (if dbr_comment_lines
                                    (= cond_new_line (+ (+ (+ (_comment_character 1) " ") (ltrim cond_new_line)) (+ cond_line_str "\n")))
                                ;else
                                    (= cond_new_line (+ (+ (_comment_character 1) " ") (+= (ltrim cond_new_line) "\n")))
                                )
                                (set_buffer cond_stack_buffer)
                                (top_of_buffer)
                                (beginning_of_line)
                                (insert cond_new_line)
                            )
                        ;else
                            (if (index (_reseting_conditionals) cond_token)
                                (
                                    (set_buffer cond_stack_buffer)
                                    (top_of_buffer)
                                    (= cond_new_line (read))
                                    (+= cond_command_line (trim cond_new_line))
                                )
                            ;else
                                (if (index (_outdenting_conditionals) cond_token)
                                    (
                                        (set_buffer cond_stack_buffer)
                                        (top_of_buffer)
                                        (= cond_new_line (read))
                                        (+= cond_command_line (trim cond_new_line))
                                        (delete_line)
                                    )
                                )
                            )
                        )
                        (set_buffer cond_temp_buffer)
                        (delete_to_eol)
                        (insert cond_command_line)
                        (if (&& (search_string (_comment_character 1) cond_command_line) (!= dbr_comment_tab 0))
                            (
                                (beginning_of_line)
                                (= temp_str (read))
                                (beginning_of_line)
                                (delete_to_eol)
                                (insert (trim (substr temp_str 1 (- (index temp_str (_comment_character 1)) 1))))
                                (if (<  (strlen (trim (substr temp_str 1 (- (index temp_str (_comment_character 1)) 1)))) (- dbr_comment_tab 1))
                                    (move_abs 0 dbr_comment_tab)
                                ;else
                                    (
                                        (end_of_line)
                                        (move_rel 0 2)
                                    )
                                )
                                (insert (trim (substr temp_str (index temp_str (_comment_character 1)))))
                            )
                        )
                    )
                )
                (move_abs (++ cond_current_line) 1)
            )
        )
        (_display_popup_message "Commenting Complete." "" 0)
        (message "")
        (set_buffer cond_temp_buffer)
        (attach_buffer cond_temp_buffer)
        (refresh)
        (restore_position)
        (delete_buffer cond_stack_buffer)
    )
)
(macro _structure
    (
        (int            structure_buffer
        )
        (string        _dbf_file
                        _str_file
                        _switch
        )
        (if (get_parm 1 _dbf_file "DBF file name: ")
            (if (get_parm 2 _switch "Window, Buffer or Printer [wbp] " 1 "W")
                (
                    (if (== (upper _switch) "T")
                        (if (get_parm 3 _switch "Window, Buffer or Printer [wbp] " 1 "W")
                            (= _switch (substr (upper _switch) 1 1))
                        )
                    )
                    (= _switch (upper _switch))
                    (= _str_file (_parse_child _dbf_file _str_file))
                    (if (index _str_file ".")
                        (= _str_file (+ (substr _str_file 1 (- (index _str_file ".") 1)) ".str"))
                    ;else
                        (
                            (= _str_file (+ _str_file ".str"))
                            (= _dbf_file (+ _dbf_file ".dbf"))
                        )
                    )
                    (if (exist _dbf_file)
                        (
                            (message "Stand by...")
                            (= temp_str (+ "dbrief " _dbf_file))
                            (+= temp_str ">&")
                            (+= temp_str _str_file)
                            (dos temp_str)
                            (= dbr_current_buffer (inq_buffer))
                            (= structure_buffer (create_buffer "Structure" _str_file))
                            (if (index "W~P" (upper _switch))
                                (
                                    (message "Getting structure, please wait...")
                                    (set_buffer structure_buffer)
                                    (keyboard_push)
                                    (if (>= (version) 310)
                                        (execute_macro "db_hide 0 _pick_action")
                                    )
                                    (create_window 30 20 75 3 (+ (upper _dbf_file) ":   Esc"))
                                    (if (>= (version) 310)
                                        (execute_macro "db_show 0")
                                    )
                                    (attach_buffer structure_buffer)
                                    (top_of_buffer)
                                    (if (inq_modified)
                                        (write_buffer)
                                    )
                                    (refresh)
                                    (if (== (upper _switch) "P")
                                        (
                                            (message "Printing, please wait...")
                                            (end_of_buffer)
                                            (insert "\n")
                                            (top_of_buffer)
                                            (drop_anchor)
                                            (end_of_buffer)
                                            (print)
                                            (top_of_buffer)
                                        )
                                    )
                                    (assign_to_key "<Esc>" "exit")
                                    (assign_to_key "<Up>" "up")
                                    (assign_to_key "<Down>" "down")
                                    (assign_to_key "<Home>" "top_of_buffer")
                                    (assign_to_key "<End>" "end_of_buffer")
                                    (assign_to_key "<PgUp>" "page_up")
                                    (assign_to_key "<PgDn>" "page_down")
                                    (message "")
                                    (process)
                                    (keyboard_pop)
                                    (delete_window)
                                    (delete_buffer structure_buffer)
                                    (set_buffer dbr_current_buffer)
                                    (attach_buffer dbr_current_buffer)
                                    (if (&& (== dbr_delete_str 1)(exist _str_file))
                                        (del _str_file)
                                    )
                                )
                            ;else
                                (
                                    (set_buffer structure_buffer)
                                    (attach_buffer structure_buffer)
                                    (top_of_buffer)
                                    (refresh)
                                )
                            )
                            (message "")
                        )
                    ;else
                        (_display_popup_message "File %s not found!" (upper _dbf_file) 0)
                    )
                )
            )
        )
    )
)
(macro _generate_fields
    (
        (int            structure_buffer
                        field_num
                        field_len
                        field_dec
                        count
                        max_count
        )
        (string        _dbf_file
                        _str_file
                        _psu_file
                        _switch
                        _operation
                        field_name
                        field_type
        )
        (get_parm 0 _dbf_file)
        (get_parm 1 _switch)
        (= _operation (upper (inq_called)))
        (= _str_file (_parse_child _dbf_file _str_file))
        (= _psu_file _str_file)
        (if (index _str_file ".")
            (= _str_file (+ (substr _str_file 1 (- (index _str_file ".") 1)) ".gen"))
        ;else
            (
                (= _str_file (+ _str_file ".gen"))
                (= _dbf_file (+ _dbf_file ".dbf"))
            )
        )
        (if (exist _dbf_file)
            (
                (message "Stand by...")
                (= temp_str (+ "dbrief " _dbf_file))
                (+= temp_str ">&")
                (+= temp_str _str_file)
                (dos temp_str)
                (= dbr_current_buffer (inq_buffer))
                (= structure_buffer (create_buffer (+ (upper _psu_file) ".DBF") _str_file))
                (if (exist _str_file)
                    (del _str_file)
                )
                (set_buffer structure_buffer)
                (if (>= (version) 310)
                    (execute_macro "db_hide 1")
                )
                (create_window 30 20 74 3 "\Generating, please wait...")
                (if (>= (version) 310)
                    (execute_macro "db_show 1")
                )
                (attach_buffer structure_buffer)
                (end_of_buffer)
                (insert "\n***\n")
                (top_of_buffer)
                (= max_count 24)
                (= count 1)
                (while (<= (++ count) max_count)
                    (insert "\n")
                )
                (save_position)
                (if (search_fwd "{SDU Error}|{SYS1107:}")
                    (
                        (restore_position)
                        (delete_line)
                        (delete_line)
                        (delete_line)
                        (delete_line)
                        (_display_popup_message "Error processing %s!" (+ (upper _dbf_file) ".DBF") 1)
                    )
                ;else
                    (
                        (restore_position)
                        (delete_line)
                        (delete_line)
                        (delete_line)
                        (delete_line)
                        (message "Generating, press any key to abort...")
                        (while (&& (!= (read 1) "\*")(! (inq_kbd_char)))
                            (
                                (= field_num (atoi (read 5)))
                                (move_abs 0 8)
                                (if (& (inq_kbd_flags) 0x40)
                                    (
                                        (= _psu_file (upper _psu_file))
                                        (= field_name (upper (read 10)))
                                    )
                                ;else
                                    (
                                        (= _psu_file (lower _psu_file))
                                        (= field_name (lower (read 10)))
                                    )
                                )
                                (move_abs 0 20)
                                (= field_type (trim (read 9)))
                                (move_abs 0 32)
                                (= field_len (atoi (read 4)))
                                (if (== (upper field_type) "NUMERIC")
                                    (
                                        (move_abs 0 38)
                                        (= field_dec (atoi (read 4)))
                                    )
                                )
                                (switch _switch
                                    "="
                                        (if (strlen dbr_mem_trail)
                                            (sprintf temp_str "%s = %s->%s" (_pad_right (+ (trim field_name) dbr_mem_trail) 12) _psu_file field_name)
                                        ;else
                                            (sprintf temp_str "%s = %s->%s" (_pad_right (+ dbr_mem_lead (trim field_name)) 12) _psu_file field_name)
                                        )
                                    "S"
                                        (= temp_str (_structure_build "STORE " " TO " _psu_file field_name 1))
                                    "R"
                                        (= temp_str (_structure_build "REPLACE " " WITH " _psu_file field_name 1))
                                    "I"
                                        (
                                            (switch (upper field_type)
                                                "LOGICAL"
                                                    (= temp_str "STORE .F.                  ")
                                                "DATE"
                                                    (= temp_str "STORE ctod(space(8))  ")
                                                "NUMERIC"
                                                    (= temp_str "STORE 0                      ")
                                                NULL
                                                    (
                                                        (sprintf temp_str "STORE space(%d)" field_len)
                                                        (sprintf temp_str (+ temp_str (substr "             " 1 (- 22 (strlen temp_str)))))
                                                    )
                                            )
                                            (= temp_str (_structure_build "" (+ temp_str " TO ") _psu_file field_name 0))
                                        )
                                )
                                (move_rel 2 0)
                                (beginning_of_line)
                                (save_position)
                                (move_abs field_num 1)
                                (if (== (upper field_type) "MEMO")
                                    (
                                        (insert (+ temp_str (_replicate " " 50)))
                                        (if (> dbr_comment_tab 40)
                                            (move_abs 0 dbr_comment_tab)
                                        ;else
                                            (move_abs 0 50)
                                        )
                                        (insert (+ (_comment_character 1) " Memo Field\n"))
                                    )
                                ;else
                                    (insert (+ temp_str "\n"))
                                )
                                (refresh)
                                (restore_position)
                            )
                        )
                        (if (inq_kbd_char)
                            (
                                (keyboard_flush)
                                (_display_popup_message "%s operation aborted!" _operation 1)
                            )
                        ;else
                            (
                                (move_abs (+ field_num 1) 1)
                                (drop_anchor)
                                (end_of_buffer)
                                (delete_block)
                                (top_of_buffer)
                                (get_parm 2 temp_str "Insert or Abandon [Ia]: " 1 "I")
                            )
                        )
                    )
                )
                (if (== (upper temp_str) "I")
                    (
                        (drop_anchor)
                        (end_of_buffer)
                        (move_abs 0 128)
                        (copy)
                        (raise_anchor)
                    )
                )
                (delete_window)
                (delete_buffer structure_buffer)
                (set_buffer dbr_current_buffer)
                (attach_buffer dbr_current_buffer)
                (del _str_file)
                (if (== (upper temp_str) "I")
                    (
                        (save_position)
                        (beginning_of_line)
                        (insert "\n")
                        (restore_position)
                        (save_position)
                        (drop_anchor)
                        (paste)
                        (rein 0)
                        (restore_position)
                    )
                )
            )
        ;else
            (_display_popup_message "File %s not found!" (upper _dbf_file) 1)
        )
    )
)
(macro _structure_build
    (
        (string            cmd_1
                            cmd_2
                            d_name
                            f_name
                            t_string
        )
        (int                flag_2
        )
        (get_parm 0 cmd_1)
        (get_parm 1 cmd_2)
        (get_parm 2 d_name)
        (get_parm 3 f_name)
        (get_parm 4 flag_2)
        (if (& (inq_kbd_flags) 0x40)
            (
                (= cmd_1 (upper cmd_1))
                (= cmd_2 (upper cmd_2))
                (= d_name (upper d_name))
                (= f_name (upper f_name))
            )
        ;else
            (
                (= cmd_1 (lower cmd_1))
                (= cmd_2 (lower cmd_2))
                (= d_name (lower d_name))
                (= f_name (lower f_name))
            )
        )
        (if flag_2
            (= t_string (+ cmd_1 (+ (+ d_name "->") f_name)))
        )
        (if (strlen dbr_mem_trail)
            (+= t_string (+ (+ cmd_2 (trim (substr f_name 1 9))) dbr_mem_trail))
        ;else
            (+= t_string (+ (+ cmd_2 dbr_mem_lead) (substr f_name 1 9)))
        )
        (return t_string)
    )
)
(macro writ
    (
        (string            _cmd_line
        )
        (if (inq_marked)
            (if (get_parm 0 _cmd_line "Procedure or Function? [pF]: " 1 "F")
                (switch (upper (substr _cmd_line 1 1))
                    "P"
                        (_create_routine_from_block "Procedure" (_end_of_rout_syntax) "prochead.cfg" (substr (_beg_of_proc_scan) 2 4))
                    "F"
                        (_create_routine_from_block "Function" (+ (_end_of_rout_syntax) "()") "funchead.cfg" (substr (_beg_of_func_scan) 2 4))
                )
            )
        ;else
            (_display_popup_message "No marked block for Function Writer!" "" 1)
        )
    )
)