home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 5 / 05.iso / a / a009 / 6.ddi / SAMPLE.LIF / TBDEMO.PRG < prev    next >
Encoding:
Text File  |  1991-04-14  |  14.2 KB  |  596 lines
  1. ****
  2. *   Tbdemo.prg
  3. *   Illustration of TBROWSE and GET objects.
  4. *   Copyright (c) 1990-1991 Nantucket Corp.  All rights reserved.
  5. *
  6. *   Compile:  CLIPPER Tbdemo /m/n/w
  7. *   Link:     RTLINK FILE Tbdemo
  8. *   Execute:  Tbdemo <dbf> [<ntx>]
  9. *
  10.  
  11. #include "Inkey.ch"
  12. #include "Setcurs.ch"
  13. #include "Error.ch"
  14.  
  15.  
  16. // These #defines use the browse's "cargo" slot to hold the
  17. // "append mode" flag for the browse. The #defines make it
  18. // easy to change this later (e.g. if you need to keep
  19. // several items in the cargo slot).
  20. #define TURN_ON_APPEND_MODE(b)      (b:cargo := .T.)
  21. #define TURN_OFF_APPEND_MODE(b)     (b:cargo := .F.)
  22. #define IS_APPEND_MODE(b)           (b:cargo)
  23.  
  24.  
  25. // Separator strings for the browse display
  26. #define MY_HEADSEP      "═╤═"
  27. #define MY_COLSEP       " │ "
  28.  
  29.  
  30.  
  31. ***
  32. *   Tbdemo <dbf> [<index>]
  33. *
  34.  
  35. PROCEDURE Tbdemo( dbf, index )
  36.  
  37.     LOCAL bSaveHandler, error
  38.     LOCAL cScreen
  39.  
  40.  
  41.     // Lazy man's error checking
  42.     bSaveHandler := ERRORBLOCK( {|x| BREAK(x)} )
  43.  
  44.     BEGIN SEQUENCE
  45.         USE (dbf) INDEX (index)
  46.  
  47.     RECOVER USING error
  48.         IF error:genCode == EG_OPEN
  49.             ?? "Error opening file(s)"
  50.  
  51.         ELSE
  52.             // Assume it was a problem with the params
  53.             ?? "Usage: Tbdemo <dbf> [<index>]"
  54.  
  55.         ENDIF
  56.  
  57.         QUIT
  58.     END
  59.  
  60.     // Restore the default error handler
  61.     ERRORBLOCK(bSaveHandler)
  62.  
  63.  
  64.     // Save screen, set color, etc.
  65.     cScreen := SAVESCREEN()
  66.     SETCOLOR("N/BG")
  67.     CLEAR SCREEN
  68.  
  69.     MyBrowse(3, 6, MAXROW() - 2, MAXCOL() - 6)
  70.  
  71.     // Put things back
  72.     SET COLOR TO
  73.     @ MAXROW(), 0
  74.     RESTSCREEN(,,,,cScreen)
  75.  
  76.     QUIT
  77.  
  78.  
  79.  
  80. ***
  81. *   MyBrowse()
  82. *   Create a Tbrowse object and browse with it.
  83. *
  84.  
  85. STATIC PROCEDURE MyBrowse(nTop, nLeft, nBottom, nRight)
  86.  
  87.     LOCAL browse                        // The TBrowse object
  88.     LOCAL cColorSave, nCursSave         // State preservers
  89.     LOCAL nKey                          // Keystroke
  90.     LOCAL lMore                         // Loop control
  91.  
  92.  
  93.     // Make a "stock" Tbrowse object for the current workarea
  94.     browse := StockBrowseNew(nTop, nLeft, nBottom, nRight)
  95.  
  96.     // This demo uses the browse's "cargo" slot to hold a logical
  97.     // value of true (.T.) when the browse is in "append mode",
  98.     // otherwise false (.F.) (see #defines at top).
  99.     TURN_OFF_APPEND_MODE(browse)
  100.  
  101.     // Use a custom 'skipper' to handle append mode (see below)
  102.     browse:skipBlock := { |x| Skipper(x, browse) }
  103.  
  104.  
  105.     // Change the heading and column separators
  106.     browse:headSep := MY_HEADSEP
  107.     browse:colSep := MY_COLSEP
  108.  
  109.     // Play with the colors
  110.     FancyColors(browse)
  111.  
  112.     // Insert a column at the left for "Rec #" and freeze it
  113.     AddRecno(browse)
  114.  
  115.  
  116.     // Draw a window shadow
  117.     cColorSave := SetColor("N/N")
  118.     @ nTop+1, nLeft+1 CLEAR TO nBottom+1, nRight+1
  119.     SETCOLOR("W/W")
  120.     @ nTop, nLeft CLEAR TO nBottom, nRight
  121.     SETCOLOR(cColorSave)
  122.  
  123.     // Save cursor shape, turn the cursor off while browsing
  124.     nCursSave := SetCursor(SC_NONE)
  125.  
  126.  
  127.     // Main loop
  128.     lMore := .T.
  129.     DO WHILE lMore
  130.  
  131.         // Don't let the cursor move into frozen columns
  132.         IF browse:colPos <= browse:freeze
  133.             browse:colPos := browse:freeze + 1
  134.         ENDIF
  135.  
  136.         // Stabilize the display until it's stable or a key is pressed
  137.         nKey := 0
  138.         DO WHILE nKey == 0 .AND. .NOT. browse:stable
  139.  
  140.             browse:stabilize()
  141.             nKey := InKey()
  142.  
  143.         ENDDO
  144.  
  145.  
  146.         IF browse:stable
  147.  
  148.             IF browse:hitBottom .AND. .NOT. IS_APPEND_MODE(browse)
  149.                 // Banged against EOF; go into append mode
  150.                 TURN_ON_APPEND_MODE(browse)
  151.                 nKey := K_DOWN
  152.  
  153.             ELSE
  154.                 IF browse:hitTop .OR. browse:hitBottom
  155.                     TONE(125, 0)
  156.                 ENDIF
  157.  
  158.                 // Make sure that the current record is showing
  159.                 // up-to-date data in case we are on a network.
  160.                 browse:refreshCurrent()
  161.                 ForceStable(browse)
  162.  
  163.                 // Everything's done -- just wait for a key
  164.                 nKey := InKey(0)
  165.  
  166.             ENDIF
  167.  
  168.         ENDIF
  169.  
  170.  
  171.         IF nKey == K_ESC
  172.             // Esc means leave
  173.             lMore := .F.
  174.  
  175.         ELSE
  176.             // Apply the key to the browse
  177.             ApplyKey(browse, nKey)
  178.  
  179.         ENDIF
  180.  
  181.  
  182.     ENDDO
  183.  
  184.  
  185.     SETCURSOR(nCursSave)
  186.  
  187.     RETURN
  188.  
  189.  
  190.  
  191. ****
  192. *   Skipper()
  193. *   Handle record movement requests from the Tbrowse object.
  194. *
  195. *   This is a special "skipper" that handles append mode. It
  196. *   takes two parameters instead of the usual one. The second
  197. *   parameter is a reference to the Tbrowse object itself. The
  198. *   Tbrowse's "cargo" variable contains information on whether
  199. *   append mode is turned on.
  200. *
  201. *   NOTE: uses the cargo #defines shown at the top of Tbdemo.prg
  202. *
  203.  
  204. STATIC FUNCTION Skipper(n, browse)
  205.  
  206.     LOCAL lAppend
  207.     LOCAL i
  208.  
  209.  
  210.     lAppend := IS_APPEND_MODE(browse)           // see #defines at top
  211.     i := 0
  212.  
  213.     IF n == 0 .OR. LASTREC() == 0
  214.  
  215.         // Skip 0 (significant on a network)
  216.         SKIP 0
  217.  
  218.     ELSEIF n > 0 .and. RECNO() != LASTREC() + 1
  219.  
  220.         // Skip forward
  221.         DO WHILE i < n
  222.             SKIP 1
  223.             IF ( EOF() )
  224.                 IF ( lAppend )
  225.                     i++
  226.                 ELSE
  227.                     SKIP -1
  228.                 ENDIF
  229.  
  230.                 EXIT
  231.             ENDIF
  232.  
  233.             i++
  234.         ENDDO
  235.  
  236.     ELSEIF n < 0
  237.  
  238.         // Skip backward
  239.         DO WHILE i > n
  240.             SKIP -1
  241.             IF ( BOF() )
  242.                 EXIT
  243.             ENDIF
  244.  
  245.             i--
  246.         ENDDO
  247.  
  248.     ENDIF
  249.  
  250.  
  251.     RETURN i
  252.  
  253.  
  254.  
  255. ***
  256. *   ApplyKey()
  257. *   Apply one keystroke to the browse.
  258. *
  259. *   NOTE: uses the cargo #defines shown at the top of Tbdemo.prg
  260. *
  261.  
  262. STATIC PROCEDURE ApplyKey(browse, nKey)
  263.  
  264.     DO CASE
  265.     CASE nKey == K_DOWN
  266.         browse:down()
  267.  
  268.     CASE nKey == K_PGDN
  269.         browse:pageDown()
  270.  
  271.     CASE nKey == K_CTRL_PGDN
  272.         browse:goBottom()
  273.         TURN_OFF_APPEND_MODE(browse)
  274.  
  275.     CASE nKey == K_UP
  276.         browse:up()
  277.  
  278.         IF IS_APPEND_MODE(browse)
  279.             TURN_OFF_APPEND_MODE(browse)
  280.             browse:refreshAll()
  281.         ENDIF
  282.  
  283.     CASE nKey == K_PGUP
  284.         browse:pageUp()
  285.  
  286.         IF IS_APPEND_MODE(browse)
  287.             TURN_OFF_APPEND_MODE(browse)
  288.             browse:refreshAll()
  289.         ENDIF
  290.  
  291.     CASE nKey == K_CTRL_PGUP
  292.         browse:goTop()
  293.         TURN_OFF_APPEND_MODE(browse)
  294.  
  295.     CASE nKey == K_RIGHT
  296.         browse:right()
  297.  
  298.     CASE nKey == K_LEFT
  299.         browse:left()
  300.  
  301.     CASE nKey == K_HOME
  302.         browse:home()
  303.  
  304.     CASE nKey == K_END
  305.         browse:end()
  306.  
  307.     CASE nKey == K_CTRL_LEFT
  308.         browse:panLeft()
  309.  
  310.     CASE nKey == K_CTRL_RIGHT
  311.         browse:panRight()
  312.  
  313.     CASE nKey == K_CTRL_HOME
  314.         browse:panHome()
  315.  
  316.     CASE nKey == K_CTRL_END
  317.         browse:panEnd()
  318.  
  319.     CASE nKey == K_RETURN
  320.         DoGet(browse)
  321.  
  322.     OTHERWISE
  323.  
  324.         KEYBOARD CHR(nKey)
  325.         DoGet(browse)
  326.  
  327.     ENDCASE
  328.  
  329.  
  330.     RETURN
  331.  
  332.  
  333.  
  334. ***
  335. *   DoGet()
  336. *   Do a GET for the current column in the browse.
  337. *
  338. *   NOTE: uses the cargo #defines shown at the top of Tbdemo.prg
  339. *
  340.  
  341. STATIC PROCEDURE DoGet(browse)
  342.  
  343.     LOCAL bIns, lScore, lExit
  344.     LOCAL col, get, nKey
  345.     LOCAL lAppend, xOldKey, xNewKey
  346.  
  347.  
  348.     // Make sure screen is fully updated, dbf position is correct, etc.
  349.     ForceStable(browse)
  350.  
  351.     // If confirming a new record, do the physical append
  352.     lAppend := IS_APPEND_MODE(browse)
  353.     IF lAppend .AND. RECNO() == LASTREC() + 1
  354.         APPEND BLANK
  355.     ENDIF
  356.  
  357.  
  358.     // Save the current record's key value (or NIL)
  359.     // (for an explanation, refer to the rambling note below)
  360.     xOldKey := IF( EMPTY(INDEXKEY()), NIL, &(INDEXKEY()) )
  361.  
  362.  
  363.     // Save global state
  364.     lScore := Set(_SET_SCOREBOARD, .F.)
  365.     lExit := Set(_SET_EXIT, .T.)
  366.     bIns := SetKey(K_INS)
  367.  
  368.     // Set insert key to toggle insert mode and cursor shape
  369.     SetKey( K_INS, {|| InsToggle()} )
  370.  
  371.     // Set initial cursor shape
  372.     SetCursor( IF(ReadInsert(), SC_INSERT, SC_NORMAL) )
  373.  
  374.  
  375.     // Get the current column object from the browse
  376.     col := browse:getColumn(browse:colPos)
  377.  
  378.     // Create a corresponding GET
  379.     get := GetNew(Row(), Col(), col:block, col:heading,, browse:colorSpec)
  380.  
  381.     // Read it using the standard reader
  382.     // NOTE: for a shared database, an RLOCK() is required here
  383.     ReadModal( {get} )
  384.  
  385.  
  386.     // Restore state
  387.     SetCursor(0)
  388.     Set(_SET_SCOREBOARD, lScore)
  389.     Set(_SET_EXIT, lExit)
  390.     SetKey(K_INS, bIns)
  391.  
  392.  
  393.     // What this next piece of code does:
  394.     //
  395.     // When a TBrowse stabilizes, it always tries to leave the
  396.     // same "cell" highlighted as was previously highlighted. That
  397.     // is, it always tries to keep the highlight at the same position
  398.     // within the browse window unless it is explicitly moved via an
  399.     // "up" or "down" message. The TBrowse positions the data source
  400.     // in a corresponding fashion. If there aren't enough rows left
  401.     // in the data source (i.e. EOF is encountered while trying to
  402.     // adjust the database to match the window), the TBrowse will
  403.     // relent and move the cursor upward, leaving it on the correct
  404.     // record but with part of the window unfilled.
  405.     //
  406.     // That works OK for logical EOF, but a problem can occur when
  407.     // a GET on a key field causes the current record to move so
  408.     // close to logical BOF that it is impossible to highlight the
  409.     // correct record while leaving the highlight at its previous
  410.     // position within the window. In this case, TBrowse opts to
  411.     // leave the highlight in the same position within the window,
  412.     // even though that position no longer corresponds with the same
  413.     // record as before. That is, it repositions the database as far
  414.     // as it will go, then leaves the highlight where it was. The
  415.     // result is that you end up with the highlight on a different
  416.     // record than the one you just edited.
  417.     //
  418.     // The following piece of code addresses this by checking to see
  419.     // if the current record's key value changed during the GET. If
  420.     // so (or if the record is a new record, just appended), the code
  421.     // below forces a complete refresh and a full stabilization. It
  422.     // then checks to see if this caused the TBrowse to position the
  423.     // database to a different record than before. If so, the old
  424.     // record is assumed to be somewhere "above" the current record,
  425.     // and a series of "up" messages are issued to the browse to get
  426.     // the highlight to move up to the proper position.
  427.  
  428.     // Get the record's key value (or NIL) after the GET
  429.     xNewKey := IF( EMPTY(INDEXKEY()), NIL, &(INDEXKEY()) )
  430.  
  431.     // If the key has changed (or if this is a new record)
  432.     IF .NOT. (xNewKey == xOldKey) .OR. (lAppend .AND. xNewKey != NIL)
  433.  
  434.         // Do a complete refresh
  435.         browse:refreshAll()
  436.         ForceStable(browse)
  437.  
  438.         // Make sure we're still on the right record after stabilizing
  439.         DO WHILE &(INDEXKEY()) > xNewKey .AND. .NOT. browse:hitTop()
  440.             browse:up()
  441.             ForceStable(browse)
  442.         ENDDO
  443.  
  444.     ENDIF
  445.  
  446.  
  447.     // For this demo, we turn append mode off after each new record
  448.     TURN_OFF_APPEND_MODE(browse)
  449.  
  450.     // Check exit key from get
  451.     nKey := LASTKEY()
  452.     IF nKey == K_UP .OR. nKey == K_DOWN .OR. ;
  453.         nKey == K_PGUP .OR. nKey == K_PGDN
  454.  
  455.         // Ugh
  456.         KEYBOARD( CHR(nKey) )
  457.  
  458.     ENDIF
  459.  
  460.  
  461.     RETURN
  462.  
  463.  
  464.  
  465. ***
  466. *   ForceStable()
  467. *   Force a complete stabilization of a TBrowse.
  468. *
  469.  
  470. STATIC PROCEDURE ForceStable(browse)
  471.  
  472.     DO WHILE .NOT. browse:stabilize()
  473.     ENDDO
  474.  
  475.     RETURN
  476.  
  477.  
  478.  
  479. ***
  480. *   InsToggle()
  481. *   Toggle the global insert mode and the cursor shape.
  482. *
  483.  
  484. STATIC PROCEDURE InsToggle()
  485.  
  486.     IF READINSERT()
  487.         READINSERT(.F.)
  488.         SETCURSOR(SC_NORMAL)
  489.  
  490.     ELSE
  491.         READINSERT(.T.)
  492.         SETCURSOR(SC_INSERT)
  493.  
  494.     ENDIF
  495.  
  496.     RETURN
  497.  
  498.  
  499.  
  500. ***
  501. *   StockBrowseNew()
  502. *   Create a "stock" Tbrowse object for the current workarea.
  503. *
  504.  
  505. STATIC FUNCTION StockBrowseNew(nTop, nLeft, nBottom, nRight)
  506.  
  507.     LOCAL browse
  508.     LOCAL n, column, cType
  509.  
  510.  
  511.     // Start with a new browse object from TBrowseDB()
  512.     browse := TBrowseDB(nTop, nLeft, nBottom, nRight)
  513.  
  514.     // Add a column for each field in the current workarea
  515.     FOR n := 1 TO FCount()
  516.  
  517.         // Make a new column
  518.         column := TBColumnNew(                                          ;
  519.                                 Field(n),                               ;
  520.                                 FieldWBlock(Field(n), Select())         ;
  521.                              )
  522.  
  523.         // Add the column to the browse
  524.         browse:addColumn(column)
  525.  
  526.     NEXT
  527.  
  528.  
  529.     RETURN browse
  530.  
  531.  
  532.  
  533. ***
  534. *   FancyColors()
  535. *   Set up some colors for the browse.
  536. *
  537.  
  538. STATIC PROCEDURE FancyColors(browse)
  539.  
  540.     LOCAL n, column
  541.     LOCAL xValue
  542.  
  543.  
  544.     // Set up a list of colors for the browse to use
  545.     browse:colorSpec := "N/W, N/BG, B/W, B/BG, B/W, B/BG, R/W, B/R"
  546.  
  547.     // Loop through the columns, choose some colors for each
  548.     FOR n := 1 TO browse:colCount
  549.  
  550.         // Get (a reference to) the column
  551.         column := browse:getColumn(n)
  552.  
  553.         // Get a sample of the underlying data by evaluating the codeblock
  554.         xValue := EVAL(column:block)
  555.  
  556.         IF VALTYPE(xValue) != "N"
  557.             // For non-numeric, just use colors 3 and 4 ("B/W" and "B/BG")
  558.             column:defColor := {3, 4}
  559.  
  560.         ELSE
  561.             // For numbers, use a color block to highlight negative values
  562.             column:colorBlock := {|x| if( x < 0, {7, 8}, {5, 6} )}
  563.  
  564.             // Set default colors also (controls the heading color)
  565.             column:defColor := {7, 8}
  566.  
  567.         ENDIF
  568.  
  569.     NEXT
  570.  
  571.  
  572.     RETURN
  573.  
  574.  
  575.  
  576. ***
  577. *   AddRecno()
  578. *   Insert a frozen column at the left that shows current record number
  579. *
  580.  
  581. STATIC PROCEDURE AddRecno(browse)
  582.  
  583.     LOCAL column
  584.  
  585.     // Create the column object
  586.     column := TBColumnNew( "  Rec #", {|| RECNO()} )
  587.  
  588.     // Insert it as the leftmost column
  589.     browse:insColumn(1, column)
  590.  
  591.     // Freeze it at the left
  592.     browse:freeze := 1
  593.  
  594.     RETURN
  595.  
  596.