├── readme.md ├── envlib ├── envlib.prg ├── README.md └── True.h └── utility ├── lightweights.prg ├── url.prg └── utils.prg /readme.md: -------------------------------------------------------------------------------- 1 | # VFP 2 | Visual FoxPro utilities, classes, and functions. 3 | -------------------------------------------------------------------------------- /envlib/envlib.prg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/StevenBlack/VFP/HEAD/envlib/envlib.prg -------------------------------------------------------------------------------- /envlib/README.md: -------------------------------------------------------------------------------- 1 | EnvLib is a code class library produced by the late great Tom Rettig. 2 | 3 | This class library contains a collection of objects that you can use (and aggregate) to save and restore your environment. The classes restore their settings when they go out of scope. -------------------------------------------------------------------------------- /utility/lightweights.prg: -------------------------------------------------------------------------------- 1 | *===================================================== 2 | DEFINE CLASS LightWeight AS RELATION OLEPUBLIC 3 | *===================================================== 4 | * Our base lightweight class. 5 | 6 | * These intrinsic properties are semantics of Relation 7 | * classes, which we are not interested in. 8 | Name= "Lightweight" 9 | PROTECTED ADDPROPERTY 10 | PROTECTED CHILDALIAS 11 | PROTECTED CHILDORDER 12 | PROTECTED ERROR 13 | PROTECTED ONETOMANY 14 | PROTECTED PARENTALIAS 15 | PROTECTED RELATIONALEXPR 16 | PROTECTED PARENT 17 | PROTECTED PARENTCLASS 18 | PROTECTED CLASSLIBRARY 19 | PROTECTED CLASS 20 | PROTECTED COMMENT 21 | PROTECTED TAG 22 | PROTECTED BASECLASS 23 | 24 | PROTECTED FUNCTION INIT 25 | PROTECTED FUNCTION DESTROY 26 | PROTECTED FUNCTION READMETHOD 27 | PROTECTED FUNCTION RESETTODEFAULT 28 | PROTECTED FUNCTION WRITEMETHOD 29 | PROTECTED FUNCTION READEXPRESSION 30 | PROTECTED FUNCTION WRITEEXPRESSION 31 | 32 | FUNCTION Release() 33 | This.GarbageCollect() 34 | RELEASE THIS 35 | 36 | PROTECTED FUNCTION GarbageCollect() 37 | RETURN 38 | 39 | ENDDEFINE 40 | 41 | 42 | *====================================================================== 43 | DEFINE CLASS cusLightWeight AS custom 44 | *====================================================================== 45 | * Lightweight based on the Custom base class 46 | * 47 | HIDDEN addobject 48 | HIDDEN cloneobject 49 | HIDDEN controlcount 50 | HIDDEN controls 51 | HIDDEN helpcontextid 52 | HIDDEN newobject 53 | HIDDEN objects 54 | HIDDEN parentclass 55 | HIDDEN picture 56 | HIDDEN readexpression 57 | HIDDEN readmethod 58 | HIDDEN removeobject 59 | HIDDEN resettodefault 60 | HIDDEN saveasclass 61 | HIDDEN showwhatsthis 62 | HIDDEN whatsthishelpid 63 | HIDDEN writeexpression 64 | HIDDEN writemethod 65 | 66 | FUNCTION RELEASE() 67 | RELEASE This 68 | RETURN 69 | ENDDEFINE 70 | 71 | 72 | -------------------------------------------------------------------------------- /utility/url.prg: -------------------------------------------------------------------------------- 1 | * 2 | * url.prg 1.0 3 | * 4 | * Copyright (c) 2010 (http://stevenblack/com) 5 | * Dual licensed under the MIT (MIT-LICENSE.txt) 6 | * and GPL (GPL-LICENSE.txt) licenses. 7 | * 8 | * URL manager class for Visual FoxPro 9 | * 10 | 11 | 12 | *======================================================================= 13 | * Test code for this class 14 | * To test, in the VFP command window, "DO url" 15 | *======================================================================= 16 | CLEAR 17 | LOCAL x 18 | x=CREATEOBJECT( "url", "http://foo.com/virtual/bar.xyz?x=1&y=2&z=3" ) 19 | ?x.getURL() 20 | x.AddElement( "test", "1" ) 21 | ?x.getURL() 22 | x.AddElement( "y", "4" ) 23 | ?x.getURL() 24 | ?"nelements=", x.nElements 25 | ?"First element=", x.getValue( 1 ) 26 | ?"y=", x.getvalue( "y" ) 27 | ? "====================" 28 | LOCAL lni 29 | FOR lni= 1 TO x.nElements 30 | ?x.getAttribute( lni ), "=", x.getValue( lni ) 31 | ENDFOR 32 | ? "====================" 33 | x.Coalesce( "http://zzz.org?x=Override&z=55&new=great" ) 34 | ?x.getURL() 35 | ? "====================" 36 | x.RemoveElement( 1 ) 37 | x.RemoveElement( "z" ) 38 | ?x.getURL() 39 | *======================================================================= 40 | 41 | ***************************************************** 42 | DEFINE CLASS URL AS Custom 43 | ***************************************************** 44 | DIMENSION aElements[ 1, 2 ] 45 | cBase = "" 46 | cElements = "" 47 | cElementDelimiter = CHR( 38 ) 48 | cBaseDelimiter = "?" 49 | nElements = 0 50 | 51 | *===================================== 52 | * URL:: 53 | FUNCTION INIT( tcURL ) 54 | *===================================== 55 | tcURL= EVL( NVL(tcURL,""), "") 56 | aElements = "" 57 | This.LoadURL( tcURL ) 58 | RETURN 59 | 60 | *===================================== 61 | * URL:: 62 | FUNCTION LoadURL( tcURL ) 63 | *===================================== 64 | IF !EMPTY( tcURL ) 65 | LOCAL lcBaseDelimiter 66 | lcBaseDelimiter = This.cBaseDelimiter 67 | This.cBase = GETWORDNUM( tcURL, 1, lcBaseDelimiter ) 68 | This.cElements = GETWORDNUM( tcURL, 2, lcBaseDelimiter ) 69 | ENDIF 70 | RETURN 71 | 72 | *===================================== 73 | * URL:: 74 | FUNCTION GetURL() 75 | *===================================== 76 | LOCAL lcRetVal, lni 77 | lcRetVal = This.cBase+ This.cBaseDelimiter 78 | FOR lni = 1 TO ALEN( This.aElements, 1 ) 79 | IF !EMPTY( This.aElements[ lni, 2 ] ) 80 | IF lni>1 81 | lcRetVal = lcRetVal+ This.cElementDelimiter 82 | ENDIF 83 | lcRetVal = lcRetVal+ TRANSFORM( This.aElements[ lni, 1 ] )+ "="+ TRANSFORM( This.aElements[ lni, 2 ] ) 84 | ELSE 85 | lcRetVal = lcRetVal+ TRANSFORM( EVL( This.aElements[ lni, 1 ], "" ) ) 86 | ENDIF 87 | ENDFOR 88 | IF lcRetVal = This.cBaseDelimiter 89 | lcRetVal = "" 90 | ENDIF 91 | IF RIGHT( lcRetVal, LEN( This.cBaseDelimiter )) = This.cBaseDelimiter 92 | lcRetVal= SUBSTR(lcRetVal, 1, LEN( lcRetVal ) - LEN( This.cBaseDelimiter )) 93 | ENDIF 94 | RETURN lcRetVal 95 | 96 | *===================================== 97 | * URL:: 98 | FUNCTION AddElement( tcAttrib, tcValue ) 99 | *===================================== 100 | LOCAL lnIndex 101 | lnIndex = ASCAN( This.aElements, tcAttrib, 1, ALEN( This.aElements, 1 ), 1, 15 ) 102 | IF lnIndex = 0 103 | lnIndex = IIF( EMPTY( This.aElements[ 1,1 ] ), 1, ALEN( This.aElements,1 )+1 ) 104 | DIMENSION This.aElements[ lnIndex, 2 ] 105 | ENDIF 106 | This.aElements[ lnIndex, 1 ] = tcAttrib 107 | This.aElements[ lnIndex, 2 ] = tcValue 108 | RETURN 109 | 110 | *===================================== 111 | * URL:: 112 | FUNCTION GetAttribute( tnPassed ) 113 | *===================================== 114 | LOCAL lcRetVal, lnIndex 115 | lcRetVal = "" 116 | DO CASE 117 | CASE VARTYPE( tnPassed ) $ "NI" 118 | IF tnPassed <= ALEN( This.aElements, 1 ) 119 | lcRetVal = This.aElements[ tnPassed, 1 ] 120 | ENDIF 121 | OTHERWISE 122 | * Bogus 123 | ENDCASE 124 | RETURN lcRetVal 125 | 126 | *===================================== 127 | * URL:: 128 | FUNCTION GetValue( tuPassed ) 129 | *===================================== 130 | LOCAL lcRetVal, lnIndex 131 | lcRetVal = "" 132 | DO CASE 133 | CASE VARTYPE( tuPassed ) $ "NI" 134 | IF tuPassed <= ALEN( This.aElements, 1 ) 135 | lcRetVal = This.aElements[ tuPassed, 2 ] 136 | ENDIF 137 | CASE VARTYPE( tuPassed ) = "C" 138 | lnIndex = ASCAN( This.aElements, tuPassed, 1, ALEN( This.aElements, 1 ), 1, 15 ) 139 | IF lnIndex>0 140 | lcRetVal = This.aElements[ lnIndex, 2 ] 141 | ENDIF 142 | OTHERWISE 143 | * Bogus 144 | ENDCASE 145 | RETURN lcRetVal 146 | 147 | *===================================== 148 | * URL:: 149 | FUNCTION RemoveElement( tuPassed ) 150 | *===================================== 151 | LOCAL lcRetVal, lnIndex 152 | lcRetVal = "" 153 | DO CASE 154 | CASE VARTYPE( tuPassed ) $ "NI" 155 | IF tuPassed <= ALEN( This.aElements, 1 ) 156 | This.aElements[ tuPassed, 2 ] = "" 157 | ENDIF 158 | CASE VARTYPE( tuPassed ) = "C" 159 | lnIndex = ASCAN( This.aElements, tuPassed, 1, ALEN( This.aElements, 1 ), 1, 15 ) 160 | IF lnIndex>1 161 | * This.aElements[ lnIndex, 2 ] = "" 162 | ADEL( This.aElements, lnIndex ) 163 | DIMENSION This.aElements[ MAX( ALEN( This.aElements, 1 )-1, 1 ), 2 ] 164 | ENDIF 165 | OTHERWISE 166 | * Bogus 167 | ENDCASE 168 | RETURN 169 | 170 | *===================================== 171 | * URL:: 172 | FUNCTION Coalesce( tcURL ) 173 | *===================================== 174 | LOCAL loURL, lni 175 | loURL = CREATEOBJECT( This.Class, tcURL ) 176 | FOR lni = 1 TO loURL.nElements 177 | This.AddElement( loURL.GetAttribute( lni ), loURL.GetValue( lni ) ) 178 | ENDFOR 179 | loURL = .NULL. 180 | RETURN 181 | 182 | *===================================== 183 | * URL:: 184 | FUNCTION cElements_Assign( tcElements ) 185 | *===================================== 186 | LOCAL lcBaseDelimiter, lcElementDelimiter 187 | lcBaseDelimiter = This.cBaseDelimiter 188 | lcElementDelimiter = This.cElementDelimiter 189 | 190 | IF This.cBaseDelimiter $ tcElements 191 | This.cElements = LOWER( GETWORDNUM( tcElements, 2, lcBaseDelimiter ) ) 192 | ELSE 193 | This.cElements = LOWER( tcElements ) 194 | ENDIF 195 | LOCAL lni, lc2PartElement 196 | FOR lni = 1 TO GETWORDCOUNT( tcElements, lcElementDelimiter ) ) 197 | lc2PartElement = GETWORDNUM( tcElements, lni, lcElementDelimiter ) 198 | THIS.AddElement( GETWORDNUM( lc2PartElement,1,"=" ), GETWORDNUM( lc2PartElement,2,"=" ) ) 199 | ENDFOR 200 | RETURN 201 | 202 | *===================================== 203 | * URL:: 204 | FUNCTION cbase_Assign( tcbase ) 205 | *===================================== 206 | IF This.cBaseDelimiter $ tcBase 207 | This.cBase = LOWER( GETWORDNUM( tcBase, 1, cBaseDelimiter ) ) 208 | ELSE 209 | This.cBase = LOWER( tcBase ) 210 | ENDIF 211 | RETURN 212 | 213 | *===================================== 214 | * URL:: 215 | FUNCTION nElements_Access 216 | *===================================== 217 | RETURN IIF( EMPTY( This.aElements[ 1,1 ] ), 0, ALEN( This.aElements,1 ) ) 218 | 219 | 220 | ENDDEFINE 221 | 222 | -------------------------------------------------------------------------------- /envlib/True.h: -------------------------------------------------------------------------------- 1 | * Program: True.h (Named Constant File) 2 | * Notice: The author releases all rights to the public domain 3 | * : subject to the Warranty Disclaimer in the programs 4 | * : and documentation. 5 | * Author: Tom Rettig 6 | * Version: TRUE Version 1.0 July 15, 1995 (#defined in True.h) 7 | * Created: December 10, 1994 (Beta 1) 8 | * Update: January 7, 1995 (Beta 1b) 9 | * Update: April 7, 1995 (Beta 2b) 10 | * Update: June 6, 1995 (Release Candidate 2a) 11 | * Update: July 15, 1995 (First Release) 12 | 13 | ************************************************************* 14 | * Visual FoxPro Specific 15 | ************************************************************* 16 | 17 | * Include VFP's constant file. 18 | #INCLUDE "FoxPro.h" 19 | 20 | * VFP AERROR() array dimensions. 21 | #DEFINE cnVF_AERR_MAX 7 22 | #DEFINE cnVF_AERR_NUMBER 1 23 | #DEFINE cnVF_AERR_MESSAGE 2 24 | #DEFINE cnVF_AERR_OBJECT 3 25 | #DEFINE cnVF_AERR_WORKAREA 4 26 | #DEFINE cnVF_AERR_TRIGGER 5 27 | #DEFINE cnVF_AERR_EXTRA1 6 28 | #DEFINE cnVF_AERR_EXTRA2 7 29 | 30 | * VFP ERRORs used. 31 | #DEFINE cnVF_ERR_FILE_NOTEXIST 1 32 | * File does not exist. 33 | #DEFINE cnVF_ERR_PARAM_INVALID 11 34 | * Function argument value, type, or count is invalid. 35 | #DEFINE cnVF_ERR_TABLE_NUMINVALID 17 36 | * Table number is invalid. 37 | #DEFINE cnVF_ERR_FIELD_NOTFOUND 47 38 | * No fields found to process. 39 | #DEFINE cnVF_ERR_TABLE_NOTOPEN 52 40 | * No table is open. 41 | #DEFINE cnVF_ERR_DISK_SPACE 56 42 | * Not enough disk space for . 43 | #DEFINE cnVF_ERR_EXCLUSIVE 110 44 | * File must be opened exclusively. 45 | #DEFINE cnVF_ERR_ARRAYDIM 230 46 | * Array dimensions are invalid. 47 | #DEFINE cnVF_ERR_SETARGINVALID 231 48 | * Invalid argument used with the SET function. 49 | #DEFINE cnVF_ERR_NOTARRAY 232 50 | * "" is not an array. 51 | #DEFINE cnVF_ERR_PARAM_TOOFEW 1229 52 | * Too few arguments. 53 | #DEFINE cnVF_ERR_PARAM_TOOMANY 1230 54 | * Too many arguments. 55 | #DEFINE cnVF_ERR_DB_NOTOPEN 1520 56 | * No database is open or set as the current database. 57 | #DEFINE cnVF_ERR_DB_NOTDB 1552 58 | * File is not a database. 59 | #DEFINE cnVF_ERR_PROP_INVALID 1560 60 | * Property value is invalid. 61 | #DEFINE cnVF_ERR_DB_OBJNOTFOUND 1562 62 | * Cannot find object in the database. 63 | #DEFINE cnVF_ERR_NAME_ISUSED 1569 64 | * The name you have chosen is already used for a 65 | * built in . Please choose a different name. 66 | #DEFINE cnVF_ERR_OBJ_NAME 1575 67 | * Object name is invalid. 68 | #DEFINE cnVF_ERR_PROP_DATATYPE 1732 69 | * Data type is invalid for this property. 70 | #DEFINE cnVF_ERR_PROP_NOTFOUND 1734 71 | * Property is not found. 72 | #DEFINE cnVF_ERR_PROP_READONLY 1743 73 | * Property is read-only. 74 | #DEFINE cnVF_ERR_PROP_PROTECTED 1757 75 | * Property is protected. 76 | #DEFINE cnVF_ERR_OBJ_TYPE 1773 77 | * Database object type is invalid. 78 | #DEFINE cnVF_ERR_STR_TOOLONG 1903 79 | * String is too long to fit. 80 | #DEFINE cnVF_ERR_FILE_NOTCLOSED 1933 81 | * File '' is not closed. 82 | #DEFINE cnVF_ERR_FUNC_NOTIMP 1999 83 | * Function is not implemented. 84 | 85 | * VFP limits. 86 | #DEFINE cnVF_FIELD_MAXCOUNT 255 87 | #DEFINE cnVF_FIELD_MAXNAMELEN 10 88 | #DEFINE cnVF_INDEX_MAXKEYLEN 240 89 | #DEFINE cnVF_NUM_MAXPRECISION 16 90 | 91 | * VFP SYS() functions used. 92 | #DEFINE cnVF_SYS_EXEDIR 2004 93 | #DEFINE cnVF_SYS_LOCKSTATUS 2011 94 | #DEFINE cnVF_SYS_RELATIVEPATH 2014 95 | #DEFINE cnVF_SYS_UNIQUEID 2015 96 | #DEFINE cnVF_SYS_CROSSPATH 2027 97 | 98 | ************************************************************* 99 | * TRUE General 100 | ************************************************************* 101 | #DEFINE ccCRLF CHR(13)+CHR(10) 102 | #DEFINE ccTAB CHR( 9) 103 | 104 | ************************************************************* 105 | * EDC Specific 106 | ************************************************************* 107 | #DEFINE ccEDC_VERSION "EDC Version 1.0 July 15, 1995" 108 | 109 | * Control codes. 110 | #DEFINE ccMSG_INSERT1 "" 111 | #DEFINE ccMSG_INSERT2 "" 112 | #DEFINE ccMSG_INSERT3 "" 113 | #DEFINE cnPROP_REMOVE -1 114 | #DEFINE ccWILDCARD "*" 115 | 116 | * Reserved keywords and names. 117 | * Mostly used in method parameters and messages. 118 | #DEFINE ccALL "ALL" 119 | #DEFINE ccCANDIDATE "CANDIDATE" 120 | #DEFINE ccCOPY "COPY" 121 | #DEFINE ccMEMO "MEMO" 122 | #DEFINE ccPACK "PACK" 123 | #DEFINE ccPRIMARY "PRIMARY" 124 | #DEFINE ccREFRESH "REFRESH" 125 | #DEFINE ccREGULAR "REGULAR" 126 | 127 | * EdcLib classes used by DEFINE CLASS. 128 | #DEFINE cxCLASS_EDC EDC 129 | #DEFINE ccCLASS_EDC "EDC" && for PrgToVcx 130 | #DEFINE cxCLASS_MSG Message 131 | #DEFINE ccCLASS_MSG "Message" && for PrgToVcx 132 | 133 | * EDC file structures. 134 | #DEFINE cxANALYZE_FIELD Analyze 135 | #DEFINE cnEDC_FIXEDFIELDS 2 && the rest are extensions 136 | #DEFINE cxEDC_ID cUniqueID 137 | #DEFINE ccEDC_ID "cUniqueID" 138 | #DEFINE cxEDC_OBJ mEdcObject 139 | #DEFINE ccEDC_OBJ "mEdcObject" 140 | 141 | * EDC system objects. 142 | * Unique rows store actual name in cxEDC_ID field instead of SYS(2015). 143 | #DEFINE ccEDC_OBJ_UNIQUETYPE "EdcUnique " 144 | ** Unique type rows are limited to size of EDC_ID field (10), 145 | ** must be PROPER() case and defined to length. 146 | #DEFINE ccEDC_OBJ_REGISTRY "Registry " 147 | 148 | * Wildcard access to property maps. 149 | #DEFINE ccEDC_MAPALL THIS.cMapName + "*" 150 | 151 | * EDC built-in registry properties. 152 | #DEFINE cnEDC_REG_DEFAULT 13 && number of default registry properties 153 | #DEFINE ccEDC_REG_ALTERNATE "cEdcAlternate" && alternate EDC file 154 | #DEFINE ccEDC_REG_CREATE "tEdcCreate" && creation DateTime 155 | #DEFINE ccEDC_REG_DBC "cDBC" && relative path back link 156 | #DEFINE ccEDC_REG_REMOVELOCK "lRemoveLock" && prevent field removal 157 | #DEFINE ccEDC_REG_VERSION "cEdcVersion" 158 | #DEFINE ccEDC_REG_EXTENSIONNAME "cEdcExtensionName" 159 | #DEFINE ccEDC_REG_VENDORNAME "cEdcVendorName" 160 | #DEFINE ccEDC_REG_METHODOPEN "cMethodOpen" && methods are 161 | #DEFINE ccEDC_REG_METHODGET "cMethodGet" && named for 162 | #DEFINE ccEDC_REG_METHODSET "cMethodSet" && wildcard 163 | #DEFINE ccEDC_REG_METHODLIB "cMethodLib" && access 164 | #DEFINE ccEDC_REG_METHODCLASS "cMethodClass" 165 | #DEFINE ccEDC_REG_METHODINIT "cMethodInit" && pass to AddObject() 166 | ** Wildcard access to registry methods. 167 | #DEFINE ccEDC_REG_METHODALL "cMethod*" && methods and 168 | ** Using string for list instead of INLIST() type list 169 | ** because these must be checked as case insensitive. 170 | #DEFINE ccEDC_REG_LISTDBF ccEDC_REG_ALTERNATE+","+ccEDC_REG_DBC 171 | #DEFINE ccEDC_REG_LISTVCX ccEDC_REG_METHODLIB 172 | #DEFINE ccEDC_REG_LISTFILES ccEDC_REG_LISTDBF+","+ccEDC_REG_LISTVCX 173 | #DEFINE ccEDC_REG_LISTTYPEC ccEDC_REG_LISTFILES+","+; 174 | ccEDC_REG_VERSION+","+ccEDC_REG_METHODGET+","+ccEDC_REG_METHODSET+","+; 175 | ccEDC_REG_METHODOPEN+","+ccEDC_REG_METHODALL 176 | #DEFINE ccEDC_REG_LISTTYPEL ccEDC_REG_REMOVELOCK 177 | #DEFINE ccEDC_REG_LISTTYPET ccEDC_REG_CREATE 178 | #DEFINE ccEDC_REG_LISTALL ccEDC_REG_LISTTYPEC+","+; 179 | ccEDC_REG_LISTTYPEL+","+ccEDC_REG_LISTTYPET 180 | ** Method argument substitution strings. Case insensitive. 181 | #DEFINE ccARG_DBC "" 182 | #DEFINE ccARG_DBCID "" 183 | #DEFINE ccARG_EDC "" 184 | #DEFINE ccARG_OBJTYPE "" 185 | #DEFINE ccARG_OBJNAME "" 186 | #DEFINE ccARG_PROPNAME "" 187 | #DEFINE ccARG_PROPVALUE "" 188 | #DEFINE ccARG_REGISTRY "" 189 | 190 | * Extended property header. 191 | #DEFINE ccHEAD_OFF "." 192 | #DEFINE ccHEAD_ON "+" 193 | #DEFINE cnHEAD_SIZE 36 194 | #DEFINE cnHEAD_TYPE 1 && system use only 195 | #DEFINE cnHEAD_NULL 2 && system use only 196 | #DEFINE cnHEAD_READLOCK 3 && user access 3..14 197 | #DEFINE cnHEAD_WRITELOCK 4 && overrides cnHEAD_UPDATE 198 | #DEFINE cnHEAD_REMOVELOCK 5 199 | #DEFINE cnHEAD_UPDATE 6 200 | #DEFINE cnHEAD_RESERVED4 7 201 | #DEFINE cnHEAD_RESERVED3 8 202 | #DEFINE cnHEAD_RESERVED2 9 203 | #DEFINE cnHEAD_RESERVED1 10 204 | #DEFINE cnHEAD_USER4 11 205 | #DEFINE cnHEAD_USER3 12 206 | #DEFINE cnHEAD_USER2 13 207 | #DEFINE cnHEAD_USER1 14 208 | #DEFINE cnHEAD_SWITCHSIZE 14 209 | #DEFINE cnHEAD_TIMESIZE 22 && max size with century and 12-hour 210 | ** Bytes 15..36 are used for PADR(TTOC(DATETIME()), cnHEAD_TIMESIZE) 211 | 212 | * Alternate EDC update property array dimensions. 213 | * Rows are dynamic. 214 | #DEFINE cnALT_COLUMNS 2 215 | #DEFINE cnALT_FIELD 1 216 | #DEFINE cnALT_ALIAS 2 217 | 218 | * Object method update property array dimensions. 219 | * Rows are dynamic. 220 | #DEFINE cnOBJ_COLUMNS 5 221 | #DEFINE cnOBJ_OWNER 1 222 | #DEFINE cnOBJ_OBJECT 2 223 | #DEFINE cnOBJ_GETMETHOD 3 224 | #DEFINE cnOBJ_SETMETHOD 4 225 | #DEFINE cnOBJ_RELEASE 5 && name of class library to release 226 | 227 | * Extended aObjectError[] array dimensions. 228 | #DEFINE cnAERR_MAX cnVF_AERR_MAX + 3 229 | #DEFINE cnAERR_METHOD cnVF_AERR_MAX + 1 230 | #DEFINE cnAERR_LINE cnVF_AERR_MAX + 2 231 | #DEFINE cnAERR_SOURCE cnVF_AERR_MAX + 3 232 | 233 | * VFP DBC object types to length of ObjectType field. Case sensitive. 234 | #DEFINE cnVF_OBJ_TYPESIZE 10 235 | #DEFINE ccVF_OBJ_CONNECTION "Connection" 236 | #DEFINE ccVF_OBJ_DATABASE "Database " 237 | #DEFINE ccVF_OBJ_FIELD "Field " 238 | #DEFINE ccVF_OBJ_INDEX "Index " 239 | #DEFINE ccVF_OBJ_RELATION "Relation " 240 | #DEFINE ccVF_OBJ_TABLE "Table " 241 | #DEFINE ccVF_OBJ_VIEW "View " 242 | #DEFINE cxVF_OBJ_LISTALL ccVF_OBJ_CONNECTION,; 243 | ccVF_OBJ_DATABASE,; 244 | ccVF_OBJ_FIELD,; 245 | ccVF_OBJ_INDEX,; 246 | ccVF_OBJ_RELATION,; 247 | ccVF_OBJ_TABLE,; 248 | ccVF_OBJ_VIEW 249 | 250 | * Known VFP DBC property types. 251 | #DEFINE ccVF_IND_TAGTYPE CHR(17) 252 | #DEFINE ccVF_OBJ_SUBTYPE CHR( 2) && local table, local view, etc. 253 | #DEFINE ccVF_REL_TAG CHR(13) 254 | #DEFINE ccVF_REL_FKTABLE CHR(18) 255 | #DEFINE ccVF_REL_FKTAG CHR(19) 256 | #DEFINE ccVF_TAB_FILEPATH CHR( 1) 257 | #DEFINE ccVF_TAB_PRIMARYTAG CHR(20) 258 | #DEFINE ccVF_VIE_COMMAND CHR(42) 259 | 260 | * Known VFP DBC property values. 261 | #DEFINE ccVF_IND_REGULAR CHR( 0) 262 | #DEFINE ccVF_IND_CANDIDATE CHR( 1) 263 | #DEFINE ccVF_OBJ_LOCALTABLE CHR( 1) 264 | #DEFINE ccVF_OBJ_LOCALVIEW CHR( 6) 265 | 266 | * VFP ADBOBJECTS("RELATION") array columns. 267 | #DEFINE cnVF_REL_MAXCOLS 5 268 | #DEFINE cnVF_REL_PARENTTABLE 1 269 | #DEFINE cnVF_REL_CHILDTABLE 2 270 | #DEFINE cnVF_REL_PARENTTAG 3 271 | #DEFINE cnVF_REL_CHILDTAG 4 272 | #DEFINE cnVF_REL_RIINFO 5 273 | 274 | 275 | ************************************************************* 276 | * ENV Specific 277 | ************************************************************* 278 | #DEFINE ccENV_VERSION "ENV Version 1.0 July 15, 1995" 279 | 280 | #DEFINE ccSET_ONE "1" 281 | #DEFINE ccSET_TWO "2" 282 | #DEFINE ccSET_BOTH "3" 283 | 284 | 285 | ************************************************************* 286 | * PTOV Specific 287 | ************************************************************* 288 | #DEFINE ccPTOV_VERSION "PrgToVcx Version 1.0 July 15, 1995" 289 | 290 | #DEFINE ccCRLF_DEF "CHR(13)+CHR(10)" 291 | #DEFINE ccVISUAL_DESCRIPTION "*>*" 292 | #DEFINE ccVISUAL_DELIMITER "," 293 | #DEFINE cnCUSTOM_HEIGHT 17 && pixels 294 | #DEFINE cnCUSTOM_WIDTH 100 && pixels 295 | 296 | *** TRUE.h ************************************************** 297 | -------------------------------------------------------------------------------- /utility/utils.prg: -------------------------------------------------------------------------------- 1 | ************************************************************************ 2 | FUNCTION Shellexec(tcFile) 3 | ************************************************************************ 4 | oShellExecute = NEWOBJECT("_shellexecute", HOME()+"FFC\_environ.vcx") 5 | oShellExecute.ShellExecute(FULLPATH(tcFile)) 6 | RETURN 7 | 8 | ************************************************************************ 9 | FUNCTION GetProperty( tcProperty, tcPropertyText) 10 | ************************************************************************ 11 | * Returns a property form a properties memo 12 | LOCAL lcRetVal, lnAtPos, lcLine 13 | lcRetVal = "" 14 | DO WHILE " ="$ tcPropertyText 15 | tcPropertyText = STRTRAN( tcPropertyText, " =", "=") 16 | ENDDO 17 | DO CASE 18 | CASE EMPTY(tcProperty) OR EMPTY(tcPropertyText) 19 | *-- Do nothing 20 | 21 | OTHERWISE 22 | lnAtPos = ATC(tcProperty + "=", tcPropertyText) 23 | IF lnAtPos > 0 24 | lcLine = MLINE(tcPropertyText, 1, lnAtPos) 25 | lcRetVal = ALLTRIM(SUBS( lcLine, AT("=", lcLine)+1)) 26 | ENDIF 27 | ENDCASE 28 | RETURN lcRetVal 29 | 30 | ************************************************************************ 31 | FUNCTION Cell( tcContents, tcAttributes) 32 | ************************************************************************ 33 | * Format a cell for display 34 | LOCAL lcRetVal, lcCell, lcAttributes 35 | IF EMPTY(tcAttributes) 36 | lcAttributes = "" 37 | ELSE 38 | lcAttributes = " " + ALLTRIM(tcAttributes) 39 | ENDIF 40 | lcRetVal =[] 41 | lcCell = ALLTRIM(TEXTMERGE(tcContents, .t., "{{","}}")) 42 | IF EMPTY(lcCell) 43 | lcCell = CHR(38) + "nbsp" + CHR(59) 44 | ENDIF 45 | lcRetVal = lcRetVal + lcCell + [] 46 | RETURN lcRetVal 47 | 48 | * --------------------------------------------------------- * 49 | FUNCTION GIFSize( pcFileName, pnWidth, pnHeight ) 50 | * 51 | * Returns the size WxH of a GIF file. 52 | * 53 | * by Thomas Gehrke 54 | * 55 | * EXAMPLE 1: 56 | * 57 | * ? GIFSize( 'C:\IMAGES\Test.GIF') 58 | * 59 | * Returns: '320x200' 60 | * 61 | * Pass optional numeric 2nd and 3rd parameters BY REFERENCE 62 | * to receive separate values into variables. 63 | * 64 | * EXAMPLE 2: 65 | * 66 | * LOCAL lnWidth, lnHeight 67 | * STORE 0 TO lnWidth, lnHeight 68 | * = GIFSize( 'C:\IMAGES\Test.GIF', @lnWidth, @lnHeight) 69 | * 70 | IF EMPTY( m.pcFileName) 71 | pcFileName = GETFILE( 'GIF', 'Select GIF File:', 'Get Size') 72 | ENDIF 73 | 74 | IF EMPTY( m.pcFileName) 75 | RETURN '' 76 | ENDIF 77 | 78 | PRIVATE lnHandle, lcRetStr 79 | lnHandle = FOPEN( m.pcFileName) 80 | lcRetStr = '' 81 | 82 | IF m.lnHandle > -1 83 | 84 | PRIVATE lnFileSize, lnCounter, lcBytes 85 | lnFileSize = FSEEK( m.lnHandle, 0, 2) 86 | lnCounter = 0 87 | 88 | IF m.lnFileSize >= 10 89 | = FSEEK( m.lnHandle, 0, 0) 90 | 91 | * Read the 1st 10 bytes: 92 | lcBytes = FREAD( m.lnHandle, 10) 93 | 94 | = FCLOSE( m.lnHandle) 95 | 96 | pnWidth = ASC( SUBSTR( m.lcBytes, 8, 1)) * 256 + ; 97 | ASC( SUBSTR( m.lcBytes, 7, 1)) 98 | 99 | pnHeight = ASC( SUBSTR( m.lcBytes, 10, 1)) * 256 + ; 100 | ASC( SUBSTR( m.lcBytes, 9, 1)) 101 | 102 | lcRetStr = LTRIM( STR( m.pnWidth)) + 'x' + LTRIM( STR( m.pnHeight)) 103 | ENDIF 104 | ELSE 105 | pnWidth = 0 106 | pnHeight = 0 107 | lcRetStr = '' 108 | ENDIF 109 | 110 | RETURN m.lcRetStr 111 | ENDFUNC && GIFSize 112 | 113 | * --------------------------------------------------------- * 114 | FUNCTION JPGSize( pcFileName, pnWidth, pnHeight ) 115 | * 116 | * Returns the size WxH of a JPG file. 117 | * 118 | * by Thomas Gehrke 119 | * 120 | * See Comments to function GIFSize() for usage notes. 121 | * 122 | IF EMPTY( m.pcFileName) 123 | pcFileName = GETFILE( 'JPG', 'Select JPG File:', 'Get Size') 124 | ENDIF 125 | 126 | IF EMPTY( m.pcFileName) 127 | RETURN '' 128 | ENDIF 129 | 130 | PRIVATE lnHandle, lcRetStr 131 | lnHandle = FOPEN( m.pcFileName) 132 | lcRetStr = '' 133 | 134 | IF m.lnHandle > -1 135 | 136 | PRIVATE lnFileSize, lnCounter, lcBytes 137 | lnFileSize = FSEEK( m.lnHandle, 0, 2) 138 | lnCounter = 0 139 | 140 | = FSEEK( m.lnHandle, 0, 0) 141 | 142 | FOR lnCounter = 1 TO m.lnFileSize - 2 143 | lcBytes = FREAD( m.lnHandle, 3) 144 | 145 | IF m.lcBytes = CHR(0) + CHR(17) + CHR(8) OR ; 146 | m.lcBytes = CHR(0) + CHR(11) + CHR(8) 147 | * 148 | * Found block marker for dimensions! 149 | lcBytes = FREAD( m.lnHandle, 4) 150 | EXIT 151 | ELSE 152 | = FSEEK( m.lnHandle, -2, 1) 153 | ENDIF 154 | ENDFOR 155 | 156 | = FCLOSE( m.lnHandle) 157 | 158 | pnWidth = ASC( SUBSTR( m.lcBytes, 3, 1)) * 256 + ; 159 | ASC( SUBSTR( m.lcBytes, 4, 1)) 160 | 161 | pnHeight = ASC( SUBSTR( m.lcBytes, 1, 1)) * 256 + ; 162 | ASC( SUBSTR( m.lcBytes, 2, 1)) 163 | 164 | lcRetStr = LTRIM( STR( m.pnWidth)) + 'x' + LTRIM( STR( m.pnHeight)) 165 | 166 | ELSE 167 | pnWidth = 0 168 | pnHeight = 0 169 | lcRetStr = '' 170 | ENDIF 171 | 172 | RETURN m.lcRetStr 173 | ENDFUNC && JPGSize 174 | 175 | ************************************************************ 176 | * FUNCTION Within() 177 | ************************************************************ 178 | FUNCTION within( tcExpression, tcLeft, tcRight, tnFirstOne, tnFollowing) 179 | * Author............: Steven M. Black 180 | * Project...........: SMS 181 | * Created...........: 27/08/96 11:06:58 182 | * Copyright.........: (c) Steven Black Consulting / UP!, 1996 183 | *) Description.......: FUNCTION Within() 184 | *) : Returns string contained within two 185 | *) others. Case sensitive 186 | * Calling Samples...: within( , , [, [,]]) 187 | * Parameter List....: tcExpression 188 | * tcLeft 189 | * tcRight 190 | * tnFirstOne 191 | * tnFollowing 192 | * Major change list.: 193 | * ERs...............: 194 | 195 | LOCAL lcReturnVal, tnLeftpos 196 | lcReturnVal = [] 197 | tnLeftpos = AT( tcLeft, tcExpression, IIF( EMPTY( tnFirstOne), 1, tnFirstOne)) 198 | IF tnLeftpos > 0 199 | tnLeftpos = tnLeftpos + LEN( tcLeft) 200 | IF tnLeftpos< LEN( tcExpression) 201 | lcReturnVal = SUBSTR( tcExpression, ; 202 | tnLeftpos, ; 203 | AT( tcRight, ; 204 | SUBSTR( tcExpression, tnLeftpos), ; 205 | IIF( EMPTY( tnFollowing), 1, tnFollowing))-1) 206 | ENDIF 207 | ENDIF 208 | RETURN lcReturnVal 209 | 210 | ************************************************************ 211 | * FUNCTION WithinC() 212 | ************************************************************ 213 | FUNCTION withinC( tcExpression, tcLeft, tcRight, tnFirstOne, tnFollowing) 214 | * Author............: Steven M. Black 215 | * Project...........: SMS 216 | * Created...........: 27/08/96 11:06:58 217 | * Copyright.........: (c) Steven Black Consulting / UP!, 1996 218 | *) Description.......: FUNCTION WithinC() 219 | *) : Returns string contained within two 220 | *) others. Case INsensitive 221 | * Calling Samples...: withinC( , , [, [,]]) 222 | * Parameter List....: tcExpression 223 | * tcLeft 224 | * tcRight 225 | * tnFirstOne 226 | * tnFollowing 227 | * Major change list.: 228 | * ERs...............: 229 | * 230 | PRIVATE lcRetVal, lnlftpos 231 | lcRetVal = '' 232 | lnlftpos = ATC(tcLeft, tcExpression, IIF(EMPTY( tnFirstOne), 1, tnFirstOne)) 233 | IF lnlftpos > 0 234 | lnlftpos = lnlftpos + LEN( tcLeft) 235 | IF lnlftpos < LEN( tcExpression) 236 | lcRetVal = SUBSTR( tcExpression, lnlftpos, ATC( tcRight, SUBSTR( tcExpression, lnlftpos), IIF(EMPTY(tnFollowing), 1, tnFollowing))-1) 237 | ENDIF 238 | ENDIF 239 | RETURN lcRetVal 240 | * 241 | 242 | ***************************************************** 243 | DEFINE CLASS URL AS Lightweight 244 | ***************************************************** 245 | *!* Test code for this class 246 | *!* clear 247 | *!* x=CREATEOBJECT("url","http://qatest.emedicine.com/gps/userhome.gps?x=1&y=2&z=3") 248 | *!* ?x.getURL() 249 | *!* x.AddElement("test","1") 250 | *!* ?x.getURL() 251 | *!* x.AddElement("y","4") 252 | *!* ?x.getURL() 253 | *!* ?"nelements=", x.nElements 254 | *!* ?"First element=", x.getValue(1) 255 | *!* ?"y=", x.getvalue("y") 256 | *!* ? "====================" 257 | *!* LOCAL lni 258 | *!* FOR lni= 1 TO x.nElements 259 | *!* ?x.getAttribute(lni), "=", x.getValue(lni) 260 | *!* ENDFOR 261 | *!* ? "====================" 262 | *!* x.Coalesce("http://zzz.org?x=Override&z=55&new=great") 263 | *!* ?x.getURL() 264 | *!* ? "====================" 265 | *!* x.RemoveElement(1) 266 | *!* x.RemoveElement("z") 267 | *!* ?x.getURL() 268 | * [2002.09.11 dragan] - initial dimension now 1,2 269 | * - GetUrl() now doesn't exit on first blank, and tests for blank values, not names. 270 | * It now skips the blank values and traverses all the elements. 271 | * - RemoveElement doesn't remove it, just blanks the value. Reason for all this was 272 | * situation we had when all elements are removed. 273 | DIMENSION aElements[1, 2] 274 | cBase = "" 275 | cElements = "" 276 | cElementDelimiter = CHR(38) 277 | cBaseDelimiter = "?" 278 | nElements = 0 279 | 280 | *===================================== 281 | FUNCTION INIT(tcURL) 282 | *===================================== 283 | aElements = "" 284 | this.LoadURL( tcURL) 285 | RETURN 286 | 287 | *===================================== 288 | FUNCTION LoadURL( tcURL) 289 | *===================================== 290 | IF !EMPTY( tcURL) 291 | LOCAL lcBaseDelimiter 292 | lcBaseDelimiter = this.cBaseDelimiter 293 | this.cBase = GETWORDNUM(tcURL, 1, lcBaseDelimiter) 294 | this.cElements = GETWORDNUM(tcURL, 2, lcBaseDelimiter) 295 | ENDIF 296 | RETURN 297 | 298 | *===================================== 299 | FUNCTION GetURL( ) 300 | *===================================== 301 | LOCAL lcRetVal, lni 302 | lcRetVal = this.cBase + this.cBaseDelimiter 303 | FOR lni = 1 TO ALEN(this.aElements, 1) 304 | IF !EMPTY(this.aElements[lni, 2]) 305 | IF lni > 1 306 | lcRetVal = lcRetVal + this.cElementDelimiter 307 | ENDIF 308 | lcRetVal = lcRetVal + TRANSFORM(this.aElements[lni, 1])+ "="+ TRANSFORM(this.aElements[lni, 2]) 309 | ENDIF 310 | ENDFOR 311 | RETURN lcRetVal 312 | 313 | *===================================== 314 | FUNCTION AddElement( tcAttrib, tcValue) 315 | *===================================== 316 | LOCAL lnIndex 317 | lnIndex = ASCAN(this.aElements, tcAttrib, 1, ALEN(this.aElements, 1), 1, 15) 318 | IF lnIndex = 0 319 | lnIndex = IIF( EMPTY( this.aElements[1, 1]), 1, ALEN(this.aElements, 1)+1) 320 | DIMENSION this.aElements[lnIndex, 2] 321 | ENDIF 322 | this.aElements[lnIndex, 1] = tcAttrib 323 | this.aElements[lnIndex, 2] = tcValue 324 | RETURN 325 | 326 | *===================================== 327 | FUNCTION GetAttribute( tnPassed) 328 | *===================================== 329 | LOCAL lcRetVal, lnIndex 330 | lcRetVal = "" 331 | DO CASE 332 | CASE VARTYPE(tnPassed) $ "NI" 333 | IF tnPassed <= ALEN(this.aElements, 1) 334 | lcRetVal = this.aElements[tnPassed, 1] 335 | ENDIF 336 | OTHERWISE 337 | * Bogus 338 | ENDCASE 339 | RETURN lcRetVal 340 | 341 | *===================================== 342 | FUNCTION GetValue( tuPassed) 343 | *===================================== 344 | LOCAL lcRetVal, lnIndex 345 | lcRetVal = "" 346 | DO CASE 347 | CASE VARTYPE(tuPassed) $ "NI" 348 | IF tuPassed<= ALEN(this.aElements, 1) 349 | lcRetVal = this.aElements[tuPassed, 2] 350 | ENDIF 351 | CASE VARTYPE(tuPassed) = "C" 352 | lnIndex = ASCAN(this.aElements, tuPassed, 1, ALEN(this.aElements, 1), 1, 15) 353 | IF lnIndex > 0 354 | lcRetVal = this.aElements[lnIndex, 2] 355 | ENDIF 356 | OTHERWISE 357 | * Bogus 358 | ENDCASE 359 | RETURN lcRetVal 360 | 361 | 362 | *===================================== 363 | FUNCTION RemoveElement( tuPassed) 364 | *===================================== 365 | LOCAL lcRetVal 366 | lcRetVal = "" 367 | DO CASE 368 | CASE VARTYPE(tuPassed) $ "NI" 369 | IF tuPassed<= ALEN(this.aElements, 1) 370 | this.aElements[tuPassed, 2]= "" 371 | ENDIF 372 | CASE VARTYPE(tuPassed) = "C" 373 | lnIndex = ASCAN(this.aElements, tuPassed, 1, ALEN(this.aElements, 1), 1, 15) 374 | IF lnIndex > 1 375 | this.aElements[lnIndex, 2]= "" 376 | ENDIF 377 | OTHERWISE 378 | * Bogus 379 | ENDCASE 380 | RETURN 381 | 382 | 383 | *===================================== 384 | FUNCTION Coalesce( tcURL) 385 | *===================================== 386 | LOCAL loURL, lni 387 | loURL = CREATEOBJECT(this.Class, tcURL) 388 | FOR lni = 1 TO loURL.nElements 389 | this.AddElement(loURL.GetAttribute(lni), loURL.GetValue(lni)) 390 | ENDFOR 391 | loURL = .NULL. 392 | RETURN 393 | 394 | *===================================== 395 | FUNCTION cElements_Assign(tcElements) 396 | *===================================== 397 | LOCAL lcBaseDelimiter, lcElementDelimiter 398 | lcBaseDelimiter = this.cBaseDelimiter 399 | lcElementDelimiter = this.cElementDelimiter 400 | 401 | IF "?" $ tcElements 402 | this.cElements = LOWER(GETWORDNUM(tcElements, 2, lcBaseDelimiter)) 403 | ELSE 404 | this.cElements = LOWER(tcElements) 405 | ENDIF 406 | LOCAL lni, lc2PartElement 407 | FOR lni = 1 TO GETWORDCOUNT(tcElements, lcElementDelimiter)) 408 | lc2PartElement = GETWORDNUM(tcElements, lni, lcElementDelimiter) 409 | this.AddElement( GETWORDNUM(lc2PartElement, 1, "="), GETWORDNUM(lc2PartElement, 2, "=") ) 410 | ENDFOR 411 | RETURN 412 | 413 | *===================================== 414 | FUNCTION cbase_Assign( tcbase) 415 | *===================================== 416 | IF "?" $ tcBase 417 | this.cBase = LOWER(GETWORDNUM(tcBase, 1, "?")) 418 | ELSE 419 | this.cBase = LOWER(tcBase) 420 | ENDIF 421 | RETURN 422 | 423 | 424 | *===================================== 425 | FUNCTION nElements_Access 426 | *===================================== 427 | RETURN IIF( EMPTY( this.aElements[1, 1]), 0, ALEN(this.aElements, 1)) 428 | 429 | ENDDEFINE 430 | 431 | ************************************************************* 432 | * StringDateTime(t) 433 | ************************************************************* 434 | FUNCTION StringDateTime( tdDateTime) 435 | * assumes you've passed in a Date or DateTime type 436 | RETURN CDOW(tdDateTime)+ " " + MDY(tdDateTime)+ " "+ SUBSTR(TTOC(tdDatetime), 10) 437 | 438 | ************************************************************* 439 | * IsEmail(c) 440 | ************************************************************* 441 | * email address validation - 442 | * is there one and only one @ symbol 443 | * is there a dot (.) somewhere post @ symbol 444 | * is there atleast 2 chars following dot 445 | 446 | FUNCTION IsEmail( tcEmailAddress ) 447 | 448 | * validate parameter 449 | IF VARTYPE(tcEmailAddress) != 'C' OR EMPTY(tcEmailAddress) 450 | RETURN .F. 451 | ENDIF 452 | 453 | * ok you gave me a string, but does it look like a valid address? 454 | LOCAL lnCheckAtSymbol, lnCheckLength, lnCheckDot, lnCheckme, lcEmail 455 | lnCheckme = 0 456 | lnCheckAtSymbol = 0 457 | lcEmail = ALLTR(tcEmailAddress) 458 | 459 | * make sure only one AT symbol 460 | lnCheckMe = AT('@', lcEmail, 2) 461 | 462 | IF NOT lnCheckMe = 0 463 | RETURN .F. 464 | ENDIF 465 | 466 | * make sure @ symbol seemingly in right place 467 | lnCheckLength = LEN(ALLTR(lcEmail)) 468 | 469 | lnCheckAtSymbol = AT('@', lcEmail) 470 | 471 | IF lnCheckAtSymbol > 1 AND ; 472 | lnCheckAtSymbol <= (lnCheckLength - 4) && min chars after at symbol is 4; i.e. tom@x.uk 473 | 474 | * we be cool, keep going 475 | ELSE 476 | RETURN .F. 477 | ENDIF 478 | 479 | * do we have a dot after @ symbol followed by atleast 2 chars (somebody@group.uk) 480 | * RoX fix 6.6.01 - use RAT here instead of AT cuz sometimes and address has periods 481 | * before @ symbol 482 | lnCheckDot = RAT('.', lcEmail) 483 | 484 | IF lnCheckDot > lnCheckAtSymbol AND ; 485 | lnCheckDot <= (lnCheckLength - 2) 486 | 487 | * we be cool, keep going 488 | ELSE 489 | RETURN .F. 490 | ENDIF 491 | 492 | * made it this far, looks good 493 | RETURN .T. 494 | 495 | ENDFUNC 496 | 497 | ************************************************************* 498 | * MakeLink(c) 499 | ************************************************************* 500 | * Link determination - 501 | * @ symbol means email 502 | * no @ and a period means regular hyperlink 503 | * else we just got a string. 504 | 505 | FUNCTION MakeLink( tcPassed ) 506 | 507 | * validate parameter 508 | IF VARTYPE( tcPassed ) != 'C' OR EMPTY( tcPassed ) 509 | RETURN tcPassed 510 | ENDIF 511 | 512 | LOCAL lcRetStr 513 | 514 | DO CASE 515 | CASE "@" $ tcPassed 516 | RETURN [] + ALLTR( tcPassed ) + [] 517 | 518 | CASE "." $ tcPassed 519 | RETURN [] + ALLTR( tcPassed ) + [] 520 | 521 | OTHERWISE 522 | RETURN tcPassed 523 | ENDCASE 524 | 525 | ENDFUNC 526 | 527 | 528 | *===================================== 529 | DEFINE CLASS Decorator AS CUSTOM 530 | * The universal decorator. 531 | *===================================== 532 | oDecorated = .NULL. 533 | 534 | FUNCTION INIT( toDecorated) 535 | this.oDecorated = toDecorated 536 | RETURN 537 | 538 | FUNCTION THIS_Access( tcMember) 539 | IF PEMSTATUS(THIS, UPPER(tcMember), 5) 540 | RETURN THIS 541 | ELSE 542 | RETURN this.oDecorated 543 | ENDIF 544 | RETURN 545 | 546 | FUNCTION DESTROY() 547 | this.oDecorated = .null. 548 | RETURN 549 | 550 | ENDDEFINE 551 | 552 | 553 | ************************************************************* 554 | DEFINE CLASS cParameter AS Custom 555 | * The universal decorator. 556 | ************************************************************* 557 | FUNCTION This_Access(tcMember) 558 | IF TYPE('this.' + tcMember) = 'U' 559 | this.ADDPROPERTY(tcMember) 560 | ENDIF 561 | RETURN THIS 562 | 563 | ENDDEFINE 564 | 565 | 566 | ******************************** 567 | DEFINE CLASS TempFile AS Relation 568 | ******************************** 569 | cFilename = "" 570 | cStem = "" 571 | cExt = "dbf" 572 | 573 | FUNCTION INIT( tcPassed) 574 | LOCAL lcTemp 575 | IF EMPTY( tcPassed) 576 | tcPassed = "" 577 | ENDIF 578 | 579 | DO CASE 580 | CASE "." $ tcPassed 581 | this.cStem = JUSTSTEM( tcPassed) 582 | this.cExt = JUSTEXT( tcPassed) 583 | this.cFileName = tcPassed 584 | 585 | CASE ! EMPTY( tcPassed) && Extension 586 | this.cExt = tcPassed 587 | this.cStem = SUBSTR( SYS(2015), 3, 10) 588 | this.cFilename = FORCEEXT( this.cStem, this.cExt) 589 | 590 | OTHERWISE 591 | this.cStem = SUBSTR( SYS(2015), 3, 10) 592 | this.cFilename = FORCEEXT( this.cStem, this.cExt) 593 | ENDCASE 594 | 595 | 596 | FUNCTION Destroy 597 | 598 | IF USED( this.cStem) 599 | USE IN ( this.cStem) 600 | ENDIF 601 | IF FILE( this.cFileName) 602 | ERASE ( this.cFileName) 603 | ENDIF 604 | 605 | LOCAL lcMemo 606 | lcMemo = FORCEEXT( this.cFileName, "FPT") 607 | IF FILE( lcMemo) 608 | ERASE ( lcMemo) 609 | ENDIF 610 | 611 | ENDDEFINE 612 | 613 | 614 | ***************************************** 615 | FUNCTION STOD( tcString ) 616 | ***************************************** 617 | * String To Date - RoX 5.5.2001 618 | * inverse of DTOS() for converting backend date values 619 | * stored as char in form of yyyymmdd. 620 | 621 | * validate we got soemthing to work with 622 | IF VARTYP( tcString ) != "C" OR EMPTY( tcString ) OR LEN( tcString ) != 8 623 | RETURN tcString 624 | ENDIF 625 | 626 | * ok disect it and gimme a string in mmddyyyy format that I can work with 627 | LOCAL lcNewStr, ldRetVal 628 | 629 | lcNewStr = SUBSTR( tcString, 5, 2) + SUBSTR( tcString, 7, 2) + SUBSTR( tcString, 1, 4) 630 | 631 | * make it look like a real date 632 | lcNewStr = STUFF( lcNewStr, 3, 0, "/" ) 633 | lcNewStr = STUFF( lcNewStr, 6, 0, "/" ) 634 | 635 | * and convert it 636 | ldRetVal = CTOD( lcNewStr ) 637 | 638 | RETURN ldRetVal 639 | 640 | ENDFUNC 641 | 642 | 643 | ************************************************************ 644 | * FUNCTION ToLeft() 645 | ************************************************************ 646 | FUNCTION ToLeft(tcsearch, tcexp, tnocc) 647 | * Author............: Steven M. Black 648 | * Project...........: SMS 649 | * Created...........: 27/08/96 11:37:10 650 | * Copyright.........: (c) Steven Black Consulting / UP!, 1996 651 | *) Description.......: FUNCTION ToLeft() 652 | *) : Returns characters from a character expression 653 | *) : to the left of a specified string.\ 654 | * Remarks...........: If is found in , the character string 655 | *) : to the left of is returned. Otherwise the 656 | *) : null string is returned. The search performed by 657 | *) : TOLEFT() is case-sensitive. To perform a search 658 | *) : that isn't case-sensitive, use TOLEFTC(). 659 | * Calling Samples...: TOLEFT(, [, ]) 660 | * Parameter List....: , ToLeft() searches for . 661 | *) : Specify which occurrence of in 662 | *) : to search for (searches for the th 663 | *) : occurrence). Default value: 1 664 | RETURN LEFT(tcexp, AT(tcsearch, tcexp, IIF(EMPTY(tnocc), 1, tnocc))-1) 665 | 666 | 667 | * 668 | ************************************************************ 669 | * FUNCTION ToLeftC() 670 | ************************************************************ 671 | FUNCTION ToLeftC(tcsearch, tcexp, tnocc) 672 | * Author............: Steven M. Black 673 | * Project...........: SMS 674 | * Created...........: 27/08/96 11:37:40 675 | * Copyright.........: (c) Steven Black Consulting / UP!, 1996 676 | *) Description.......: FUNCTION ToLeftC() 677 | *) : Returns characters from a character expression 678 | *) : to the left of a specified string. CASE UNSENSITIVE. 679 | * Remarks...........: Remarks: If is found in , the character 680 | *) : string to the left of is returned. Otherwise the 681 | *) : null string is returned. The search is not case-sensitive. 682 | *) : To perform a case-sensitive search, use TOLEFT(). 683 | * Calling Samples...: TOLEFT(, [, ]) 684 | * Parameter List....: , ToLeft() searches for . 685 | *) : Specify which occurrence of in 686 | *) : to search for (searches for the th 687 | *) : occurrence). Default value: 1 688 | 689 | * Major change list.: 690 | * ERs...............: 691 | RETURN LEFT(tcexp, ATC(tcsearch, tcexp, IIF(EMPTY(tnocc), 1, tnocc))-1) 692 | 693 | * 694 | ************************************************************ 695 | * FUNCTION ToRight() 696 | ************************************************************ 697 | FUNCTION ToRight(tcsearch, tcexp, tnocc) 698 | * Author............: Steven M. Black 699 | * Project...........: SMS 700 | * Created...........: 27/08/96 11:38:05 701 | * Copyright.........: (c) Steven Black Consulting / UP!, 1996 702 | *) Description.......: FUNCTION ToRight() 703 | *) : Returns characters from a character expression to the right 704 | *) : of a specified string. 705 | *) Remarks...........: If is found in , the character string to the right 706 | *) : of is returned. Otherwise the null string is returned. 707 | *) : The search performed by TORIGHT() is case-sensitive. To perform a search that 708 | *) : isn't case-sensitive, use TORIGHTC(). 709 | * Calling Samples...: TORIGHT(, [, ]) 710 | * Parameter List....: , TORIGHT() searches for . 711 | *) : Specify which occurrence of in to 712 | *) : search for (searches for the th occurrence). Default value: 1 713 | 714 | * Major change list.: 715 | * ERs...............: 716 | LOCAL lnsplitpos 717 | lnsplitpos = AT(tcsearch, tcexp, IIF(EMPTY(tnocc), 1, tnocc)) 718 | RETURN IIF(lnsplitpos == 0, '', RIGHT(tcexp, LEN(tcexp)-lnsplitpos-LEN(tcsearch)+1)) 719 | * 720 | 721 | 722 | ************************************************************ 723 | * FUNCTION ToRightC() 724 | ************************************************************ 725 | FUNCTION ToRightC(tcsearch, tcexp, tnocc) 726 | * Author............: Steven M. Black 727 | * Project...........: SMS 728 | * Created...........: 27/08/96 11:38:14 729 | * Copyright.........: (c) Steven Black Consulting / UP!, 1996 730 | *) Description.......: FUNCTION ToRightC() 731 | *) : Returns characters from a character expression to the 732 | *) : right of a specified string. Searches without regard for case. 733 | *) Remarks...........: If is found in , the character string to the right 734 | *) : of is returned. Otherwise the null string is returned. The search 735 | *) : is not case-sensitive. To perform a case-sensitive search, use TORIGHT(). 736 | * Calling Samples...: TORIGHTC(, [, ]) 737 | * Parameter List....: 738 | * Major change list.: 739 | * ERs...............: 740 | LOCAL lnsplitpos 741 | lnsplitpos = ATC(tcsearch, tcexp, IIF(EMPTY(tnocc), 1, tnocc)) 742 | RETURN IIF(lnsplitpos = 0, '', RIGHT(tcexp, LEN(tcexp)-lnsplitpos-LEN(tcsearch)+1)) 743 | 744 | ************************************************************ 745 | * FUNCTION CDATA(C) 746 | ************************************************************ 747 | FUNCTION CDATA(tcPassed) 748 | RETURN "" 749 | 750 | 751 | 752 | *===================================================== 753 | DEFINE CLASS LightWeight AS RELATION OLEPUBLIC 754 | *===================================================== 755 | * Our base lightweight class. 756 | 757 | * These intrinsic properties are semantics of Relation 758 | * classes, which we are not interested in. 759 | PROTECTED CHILDALIAS 760 | PROTECTED CHILDORDER 761 | PROTECTED ONETOMANY 762 | PROTECTED PARENTALIAS 763 | PROTECTED RELATIONALEXPR 764 | PROTECTED PARENT 765 | PROTECTED PARENTCLASS 766 | PROTECTED CLASSLIBRARY 767 | PROTECTED CLASS 768 | PROTECTED COMMENT 769 | PROTECTED TAG 770 | PROTECTED BASECLASS 771 | 772 | PROTECTED FUNCTION INIT 773 | PROTECTED FUNCTION DESTROY 774 | PROTECTED FUNCTION READMETHOD 775 | PROTECTED FUNCTION WRITEMETHOD 776 | PROTECTED FUNCTION READEXPRESSION 777 | PROTECTED FUNCTION WRITEEXPRESSION 778 | 779 | FUNCTION RELEASE() 780 | this.GarbageCollect() 781 | RELEASE THIS 782 | 783 | FUNCTION GarbageCollect() 784 | 785 | ENDDEFINE 786 | 787 | *===================================================== 788 | DEFINE CLASS Q AS Lightweight 789 | *===================================================== 790 | Name = "Q" 791 | H = 0 792 | C = "Temp" 793 | Q = "" 794 | XStat = 0 795 | Halt =.f.&& halt on error 796 | E =.F. && auto error-check 797 | LastId = 0 798 | I = .F. && Instrumentation 799 | InstrumentTable = "Q_Instrument" 800 | 801 | nStart = 0 802 | nEnd = 0 803 | nInstrumentTime = 0.025 && Ignore queries below this time thresshold 804 | Cache = .F. 805 | CacheDie = 3600 && 1 hour 806 | CacheTable = "Q_Cache" 807 | 808 | DSN = "ConNLRollup" 809 | User = "configure.me" 810 | PW = "configure.me" 811 | DSN = "configure.me" 812 | User = "configure.me" 813 | PW = "" 814 | 815 | ******************************** 816 | FUNCTION LastId_Access 817 | ******************************** 818 | LOCAL lnOldSelect 819 | lnOldSelect = SELECT() 820 | SQLExec(this.H, "SELECT @@IDENTITY AS nLast", "TempLastId") 821 | lnRetVal = nLast 822 | USE IN TempLastId 823 | SELECT (lnOldSelect) 824 | RETURN lnRetVal 825 | 826 | ******************************** 827 | FUNCTION INIT 828 | ******************************** 829 | this.Connect() 830 | RETURN 831 | 832 | ******************************** 833 | FUNCTION Connect() 834 | ******************************** 835 | IF this.H > 0 836 | SQLDISCONNECT(this.H) 837 | ENDIF 838 | this.H = SQLCONNECT(this.DSN, this.User, this.PW) 839 | RETURN this.H 840 | 841 | ******************************** 842 | FUNCTION Destroy 843 | ******************************** 844 | SQLDISCONNECT(this.H) 845 | RETURN 846 | 847 | ******************************** 848 | FUNCTION X 849 | * execute 850 | ******************************** 851 | LOCAL lnOldSelect 852 | IF this.Cache 853 | lnOldSelect = SELECT() 854 | IF ! FILE(this.Cachetable + ".dbf") 855 | CREATE TABLE (this.Cachetable) (tTime T, Query M, Results M) 856 | USE && releasing the EXCLUSIVE that CREATE TABLE yields 857 | ENDIF 858 | 859 | LOCAL llOut, llOpenedHere 860 | llOut = .F. 861 | llOpenedHere = .F. 862 | IF ! USED(this.Cachetable) 863 | SELECT 0 864 | USE (this.Cachetable) 865 | llOpenedHere = .T. 866 | ELSE 867 | SELECT (this.Cachetable) 868 | ENDIF 869 | DELETE FOR tTime < DATETIME() 870 | LOCATE FOR Query == this.q 871 | IF ! EOF() 872 | llOut = .T. 873 | XMLTOCURSOR(Results, this.C) 874 | ENDIF 875 | SELECT (lnOldSelect) 876 | IF llOUT 877 | SELECT (this.C) 878 | IF llOpenedHere 879 | USE IN (this.Cachetable) 880 | ENDIF 881 | RETURN 882 | ENDIF 883 | ENDIF 884 | 885 | this.nStart = SECONDS() 886 | this.XStat = SQLExec(this.H, this.Q, this.C) 887 | this.nEnd = SECONDS() 888 | 889 | IF (this.I AND USED(this.C) AND (this.nEnd-this.nStart > this.nInstrumentTime)) OR ; 890 | (this.I AND this.XStat =-1) 891 | 892 | LOCAL lnOldSelect 893 | lnOldSelect = SELECT() 894 | IF ! FILE(this.InstrumentTable + ".dbf") 895 | CREATE TABLE (this.InstrumentTable) (tTime T, cSQL M, nTime N (7, 3), nRecs I) 896 | USE 897 | ENDIF 898 | INSERT INTO (this.InstrumentTable) (tTime, cSQL, nTime, nRecs) ; 899 | VALUES (DATETIME(), this.Q, this.nEnd-this.nStart, IIF(USED(this.c), RECCOUNT(this.C), 0)) 900 | USE IN (this.InstrumentTable) 901 | SELECT (lnOldSelect) 902 | ENDIF 903 | IF this.E 904 | this.S() 905 | ENDIF 906 | 907 | IF this.Cache AND this.xStat > 0 908 | LOCAL lnOldSelect 909 | lnOldSelect = SELECT() 910 | LOCAL lcResults 911 | CURSORTOXML(this.C, "lcResults", 1, 1, 0, "1") 912 | INSERT INTO (this.Cachetable) (tTime, Query, Results) ; 913 | VALUES (DATETIME()+ this.CacheDie, this.Q, lcResults) 914 | USE IN (this.Cachetable) 915 | RELEASE lcResults 916 | SELECT (lnOldSelect) 917 | ENDIF 918 | 919 | ******************************** 920 | FUNCTION S 921 | ******************************** 922 | IF this.XStat = -1 923 | = AERROR(aErrorArray) && Data from most recent error 924 | ? 'The error provided the following information' && Display message 925 | FOR n = 1 TO 7 && Display all elements of the array 926 | ? aErrorArray(n) 927 | ENDFOR 928 | IF this.Halt 929 | SET STEP ON 930 | ENDIF 931 | ENDIF 932 | 933 | ******************************** 934 | FUNCTION ClearCache 935 | ******************************** 936 | IF FILE(this.Cachetable + ".dbf") 937 | LOCAL llOpenedHere 938 | llOpenedHere = .F. 939 | IF ! USED(this.Cachetable) 940 | TRY 941 | USE (this.Cachetable) IN 0 EXCLUSIVE 942 | llOpenedHere = .T. 943 | ZAP IN (this.Cachetable) 944 | CATCH 945 | USE (this.Cachetable) IN 0 946 | llOpenedHere = .T. 947 | DELETE ALL IN (this.Cachetable) 948 | ENDTRY 949 | ELSE 950 | DELETE ALL IN (this.Cachetable) 951 | ENDIF 952 | IF llOpenedHere 953 | USE IN (this.Cachetable) 954 | ENDIF 955 | ENDIF 956 | RETURN 957 | ENDDEFINE 958 | 959 | 960 | --------------------------------------------------------------------------------