home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 5 / 05.iso / a / a066 / 1.img / HERITEST.PRG < prev    next >
Encoding:
Text File  |  1992-03-20  |  7.9 KB  |  224 lines
  1. /*
  2.     heritest.prg
  3.  
  4.     21/03/1991 21:18 avs - updated
  5.     26/05/1991 07:36 avs - updated
  6.  
  7.     This program demonstrates many of the inheritance and scoping features
  8.     of Class(y), as well as some of the more advanced features.  The
  9.     program displays a menu of options; many of which will generate an
  10.     error when selected.  In these cases, an illegal operation has
  11.     deliberately been performed.
  12.  
  13.     NOTE: The output from this program is not very informative in itself.
  14.     We suggest that you trace through the program in the Clipper debugger,
  15.     and examine variable values as necessary.
  16.  
  17.     The program uses a box class, defined in HTBOX.PRG, which is inherited
  18.     from the rectangle class defined in this module. The rectangle class is
  19.     very limited, and is not the same one used in the manual.
  20. */
  21.  
  22. #include "class(y).ch"
  23.  
  24.  
  25. procedure main
  26.     local i, ivar, oBox, tStart
  27.     local BoxClass
  28.     local opt := 1
  29.  
  30.     cls
  31.     oBox := Box():new(2, 5, 16, 24, "╔═╗║╝═╚║ ", "R+/W", "RB+/BG")
  32.  
  33.     while opt <> 0
  34.         @  2, 12 say          'Errors'
  35.         @  3,  6 prompt ' Private access   '
  36.         @  4,  6 prompt ' Protected access '
  37.         @  5,  6 prompt ' Bad assignment   '
  38.         @  6,  6 prompt ' Msg -> non-obj   '
  39.         @  7,  6 prompt ' Bad message      '
  40.         @  8,  6 prompt ' Access via class '
  41.         @  9,  6 say    '──────Tests───────'
  42.         @ 10,  6 prompt ' Self in block    '
  43.         @ 11,  6 prompt ' Scalar classes   '
  44.         @ 12,  6 prompt ' Superclass name  '
  45.         @ 13,  6 prompt ' Class scope msgs '
  46.         @ 14,  6 prompt ' Class variables  '
  47.         @ 15,  6 prompt ' Class objects    '
  48.         menu to opt
  49.         set color to 'W/N'
  50.         @ 20, 0
  51.         do case
  52.             /*
  53.                 The following six options test variable scoping features
  54.                 and so forth, and all intentionally cause an error.
  55.             */
  56.             case opt == 1
  57.                 // illegal access of a private instance variable
  58.                 ? oBox:boxChars
  59.             case opt == 2
  60.                 // illegal access of a protected instance variable
  61.                 ? oBox:boxType
  62.  
  63.             case opt == 3
  64.                 // illegal assignment to read-only variable
  65.                 oBox:top := 42
  66.             case opt == 4
  67.                 // sending a message to a non-object
  68.                 ? opt:boxChars
  69.             case opt == 5
  70.                 // sending an unknown message to an object
  71.                 ? oBox:volume
  72.             case opt == 6
  73.                 // attempting to access an _instance_ variable via the
  74.                 // class function ie. without using an object of that class.
  75.                 ? box():top
  76.             /*
  77.                 The following options demonstrate and test various
  78.                 Class(y) features.  These should not cause errors.
  79.             */
  80.             case opt == 7
  81.                 // Accessing the 'self' variable within a code block
  82.                 // (see the 'testBlock' method)
  83.                 oBox:testBlock()
  84.             case opt == 8
  85.                 // Sending messages to the 'scalar' types such as numeric,
  86.                 // character etc (see the 'scalarClasses()' function).
  87.                 scalarClasses()
  88.             case opt == 9
  89.                 // Explicitly accessing an object's superclass with the
  90.                 // 'super' message.  In this case, we print the name of
  91.                 // the superclass using the 'className' message.
  92.                 ? "Using :super to access the name of an object's superclass"
  93.                 ? 'oBox:super:className -', oBox:super:className
  94.             case opt == 10
  95.                 // Another test of the 'super' message, comparing it with
  96.                 // using a specific class name ('rectangle') to specify
  97.                 // where to begin a message search.
  98.  
  99.                 ? 'See HERITEST.PRG for explanation'
  100.                 // First invoke method 'test' in class Box
  101.                 oBox:test()
  102.                 // Now invoke the same method in the Box's superclass, which
  103.                 // in this example is Rectangle.  Use the 'super' message.
  104.                 oBox:super:test()
  105.                 // Invoke it in Box again, to check that nothing is 'stuck'
  106.                 oBox:test()
  107.                 // invoke in class Rectangle by naming the class explicitly
  108.                 oBox:rectangle:test()
  109.                 // and Box again, as a final check
  110.                 oBox:test()
  111.             case opt == 11
  112.                 // Test class variables, which apply to an entire class rather
  113.                 // than to an individual object, or instance of the class.
  114.                 // First access class variables via an object.
  115.                 oBox:nRects := 42
  116.                 oBox:nBoxes := 23
  117.                 ? 'Accessing :nRects and :nBoxes via the oBox object:'
  118.                 ? oBox:nRects, oBox:nBoxes
  119.                 // Now access them via the 'class functions'.  Note that the
  120.                 // same values are printed, since they are the same variables.
  121.                 ? 'Do the same use the Box() class function:'
  122.                 ? Box():nRects, Box():nBoxes
  123.                 ? 'And access :nRects via the Rectangle() class function:'
  124.                 ? Rectangle():nRects
  125.             case opt == 12
  126.                 // Use the predefined 'class' message to obtain an object's
  127.                 // 'class object'.  A class object contains any class variables
  128.                 // that a class has.
  129.                 BoxClass := oBox:class
  130.                 ? 'Access class variables via a class object:'
  131.                 ? BoxClass:nBoxes
  132.                 // The class function also returns a class object.  We can
  133.                 // check that these are the same as follows:
  134.                 ? 'Check that class object is same as returned by class function:'
  135.                 ? (BoxClass == Box())
  136.         end
  137.         if opt <> 0
  138.             wait
  139.             cls
  140.             oBox:draw()
  141.         end
  142.     end
  143. return
  144.  
  145.  
  146. /*
  147.     Using Class(y), the scalar types (eg. NUMERIC, DATE etc) accept the
  148.     CLASSNAME and CLASSH messages, as they do in standard Clipper 5.01. In
  149.     all object classes, 'classH' returns a number identifying the class.
  150.     This can be used to test whether two objects belong to the same class,
  151.     for example.  The built in data types all respond to the 'classH'
  152.     message with zero.
  153. */
  154.  
  155. static procedure scalarClasses
  156.     local i
  157.     // set up an array of the simple types: code block, nil, numeric, logical, character, array, date
  158.     local aTypes := { { || qout("wow") }, nil, 2, .t., "wow", array(4), date() }
  159.  
  160.     ? 'Simple (scalar) variable type response to standard messages'
  161.     ?
  162.     ? '    classH  valtype()  className'
  163.     for i := 1 to len(aTypes)
  164.         ? aTypes[i]:classH, '    ', valtype(aTypes[i]), '    ', aTypes[i]:className
  165.     next
  166. return
  167.  
  168.  
  169. /*
  170.     Here we define the Rectangle class
  171. */
  172.  
  173. create class Rectangle
  174.  
  175. export:
  176.     classvar nRects
  177.  
  178.     instvar top, left, bottom, right    readonly
  179.     instvar width, height               readonly
  180.  
  181.     method set
  182.     method test
  183.     method testBlock
  184.  
  185. endclass
  186.  
  187.  
  188. constructor new (nTop, nLeft, nBottom, nRight)
  189.     ::set(nTop, nLeft, nBottom, nRight)
  190. return
  191.  
  192.  
  193. method procedure set(nTop, nLeft, nBottom, nRight)
  194.     ::top    := nTop
  195.     ::left   := nLeft
  196.     ::bottom := nBottom
  197.     ::right  := nRight
  198.  
  199.     ::width  := nBottom - nTop
  200.     ::height := nRight - nLeft
  201. return
  202.  
  203.  
  204. method procedure test
  205.     // print a message to indicate which method is executing
  206.     ? 'Executing Rectangle:test'
  207. return
  208.  
  209.  
  210. /*
  211.     :testBlock
  212.  
  213.     Test the accessing of an instance variable within a code block.
  214. */
  215.  
  216. method procedure testBlock
  217.     local b := { || ::top }
  218.     ? 'Accessing an instance variable within a code block:'
  219.     ? 'self:top =', eval(b)
  220. return
  221.  
  222.  
  223. // eof heritest.prg
  224.