home *** CD-ROM | disk | FTP | other *** search
/ Programming Languages Suite / ProgramD2.iso / Database / CLIPR503.W96 / TBDEMO.PR_ / TBDEMO.PR
Encoding:
Text File  |  1995-06-20  |  12.1 KB  |  566 lines
  1. /***
  2. *
  3. *  Tbdemo.prg
  4. *
  5. *  Illustration of TBROWSE and GET objects.
  6. *
  7. *  Copyright (c) 1990-1995, Computer Associates International Inc.
  8. *  All rights reserved.
  9. *
  10. *  Compile:  CLIPPER Tbdemo /m /n /w
  11. *  Link:     RTLINK FILE Tbdemo
  12. *  Execute:  Tbdemo <dbf> [<ntx>]
  13. *
  14. */
  15.  
  16. #include "Common.ch"
  17. #include "Inkey.ch"
  18. #include "Setcurs.ch"
  19. #include "Error.ch"
  20.  
  21.  
  22. /*
  23. *  These #defines use the browse's "cargo" slot to hold the
  24. *  "append mode" flag for the browse. The #defines make it
  25. *  easy to change this later (e.g. if you need to keep
  26. *  several items in the cargo slot).
  27. */
  28. #define APP_MODE_ON( b )      ( b:cargo := TRUE  )
  29. #define APP_MODE_OFF( b )     ( b:cargo := FALSE )
  30. #define APP_MODE_ACTIVE( b )  ( b:cargo )
  31.  
  32. // Separator strings for the browse display
  33. #define MY_HEADSEP      "═╤═"
  34. #define MY_COLSEP       " │ "
  35.  
  36.  
  37.  
  38. /***
  39. *
  40. *  Tbdemo <dbf> [<index>]
  41. *
  42. */
  43. PROCEDURE Tbdemo( dbf, index )
  44.  
  45.    LOCAL bSaveHandler
  46.    LOCAL oError
  47.    LOCAL cScreen
  48.    LOCAL cSavClr
  49.  
  50.    // Lazy man's error checking
  51.    bSaveHandler := errorblock( { |x| break(x) } )
  52.  
  53.    BEGIN SEQUENCE
  54.       use (dbf) index (index)
  55.  
  56.    RECOVER USING oError
  57.       if ( oError:genCode == EG_OPEN )
  58.          ?? "Error opening file(s)"
  59.  
  60.       else
  61.          // Assume it was a problem with the params
  62.          ?? "Usage: Tbdemo <dbf> [<index>]"
  63.  
  64.       endif
  65.  
  66.       QUIT     // NOTE
  67.    END
  68.  
  69.    // Restore the default error handler
  70.    errorblock( bSaveHandler )
  71.  
  72.    // Save screen, set color, etc.
  73.    set scoreboard off
  74.    cScreen := savescreen()
  75.    cSavClr := setcolor("N/BG")
  76.    cls
  77.  
  78.    MyBrowse( 3, 6, maxrow() - 2, maxcol() - 6 )
  79.  
  80.    // Put things back
  81.    setcolor  ( cSavClr )
  82.    setpos    ( maxrow(), 0 )
  83.    restscreen( ,,,, cScreen )
  84.  
  85.    QUIT
  86.  
  87.    RETURN
  88.  
  89.  
  90.  
  91. /***
  92. *
  93. *  MyBrowse()
  94. *
  95. *  Create a Tbrowse object and browse with it.
  96. *
  97. */
  98. STATIC PROCEDURE MyBrowse(nTop, nLeft, nBottom, nRight)
  99.  
  100.    LOCAL oBrowse                          // The TBrowse object
  101.    LOCAL cColorSave, nCursSave            // State preservers
  102.    LOCAL nKey                             // Keystroke
  103.    LOCAL lMore := TRUE                    // Loop control
  104.    LOCAL lSavReadExit := READEXIT( .T. )  // Enable Up/Down as READ exit keys
  105.  
  106.    // Make a "stock" Tbrowse object for the current workarea
  107.    oBrowse := StockBrowseNew( nTop, nLeft, nBottom, nRight )
  108.  
  109.    /*
  110.    *  This demo uses the browse's "cargo" slot to hold a logical
  111.    *  value of true (.T.) when the browse is in "append mode",
  112.    *  otherwise false (.F.) (see #defines at top).
  113.    */
  114.    APP_MODE_OFF( oBrowse )
  115.  
  116.    // Use a custom 'skipper' to handle append mode (see below)
  117.    oBrowse:skipBlock := { |x| Skipper( x, oBrowse ) }
  118.  
  119.    // Change the heading and column separators
  120.    oBrowse:headSep := MY_HEADSEP
  121.    oBrowse:colSep  := MY_COLSEP
  122.  
  123.    // Play with the colors and picture
  124.    FormatColumns( oBrowse )
  125.  
  126.    // Insert a column at the left for "Rec #" and freeze it
  127.    AddRecno( oBrowse )
  128.  
  129.    // Draw a window shadow
  130.    dispbegin()
  131.  
  132.    cColorSave := setcolor( "N/N" )
  133.    scroll( nTop + 1, nLeft + 2, nBottom + 1, nRight + 2 )
  134.  
  135.    setcolor( "W/W" )
  136.    scroll( nTop, nLeft, nBottom, nRight )
  137.  
  138.    dispend()
  139.  
  140.    setcolor( cColorSave )
  141.  
  142.    // Save cursor shape, turn the cursor off while browsing
  143.    nCursSave := setcursor( SC_NONE )
  144.  
  145.    // Main loop
  146.    while lMore
  147.  
  148.       // Don't let the cursor move into frozen columns
  149.       if ( oBrowse:colPos <= oBrowse:freeze )
  150.          oBrowse:colPos := ( oBrowse:freeze + 1 )
  151.  
  152.       endif
  153.  
  154.       // Stabilize the display until it's stable or a key is pressed
  155.       oBrowse:forceStable()
  156.  
  157.       if ( oBrowse:hitBottom .and. !APP_MODE_ACTIVE( oBrowse ) )
  158.          // Banged against EOF; go into append mode
  159.          APP_MODE_ON( oBrowse )
  160.          nKey := K_DOWN
  161.  
  162.       else
  163.          if ( oBrowse:hitTop .or. oBrowse:hitBottom )
  164.             tone( 125, 0 )
  165.  
  166.          endif
  167.  
  168.          /*
  169.          *  Make sure that the current record is showing
  170.          *  up-to-date data in case we are on a network.
  171.          */
  172.          oBrowse:refreshCurrent():forceStable()
  173.  
  174.          // Everything's done -- just wait for a key
  175.          nKey := inkey( 0 )
  176.  
  177.       endif
  178.  
  179.       if ( nKey == K_ESC )
  180.          // Esc means leave
  181.          lMore := .F.
  182.  
  183.       else
  184.          // Apply the key to the oBrowse
  185.          applyKey( oBrowse, nKey )
  186.  
  187.       endif
  188.    enddo
  189.  
  190.    setcursor( nCursSave )
  191.    READEXIT( lSavReadExit )
  192.  
  193.    RETURN
  194.  
  195.  
  196.  
  197. /***
  198. *
  199. *  Skipper()
  200. *
  201. *  Handle record movement requests from the Tbrowse object.
  202. *
  203. *  This is a special "skipper" that handles append mode. It
  204. *  takes two parameters instead of the usual one. The second
  205. *  parameter is a reference to the Tbrowse object itself. The
  206. *  Tbrowse's "cargo" variable contains information on whether
  207. *  append mode is turned on.
  208. *
  209. *  NOTE: uses the cargo #defines shown at the top of Tbdemo.prg
  210. *
  211. */
  212. STATIC FUNCTION Skipper( nSkip, oBrowse )
  213.  
  214.    LOCAL lAppend := APP_MODE_ACTIVE( oBrowse )
  215.    LOCAL i       := 0
  216.  
  217.    do case
  218.    case ( nSkip == 0 .or. lastrec() == 0 )
  219.       // Skip 0 (significant on a network)
  220.       dbSkip( 0 )
  221.  
  222.    case ( nSkip > 0 .and. !eof() )
  223.       while ( i < nSkip )           // Skip Foward
  224.  
  225.          dbskip( 1 )
  226.  
  227.          if eof()
  228.             iif( lAppend, i++, dbskip( -1 ) )
  229.             exit
  230.  
  231.          endif
  232.  
  233.          i++
  234.  
  235.       enddo
  236.  
  237.    case ( nSkip < 0 )
  238.       while ( i > nSkip )           // Skip backward
  239.  
  240.          dbskip( -1 )
  241.  
  242.          if bof()
  243.             exit
  244.  
  245.          endif
  246.  
  247.          i--
  248.  
  249.       enddo
  250.  
  251.    endcase
  252.  
  253.    RETURN i
  254.  
  255.  
  256.  
  257. /***
  258. *
  259. *   ApplyKey()
  260. *
  261. *   Apply one keystroke to the oBrowse.
  262. *
  263. *   NOTE: uses the cargo #defines shown at the top of Tbdemo.prg
  264. *
  265. */
  266. STATIC PROCEDURE ApplyKey( oBrowse, nKey )
  267.  
  268.    do case
  269.    case nKey == K_DOWN
  270.       oBrowse:down()
  271.  
  272.    case nKey == K_PGDN
  273.       oBrowse:pageDown()
  274.  
  275.    case nKey == K_CTRL_PGDN
  276.       oBrowse:goBottom()
  277.       APP_MODE_OFF( oBrowse )
  278.  
  279.    case nKey == K_UP
  280.       oBrowse:up()
  281.  
  282.       if APP_MODE_ACTIVE( oBrowse )
  283.          APP_MODE_OFF( oBrowse )
  284.          oBrowse:refreshAll()
  285.  
  286.       endif
  287.  
  288.    case nKey == K_PGUP
  289.       oBrowse:pageUp()
  290.  
  291.       if APP_MODE_ACTIVE( oBrowse )
  292.          APP_MODE_OFF( oBrowse )
  293.          oBrowse:refreshAll()
  294.  
  295.       endif
  296.  
  297.    case nKey == K_CTRL_PGUP
  298.       oBrowse:goTop()
  299.       APP_MODE_OFF( oBrowse )
  300.  
  301.    case nKey == K_RIGHT
  302.       oBrowse:right()
  303.  
  304.    case nKey == K_LEFT
  305.       oBrowse:left()
  306.  
  307.    case nKey == K_HOME
  308.       oBrowse:home()
  309.  
  310.    case nKey == K_END
  311.       oBrowse:end()
  312.  
  313.    case nKey == K_CTRL_LEFT
  314.       oBrowse:panLeft()
  315.  
  316.    case nKey == K_CTRL_RIGHT
  317.       oBrowse:panRight()
  318.  
  319.    case nKey == K_CTRL_HOME
  320.       oBrowse:panHome()
  321.  
  322.    case nKey == K_CTRL_END
  323.       oBrowse:panEnd()
  324.  
  325.    case nKey == K_RETURN
  326.       DoGet( oBrowse )
  327.  
  328.    otherwise
  329.       KEYBOARD chr( nKey )
  330.       DoGet( oBrowse )
  331.  
  332.    endcase
  333.  
  334.    RETURN
  335.  
  336.  
  337.  
  338. /***
  339. *
  340. *   DoGet()
  341. *
  342. *   Do a GET for the current column in the browse.
  343. *
  344. *   NOTE: uses the cargo #defines shown at the top of Tbdemo.prg
  345. *
  346. */
  347. PROCEDURE doGet( oBrowse )
  348.  
  349.    LOCAL lFlag := TRUE
  350.    LOCAL oCol
  351.    LOCAL GetList
  352.    LOCAL nKey
  353.    LOCAL nLen
  354.    LOCAL lAppend
  355.    LOCAL bSavIns
  356.    LOCAL nSavRecNo := recno()
  357.    LOCAL xNewKey
  358.    LOCAL xSavKey
  359.  
  360.    // If we're at EOF we're adding the first record, so turn on append mode
  361.    if EOF()
  362.       lAppend := APP_MODE_ON( oBrowse )
  363.    else
  364.       lAppend := APP_MODE_ACTIVE( oBrowse )
  365.    endif
  366.  
  367.    // Make sure screen is fully updated, dbf position is correct, etc.
  368.    oBrowse:forceStable()
  369.  
  370.    if ( lAppend .and. ( recno() == lastrec() + 1 ) )
  371.       dbAppend()
  372.  
  373.    endif
  374.  
  375.    // Save the current record's key value (or NIL)
  376.    xSavKey := iif( empty( indexkey() ), NIL, &( indexkey() ) )
  377.  
  378.    // Get the current column object from the browse
  379.    oCol := oBrowse:getColumn( oBrowse:colPos )
  380.  
  381.    // Get picture len to force scrolling if var is larger than window
  382.    nLen := oBrowse:colWidth( oBrowse:colPos )
  383.  
  384.    // Create a corresponding GET
  385.    GetList := { getnew( row(), col(),     ;
  386.                         oCol:block,       ;
  387.                         oCol:heading,     ;
  388.                         oCol:picture,     ;
  389.                         oBrowse:colorSpec ) }
  390.  
  391.    // Set insert key to toggle insert mode and cursor shape
  392.    bSavIns := setkey( K_INS, { || InsToggle() } )
  393.  
  394.    // Set initial cursor shape
  395.    setcursor( iif( ReadInsert(), SC_INSERT, SC_NORMAL ) )
  396.    READ
  397.    setcursor( SC_NONE )
  398.    setkey( K_INS, bSavIns )
  399.  
  400.    // For this demo, we turn append mode off after each new record
  401.    APP_MODE_OFF( oBrowse )
  402.  
  403.    // Get the record's key value (or NIL) after the GET
  404.    xNewKey := if( empty( indexkey() ), NIL, &( indexkey() ) )
  405.  
  406.    oBrowse:inValidate()
  407.    oBrowse:refreshAll():forceStable()
  408.  
  409.    // if the key has changed (or if this is a new record)
  410.    if !( xNewKey == xSavKey ) .or. ( lAppend .and. xNewKey != NIL )
  411.  
  412.       // do a complete refresh
  413.       oBrowse:refreshAll():forceStable()
  414.  
  415.       // Make sure we're still on the right record after stabilizing
  416.       while &( indexkey() ) > xNewKey .and. !oBrowse:hitTop()
  417.          oBrowse:up():forceStable()
  418.  
  419.       enddo
  420.  
  421.    endif
  422.  
  423.    // Check exit key from get
  424.    nKey := lastkey()
  425.    if nKey == K_UP   .or. nKey == K_DOWN .or. ;
  426.       nKey == K_PGUP .or. nKey == K_PGDN
  427.  
  428.       // Ugh
  429.       keyboard( chr( nKey ) )
  430.  
  431.    endif
  432.  
  433.    RETURN
  434.  
  435.  
  436.  
  437. /***
  438. *
  439. *   InsToggle()
  440. *
  441. *   Toggle the global insert mode and the cursor shape.
  442. *
  443. */
  444. STATIC PROCEDURE InsToggle()
  445.  
  446.    if readinsert()
  447.       readinsert( FALSE )
  448.       setcursor( SC_NORMAL )
  449.  
  450.    else
  451.       readinsert( TRUE )
  452.       setcursor( SC_INSERT )
  453.  
  454.    endif
  455.  
  456.    RETURN
  457.  
  458.  
  459.  
  460. /***
  461. *
  462. *   StockBrowseNew()
  463. *
  464. *   Create a "stock" Tbrowse object for the current workarea.
  465. *
  466. */
  467. STATIC FUNCTION StockBrowseNew( nTop, nLeft, nBottom, nRight )
  468.  
  469.    LOCAL oBrowse
  470.    LOCAL n
  471.    LOCAL oColumn
  472.    LOCAL cType
  473.  
  474.    // Start with a new browse object from TBrowseDB()
  475.    oBrowse := TBrowseDB( nTop, nLeft, nBottom, nRight )
  476.  
  477.    // Add a column for each field in the current workarea
  478.    for n := 1 to fcount()
  479.  
  480.       // Make a new column
  481.       oColumn := TBColumnNew( field( n ),                         ;
  482.                               FieldWBlock( field( n ), select() ) )
  483.  
  484.       // Add the column to the browse
  485.       oBrowse:addColumn( oColumn )
  486.  
  487.    next
  488.  
  489.    RETURN oBrowse
  490.  
  491.  
  492.  
  493. /***
  494. *
  495. *   FormatColumn()
  496. *
  497. *   Set up some colors and pictures for the column.
  498. *
  499. */
  500. STATIC PROCEDURE FormatColumn( oBrowse )
  501.  
  502.    LOCAL n
  503.    LOCAL oColumn
  504.    LOCAL xValue
  505.  
  506.    // Set up a list of colors for the browse to use
  507.    oBrowse:colorSpec := "N/W,N/BG,B/W,B/BG,B/W,B/BG,R/W,B/R"
  508.  
  509.    // Loop through the columns, choose some colors for each
  510.    for n := 1 to oBrowse:colCount
  511.       
  512.       // Get (a reference to) the column
  513.       oColumn := oBrowse:getColumn( n )
  514.  
  515.       // Get a sample of the underlying data by evaluating the codeblock
  516.       xValue := eval( oColumn:block )
  517.  
  518.       do case
  519.       case ISNUM( xValue )
  520.           // For numbers, use a color block to highlight negative values
  521.           oColumn:picture    := "999,999"
  522.           oColumn:colorBlock := { |x| iif( x < 0, { 7, 8 }, { 5, 6 } ) }
  523.  
  524.           // Set default colors also (controls the heading color)
  525.           oColumn:defColor := {7, 8}
  526.  
  527.       case ISCHAR( xValue )
  528.          // For non-numeric, just use colors 3 and 4 ("B/W" and "B/BG")
  529.          oColumn:picture  := repl( "!", len( xValue ) )
  530.          oColumn:defColor := { 3, 4 }
  531.  
  532.       otherwise
  533.          // For non-numeric, just use colors 3 and 4 ("B/W" and "B/BG")
  534.          oColumn:defColor := { 3, 4 }
  535.  
  536.       endcase
  537.  
  538.    next
  539.  
  540.    RETURN
  541.  
  542.  
  543.  
  544. /***
  545. *
  546. *   AddRecno()
  547. *
  548. *   Insert a frozen column at the left that shows current record number
  549. *
  550. */
  551. STATIC PROCEDURE AddRecno( oBrowse )
  552.  
  553.    LOCAL oColumn
  554.  
  555.    // Create the column object
  556.    oColumn := TBColumnNew( "  Rec #", { || recno() } )
  557.  
  558.    // Insert it as the leftmost column
  559.    oBrowse:insColumn( 1, oColumn )
  560.  
  561.    // Freeze it at the left
  562.    oBrowse:freeze := 1
  563.  
  564.    RETURN
  565.  
  566.