Programmer 7500/MAX_PROGRAMMERS.iso/CLIPPER/DATABASE/READTXC.ZIP/READTXT.PRG

Text File | 1993-05-12 | 17.2 KB | 580 lines

//───────────────────────────────────────────────────
//
//        Program  READTXT.PRG
//        Function(S) READTEXT()
//                    SHOWLINS()
//                    ML_BOX()
//                    RS_BOX()
//                    ParseSlash()
//                    Centr()
//                    O_ERROR()
//
//           Uses: TEXT.$db
//
//    Other Files: &TEXTFILE
//
//    Originally written by Eric Engelmann for the US Army.
//
//    Extensively modifed by TED LONG 11/92
//    Orlando, Fl   [phone]
//──────────────────────────────────────────────────────
//
// Substitute for Buerg's List program with Clipper.  Allows user
//    to examine any text type file, such as generated report files
//    (or source code files, if you have set up your error handler
//     to call this program with the name of the error program),
//    without having to use the RUN or ! command with its very high
//    RAM overhead requirements.
//    The program works by appending a DBF file from a text file (SDF)
//    It then uses the SCROLL function to move the current picture of
//    text on the screen.
//
//
//───────────────────────────────────────────────────────────────────
//  Extensive changes were made to the original. The entire screen was
//  changed along with additional key trapping.
//  Also, optimized for clipper 5.01.
//───────────────────────────────────────────────────────────────
//    1) Converted to a function from a proc
//    2) Save and restore prior screens
//    3) Create text.$$$ on the fly and delete when finished
//    4) Reformated the source code with Snap
//    5) Fixed the color problems with the opening screen
//    6) Added a real help screen
//───────────────────────────────────────────────────────────────
STATIC offset, boxbott, scr_row, boxtop, getstr

//───────────────────────────
FUNCTION READTEXT(textfile)
//───────────────────────────
LOCAL getlist   := {}, darray := {}
LOCAL oldcolor  := SETCOLOR()
LOCAL oldscreen := SAVESCREEN(0,0,24,79)
LOCAL oldsele   := SELECT()
LOCAL toprec    := 1          &&Record number on diplay at top line of box.
LOCAL lastrec, keystroke, newrec, oldtop, mphrase, newcolor, flag, readscr
LOCAL readfile := parseslash( textfile )

boxbott   := 23         &&Bottom row of display box.
offset    := 1          &&Starting position to display for each line of text.
scr_row   := 1          &&Screen row.
boxtop    := 1          &&Top row of display box.

SET SCOREBOARD OFF
// save the old color attributes
// SET COLOR TO SOMETHING OTHER THAN WHITE ON BLACK
IF ISCOLOR()
   IF oldcolor = "" .OR. oldcolor = 'W/N'
      newcolor := 'W/+B'
   ELSE
      newcolor := oldcolor
   ENDI
ELSE
   newcolor := 'w/n'
ENDI

SETCOLOR(newcolor)

ML_BOX(10, 'Please wait while the File is prepared for display...')

AADD(darray,{"LINE", "C", 220 , 0 } )
DBCREATE('TEXT.$DB', darray )

USE TEXT.$db NEW EXCLUSIVE
APPEND FROM &textfile. SDF
GO TOP
LASTREC := RECCOUNT()

// Present the database in a window.
CLS

// Paint first screen.
SHOWLINS()

SETCOLOR("I")
@ 00,00 SAY SPACE(80)
@ 00,00 SAY 'File: '+ALLTRIM( readfile )
@ 00,70 SAY DTOC(DATE())
@ 24,00 SAY SPACE(80)
@ 24,00 SAY SPACE(30)+'Keys: '+CHR(24)+CHR(25)+CHR(26)+CHR(27)+;
'/PgDn/PgUp/Home/End    ESC=Exit F1=HELP'
@ 24, 00 SAY 'Command  '
SETCOLOR(newcolor)

flag    := .F.

DO WHILE .T.
   SETCOLOR("I")
   @ 0,19 SAY 'Line: '+STR(toprec,6,0)
   @ 24, 09 SAY ""
   SETCOLOR(newcolor)

   keystroke := INKEY(0)

   DO CASE
      // User pressed ESC, and wants out.
   CASE LASTKEY() == 27
      USE
      FCLOSE("TEXT.$DB")
      FERASE("TEXT.$db")
      SETCOLOR(oldcolor)
      CLS
      SELECT(oldsele)
      RESTSCREEN(0,0,24,79,oldscreen)
      RETURN NIL

      // User wants to pan right.
   CASE keystroke = 4
      IF offset< 240
         offset := offset+20
      ENDIF

      GO toprec
      showlins()

      // User wants to pan left.
   CASE keystroke = 19
      IF offset>=21
         offset := offset-20
      ENDIF (offset>=21)
      GO toprec
      showlins()

      // User wants top of file.
   CASE keystroke = 1
      GO 1
      toprec := 1
      showlins()

      // User wants end of file.
   CASE keystroke = 6
      IF LASTREC>=boxbott-boxtop
         GO LASTREC-(boxbott-boxtop)
      ELSE
         GO 1
      ENDIF (lastrec>=boxbott-boxtop)
      toprec := RECNO()
      showlins()

      // User wants to page down a screen.
   CASE keystroke = 3
      IF toprec+boxbott-boxtop <= LASTREC
         toprec := toprec+boxbott-boxtop
      ELSE
         toprec := LASTREC
      ENDIF (toprec+boxbott-boxtop <= lastrec)
      GO toprec
      showlins()

      // User wants to page up a screen.
   CASE keystroke = 18
      newrec := toprec-(boxbott-boxtop)
      IF newrec>0
         toprec := newrec
      ELSE
         toprec := 1
      ENDIF (newrec>0)
      GO toprec
      showlins()

      // User chose uparrow.
   CASE keystroke = 5
      IF toprec>1
         SCROLL(boxtop,0,boxbott,79,-1)
         // Got to the new record.
         toprec := toprec-1
         GO toprec
         @ boxtop,0 SAY SUBSTR(FIELD->line,offset,79)
      ELSE
         // If we are at the first record already, do nothing.
      ENDIF (toprec>1)

      // User chose down arrow.
   CASE keystroke = 24
      IF toprec-boxtop+boxbott<LASTREC
         SCROLL(boxtop,0,boxbott,79,1)
         toprec := toprec+1
         GO toprec+boxbott-boxtop
         @ boxbott,0 SAY SUBSTR(FIELD->line,offset,79)
      ENDIF (toprec-boxtop+boxbott<lastrec)

      // User claims he needs help.
   CASE keystroke = 28 .OR. keystroke = 72 .OR. keystroke = 104 .OR. keystroke = 63
       readscr := SAVESCREEN(0,0,24,79)

       IF !ISCOLOR()
         CLS
       ENDI

       RS_BOX(6,8,18,72)
       CENTR(6, "┤ HELP SCREEN ├")
       @ 07, 09 SAY ' Cursor Left    - Pans the screen left'
       @ 08, 09 SAY ' Cursor Right   - Pans the screen right'
       @ 09, 09 SAY ' Cursor up/down - Move to the next or previous line'
       @ 10, 09 SAY ' Page-Up        - Move up one screen page'
       @ 11, 09 SAY ' Page-Down      - Move down one screen page'
       @ 12, 09 SAY ' Home           - Go to the top of the document'
       @ 13, 09 SAY ' End            - Go to the bottom of the document'
       @ 14, 09 SAY ' F  Find Text   - Non case sensitive find'
       @ 15, 09 SAY ' C  Find Text   - Case sensitive find'
       @ 16, 09 SAY ' N  Next        - Next find'
       @ 17, 09 SAY ' P  Print       - Print viewed document'
       INKEY(0)
       RESTSCREEN(0,0,24,79, readscr)
   CASE keystroke = 112 .OR. keystroke = 80
      IF ISPRINTER()
         SET CONSOLE OFF
         TYPE &TEXTFILE. TO PRINT
         SET CONSOLE ON
      ELSE
         O_ERROR("PRINTER IS NOT READY......")
      ENDI

      // User wants to locate a string.
   CASE keystroke = 70 .OR. keystroke = 102
      oldtop    := toprec
      GO toprec
      SETCOLOR("I")
      @ 24,0 SAY SPACE(80)

      getstr := REPLICATE(" ",25)
      @ 24,00 SAY "Search for ? " GET getstr
      READ

      IF !EMPTY(getstr)
        getstr  := LOWER(TRIM(getstr))
        mphrase := CHR(34)+TRIM(getstr)+CHR(34)
        LOCATE NEXT 1000000 FOR getstr $ LOWER(FIELD->line)
        IF EOF()
           @ 24,0 SAY SPACE(80)
           @ 24,0 SAY mphrase+' not found. Press any key....'
           keystroke := INKEY(0)
           toprec    := oldtop
           GO toprec
        ELSE
           toprec := RECNO()
        ENDIF (eof())
        flag := .T.
      ENDI

      SETCOLOR(newcolor)
      showlins()
      SETCOLOR("I")
      @ 24,0 SAY SPACE(80)
      @ 24, 00 SAY SPACE(30)+'Keys: '+CHR(24)+CHR(25)+CHR(26)+CHR(27)+;
      '/PgDn/PgUp/Home/End    ESC=Exit F1=HELP'
      @ 24, 00 SAY 'Command  '
      SETCOLOR(newcolor)

   CASE keystroke = 67 .OR. keystroke = 99
      getstr := REPLICATE(" ",25)
      oldtop := toprec
      GO toprec
      SETCOLOR("I")
      @ 24,0 SAY SPACE(80)
      @ 24,00 SAY "Search for ? " GET getstr
      READ

      mphrase := CHR(34)+TRIM(getstr)+CHR(34)
      IF !EMPTY(getstr)
        getstr := TRIM(getstr)
        LOCATE NEXT 1000000 FOR getstr $ FIELD->line
        IF EOF()
           @ 24,0 SAY SPACE(80)
           @ 24,0 SAY mphrase + ' not found. Press any key....'
           keystroke := INKEY(0)
           toprec    := oldtop
           GO toprec
        ELSE
           toprec := RECNO()
         ENDIF (eof())
        flag := .T.
      ENDI

      SETCOLOR(newcolor)
      showlins()
      SETCOLOR("I")
      @ 24,0 SAY SPACE(80)
      @ 24, 00 SAY SPACE(30)+'Keys: '+CHR(24)+CHR(25)+CHR(26)+CHR(27)+;
      '/PgDn/PgUp/Home/End    ESC=Exit F1=HELP'
      @ 24, 00 SAY 'Command  '
      SETCOLOR(newcolor)

      // User wants to find the next occurrence.
   CASE keystroke = 78 .OR. keystroke = 110
      IF flag
        CONTINUE
        IF EOF()
           SETCOLOR("I")
           @ 24,0 SAY SPACE(80)
           @ 24,0 SAY mphrase + '- Next occurrence not found. Press any key....'
           keystroke := INKEY(0)
           toprec := oldtop
           GO toprec
        ELSE
           toprec := RECNO()
        ENDIF (eof())

        SETCOLOR(newcolor)
        showlins()
        SETCOLOR("I")
        @ 24,0 SAY SPACE(80)
        @ 24, 00 SAY SPACE(30)+'Keys: '+CHR(24)+CHR(25)+CHR(26)+CHR(27)+;
        '/PgDn/PgUp/Home/End    ESC=Exit F1=HELP'
        @ 24, 00 SAY 'Command  '
        SETCOLOR(newcolor)
     ENDI

   ENDCASE

ENDDO
RETURN NIL

//──────────────────────────────────────────────────────────────────────
//
//       Function: SHOWLINS()
//
//      Called by: READTXT.PRG
//
//─────────────────────────────────────────────────────────────────────
STATIC FUNCTION showlins()
//──────────────────
LOCAL lastrow

@ boxtop, 0 CLEAR TO boxbott,79
scr_row := boxtop
DO WHILE .NOT. EOF() .AND. scr_row <= boxbott
   @ scr_row,0 SAY SUBSTR(FIELD->line, offset,79)
   SKIP
   scr_row := scr_row+1
ENDDO
lastrow := scr_row-1
RETURN .T.

//───────────────────────────────────
// Function ParseSlash()
//        By Ted Long
//───────────────────────────────────
STATIC FUNCTION ParseSlash(cFname)
//───────────────────────────────────
LOCAL posa, posb

cFname := ALLTRIM( cFname )

// If the filename is included within a path, the parse out the filename
posa := RAT("\",cFname)
IF posa > 0
   cFname := SUBSTR(cFname, posa + 1, LEN( cfname) )
endif

RETURN cFname

//───────────────────────────────────────────────────────────────────────
//      Function: ML_BOX()
//
//        By Ted Long
//
//      usage: m_box(5,"character string")
//      What it does: centers a message on the screen with a box.
//      Starting at the specific line number
//───────────────────────────────────────────────────────────────────────
STATIC FUNCTION ML_box(mrow, M_string)
//─────────────────────────────
LOCAL length, beg_it, end_it

IF LEN(ALLTRIM(M_string)) >= 76
   length := 76
   M_string := SUBSTR(M_string,1,76)
ELSE
   length := ROUND(LEN(ALLTRIM(M_string)),0)
ENDI

beg_it := ROUND((80-length)/2,0)-2
end_it := ROUND(((80-length)/2)+length,0)+1

RS_BOX( mrow-1, beg_it, mrow+1, end_it )
@ mrow-1, 34 SAY "┤  Message  ├"
@ mrow,(beg_it +2) SAY ALLTRIM(M_string)
RETURN NIL

//───────────────────────────────────────────────────────────────────────
//        Function: RS_BOX()
//
//        By Ted Long
//
//        A REAL SHADOW BOX (NON-DESTRUCTIVE SHADOW ON BOTTOM AND RIGHT)
//
//         USAGE: C_BOX(n1 ,n2 , n3, n4, n5)
//         WHERE:  n1 := BEGINING ROW
//                 n2 := BEGINING COL
//                 n3 := ENDING ROW
//                 n4 := ENDING COLUMN
//                 n5 := BOX TYPE  (optional)
//
//                 BOX OPTIONS   1 := ┌─┐│┘─└│     2 := ╔═╗║╝═╚║
//                               3 := ╒═╕│╛═╘│     4 := ╓─╖║╜─╙║
//                               5 := "█▀███▄██ ████"
//
//                               DEFAULT :=  ┌─┐│┘─└│
//───────────────────────────────────────────────────────────────────────
// I'm sure that this is the fastet non-destructive shadowbox available
// that is written in 100% Clipper. Speed gets damn close to ASM
//───────────────────────────────────────────────────────────────────────
STATIC FUNCTION RS_BOX(beg_row, beg_col, end_row, end_col, b_type, color)
//───────────────────────────────────────────────────────────────────────
LOCAL mboxer, horiz, vert, h, v, origcolor

//───────────────────────────────────────────────────────────────
// check to see if the parameters passed are greater than possible
// shadow box coordinates on a 80 X 25 Screen
//───────────────────────────────────────────────────────────────
DO CASE
   CASE beg_row < 0 .or. beg_row > 23
      RETURN NIL
   CASE beg_col < 0 .or. beg_col > 77
      RETURN NIL
   CASE end_row < 2 .or. end_row > 23
      RETURN NIL
   CASE end_col < 0 .or. end_col > 77
      RETURN NIL
ENDCASE

origcolor := SETCOLOR()

//───────────────────────────────────────────────────────────────
// Spec out the box type. Default is type 1 or a single line box
//───────────────────────────────────────────────────────────────
DO CASE
CASE b_type == 1
   mboxer := "┌─┐│┘─└│"
CASE b_type == NIL
   mboxer := "┌─┐│┘─└│"
CASE b_type == 2
   mboxer := "╔═╗║╝═╚║ "
CASE b_type == 3
   mboxer := "╒═╕│╛═╘│ "
CASE b_type == 4
   mboxer := "╓─╖║╜─╙║ "
CASE b_type == 5
   mboxer := "█▀███▄██ ████"
CASE b_type == 6
   mboxer := "             "
OTHERWISE
   mboxer := "┌─┐│┘─└│"
ENDCASE

//───────────────────────────────────────────────────────────────
// Create a transparent shadow by replacing every other char within the
// savescreen memvars with CHR(07) [ white on black ] for both the
// vertical and horizontal axis.  REPLACED the loop with REPLICATE()
// and TRANSFORM() 03/91
//───────────────────────────────────────────────────────────────
//   Save and transform the Right Vertical axis
//───────────────────────────────────────────────────────────────

vert := SAVESCREEN(beg_row+1, end_col+1, end_row+1, end_col+2)
v    := TRANSFORM(vert, REPLICATE("X"+CHR(07), LEN(vert)))

//───────────────────────────────────────────────────────────────
//   Save and transform the Bottom horizontal axis
//───────────────────────────────────────────────────────────────

horiz := SAVESCREEN(end_row+1, beg_col+2, end_row+1, end_col+2)
h     := TRANSFORM(horiz, REPLICATE("X"+CHR(07), LEN(horiz)))

//───────────────────────────────────────────────────────────────
// restore the screen with the vertical and horizontal axis (memvar)
// changed for white on black
//───────────────────────────────────────────────────────────────
RESTSCREEN(beg_row+1, end_col+1, end_row+1, end_col+2, v)
RESTSCREEN(end_row+1, beg_col+2, end_row+1, end_col+2, h)

//─────────────────────────
// do da box
//─────────────────────────
IF color != NIL
  SETCOLOR(color)
ENDI

@ (beg_row), (beg_col), (end_row), (end_col)  BOX "         "
@ (beg_row), (beg_col), (end_row), (end_col)  BOX mboxer

SETCOLOR(origcolor)

RETURN NIL

//──────────────────────────────────────────────────────────────────
//  Function  O_error()
//
//  By Ted Long
//──────────────────────────────────────────────────────────────────
STATIC FUNCTION o_error( Amessage, color, whatline, defaultval, boxtype )
//──────────────────────────────────────────────────────────────────
local width, oldcolor, oldscreen, thecolor, choice, retval, i, a
local maxlength

oldcolor  := setcolor()

if( iscolor(), thecolor := "+W/R,+W/N", thecolor := "w/n" )
if( !empty(color), thecolor := color,  )
if( whatline == nil, whatline  := 10,  )
if( defaultval == nil,  defaultval := .T., )
if( defaultval == nil,  defaultval := .T., )
if( boxtype == nil,  boxtype := 1, )

if valtype( Amessage ) == "C"
  Amessage  := { alltrim( Amessage ) }
endi

// Determine the maximum length element of the array
a         := 1
maxlength := 1

for i = 1 to len( Amessage )
  a := max( len( Amessage[ i ]), maxlength )
  maxlength := a
next

width     := int(max(74 - maxlength, 0)) / 2
oldscreen := savescreen(whatline, width, whatline + maxlength + 4 , 82 - width)

setcolor(thecolor)

TONE(200,2)

RS_BOX(whatline, width, whatline + len( Amessage ) + 3, 80 - width, boxtype )

for i = 1 to len( Amessage )
  centr(whatline + i, Amessage[i] )
next

centr(whatline + len( aMessage ) + 2,"** Press any key **")
inkey(0)

restscreen(whatline, width, whatline + maxlength + 4 , 82 - width, oldscreen)
setcolor(oldcolor)

return( retval )

//───────────────────────────────────────────────────────────────
//       Function: CENTR()
//
//       By Ted Long
//
//       usage: CENTR(5,"character string")
//       What it does: centers a char string on the screen.
//       Starting at the specific line number
//───────────────────────────────────────────────────────────────
STATIC FUNCTION CENTR(disp_row, m_string, cColor)
//───────────────────────────────────────────────────────────────
LOCAL length, beg, dacolor

if(cColor == NIL, dacolor := setcolor(), dacolor := cColor)

length := ROUND(LEN(ALLTRIM(m_string)),0)

beg := ROUND((80-length)/2,0)-2
@ disp_row,(beg +2) SAY ALLTRIM(m_string) COLOR dacolor

RETURN NIL