home *** CD-ROM | disk | FTP | other *** search
/ Total C++ 2 / TOTALCTWO.iso / vfp5.0 / vfp / samples / csapp / csprocs.prg < prev    next >
Encoding:
Text File  |  1996-08-21  |  13.4 KB  |  481 lines
  1. **************************************************************************
  2. **************************************************************************
  3. *     Summary of Classes:
  4. *
  5. *    CSEngine - base engine
  6. *
  7. *        Setup - save environment
  8. *        Clearnup - restore environment
  9. *        Error - common error handling
  10. *        Alert - displays MessageBox alert
  11. *        GetOS - returns operating system code (see #DEFINES)
  12. *        JustPath - returns path of file name
  13. *        JustStem - returns stem of file name (name only with no extension)
  14. *        JustFName - returns file name
  15. *        ForceExt - forces file to have certain extension
  16. *        AddBs - adds backslash (colon for Macs) to file path if needed
  17. *        GetDBCAlias - returns DBC alias
  18. **************************************************************************
  19.  
  20. #INCLUDE csdefs.h
  21. ******************************************************************************
  22. DEFINE CLASS CSEngine AS custom
  23. ******************************************************************************
  24.  
  25.     * Globals
  26.     Start = .F.                && start app or cancel
  27.     iHelpContextID = 0        && used as default
  28.     cDBCName = ""            &&DBC name
  29.     cDBCAlias = ""            &&DBC Alias name
  30.     cDBCTable = ""            &&DBC Table name
  31.     SetErrorOff = .F.        &&bypass normal Error handling
  32.     HadError = .f.            &&error occurred
  33.     iError = -1                &&error number
  34.     cMessage = ''            &&error message
  35.     ThermRef = ""            &&reference to thermometer
  36.     nCurrentOS = 0            &&operating system code
  37.     oServer = null            &&Middle Tire Server
  38.  
  39.     DatabaseName = CS_DATABASE
  40.     DatabaseFile = ""
  41.     DatabaseIsOpened = .F.
  42.     ShowOpenDatabase = .T.
  43.     CursorAlias = ""
  44.     CursorType = NO_CURSOR
  45.     RowConflict = .T.
  46.     ConflictAlias = ""
  47.     CurrentPage = 1
  48.     OnlineStatus = ""               
  49.     dimension aEnvironment[1]
  50.     
  51.     * middle-tire server procedures
  52.     PROCEDURE ServerStart
  53.         this.oServer = createobj('Bizrules.Salaryrule')
  54.         IF !this.ServerIsStarted()
  55.             * Let's try to register the server
  56.             RUN /N BIZRULES.EXE /RegServer
  57.             this.oServer = createobj('Bizrules.Salaryrule')
  58.             IF !this.ServerIsStarted()    
  59.                 this.oServer = .null.
  60.                 RETURN .F.
  61.             ENDIF
  62.         ENDIF
  63.     ENDPROC
  64.  
  65.     PROCEDURE ServerStop
  66.         this.oServer = .null.
  67.     ENDPROC
  68.  
  69.     FUNCTION ServerIsStarted
  70.         RETURN (TYPE('this.oServer') == 'O' AND !ISNULL(this.oServer))
  71.     ENDFUNC
  72.  
  73.     FUNCTION ServerValidateRow
  74.         PARAMETER llReturn
  75.         LOCAL lcError
  76.         PRIVATE cTitle,nSalary,dBirth,dHire,cCountry
  77.  
  78.         cTitle = Title
  79.         nSalary = Salary
  80.         dBirth = Birth_date
  81.         dHire = Hire_date
  82.         cCountry = Country
  83.  
  84.         lcError = this.oServer.validate(m.cTitle, m.nSalary, m.dBirth, m.dHire, m.cCountry)
  85.         IF !EMPTY(m.lcError)
  86.             this.Alert(m.lcError, MB_ICONEXCLAMATION + MB_OK, BIZRULEERROR_LOC)
  87.             RETURN .F.
  88.         ENDIF
  89.         RETURN .T.
  90.     ENDFUNC
  91.  
  92.     procedure Destroy
  93.         this.Cleanup
  94.     endproc
  95.     
  96.     procedure Init
  97.         this.Setup()
  98.     endproc
  99.     
  100.     procedure Setup
  101.         clear program
  102.         dimension this.aEnvironment[30, 1]
  103.         this.aEnvironment[1,1] = SET("TALK")
  104.         SET TALK OFF
  105.         this.aEnvironment[2,1] = on('escape')
  106.         this.aEnvironment[3,1] = set('escape')
  107.         push key clear
  108.         this.aEnvironment[4,1] = set("compatible")
  109.         set compatible off noprompt
  110.         this.aEnvironment[6,1] = select()
  111.         this.aEnvironment[7,1] = set("exclusive")
  112.         this.aEnvironment[8,1] = set("message", 1)
  113.         this.aEnvironment[9,1] = set("safety")
  114.         set safety off
  115.         this.aEnvironment[10,1] = set("path")
  116.         this.aEnvironment[12,1] = set("fields")
  117.         set fields off
  118.         this.aEnvironment[13,1] = set("fields", 2)
  119.         set fields local
  120.         this.aEnvironment[14,1] = on("error")
  121.         this.aEnvironment[15,1] = set('point')
  122.         this.aEnvironment[16,1] = set("deleted")
  123.         this.aEnvironment[18,1] = SET("database")
  124.         this.aEnvironment[19,1] = set("exact")
  125.         set exact on
  126.         this.aEnvironment[20,1] = set("echo")
  127.         set echo off
  128.         this.aEnvironment[21,1] = set("memowidth")
  129.         this.aEnvironment[22,1] = set("udfparms")
  130.         set udfparms to value
  131.         this.aEnvironment[23,1] = set("near")
  132.         set near off
  133.         this.aEnvironment[24,1] = set("unique")
  134.         set unique off
  135.         this.aEnvironment[25,1] = set("ansi")
  136.         set ansi off
  137.         this.aEnvironment[26,1] = set("carry")
  138.         set carry off
  139.         this.aEnvironment[27,1] = set("cpdialog")
  140.         set cpdialog off
  141.         this.aEnvironment[28,1] = set("status bar")
  142.         this.aEnvironment[29,1] = sys(5) + curdir()
  143.         IF TYPE("m.cCSDir")="C" AND !EMPTY(m.cCSDir)
  144.             cCSDir = THIS.justpath(m.cCSDir)
  145.             SET DEFAULT TO (m.cCSDir)
  146.         ENDIF
  147.         this.aEnvironment[30,1] = set("date")
  148.  
  149.         on key label f1 oEngine.Help
  150.         ON ERROR oEngine.Error
  151.     endproc
  152.     
  153.     procedure Cleanup
  154.         * copy this.aEnvironment to local aEnvironment so we can macro substitute directly
  155.         local array aEnvironment[alen(this.aEnvironment,1), alen(this.aEnvironment,2)]
  156.         =acopy(this.aEnvironment, aEnvironment)
  157.         on key label f1
  158.         on key
  159.         set compatible &aEnvironment[4,1]
  160.         select (aEnvironment[6,1])
  161.         set exclusive &aEnvironment[7,1]
  162.         set message to [&aEnvironment[8,1]]
  163.         set safety &aEnvironment[9,1]
  164.         if !empty(aEnvironment[10,1])
  165.             set path to &aEnvironment[10, 1]
  166.         else
  167.             set path to
  168.         endif
  169.         set fields &aEnvironment[12,1]
  170.         set fields &aEnvironment[13,1]
  171.         on error &aEnvironment[14,1]
  172.         set point to "&aEnvironment[15,1]"
  173.         set deleted &aEnvironment[16,1]
  174.         if empty(aEnvironment[18,1])
  175.             set database to
  176.         else
  177.             set database to &aEnvironment[18,1]
  178.         endif
  179.         set exact &aEnvironment[19,1]
  180.         set echo &aEnvironment[20,1]
  181.         set memowidth to (aEnvironment[21,1])
  182.         set udfparms to &aEnvironment[22,1]
  183.         set near &aEnvironment[23,1]
  184.         set unique &aEnvironment[24,1]
  185.         set ansi &aEnvironment[25,1]
  186.         set carry &aEnvironment[26,1]
  187.         set cpdialog &aEnvironment[27,1]
  188.         set status bar &aEnvironment[28,1]
  189.         set default to (aEnvironment[29,1])
  190.         set date to &aEnvironment[30,1]
  191.         set escape &aEnvironment[3,1]
  192.         on escape &aEnvironment[2,1]
  193.         set talk &aEnvironment[1,1]
  194.         pop key
  195.     endproc
  196.     
  197.     PROCEDURE Error
  198.         Parameters nError, cMethod, nLine, oObject, cMessage
  199.         local cAction
  200.         THIS.HadError = .T.
  201.         this.iError = m.nError
  202.         this.cMessage = iif(empty(m.cMessage), message(), m.cMessage)
  203.         m.cMessage = iif(empty(m.cMessage), message(), m.cMessage)
  204.         if type('m.oObject') = 'O' .and. .not. isnull(m.oObject) .and. at('.', m.cMethod) = 0
  205.             m.cMethod = m.oObject.Name + '.' + m.cMethod
  206.         endif
  207.         
  208.         IF this.SetErrorOff
  209.             RETURN
  210.         ENDIF
  211.             
  212.         if C_DEBUG
  213.             do case
  214.             case m.cAction='RETRY'
  215.                 this.HadError = .f.
  216.                 clear typeahead
  217.                 set step on
  218.                 &cAction
  219.             case m.cAction='IGNORE'
  220.                 this.HadError = .f.
  221.                 return
  222.             endcase
  223.         else
  224.             m.cAction = this.Alert(message(), MB_ICONEXCLAMATION + MB_OK)
  225.             * m.cAction = this.Alert(ERRORMESSAGE_LOC, MB_ICONEXCLAMATION + ;
  226.             *        MB_OK, ERRORTITLE_LOC)
  227.         endif
  228.     ENDPROC
  229.     
  230.     PROCEDURE Alert
  231.         parameters m.cMessage, m.cOptions, m.cTitle, m.cParameter1, m.cParameter2
  232.         private m.cOptions, m.cResponse
  233.         m.cOptions = iif(empty(m.cOptions), 0, m.cOptions)
  234.         if parameters() > 3 && a parameter was passed
  235.             m.cMessage = [&cMessage]
  236.         endif
  237.         clear typeahead
  238.         if !empty(m.cTitle)
  239.             m.cResponse = MessageBox(m.cMessage, m.cOptions, m.cTitle)
  240.         else
  241.             m.cResponse = MessageBox(m.cMessage, m.cOptions, ALERTTITLE_LOC)
  242.         endif
  243.         do case
  244.         * The strings below should not be localized
  245.         case m.cResponse = 1
  246.             m.cResponse = 'OK'
  247.         case m.cResponse = 6
  248.             m.cResponse = 'YES'
  249.         case m.cResponse = 7
  250.             m.cResponse = 'NO'
  251.         case m.cResponse = 2
  252.             m.cResponse = 'CANCEL'
  253.         case m.cResponse = 3
  254.             m.cResponse = 'ABORT'
  255.         case m.cResponse = 4
  256.             m.cResponse = 'RETRY'
  257.         case m.cResponse = 5
  258.             m.cResponse = 'IGNORE'
  259.         endcase
  260.         return m.cResponse
  261.     ENDPROC
  262.     
  263.     procedure Help
  264.         do case
  265.         case type('_screen.ActiveForm') = 'O' .and. ;
  266.             type('_screen.ActiveForm.HelpContextID') = 'N' .and. ;
  267.             _screen.ActiveForm.HelpContextID <> 0
  268.             help id (_screen.ActiveForm.HelpContextID)
  269.         case this.iHelpContextID <> 0
  270.             help id (this.iHelpContextID)
  271.         otherwise
  272.             help
  273.         endcase
  274.     endproc
  275.  
  276.     PROCEDURE GetOS
  277.         DO CASE
  278.         CASE _DOS 
  279.             THIS.nCurrentOS = OS_DOS
  280.         CASE _UNIX
  281.             THIS.nCurrentOS = OS_UNIX
  282.         CASE _MAC
  283.             THIS.nCurrentOS = OS_MAC
  284.         CASE ATC("Windows 3",OS(1)) # 0
  285.             THIS.nCurrentOS = OS_W32S
  286.         CASE ATC("Windows NT",OS(1)) # 0
  287.             THIS.nCurrentOS = OS_NT
  288.         OTHERWISE
  289.             THIS.nCurrentOS = OS_WIN95
  290.         ENDCASE
  291.     ENDPROC
  292.  
  293.     FUNCTION JustPath
  294.         * Returns just the pathname.
  295.         LPARAMETERS m.filname
  296.         LOCAL cdirsep
  297.         cdirsep = IIF(_mac,':','\')
  298.         m.filname = SYS(2027,ALLTRIM(UPPER(m.filname)))
  299.         IF m.cdirsep $ m.filname
  300.            m.filname = SUBSTR(m.filname,1,RAT(m.cdirsep,m.filname))
  301.            IF RIGHT(m.filname,1) = m.cdirsep AND LEN(m.filname) > 1 ;
  302.                     AND SUBSTR(m.filname,LEN(m.filname)-1,1) <> ':'
  303.                  filname = SUBSTR(m.filname,1,LEN(m.filname)-1)
  304.            ENDIF
  305.            RETURN m.filname
  306.         ELSE
  307.            RETURN ''
  308.         ENDIF
  309.     ENDFUNC
  310.     
  311.     FUNCTION ForceExt
  312.         * Force filename to have a particular extension.
  313.         LPARAMETERS m.filname,m.ext
  314.         LOCAL m.ext
  315.         IF SUBSTR(m.ext,1,1) = "."
  316.            m.ext = SUBSTR(m.ext,2,3)
  317.         ENDIF
  318.         m.pname = THIS.justpath(m.filname)
  319.         m.filname = THIS.justfname(UPPER(ALLTRIM(m.filname)))
  320.         IF AT('.',m.filname) > 0
  321.            m.filname = SUBSTR(m.filname,1,AT('.',m.filname)-1) + '.' + m.ext
  322.         ELSE
  323.            m.filname = m.filname + '.' + m.ext
  324.         ENDIF
  325.         RETURN THIS.addbs(m.pname) + m.filname
  326.     ENDFUNC
  327.     
  328.     FUNCTION JustFname
  329.         * Return just the filename (i.e., no path) from "filname"
  330.         LPARAMETERS m.filname
  331.         LOCAL clocalfname, cdirsep
  332.         clocalfname = SYS(2027,m.filname)
  333.         cdirsep = IIF(_mac,':','\')
  334.         IF RAT(m.cdirsep ,m.clocalfname) > 0
  335.            m.clocalfname= SUBSTR(m.clocalfname,RAT(m.cdirsep,m.clocalfname)+1,255)
  336.         ENDIF
  337.         IF AT(':',m.clocalfname) > 0
  338.            m.clocalfname= SUBSTR(m.clocalfname,AT(':',m.clocalfname)+1,255)
  339.         ENDIF
  340.         RETURN ALLTRIM(UPPER(m.clocalfname))
  341.     ENDFUNC
  342.  
  343.     FUNCTION AddBS
  344.         * Add a backslash unless there is one already there.
  345.         LPARAMETER m.pathname
  346.         LOCAL m.separator
  347.         m.separator = IIF(_MAC,":","\")
  348.         m.pathname = ALLTRIM(UPPER(m.pathname))
  349.         IF !(RIGHT(m.pathname,1) $ '\:') AND !EMPTY(m.pathname)
  350.            m.pathname = m.pathname + m.separator
  351.         ENDIF
  352.         RETURN m.pathname
  353.     ENDFUNC
  354.  
  355.     FUNCTION JustStem
  356.         * Return just the stem name from "filname"
  357.         LPARAMETERS m.filname
  358.         IF RAT('\',m.filname) > 0
  359.            m.filname = SUBSTR(m.filname,RAT('\',m.filname)+1,255)
  360.         ENDIF
  361.         IF RAT(':',m.filname) > 0
  362.            m.filname = SUBSTR(m.filname,RAT(':',m.filname)+1,255)
  363.         ENDIF
  364.         IF AT('.',m.filname) > 0
  365.            m.filname = SUBSTR(m.filname,1,AT('.',m.filname)-1)
  366.         ENDIF
  367.         RETURN ALLTRIM(UPPER(m.filname))
  368.     ENDFUNC
  369.  
  370.     FUNCTION justext
  371.         * Return just the extension from "filname"
  372.         PARAMETERS m.filname
  373.         LOCAL m.ext
  374.         m.filname = this.justfname(m.filname)   && prevents problems with ..\ paths
  375.         m.ext = ""
  376.         IF AT('.', m.filname) > 0
  377.            m.ext = SUBSTR(m.filname, AT('.', m.filname) + 1, 3)
  378.         ENDIF
  379.         RETURN UPPER(m.ext)
  380.     ENDFUNC
  381.  
  382.     PROCEDURE GetDbcAlias
  383.         * Takes the current DBC and gets its alias name
  384.         * cDBC - DBC name passed if not current DBC()
  385.         LPARAMETER cDBC
  386.         LOCAL aDBCtmp,cGetDBC,nPos
  387.         IF TYPE("m.cDBC") # "C"
  388.             m.cDBC  =""
  389.         ENDIF
  390.         IF EMPTY(m.cDBC) AND EMPTY(DBC()) 
  391.             RETURN ""
  392.         ENDIF
  393.         m.cGetDBC = IIF(EMPTY(m.cDBC),DBC(),UPPER(m.cDBC))
  394.         DIMENSION aDBCtmp[1,2]
  395.         =ADATA(aDBCtmp)
  396.         m.nPos = ASCAN(aDBCtmp,m.cGetDBC)
  397.     RETURN IIF(m.nPos = 0,"",aDBCtmp[m.nPos-1])
  398.     ENDPROC
  399.     
  400.     FUNCTION TableExists
  401.         PARAMETERS lcTableName
  402.         LOCAL dummy, lcSQuote
  403.         *Checks to see if a table of the same name already exists on the server    
  404.         dummy='x'
  405.         lcSQuote=CHR(39)
  406.             lcSQL="select uid from sysobjects where uid = user_id() and name =" + lcSQuote + lcTableName + lcSQuote
  407.             lcField="uid"
  408.         RETURN this.ExecuteTempSPT(lcSQL)
  409.     ENDFUNC
  410.         
  411.     FUNCTION SingleValueSPT
  412.         PARAMETERS lcSQL, lcReturnValue, lcFieldName, llReturnedOneValue
  413.         LOCAL lcMsg, lcErrMsg, llRetVal, lcCursor, lnOldArea, lnServerError
  414.         * Executes a server query and sees if it return one value or not
  415.         * If it returns one value, that value gets placed in a variable passed by reference        
  416.         lnOldArea=select()
  417.         lcCursor=this.UniqueCursorName("_spt")
  418.         SELECT 0
  419.         IF this.ExecuteTempSPT(lcSQL,@lnServerError,@lcErrMsg,lcCursor) THEN
  420.             IF RECCOUNT(lcCursor)=0 THEN
  421.                 llReturnedOneValue= .F.
  422.             ELSE
  423.                 lcReturnValue=&lcCursor..&lcFieldName
  424.                 llReturnedOneValue=.T.
  425.             ENDIF
  426.             USE
  427.         ELSE
  428.             lcMsg=STRTRAN(QUERY_FAILURE_LOC,"|1",LTRIM(STR(lnServerError)))
  429.             =MESSAGEBOX(lcMsg,ICON_EXCLAMATION,TITLE_TEXT_LOC)
  430.             this.Die
  431.             RETURN
  432.         ENDIF
  433.         SELECT (lnOldArea)
  434.         RETURN llReturnedOneValue
  435.     ENDFUNC
  436.     
  437.     FUNCTION DropTable
  438.         PARAMETERS lcTable
  439.         LOCAL lcSQL
  440.         lcSQL="drop table " + RTRIM(this.UserName) + "." + RTRIM(lcTable)
  441.         lnRetVal=this.ExecuteTempSPT(lcSQL)
  442.         RETURN lnRetVal
  443.     ENDFUNC
  444.     
  445.     FUNCTION ExecuteTempSPT
  446.         parameters lcSQL, lnServerError, lcErrMsg, lcCursor
  447.         LOCAL nRetVal, lcMsg
  448.         
  449.         nRetVal=SQLEXEC(this.MasterConnHand,lcSQL)
  450.     
  451.         DO CASE
  452.             *Success
  453.             CASE nRetVal=1 
  454.                 lnServerError=0
  455.                 lcErrMsg=""
  456.                 RETURN .T.
  457.             
  458.             *Server error occurred
  459.             CASE nRetVal=-1
  460.                 =AERROR(aErrArray)
  461.                 lnServerError=aErrArray[1]
  462.                 lcErrMsg=aErrArray[2]
  463.                 
  464.                 IF lnServerError=1526 AND !ISNULL(aErrArray[5])THEN
  465.                     lnServerError=aErrArray[5]
  466.                 ENDIF
  467.                 
  468.             
  469.             *Connection level error occurred
  470.             CASE nRetVal=-2
  471.                 *This is trouble; continue to generate script if user wants; otherwise bail
  472.                 lcMsg=STRTRAN(CONNECT_FAILURE_LOC,"|1",LTRIM(STR(lnServerErr)))
  473.                 =MESSAGEBOX(lcMsg,ICON_EXCLAMATION,TITLE_TEXT_LOC)
  474.     
  475.         ENDCASE
  476.     ENDFUNC
  477.  
  478. ENDDEFINE
  479.  
  480.  
  481.