Category : Dbase (Clipper, FoxBase, etc) Languages Source Code
Archive   : NN0505.ZIP
Filename : DSOOPS.PRG

/*********************************************************************
DSOOPS.PRG
This Clipper program-file manages the pseudo-object system
<< Danny Sukdeo (c) 1991 for Danny's Solveware >>

Example of a class definition:
----------------------------------------
CLASS: NewFuelGauge
INSTANCE VAR: Top := 20
INSTANCE VAR: Left := 10
INSTANCE VAR: Title := ""
INSTANCE VAR: ColorBar := "W/N"
INSTANCE VAR: ColorWnd := "N/W"
INSTANCE VAR: SaveBuf := ""
METHOD: CreateFuelGauge()
METHOD: UpdateFuelGauge(nPercent)
METHOD: CloseFuelGauge()
ENDCLASS: NewFuelGauge

Example of the creation of a new object:
----------------------------------------
LOCAL FuelBar := {}

CREATE OBJECT FuelBar FROM NewFuelGauge

Example of message sending:
---------------------------
SEND FuelBar:Title := "Progression" // Define Title
SEND FuelBar:CreateFuelGauge() // Create Fuel Gauge Bar
SEND FuelBar:UpdateFuelGauge(10) // Update Bar
SEND FuelBar:CloseFuelGauge() // Close
FuelBar := NIL // Release class

*********************************************************************/
#include "DsClass.ch"

/*****
CLIP_OOPS()
The pseudo-object system manager
<< Danny Sukdeo (c) 1991 for Danny's Solveware >>

Syntax:
Clip_Oops(,[acObj],[cMsg],[xArg],[xP1...xP13])
Arguments : activates one of these functions:
1 = Create Class
2 = Create Instance Variable
3 = Create Instance Method
4 = Inherit Superclass
5 = End Class Definition
6 = Retrieve Instance Variable
7 = Set Instance Variable
8 = Invoke Method
9 = Create New Object From Class
10 = Retrieve Instance Variable

is depending on ) an object (type array)
or a class (type character)

is depending on an instance variable or a method

is used as arguments in the class definition

are 13 parameters that can be passed with a method.
Why 13 parameters? Because MEMOEDIT() is the only Clipper function
that supports that many parameters. The number of parameters can be
easily increased or decreased.

Returns: Depends on

Description: Clip_Oops() is a function that makes it
possible to create pseudo-objects.

Author: Danny Sukdeo
*****/

FUNCTION Clip_Oops( nAction, acObj, cMsg, xArg, xP1, ;
xP2, xP3, xP4, xP5, xP6, xP7, xP8, xP9, xP10, xP11, ;
xP12, xP13 )

STATIC aClassTable := {}, aMessageTable := {}, cClassName := NIL
STATIC aActiveObject := NIL, aTmpTable := {}
STATIC aObjStack := {}, nObjCounter := 0
LOCAL nScanRet := 0, nTypeInst := 0, nCount1 := 0, xRet := NIL

DO CASE
CASE nAction = OOP_CREATE_CLASS // Create new class
cClassName := UPPER(acObj) // Assign name of class to static

// Check if class already exists...
nScanRet := ASCAN( aClassTable, { |p1| p1 == cClassName } )

IF nScanRet # 0 // Class Already Exists!
OopsError( ERR_CLASS_EXISTS, cClassName )
ELSE
AADD( aClassTable, cClassName )
// Add class to aClassTable
ENDIF

// Create instance variable or create method
CASE nAction = OOP_CREATE_INSTVAR .OR. nAction = OOP_CREATE_METHOD
// Search name of class in aClassTable
nScanRet := ASCAN( aClassTable, { |p1| p1 == cClassName } )

IF nScanRet = 0 // Class Not Found While Creating Message!
OopsError( ERR_CLASS_NOT_FOUND_MSG, "" )
ELSE
// Get type of message to store in aMessageTable[]
nTypeInst = IIF(nAction = OOP_CREATE_INSTVAR, OOP_INSTVAR_TYPE, nTypeInst )
nTypeInst = IIF(nAction = OOP_CREATE_METHOD, OOP_METHOD_TYPE, nTypeInst )

// Add data about messages in temporary table: aTmpTable[]
AADD( aTmpTable, { UPPER(cMsg), nTypeInst, xArg } )
ENDIF

CASE nAction = OOP_INHERIT_CLASS // Inherit contents of a class
// Make upper
acObj := UPPER(acObj)

// Search name of class in aClassTable
nScanRet := ASCAN( aClassTable, { |p1| p1 == acObj } )

IF nScanRet = 0
// Class Not Found While Inheriting Class!
OopsError( ERR_CANNOT_INHERIT, UPPER(acObj) )
ELSE
AEVAL( aMessageTable[nScanRet,1], { |p1, elem| ;
AADD( aTmpTable, ;
{ aMessageTable[nScanRet,1,elem], ;
aMessageTable[nScanRet,2,elem], ;
aMessageTable[nScanRet,3,elem]});
} )
ENDIF

CASE nAction = OOP_END_CLASS
// How many instance variables & methods are defined?
nCount1 := LEN(aTmpTable)

// Make some space for this new class
AADD( aMessageTable, { ARRAY(nCount1), ARRAY(nCount1), ARRAY(nCount1) } )

// How many classes are already defined?
nCount1 := LEN(aMessageTable)

// Copy contents of temporary table to message table
AEVAL( aTmpTable, { |p1, elem| ;
aMessageTable[nCount1,1,elem] := aTmpTable[elem,1], ;
aMessageTable[nCount1,2,elem] := aTmpTable[elem,2], ;
aMessageTable[nCount1,3,elem] := aTmpTable[elem,3] } )
aTmpTable := {} // reset temporary table
cClassName := NIL // reset classname variable

CASE nAction = OOP_GET_INSTVAR
// Search for instance- or methodname
nCount1 := ASCAN( acObj[1], UPPER(cMsg) )
IF nCount1 = 0 // Instance Not Found!
OopsError( ERR_INSTANCE_NOT_FOUND, UPPER(cMsg) )
ELSE
IF acObj[2,nCount1] # OOP_INSTVAR_TYPE
// Not An Instance!
OopsError( ERR_NOT_AN_INSTANCE, UPPER(cMsg) )
ELSE
xRet := acObj[3,nCount1]
ENDIF
ENDIF

CASE nAction = OOP_SET_INSTVAR
// Search for instance- or methodname
nCount1 := ASCAN( acObj[1], UPPER(cMsg) )
IF nCount1 = 0 // Instance Not Found!
OopsError( ERR_INSTANCE_NOT_FOUND, UPPER(cMsg) )
ELSE
IF acObj[2,nCount1] # OOP_INSTVAR_TYPE
// Not An Assignable Instance!
OopsError(ERR_NOT_ASSIGNABLE,UPPER(cMsg) )
ELSE
acObj[3,nCount1] := xArg
ENDIF
ENDIF

CASE nAction = OOP_DO_METHOD
// Search for instance- or methodname
nCount1 := ASCAN( acObj[1], UPPER(cMsg) )
IF nCount1 = 0 // Instance Not Found!
OopsError( ERR_INSTANCE_NOT_FOUND, UPPER(cMsg) )
ELSE
IF acObj[2,nCount1] # OOP_METHOD_TYPE // Not A Method!
OopsError( ERR_NOT_A_METHOD, UPPER(cMsg) )
ELSE
// Push active object on stack to allow nested
// objects being called
AADD( aObjStack, acObj )
nObjCounter++
aActiveObject := acObj // point to active object
xRet := EVAL(acObj[3,nCount1], xP1, xP2, xP3, ;
xP4, xP5, xP6, xP7, xP8, xP9, xP10, xP11, xP12, xP13 )
// Pop previous called object from stack
nObjCounter--
ASIZE( aObjStack, nObjCounter )
ENDIF
ENDIF

CASE nAction = OOP_ACTIVE_OBJECT
IF nObjCounter = 0 // No Object Active!
OopsError( ERR_NO_ACTIVE_OBJECT, "" )
ELSE
xRet := aObjStack[nObjCounter]
ENDIF // return array of active object

CASE nAction = OOP_CREATE_NEW_OBJECT
// Make upper
acObj := UPPER(acObj)
// Search name of class in aClassTable
nScanRet := ASCAN( aClassTable, { |p1| p1 == acObj } )

IF nScanRet = 0
// Class Not Found While Creating New Object!
OopsError( ERR_CLASS_NOT_FOUND_OBJECT, UPPER(acObj) )
ELSE
xRet := ACLONE(aMessageTable[nScanRet])
// Make a clone of messagetable
ENDIF
ENDCASE
RETURN(xRet)

//::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
// OopsError( , )
//::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
FUNCTION OopsError( nErrNum, cErrName )
LOCAL aErrorTable
aErrorTable := { ;
"Class Already Exists!", ;
"Class Not Found While Creating Message!", ;
"Instance Not Found!", ;
"Not An Instance!", ;
"Not An Assignable Instance!", ;
"Not A Method!", ;
"No Object Active!", ;
"Class Not Found While Inheriting Class!", ;
"Class Not Found While Creating New Object!";
}

@ 00,00 SAY "OOP ERROR: " + aErrorTable[nErrNum] + ;
IIF(!EMPTY(cErrName)," -> " + cErrName,"")
aErrorTable := "*"

// Create a run-time error to trace actual error
RETURN NIL

// EOF: Dsoops.prg