added sysprog entities
This commit is contained in:
Infineon\StieberD
145
SYSPROG/STPROC/ACTIVE_DIRECTORY_SERVICES.txt
Normal file
145
SYSPROG/STPROC/ACTIVE_DIRECTORY_SERVICES.txt
Normal file
@ -0,0 +1,145 @@
|
||||
Compile function Active_Directory_Services(@Service, @Params)
|
||||
/***********************************************************************************************************************
|
||||
|
||||
This program is proprietary and is not to be used by or disclosed to others, nor is it to be copied without written
|
||||
permission from SRP Computer Solutions, Inc.
|
||||
|
||||
Name : Active_Directory_Services
|
||||
|
||||
Description : Handler program for all module related services.
|
||||
|
||||
Notes : The generic parameters should contain all the necessary information to process the services. Often
|
||||
this will be information like the data Record and Key ID.
|
||||
|
||||
Parameters :
|
||||
Service [in] -- Name of the service being requested
|
||||
Param1-10 [in/out] -- Additional request parameter holders
|
||||
Response [out] -- Response to be sent back to the Controller (MCP) or requesting procedure
|
||||
|
||||
History : (Date, Initials, Notes)
|
||||
02/17/23 djs Original programmer.
|
||||
|
||||
***********************************************************************************************************************/
|
||||
|
||||
#pragma precomp SRP_PreCompiler
|
||||
|
||||
$Insert SERVICE_SETUP
|
||||
$Insert APP_INSERTS
|
||||
$Insert REVDOTNETEQUATES
|
||||
|
||||
Declare subroutine Set_Property.Net
|
||||
|
||||
GoToService
|
||||
|
||||
Return Response or ""
|
||||
|
||||
//-----------------------------------------------------------------------------
|
||||
// SERVICES
|
||||
//-----------------------------------------------------------------------------
|
||||
|
||||
|
||||
Service AuthenticateUser(Username, Password, Domain)
|
||||
|
||||
Authenticated = False$
|
||||
DotNetHandle = StartDotNet("","4.0")
|
||||
DotNetDir = CheckDotNet('4.0'):'\'
|
||||
AccountMgmtDllPath = DotNetDir:'System.DirectoryServices.AccountManagement.dll'
|
||||
Set_Property.Net(DotNetHandle, "AssemblyName", AccountMgmtDllPath)
|
||||
If Not(Get_Status(errCode)) then
|
||||
Params = 'Domain':@FM:Domain
|
||||
ParamTypes = 'System.DirectoryServices.AccountManagement.ContextType':@FM:'System.String'
|
||||
objPC = Create_Class.Net(DotNetHandle, "System.DirectoryServices.AccountManagement.PrincipalContext", 0, Params, ParamTypes)
|
||||
If Not(Get_Status(errCode)) then
|
||||
Params = Username:@FM:Password
|
||||
ParamTypes = 'System.String':@FM:'System.String'
|
||||
Authenticated = Send_Message.Net(objPC, 'ValidateCredentials', Params, ParamTypes, 0)
|
||||
Swap 'True' with True$ in Authenticated
|
||||
Swap 'False' with False$ in Authenticated
|
||||
Free_Class.Net(objPC)
|
||||
end
|
||||
end
|
||||
Response = Authenticated
|
||||
|
||||
end service
|
||||
|
||||
|
||||
Service GetADGroups(Username, Domain)
|
||||
|
||||
ADGroups = ''
|
||||
DotNetHandle = StartDotNet("","4.0")
|
||||
DotNetDir = CheckDotNet('4.0'):'\'
|
||||
AccountMgmtDllPath = DotNetDir:'System.DirectoryServices.AccountManagement.dll'
|
||||
Set_Property.Net(DotNetHandle, "AssemblyName", AccountMgmtDllPath)
|
||||
If Not(Get_Status(errCode)) then
|
||||
|
||||
|
||||
Params = 'Domain':@FM:'Infineon'
|
||||
ParamTypes = 'System.DirectoryServices.AccountManagement.ContextType':@FM:'System.String'
|
||||
objPC = Create_Class.Net(DotNetHandle, "System.DirectoryServices.AccountManagement.PrincipalContext", 0, Params, ParamTypes)
|
||||
If Not(Get_Status(errCode)) then
|
||||
objUserPrincipal = Create_Class.Net(DotNetHandle, "System.DirectoryServices.AccountManagement.UserPrincipal", 0, objPC, 'RevDotNet')
|
||||
If Not(Get_Status(errCode)) then
|
||||
Set_Property.Net(objUserPrincipal, 'Name', Username)
|
||||
objPrinSearcher = Create_Class.Net(DotNetHandle, "System.DirectoryServices.AccountManagement.PrincipalSearcher", 0, objUserPrincipal, 'RevDotNet')
|
||||
If Not(Get_Status(errCode)) then
|
||||
objPrin = Send_Message.Net(objPrinSearcher, 'FindOne', '', '', 1)
|
||||
If Not(Get_Status(errCode)) then
|
||||
Name = Get_Property.Net(objPrin, 'Name', 0)
|
||||
objPrinSearchResult = Send_Message.Net(objPrin, 'GetGroups', '', '', 1)
|
||||
If Not(Get_Status(errCode)) then
|
||||
objEnum = Send_Message.Net(objPrinSearchResult, 'GetEnumerator', '', '', 1)
|
||||
If Not(Get_Status(errCode)) then
|
||||
Loop
|
||||
Done = Send_Message.Net(objEnum, 'MoveNext', '', '', 0)
|
||||
Until Done EQ 'False'
|
||||
If Not(Get_Status(errCode)) then
|
||||
objCurrPrin = Get_Property.Net(objEnum, 'Current', 1)
|
||||
If Not(Get_Status(errCode)) then
|
||||
CurrPrinName = Get_Property.Net(objCurrPrin, 'Name', 0)
|
||||
If CurrPrinName NE 'Domain Users' then ADGroups<-1> = CurrPrinName
|
||||
Free_Class.Net(objCurrPrin)
|
||||
end
|
||||
end
|
||||
Repeat
|
||||
Free_Class.Net(objEnum)
|
||||
end
|
||||
Free_Class.Net(objPrinSearchResult)
|
||||
end
|
||||
Free_Class.Net(objPrin)
|
||||
end
|
||||
Free_class.Net(objPrinSearcher)
|
||||
end
|
||||
Free_Class.Net(objUserPrincipal)
|
||||
end
|
||||
Free_Class.Net(objPC)
|
||||
end
|
||||
end
|
||||
Response = ADGroups
|
||||
|
||||
End Service
|
||||
|
||||
|
||||
Service GetComputerDomain()
|
||||
|
||||
Domain = ''
|
||||
DotNetHandle = StartDotNet("","4.0")
|
||||
DotNetDir = CheckDotNet('4.0'):'\'
|
||||
DirDllPath = DotNetDir:'System.DirectoryServices.dll'
|
||||
Set_Property.Net(DotNetHandle, "AssemblyName", DirDllPath)
|
||||
If Not(Get_Status(errCode)) then
|
||||
objDomain = Create_Class.Net(DotNetHandle, "System.DirectoryServices.ActiveDirectory.Domain", 0, '', '')
|
||||
If Not(Get_status(errCode)) then
|
||||
ObjCompDomain = Send_Message.Net(objDomain, 'GetComputerDomain', '', '', True$)
|
||||
If Not(Get_Status(errCode)) then
|
||||
Domain = Get_Property.Net(objCompDomAin, 'Name', False$)
|
||||
Free_class.Net(objCompDomain)
|
||||
end
|
||||
Free_Class.Net(objDomain)
|
||||
end
|
||||
end
|
||||
Response = Domain
|
||||
|
||||
end service
|
||||
|
||||
|
||||
|
||||
7
SYSPROG/STPROC/ADIOS.txt
Normal file
7
SYSPROG/STPROC/ADIOS.txt
Normal file
@ -0,0 +1,7 @@
|
||||
Compile Subroutine Adios(void)
|
||||
|
||||
Declare function Utility
|
||||
|
||||
rv = Utility('DESTROY','SYSTEM')
|
||||
|
||||
return
|
||||
269
SYSPROG/STPROC/AUDIT_MFS.txt
Normal file
269
SYSPROG/STPROC/AUDIT_MFS.txt
Normal file
@ -0,0 +1,269 @@
|
||||
COMPILE SUBROUTINE Audit_MFS(Code, BFS, Handle, Name, FMC, Record, Status)
|
||||
|
||||
DECLARE Subroutine Msg, FSMsg
|
||||
|
||||
COMMON /FILENAME/ Files_Array, Handles_Array
|
||||
|
||||
$INSERT FILE.SYSTEM.ONGOSUB
|
||||
$INSERT FILE.SYSTEM.EQUATES
|
||||
$INSERT MSG_EQUATES
|
||||
$INSERT AUDIT_EQUATES
|
||||
$INSERT DICT_EQUATES
|
||||
|
||||
EQU ReadRec$ TO 1
|
||||
|
||||
EQU Master$ TO 1
|
||||
EQU Dependent$ TO 2
|
||||
|
||||
|
||||
RETURN
|
||||
|
||||
/* Directly called functions - don't pass to next file system */
|
||||
|
||||
INSTALL:
|
||||
FLUSH:
|
||||
UNLOCK.ALL:
|
||||
FLUSH.CACHE:
|
||||
|
||||
Status = 1
|
||||
RETURN
|
||||
|
||||
/* Not available to MFS */
|
||||
|
||||
LOCK.SEMAPHORE:
|
||||
UNLOCK.SEMAPHORE:
|
||||
SET.USER.SEMAPHORE:
|
||||
|
||||
RETURN
|
||||
|
||||
/* Directory level calls */
|
||||
|
||||
CREATE.MEDIA:
|
||||
OPEN.MEDIA:
|
||||
CLOSE.MEDIA:
|
||||
READ.MEDIA:
|
||||
WRITE.MEDIA:
|
||||
GROUP.NUMBER:
|
||||
RECORD.COUNT:
|
||||
CREATE.FILE:
|
||||
RENAME.FILE:
|
||||
MOVE.FILE:
|
||||
DELETE.FILE:
|
||||
|
||||
Goto NEXT.FS
|
||||
|
||||
OPEN.FILE:
|
||||
|
||||
* Call BFS in order to get file handle
|
||||
|
||||
FS = DELETE(BFS,1,1,1)
|
||||
NEXTFS = FS<1,1,1>
|
||||
CALL @NEXTFS(Code, FS, Handle, Name, FMC, Record, Status)
|
||||
|
||||
* Load handle and file name into labelled common
|
||||
|
||||
IF Status THEN
|
||||
LOCATE Name IN Files_Array USING @FM SETTING POS THEN
|
||||
Handles_Array<POS> = Record
|
||||
END ELSE
|
||||
Files_Array<-1> = Name
|
||||
Handles_Array<-1> = Record
|
||||
END
|
||||
END
|
||||
RETURN
|
||||
|
||||
CLEARFILE:
|
||||
REMAKE.FILE:
|
||||
SELECT:
|
||||
READNEXT:
|
||||
CLEARSELECT:
|
||||
|
||||
READ.RECORD:
|
||||
READO.RECORD:
|
||||
|
||||
GOTO NEXT.FS
|
||||
|
||||
WRITE.RECORD:
|
||||
|
||||
* Get original record and compare with RECORD being written
|
||||
|
||||
LOCATE Handle IN Handles_Array USING @FM SETTING POS ELSE
|
||||
mesg = "Missing file handle in AUDIT_MFS!|"
|
||||
mesg := handle
|
||||
MSG('',mesg)
|
||||
Status = 0
|
||||
RETURN
|
||||
END
|
||||
|
||||
OPEN 'AUDIT' TO Audit_File ELSE
|
||||
MSG('',"Put FSMSG in AUDIT_MFS")
|
||||
*FSMsg()
|
||||
Status = 0
|
||||
RETURN
|
||||
END
|
||||
|
||||
Write_Flag = 0
|
||||
Org_Rec = ''
|
||||
NextFS = BFS<1,1,2>
|
||||
|
||||
CALL @NextFS(ReadRec$, FS, Handle, Name, FMC, Org_Rec, Status) ;* Read old record
|
||||
|
||||
File_Name = Files_Array<POS>[1,'*'] ;* Extract corresponding file name
|
||||
|
||||
Time_Date = TimeDate()
|
||||
Date_Time = FIELD(Time_Date,' ',2,4):" ":Time_Date[1,' ']
|
||||
DTM = ICONV(Date_Time,'DT2/^S')
|
||||
|
||||
Audit_Key = File_Name:"*":@USERNAME:"*":DTM:"*":Name
|
||||
|
||||
IF Status THEN
|
||||
|
||||
* Original record found - check for changes
|
||||
|
||||
IF RECORD NE Org_Rec THEN
|
||||
|
||||
Write_Flag = 1
|
||||
|
||||
AMV_Master = 0 ;* Flag for Master value found
|
||||
AMV_Dependent = 0 ;* Flag for Dependent value found
|
||||
AMV_List = '' ;* Master & Dependent field numbers
|
||||
|
||||
* Record has been modified - write changes to history
|
||||
|
||||
Pct_Field = XLATE('DICT.':File_Name,'%FIELDS%','',"X")
|
||||
|
||||
Audit_Rec = 'Change' ;* Initialize audit record & load field 1
|
||||
Change_Cnt = 1
|
||||
|
||||
FOR I = 1 TO Pct_Field<FIELDS_MAXFIELD$>
|
||||
IF RECORD<I> NE Org_Rec<I> THEN
|
||||
|
||||
IF I = AMV_List<Master$> THEN AMV_Master = 1
|
||||
LOCATE I IN AMV_List<Dependent$> USING @VM SETTING DUMMY THEN AMV_Dependent = 1
|
||||
|
||||
LOCATE I IN Pct_Field<FIELDS_FIELD_NO$> USING @VM SETTING POS THEN
|
||||
|
||||
Field_Name = Pct_Field<FIELDS_NAME$,POS>
|
||||
New_Val = RECORD<I>
|
||||
Old_Val = Org_Rec<I>
|
||||
|
||||
CONVERT @VM TO '}' IN New_Val
|
||||
CONVERT @VM TO '}' IN Old_Val
|
||||
|
||||
Audit_Rec<AUDIT_FIELDS$,Change_Cnt> = Field_Name
|
||||
Audit_Rec<AUDIT_NEW_VALS$,Change_Cnt> = New_Val
|
||||
Audit_Rec<AUDIT_OLD_VALS$,Change_Cnt> = Old_Val
|
||||
Change_Cnt += 1
|
||||
|
||||
END ; * End of check for field number in Pct_Fields
|
||||
|
||||
END ; * End of check for matching field
|
||||
|
||||
NEXT I
|
||||
|
||||
IF AMV_Dependent AND NOT(AMV_Master) THEN
|
||||
|
||||
* Dependent fields updated - write the master field also
|
||||
|
||||
Master_Field = AMV_List<Master$>
|
||||
|
||||
LOCATE Master_Field IN Pct_Field<FIELDS_FIELD_NO$> USING @VM SETTING POS THEN
|
||||
|
||||
Field_Name = Pct_Field<FIELDS_NAME$,POS>
|
||||
New_Val = RECORD<Master_Field>
|
||||
Old_Val = Org_Rec<Master_Field>
|
||||
|
||||
CONVERT @VM TO '}' IN New_Val
|
||||
CONVERT @VM TO '}' IN Old_Val
|
||||
|
||||
Audit_Rec<AUDIT_FIELDS$,Change_Cnt> = Field_Name
|
||||
Audit_Rec<AUDIT_NEW_VALS$,Change_Cnt> = New_Val
|
||||
Audit_Rec<AUDIT_OLD_VALS$,Change_Cnt> = Old_Val
|
||||
Change_Cnt += 1
|
||||
|
||||
END ; * End of locate
|
||||
|
||||
END ;* End of check for master multivalue flag
|
||||
|
||||
END ; * End of global record check
|
||||
|
||||
END ELSE
|
||||
* Old record not found => This is a new record being written
|
||||
|
||||
Audit_Rec = 'Created'
|
||||
Write_Flag = 1
|
||||
|
||||
END ; * End of Status check
|
||||
|
||||
IF Write_Flag THEN
|
||||
WRITE Audit_Rec ON Audit_File,Audit_Key ELSE
|
||||
MSG('',"Put FSMSG in AUDIT_MFS")
|
||||
*FSMsg()
|
||||
Status = 0
|
||||
RETURN
|
||||
END
|
||||
END
|
||||
|
||||
GOTO NEXT.FS
|
||||
|
||||
|
||||
DELETE.RECORD:
|
||||
|
||||
LOCATE Handle IN Handles_Array USING @FM SETTING POS ELSE
|
||||
mesg = "Missing file handle in AUDIT_MFS!|"
|
||||
mesg := handle
|
||||
MSG('',mesg)
|
||||
Status = 0
|
||||
RETURN
|
||||
END
|
||||
|
||||
OPEN 'AUDIT' TO Audit_File ELSE
|
||||
MSG('',"Put FSMSG in AUDIT_MFS")
|
||||
*FSMsg()
|
||||
Status = 0
|
||||
RETURN
|
||||
END
|
||||
|
||||
Org_Rec = ''
|
||||
NextFS = BFS<1,1,2>
|
||||
|
||||
CALL @NextFS(ReadRec$, FS, Handle, Name, FMC, Org_Rec, Status) ;* Read old record
|
||||
|
||||
File_Name = Files_Array<POS>[1,'*'] ;* Extract corresponding file name
|
||||
|
||||
Time_Date = TimeDate()
|
||||
Date_Time = FIELD(Time_Date,' ',2,4):" ":Time_Date[1,' ']
|
||||
DTM = ICONV(Date_Time,'DT2/^S')
|
||||
|
||||
Audit_Key = File_Name:"*":@USERNAME:"*":DTM:"*":Name
|
||||
|
||||
Audit_Rec = 'Deleted'
|
||||
Audit_Rec<AUDIT_DEL_RECORD$> = Org_Rec ; * Put the old record in Audit_Rec<5>
|
||||
|
||||
WRITE Audit_Rec ON Audit_File,Audit_Key ELSE
|
||||
MSG('',"Put FSMSG in AUDIT_MFS")
|
||||
*FSMsg()
|
||||
Status = 0
|
||||
RETURN
|
||||
END
|
||||
|
||||
GOTO NEXT.FS
|
||||
|
||||
/* Unused calls */
|
||||
LOCK.RECORD:
|
||||
UNLOCK.RECORD:
|
||||
RESERVED:
|
||||
OMNI.SCRIPT:
|
||||
|
||||
CREATE.INDEX:
|
||||
DELETE.INDEX:
|
||||
SELECT.INDEX:
|
||||
UPDATE.INDEX:
|
||||
READNEXT.INDEX:
|
||||
|
||||
NEXT.FS:
|
||||
|
||||
FS = DELETE(BFS,1,1,1)
|
||||
NEXTFS = FS<1,1,1>
|
||||
CALL @NEXTFS(Code, FS, Handle, Name, FMC, Record, Status)
|
||||
RETURN
|
||||
74
SYSPROG/STPROC/AUTHENTICATE_LDAP.txt
Normal file
74
SYSPROG/STPROC/AUTHENTICATE_LDAP.txt
Normal file
@ -0,0 +1,74 @@
|
||||
function Authenticate_LDAP(void)
|
||||
|
||||
$Insert LOGICAL
|
||||
|
||||
/* equates for the base registry keys */
|
||||
equ HKEY_CLASSES_ROOT$ to 0x80000000
|
||||
equ HKEY_CURRENT_USER$ to 0x80000001
|
||||
equ HKEY_LOCAL_MACHINE$ to 0x80000002
|
||||
equ HKEY_USERS$ to 0x80000003
|
||||
equ HKEY_PERFORMANCE_DATA$ to 0x80000004
|
||||
equ HKEY_CURRENT_CONFIG$ to 0x80000005
|
||||
equ HKEY_DYN_DATA$ to 0x80000006
|
||||
equ KEY_QUERY_VALUE$ to 0x0001
|
||||
equ ERROR_SUCCESS to 0x0000
|
||||
|
||||
Declare subroutine Set_Property.Net, Utility, RegQueryValueEx, Msg, Create_User, RTI_Create_User_Details
|
||||
Declare Subroutine Set_Property
|
||||
Declare function Active_Directory_Services, RegOpenKeyEx, RTI_GetNetworkUserName, RegCloseKey
|
||||
Declare Function Database_Services
|
||||
|
||||
Log = @AppId<1>
|
||||
Oswrite Log to 'D:\Temp\auth.txt'
|
||||
|
||||
Authenticated = False$
|
||||
Options = 0
|
||||
SamDesired = KEY_QUERY_VALUE$
|
||||
KeyHandle = 0
|
||||
Hkey = HKEY_LOCAL_MACHINE$
|
||||
SubKey = "SYSTEM\CurrentControlSet\Services\Tcpip\Parameters":\00\
|
||||
Stat = 0
|
||||
Null = ''
|
||||
LockVariable KeyHandle as Long
|
||||
Stat = RegOpenKeyEx(Hkey, SubKey, Options, SamDesired, KeyHandle)
|
||||
If Stat = ERROR_SUCCESS Then
|
||||
Domain = str(\00\, 512)
|
||||
Reg_SZ = 1
|
||||
CbBuf = 512
|
||||
Key = "Domain":\00\
|
||||
RegQueryValueEx(KeyHandle, Key, 0, Reg_SZ, Domain, CbBuf)
|
||||
Domain = Domain[1, CbBuf - 1]
|
||||
end
|
||||
rv = RegCloseKey(KeyHandle)
|
||||
|
||||
UserADName = RTI_GetNetworkUserName()
|
||||
UserADGroups = Active_Directory_Services('GetADGroups', UserADName, Domain)
|
||||
**SSOInfo = Database_Services('ReadDataRow', 'SYSENV', 'CFG_LOGIN*':@AppId<1>)
|
||||
*SSOErrorMsg = SSOInfo<9>
|
||||
*SSOADGroups = Field(SSOInfo, @FM, 2, 3)
|
||||
SSOADGroups = Database_Services('ReadDataRow', 'SYSENV', 'SSO*LSL2')
|
||||
|
||||
For GroupIndex = 3 to 1 Step -1
|
||||
SSOADGroup = SSOADGroups<GroupIndex>
|
||||
If InList(UserADGroups, SSOADGroup, @FM) then
|
||||
@UserName = UserADName
|
||||
SecurityLevel = GroupIndex - 1
|
||||
@Admin = SecurityLevel
|
||||
Authenticated = True$
|
||||
Set_Property( "SYSTEM", "LOGININFO" , 'LSL2':@FM:UserADName:@FM:'')
|
||||
end
|
||||
Until Authenticated
|
||||
Next GroupIndex
|
||||
|
||||
Swap 1 With 'True' In Authenticated
|
||||
Swap 0 With 'False' In Authenticated
|
||||
Log := ', Authenticated ':Authenticated
|
||||
Oswrite Log to 'D:\Temp\auth.txt'
|
||||
|
||||
If Not(Authenticated) then
|
||||
Msg(@Window, 'SSO Error')
|
||||
Utility('DESTROY', 'SYSTEM')
|
||||
End
|
||||
|
||||
Return
|
||||
|
||||
449
SYSPROG/STPROC/BASE_MFS.txt
Normal file
449
SYSPROG/STPROC/BASE_MFS.txt
Normal file
@ -0,0 +1,449 @@
|
||||
Subroutine Base_MFS(Code, FSList, Handle, Name, FMC, Record, Status)
|
||||
/***********************************************************************************************************************
|
||||
|
||||
This program is proprietary and is not to be used by or disclosed to others, nor is it to be copied without written
|
||||
permission from SRP Computer Solutions, Inc.
|
||||
|
||||
Name : Base_MFS
|
||||
|
||||
Description : Base MFS (Modified File System) shell for general use.
|
||||
|
||||
Notes : Used to track activity in a given database table, regardless of how the table is accessed.
|
||||
Generally the MFS remains as generic as possible and makes a call to another table-specific stored
|
||||
procedure to handle all of the main functionality.
|
||||
|
||||
MFS procedures should normally be stored in the SYSPROG application for optimum accessibility.
|
||||
The table-specific stored procedures should be stored in the local application.
|
||||
|
||||
Some methods might need the regular name of the database table. Since the MFS routine does not
|
||||
normally provide this information we need to track it ourselves. The OPEN.FILE method gives us
|
||||
an opportunity to retrieve the regular name as well as the table handle. This information is then
|
||||
stored in the /Tables/ global common for convenient reference.
|
||||
|
||||
Record based actions (e.g. READ.RECORD, WRITE.RECORD, DELETE.RECORD) will be routed to table
|
||||
specific and promoted (i.e. generic) action handlers befoe the BFS is called (Call_Next_FS internal
|
||||
method.) The MFS argument Status can be set accordingly to determine how the rest of the action
|
||||
chain should be executed (see the ACTION_SETUP insert for more information.)
|
||||
|
||||
Parameters :
|
||||
Code [in] -- An integer value indicating the operation to be performed (1 = read a record, 4 = delete a
|
||||
record, 11 = open a file, etc.)
|
||||
FSList [in] -- The list of MFSs and the BFS name for the current file or volume. This is an @SVM delimited
|
||||
array, with the current MFS name as the first value in the array, and the BFS name as the
|
||||
last value.
|
||||
Handle [in] -- The file handle of the file or media map being accessed. Note, this does contain the entire
|
||||
handle structure that the Basic+ Open statement would provide.
|
||||
Name [in] -- The name (key) of the record or file being accessed.
|
||||
FMC [in] -- Various functions.
|
||||
Record [in] -- The entire record (for record-oriented functions) or a newly-created handle (for "get
|
||||
handle" functions).
|
||||
Status [out/in] -- A return code indicating the success or failure of an operation.
|
||||
|
||||
History : (Date, Initials, Notes)
|
||||
07/27/10 dmb Original programmer
|
||||
03/26/11 dmb Save and restore @FILE.ERROR to prevent incorrect error messages being passed down the line.
|
||||
05/03/16 dmb [SRPFW-124] Revise the Get_Original_Record logic to call the remaing MFS chain rather
|
||||
than just try to call the BFS directly.
|
||||
06/09/16 dmb [SRPFW-282] Update the CLEARFILE action to gosub to Action_Chain rather than Call_Next_FS
|
||||
so the promoted action can be invoked.
|
||||
09/18/19 dmb [SRPFW-282] Update OPEN.FILE to set the volume based on the path in the handle
|
||||
(Record argument).
|
||||
06/25/20 dmb [SRPFW-282] Update OPEN.FILE to also remove the Table*Database prefix in the Record
|
||||
argument if it exists.
|
||||
09/10/20 dmb [SRPFW-282] Update OPEN.FILE to default Volume to REVBOOT.
|
||||
|
||||
***********************************************************************************************************************/
|
||||
|
||||
#pragma precomp SRP_PreCompiler
|
||||
|
||||
$insert LOGICAL
|
||||
$insert FSERRORS_HDR
|
||||
$insert FILE.SYSTEM.EQUATES
|
||||
$insert ACTION_SETUP
|
||||
|
||||
Declare subroutine SRP_Stopwatch
|
||||
|
||||
Actions = 'READ_RECORD,READONLY_RECORD,WRITE_RECORD,DELETE_RECORD,LOCK_RECORD,UNLOCK_RECORD,SELECT,READNEXT,'
|
||||
Actions := 'CLEARSELECT,CLEARFILE,OPEN_FILE,CREATE_FILE,RENAME_FILE,MOVE_FILE,DELETE_FILE,OPEN_MEDIA,CREATE_MEDIA,'
|
||||
Actions := 'READ_MEDIA,WRITE_MEDIA,UNLOCK_ALL,FLUSH,INSTALL,RESERVED,RESERVED,RESERVED,OMNI_SCRIPT,CLOSE_MEDIA,'
|
||||
Actions := 'RECORD_COUNT,REMAKE_FILE,CREATE_INDEX,DELETE_INDEX,UPDATE_INDEX,SELECT_INDEX,READNEXT_INDEX'
|
||||
BaseAction = Field(Actions, ',', Code)
|
||||
|
||||
// Initialize the ActionFlow variable. Assume the action will chain forward.
|
||||
ActionFlow = ACTION_CONTINUE$
|
||||
|
||||
// Initialize the OrigRecord variable. The WRITE.RECORD and DELETE.RECORD actions will populate this.
|
||||
OrigRecord = ''
|
||||
|
||||
// FILE.SYSTEM.ONGOSUB has the On Code GoSub... command
|
||||
$insert FILE.SYSTEM.ONGOSUB
|
||||
|
||||
Return
|
||||
|
||||
|
||||
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
|
||||
// MFS Actions
|
||||
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
|
||||
|
||||
READ.RECORD:
|
||||
GoSub Action_Chain
|
||||
return
|
||||
|
||||
|
||||
READO.RECORD:
|
||||
GoSub Action_Chain
|
||||
return
|
||||
|
||||
|
||||
WRITE.RECORD:
|
||||
// Get the original (static) record from the database table.
|
||||
GoSub Get_Original_Record
|
||||
|
||||
GoSub Action_Chain
|
||||
return
|
||||
|
||||
|
||||
DELETE.RECORD:
|
||||
// Get the original (static) record from the database table.
|
||||
GoSub Get_Original_Record
|
||||
|
||||
GoSub Action_Chain
|
||||
return
|
||||
|
||||
|
||||
LOCK.RECORD:
|
||||
GoSub Call_Next_FS
|
||||
return
|
||||
|
||||
|
||||
UNLOCK.RECORD:
|
||||
GoSub Call_Next_FS
|
||||
return
|
||||
|
||||
|
||||
SELECT:
|
||||
GoSub Call_Next_FS
|
||||
return
|
||||
|
||||
|
||||
READNEXT:
|
||||
GoSub Call_Next_FS
|
||||
return
|
||||
|
||||
|
||||
CLEARSELECT:
|
||||
GoSub Call_Next_FS
|
||||
return
|
||||
|
||||
|
||||
CLEARFILE:
|
||||
GoSub Action_Chain
|
||||
return
|
||||
|
||||
|
||||
OPEN.FILE:
|
||||
// Call BFS in order to get the table handle. The regular name of the table will be returned in the Name argument
|
||||
// and the handle will be returned in the Record argument.
|
||||
GoSub Call_Next_FS
|
||||
|
||||
// Load the handle and table name into the labelled common.
|
||||
If Status then
|
||||
TableName = Name[1, '*']
|
||||
Accountname = Name[Col2() + 1, '999']
|
||||
Volume = Record[-1, 'B' : @TM]
|
||||
Volume = Volume[14, 9999]
|
||||
Volume[-12, 12] = ''
|
||||
If Volume EQ '' then Volume = 'REVBOOT'
|
||||
Locate TableName in TableNames@ using @FM Setting fPos then
|
||||
If TableHandles@<fPos> EQ Record else
|
||||
// There is a new handle for the indicated table. This could be the same table name from a different
|
||||
// volume or an updated handle for the same table. Either way, just append a new handle/table pair
|
||||
// to the lookup arrays.
|
||||
TableNames@ := TableName : @FM
|
||||
TableAccounts@ := AccountName : @FM
|
||||
TableHandles@ := Record : @FM
|
||||
TableVolumes@ := Volume : @FM
|
||||
end
|
||||
end else
|
||||
TableNames@ := TableName : @FM
|
||||
TableAccounts@ := AccountName : @FM
|
||||
TableHandles@ := Record : @FM
|
||||
TableVolumes@ := Volume : @FM
|
||||
end
|
||||
end
|
||||
return
|
||||
|
||||
|
||||
CREATE.FILE:
|
||||
GoSub Call_Next_FS
|
||||
return
|
||||
|
||||
|
||||
RENAME.FILE:
|
||||
GoSub Call_Next_FS
|
||||
return
|
||||
|
||||
|
||||
MOVE.FILE:
|
||||
GoSub Call_Next_FS
|
||||
return
|
||||
|
||||
|
||||
DELETE.FILE:
|
||||
GoSub Call_Next_FS
|
||||
return
|
||||
|
||||
|
||||
OPEN.MEDIA:
|
||||
GoSub Call_Next_FS
|
||||
return
|
||||
|
||||
CREATE.MEDIA:
|
||||
GoSub Call_Next_FS
|
||||
return
|
||||
|
||||
|
||||
READ.MEDIA:
|
||||
GoSub Call_Next_FS
|
||||
return
|
||||
|
||||
|
||||
WRITE.MEDIA:
|
||||
GoSub Call_Next_FS
|
||||
return
|
||||
|
||||
|
||||
UNLOCK.ALL:
|
||||
Record = ''
|
||||
Status = ACTION_CONTINUE$
|
||||
return
|
||||
|
||||
|
||||
FLUSH:
|
||||
Record = ''
|
||||
Status = ACTION_CONTINUE$
|
||||
return
|
||||
|
||||
|
||||
INSTALL:
|
||||
Status = ACTION_CONTINUE$
|
||||
return
|
||||
|
||||
|
||||
RESERVED:
|
||||
// There is a critical error if this has been reached.
|
||||
Status = ACTION_STOP$
|
||||
return
|
||||
|
||||
|
||||
OMNI.SCRIPT:
|
||||
GoSub Call_Next_FS
|
||||
return
|
||||
|
||||
|
||||
CLOSE.MEDIA:
|
||||
GoSub Call_Next_FS
|
||||
return
|
||||
|
||||
|
||||
RECORD.COUNT:
|
||||
GoSub Call_Next_FS
|
||||
return
|
||||
|
||||
|
||||
REMAKE.FILE:
|
||||
GoSub Call_Next_FS
|
||||
return
|
||||
|
||||
|
||||
CREATE.INDEX:
|
||||
GoSub Call_Next_FS
|
||||
return
|
||||
|
||||
|
||||
DELETE.INDEX:
|
||||
GoSub Call_Next_FS
|
||||
return
|
||||
|
||||
|
||||
UPDATE.INDEX:
|
||||
GoSub Call_Next_FS
|
||||
return
|
||||
|
||||
|
||||
SELECT.INDEX:
|
||||
GoSub Call_Next_FS
|
||||
return
|
||||
|
||||
|
||||
READNEXT.INDEX:
|
||||
GoSub Call_Next_FS
|
||||
return
|
||||
|
||||
|
||||
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
|
||||
// Internal GoSubs
|
||||
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
|
||||
|
||||
Get_Original_Record:
|
||||
// To get the original record from the database table a direct call to this table's remaing chain must be made.
|
||||
@FILE.ERROR = ''
|
||||
NewFSList = Delete(FSList, 1, 1, 1)
|
||||
NextFS = NewFSList<1, 1, 1>
|
||||
Call @NextFS(READO.RECORD, NewFSList, Handle, Name, FMC, OrigRecord, ActionStatus)
|
||||
// If ActionStatus is Null then it is a new record or an error reading.
|
||||
return
|
||||
|
||||
|
||||
Call_Next_FS:
|
||||
// Since this MFS is being executed it is responsible for moving the chain forward. The next MFS/BFS item is in the
|
||||
// BFS array. Pull it from the top and pass the remaining items.
|
||||
NewFSList = Delete(FSList, 1, 1, 1)
|
||||
NextFS = NewFSList<1, 1, 1>
|
||||
If Len(NextFS) then
|
||||
Call @NextFS(Code, NewFSList, Handle, Name, FMC, Record, Status)
|
||||
end
|
||||
return
|
||||
|
||||
|
||||
Action_Chain:
|
||||
// This internal method provides the developer with a complete chain of actions. Prior to the BFS call the developer
|
||||
// can execute logic in a table specific action handler and then a promoted (i.e. generic) action handler. The
|
||||
// action will be suffixed with '_PRE' to identify the action logic before the BFS. After the BFS the table specific
|
||||
// action handler and promoted action handler will be called again. This is very analogous to the way event handling
|
||||
// in OpenInsight is managed (i.e. pre-system event handler, system event handler, post-system event handler.)
|
||||
Action = BaseAction : '_PRE'
|
||||
|
||||
GoSub Call_Table_Actions
|
||||
|
||||
If ActionFlow EQ ACTION_CONTINUE$ OR ActionFlow EQ ACTION_CONTINUE_NO_SYSTEM$ then
|
||||
GoSub Call_Promoted_Actions
|
||||
end
|
||||
|
||||
If ActionFlow EQ ACTION_CONTINUE$ OR ActionFlow EQ ACTION_CONTINUE_NO_PROMOTED$ OR ActionFlow EQ ACTION_SYSTEM_ONLY$ then
|
||||
GoSub Call_Next_FS
|
||||
end
|
||||
|
||||
Action = BaseAction
|
||||
If ActionFlow EQ ACTION_CONTINUE$ OR ActionFlow EQ ACTION_CONTINUE_NO_PROMOTED$ OR ActionFlow EQ ACTION_CONTINUE_NO_SYSTEM$ then
|
||||
GoSub Call_Table_Actions
|
||||
end
|
||||
|
||||
If ActionFlow EQ ACTION_CONTINUE$ OR ActionFlow EQ ACTION_CONTINUE_NO_SYSTEM$ then
|
||||
GoSub Call_Promoted_Actions
|
||||
end
|
||||
return
|
||||
|
||||
|
||||
Call_Table_Actions:
|
||||
// Pass activity to the datatable table's action handler if it exists.
|
||||
// Note: It is critical that handler routine be named in this format: TableName_ACTIONS
|
||||
|
||||
// Check to see if this table has already been determine to have an action handler. Once it has already been
|
||||
// checked, whether or not a handler exists, it will not be checked again during this session. This will optimize
|
||||
// performance.
|
||||
InActionList = False$ ; // Assume False for now.
|
||||
InNoActionList = False$ ; // Assume False for now.
|
||||
|
||||
InActionList = SRP_List_Locate(ActionListHandle@, TableName) NE 0
|
||||
If Not(InActionList) then
|
||||
InNoActionList = SRP_List_Locate(NoActionListHandle@, TableName)
|
||||
end
|
||||
|
||||
If Not(InActionList) AND Not(InNoActionList) then
|
||||
// This table has not yet been added to either list, so a table action handler might exist.
|
||||
NumApps = Count(@APPID, @FM) + (@APPID NE '')
|
||||
|
||||
// Starting with the current application, search for an action routine and go through the list of inherited
|
||||
// applications until SYSPROG has been checked.
|
||||
For AppCnt = 1 to NumApps
|
||||
AppID = @APPID<AppCnt>
|
||||
If AppID _EQC 'SYSPROG' then
|
||||
SysObjKey = '$' : TableName : '_ACTIONS'
|
||||
end else
|
||||
SysObjKey = '$' : TableName : '_ACTIONS' : '*' : @APPID<AppCnt>
|
||||
end
|
||||
If Len(SysObjHandle@) then
|
||||
OrigFileError = @FILE.ERROR
|
||||
@FILE.ERROR = ''
|
||||
BFS = 'RTP57'
|
||||
Call @BFS(READO.RECORD, BFS, SysObjHandle@, SysObjKey, FMC, SysObjRecord, ActionStatus)
|
||||
@FILE.ERROR = OrigFileError
|
||||
If ActionStatus then InActionList = True$
|
||||
end
|
||||
Until InActionList
|
||||
Next AppCnt
|
||||
|
||||
If (InActionList) then
|
||||
SRP_List_Add(ActionListHandle@, TableName)
|
||||
end else
|
||||
SRP_List_Add(NoActionListHandle@, TableName)
|
||||
end
|
||||
end
|
||||
|
||||
If InActionList then
|
||||
ActionRoutine = TableName : '_ACTIONS'
|
||||
Transfer ActionFlow to OrigActionFlow ; // Save the current action flow.
|
||||
ActionFlow = Function(@ActionRoutine(Action, '', FSList, Handle, Name, FMC, Record, Status, OrigRecord))
|
||||
|
||||
// If the table action returned ACTION_CONTINUE, then this means no special action flow was returned.
|
||||
// Therefore, restore the action flow that existed before the table action call.
|
||||
If ActionFlow EQ ACTION_CONTINUE$ then Transfer OrigActionFlow to ActionFlow
|
||||
end
|
||||
return
|
||||
|
||||
|
||||
Call_Promoted_Actions:
|
||||
// Pass activity to the application's promoted action handler if it exists.
|
||||
// Note: It is critical that handler routine be named in this format: PROMOTED_BaseAction_ACTION
|
||||
|
||||
// Check to see if this action has already been determine to have a promoted handler. Once it has already been
|
||||
// checked, whether or not a handler exists, it will not be checked again during this session. This will optimize
|
||||
// performance.
|
||||
InNoPromotedList = False$ ; // Assume False for now.
|
||||
InPromotedList = SRP_List_Locate(PromotedListHandle@, BaseAction) NE 0
|
||||
If Not(InPromotedList) then
|
||||
InNoPromotedList = SRP_List_Locate(NoPromotedListHandle@, BaseAction)
|
||||
end
|
||||
|
||||
If Not(InPromotedList) AND Not(InNoPromotedList) then
|
||||
// This action has not yet been added to either list, so a promoted action handler might exist.
|
||||
NumApps = Count(@APPID, @FM) + (@APPID NE '')
|
||||
|
||||
// Starting with the current application, search for an action routine and go through the list of inherited
|
||||
// applications until SYSPROG has been checked.
|
||||
For AppCnt = 1 to NumApps
|
||||
AppID = @APPID<AppCnt>
|
||||
If AppID _EQC 'SYSPROG' then
|
||||
SysObjKey = '$PROMOTED_' : BaseAction : '_ACTION'
|
||||
end else
|
||||
SysObjKey = '$PROMOTED_' : BaseAction : '_ACTION' : '*' : @APPID<AppCnt>
|
||||
end
|
||||
If Len(SysObjHandle@) then
|
||||
OrigFileError = @FILE.ERROR
|
||||
@FILE.ERROR = ''
|
||||
BFS = 'RTP57'
|
||||
Call @BFS(READO.RECORD, BFS, SysObjHandle@, SysObjKey, FMC, SysObjRecord, ActionStatus)
|
||||
@FILE.ERROR = OrigFileError
|
||||
If ActionStatus then InPromotedList = True$
|
||||
end
|
||||
Until InPromotedList
|
||||
Next AppCnt
|
||||
|
||||
If (InPromotedList) then
|
||||
SRP_List_Add(PromotedListHandle@, BaseAction)
|
||||
end else
|
||||
SRP_List_Add(NoPromotedListHandle@, BaseAction)
|
||||
end
|
||||
end
|
||||
|
||||
If InPromotedList then
|
||||
ActionRoutine = 'PROMOTED_' : BaseAction : '_ACTION'
|
||||
Transfer ActionFlow to OrigActionFlow ; // Save the current action flow.
|
||||
ActionFlow = Function(@ActionRoutine(Action, '', FSList, Handle, Name, FMC, Record, Status, OrigRecord))
|
||||
|
||||
// If the promoted action returned ACTION_CONTINUE, then this means no special action flow was returned.
|
||||
// Therefore, restore the action flow that existed before the promoted action call.
|
||||
If ActionFlow EQ ACTION_CONTINUE$ then Transfer OrigActionFlow to ActionFlow
|
||||
end
|
||||
return
|
||||
146
SYSPROG/STPROC/COMM_DIALOG_IDXSVR.txt
Normal file
146
SYSPROG/STPROC/COMM_DIALOG_IDXSVR.txt
Normal file
@ -0,0 +1,146 @@
|
||||
COMPILE FUNCTION Comm_Dialog_IDXSVR( Instruction, Parm1 )
|
||||
|
||||
/*
|
||||
Commuter Module for Index Server (IDXSVR) Dialog Window
|
||||
|
||||
J.C. Henry, Inc. - John C. Henry
|
||||
|
||||
*/
|
||||
|
||||
DECLARE SUBROUTINE Center_Window,StatusLine,Set_Property,End_Dialog, Send_Event, Set_Status, Adios
|
||||
DECLARE SUBROUTINE ErrMsg, Send_Message, obj_Tables, Post_Event, Set_Bgnd_IX_Time, Set_IDXSvr, ShowWindow
|
||||
DECLARE FUNCTION Get_Property, Get_Status,Dialog_Box, FindWindow
|
||||
|
||||
EQU CRLF$ TO \0D0A\
|
||||
|
||||
EQU TRUE$ TO 1
|
||||
EQU FALSE$ TO 2
|
||||
|
||||
$INSERT ENVIRON_CONSTANTS
|
||||
|
||||
ErrTitle = 'Error in Comm_Dialog_IDXSVR routine'
|
||||
ErrorMsg = ''
|
||||
|
||||
|
||||
Instructions = 'Create'
|
||||
Instructions := @FM:'Timer'
|
||||
Instructions := @FM:'StartStop'
|
||||
Instructions := @FM:'Close'
|
||||
|
||||
RetVal = ''
|
||||
|
||||
LOCATE Instruction IN Instructions USING @FM SETTING Pos THEN
|
||||
ON Pos GOSUB Create,Timer,StartStop,Close
|
||||
END
|
||||
|
||||
RETURN RetVal
|
||||
|
||||
|
||||
* * * * * * *
|
||||
Create:
|
||||
* * * * * * *
|
||||
|
||||
*Center_Window(@WINDOW)
|
||||
|
||||
StatusLine(@WINDOW)
|
||||
|
||||
Set_Status(0)
|
||||
|
||||
otParms = 'SYSOBJ':@RM:'INDEX_SERVER'
|
||||
obj_Tables('LockRec',otParms) ;* Places lock on fictional record
|
||||
|
||||
IF Get_Status(errCode) THEN
|
||||
ErrorMsg = ErrTitle:@SVM:'Another index server is already running.'
|
||||
ErrMsg(ErrorMsg)
|
||||
Post_Event(@WINDOW,'CLOSE')
|
||||
RETURN
|
||||
END
|
||||
|
||||
Set_Property(@WINDOW,'@LOCKED',1) ;* Set ad-hoc property '@LOCKED' to true
|
||||
*Set_Property(@WINDOW,'TIMER','5000':@FM:'0') ;* Set timer event to 5000 msecs (5 seconds) to check for shutdown time.
|
||||
|
||||
* Code added 6/9/2004 to show engine window when running on a runtime JCH
|
||||
|
||||
OpenEngineHandle = FindWindow("AREV":\00\,0)
|
||||
ShowWindow(OpenEngineHandle,1)
|
||||
|
||||
|
||||
|
||||
* No return on create -> automatically starts index server
|
||||
|
||||
* * * * * * *
|
||||
StartStop:
|
||||
* * * * * * *
|
||||
|
||||
StartStop = Get_Property(@WINDOW:'.START_STOP_BUTTON','TEXT')
|
||||
|
||||
IF StartStop = 'Stop Index Server' THEN
|
||||
|
||||
* Index server is running
|
||||
|
||||
Set_IDXSvr(0) ;* Turn off index server
|
||||
Set_Bgnd_IX_Time(0) ;* Turn off background indexing by setting interval to zero
|
||||
Set_Property(@WINDOW:'.START_STOP_BUTTON','TEXT', 'Start Index Server')
|
||||
Set_Property(@WINDOW:'.CLOSE_BUTTON','ENABLED',1)
|
||||
|
||||
END ELSE
|
||||
|
||||
IndexInterval = Get_Property(@WINDOW:'.INTERVAL','TEXT')
|
||||
|
||||
IF IndexInterval = '' THEN
|
||||
* bad value entered or null
|
||||
IndexInterval = 10
|
||||
Set_Property(@WINDOW:'.INTERVAL','INVAL',IndexInterval)
|
||||
END
|
||||
|
||||
Set_Bgnd_IX_Time(IndexInterval) ;* Set background index inteval to IndexInterval (Seconds)
|
||||
Set_Property(@WINDOW:'.START_STOP_BUTTON','TEXT', 'Stop Index Server')
|
||||
Set_IDXSvr(1) ;* Start the index server process
|
||||
Set_Property(@WINDOW:'.CLOSE_BUTTON','ENABLED',0)
|
||||
|
||||
END
|
||||
|
||||
|
||||
RETURN
|
||||
|
||||
|
||||
* * * * * * *
|
||||
Close:
|
||||
* * * * * * *
|
||||
|
||||
otParms = 'SYSOBJ':@RM:'INDEX_SERVER'
|
||||
|
||||
obj_Tables('LockRec',otParms) ;* Places lock on fictional record
|
||||
|
||||
IF Get_Status(errCode) THEN
|
||||
Set_Status(0)
|
||||
obj_Tables('UnlockRec',otParms) ;* Removes lock on fictional record
|
||||
|
||||
END
|
||||
|
||||
Set_Property('SYSTEM','IDLEPROC','ADIOS')
|
||||
*Adios() ;* Utility('SYSTEM','DESTROY') in a wrapper
|
||||
|
||||
RETURN
|
||||
|
||||
|
||||
* * * * * * *
|
||||
Timer:
|
||||
* * * * * * *
|
||||
|
||||
ShutDownTime = Get_Property(@WINDOW:'.SHUTDOWN_TIME','INVALUE')
|
||||
|
||||
Set_Property(@WINDOW:'.COUNTDOWN','INVALUE',ShutDownTime - TIME())
|
||||
|
||||
IF TIME() > ShutDownTime THEN
|
||||
|
||||
Set_IDXSvr(0) ;* Turn off index server
|
||||
Set_Bgnd_IX_Time(0) ;* Turn off background indexing by setting interval to zero
|
||||
Set_Property('SYSTEM','IDLEPROC','ADIOS')
|
||||
|
||||
END
|
||||
|
||||
|
||||
RETURN
|
||||
|
||||
|
||||
56
SYSPROG/STPROC/CONVERT_LSL2_FORMS.txt
Normal file
56
SYSPROG/STPROC/CONVERT_LSL2_FORMS.txt
Normal file
@ -0,0 +1,56 @@
|
||||
Function Convert_LSL2_Forms(Void)
|
||||
|
||||
#pragma precomp SRP_PreCompiler
|
||||
|
||||
$Insert Logical
|
||||
|
||||
Declare Function RTI_Migrate_Repository_Entity_OIWin, Repository
|
||||
|
||||
debug
|
||||
|
||||
Open 'SYSUPGRADE' To hSysUpgrade Then
|
||||
Select hSysUpgrade
|
||||
EOF = False$
|
||||
Loop
|
||||
Readnext ID Else EOF = True$
|
||||
Until EOF EQ True$
|
||||
* If Index(ID, 'NDW_MAIN', 1) Then
|
||||
* DEBUG
|
||||
Read V9OIWinRec From hSysUpgrade, ID Then
|
||||
If Index(ID, 'SYSREPOSWINS', 1) then Gosub WriteAndCompile
|
||||
End Else
|
||||
debug
|
||||
Status = Get_Status(StatusCode)
|
||||
rv = Set_Status(0)
|
||||
end
|
||||
* end
|
||||
Repeat
|
||||
end
|
||||
|
||||
Return ''
|
||||
|
||||
|
||||
WriteAndCompile:
|
||||
|
||||
V10OIWinRec = RTI_Migrate_Repository_Entity_OIWin(V9OIWinRec, WarningText, UpdateText, @AppID)
|
||||
|
||||
If V10OIWinRec NE '' Then
|
||||
WinID = ID[-1, 'B*']
|
||||
ReposID = @AppID<1> : '*OIWIN**' : WinID
|
||||
FormPart1 = V10OIWinRec[1, @RM]
|
||||
FormPart2 = V10OIWinRec[Col2() + 1, @RM]
|
||||
WindowTitle = FormPart2<0, 9>
|
||||
rv = Repository('WRITE', ReposID, '', '', '', '', '', '', '', '', WindowTitle, V10OIWinRec)
|
||||
If Get_Status(StatusCode) Then
|
||||
debug
|
||||
rv = Set_Status(0)
|
||||
End Else
|
||||
rv = Repository('COMPILE', ReposID)
|
||||
If Get_Status(StatusCode) Then
|
||||
debug
|
||||
rv = Set_Status(0)
|
||||
end
|
||||
end
|
||||
end
|
||||
|
||||
Return ''
|
||||
56
SYSPROG/STPROC/CONVERT_OI9_FORMS.txt
Normal file
56
SYSPROG/STPROC/CONVERT_OI9_FORMS.txt
Normal file
@ -0,0 +1,56 @@
|
||||
Function Convert_OI9_Forms(Void)
|
||||
|
||||
#pragma precomp SRP_PreCompiler
|
||||
|
||||
$Insert Logical
|
||||
|
||||
Declare Function RTI_Migrate_Repository_Entity_OIWin, Repository
|
||||
|
||||
debug
|
||||
|
||||
Open 'SYSUPGRADE' To hSysUpgrade Then
|
||||
Select hSysUpgrade
|
||||
EOF = False$
|
||||
Loop
|
||||
Readnext ID Else EOF = True$
|
||||
Until EOF EQ True$
|
||||
* If Index(ID, 'NDW_MAIN', 1) Then
|
||||
* DEBUG
|
||||
Read V9OIWinRec From hSysUpgrade, ID Then
|
||||
Gosub WriteAndCompile
|
||||
End Else
|
||||
debug
|
||||
Status = Get_Status(StatusCode)
|
||||
rv = Set_Status(0)
|
||||
end
|
||||
* end
|
||||
Repeat
|
||||
end
|
||||
|
||||
Return ''
|
||||
|
||||
|
||||
WriteAndCompile:
|
||||
|
||||
V10OIWinRec = RTI_Migrate_Repository_Entity_OIWin(V9OIWinRec, WarningText, UpdateText, @AppID)
|
||||
|
||||
If V10OIWinRec NE '' Then
|
||||
WinID = ID[-1, 'B*']
|
||||
ReposID = @AppID<1> : '*OIWIN**' : WinID
|
||||
FormPart1 = V10OIWinRec[1, @RM]
|
||||
FormPart2 = V10OIWinRec[Col2() + 1, @RM]
|
||||
WindowTitle = FormPart2<0, 9>
|
||||
rv = Repository('WRITE', ReposID, '', '', '', '', '', '', '', '', WindowTitle, V10OIWinRec)
|
||||
If Get_Status(StatusCode) Then
|
||||
debug
|
||||
rv = Set_Status(0)
|
||||
End Else
|
||||
rv = Repository('COMPILE', ReposID)
|
||||
If Get_Status(StatusCode) Then
|
||||
debug
|
||||
rv = Set_Status(0)
|
||||
end
|
||||
end
|
||||
end
|
||||
|
||||
Return ''
|
||||
1046
SYSPROG/STPROC/DATABASE_SERVICES.txt
Normal file
1046
SYSPROG/STPROC/DATABASE_SERVICES.txt
Normal file
File diff suppressed because it is too large
Load Diff
271
SYSPROG/STPROC/DEBUGGER_DUMP.txt
Normal file
271
SYSPROG/STPROC/DEBUGGER_DUMP.txt
Normal file
@ -0,0 +1,271 @@
|
||||
compile subroutine debugger_Dump( void )
|
||||
/*
|
||||
Author : Meester C
|
||||
Date : 21 October 2008
|
||||
Purpose : Simple function to grab all the variable contents in a broken
|
||||
proc and write them out to a "DEBUGGER_DUMP" record in SYSLISTS
|
||||
|
||||
Comments
|
||||
========
|
||||
|
||||
This is a very basic procedure. It would really be a good idea to monitor
|
||||
the size of the dump output and break it up into sections and write it out
|
||||
as an OS file for example. The output has the potential to be extremely
|
||||
large due to the possibility of large variable contents and iterating
|
||||
through dimensioned arrays with large values.
|
||||
|
||||
... but that is another story ...
|
||||
|
||||
|
||||
Amended Version Date Reason
|
||||
======= ======= ==== ======
|
||||
|
||||
*/
|
||||
declare function debugger_Fetch
|
||||
$insert debugger_Fetch_Equates
|
||||
$insert logical
|
||||
|
||||
equ VERSION$ to "1.0.0"
|
||||
equ LOCAL_DUMP_ID$ to "oe_local_dmp.txt"
|
||||
equ LCOMM_DUMP_ID$ to "oe_lcomm_dmp.txt"
|
||||
equ CRLF$ to \0D0A\
|
||||
equ CR$ to \0D\
|
||||
equ LF$ to \0A\
|
||||
equ TAB$ to \09\
|
||||
|
||||
goSub dumpLocalVars
|
||||
goSub dumpLabelledCommonVars
|
||||
|
||||
return
|
||||
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
|
||||
dumpLocalVars:
|
||||
|
||||
localList = debugger_Fetch( "LISTLOCAL" )
|
||||
localVars = ""
|
||||
|
||||
xCount = count( localList, @fm ) + ( localList # "" )
|
||||
for x = 1 to xCount
|
||||
var = localList<x>
|
||||
varName = var[1,@vm]
|
||||
varType = var[col2()+1,@vm]
|
||||
varDim = var[col2()+1,@vm]
|
||||
|
||||
begin case
|
||||
case ( varType = VAR_TYPE_DESC_UNASSIGNED$ )
|
||||
localVars := varName : @vm : varType : @vm : "" : @fm
|
||||
|
||||
case ( varType = VAR_TYPE_DESC_IDISPATCH$ )
|
||||
localVars := varName : @vm : varType : @vm : "" : @fm
|
||||
|
||||
case ( varType = VAR_TYPE_DESC_DIM_ARRAY$ )
|
||||
localVars := varName : @vm : varType : @vm : "" : @fm
|
||||
|
||||
* // We need to iterate across the matrix ...
|
||||
dim1 = varDim[1,@svm]
|
||||
dim2 = varDim[col2()+1,@svm]
|
||||
|
||||
d1 = 0
|
||||
d2 = 0
|
||||
if len( dim2 ) then
|
||||
dVar = debugger_Fetch( "GETLOCALDIMTYPE", varName, d1, d2 )
|
||||
goSub processLocalDimVar
|
||||
end else
|
||||
dVar = debugger_Fetch( "GETLOCALDIMTYPE", varName, d1 )
|
||||
goSub processLocalDimVar
|
||||
end
|
||||
|
||||
for d1 = 1 to dim1
|
||||
if len( dim2 ) then
|
||||
for d2 = 1 to dim2
|
||||
dVar = debugger_Fetch( "GETLOCALDIMTYPE", varName, d1, d2 )
|
||||
goSub processLocalDimVar
|
||||
next
|
||||
end else
|
||||
dVar = debugger_Fetch( "GETLOCALDIMTYPE", varName, d1 )
|
||||
goSub processLocalDimVar
|
||||
end
|
||||
next
|
||||
|
||||
case OTHERWISE$
|
||||
varData = debugger_Fetch( "GETLOCAL", varName )
|
||||
goSub escapeVarData
|
||||
|
||||
localVars := varName : @vm : varType : @vm : varData : @fm
|
||||
|
||||
end case
|
||||
|
||||
next
|
||||
|
||||
localVars[-1,1] = ""
|
||||
|
||||
swap @fm with CRLF$ in localVars
|
||||
convert @vm to "|" in localVars
|
||||
|
||||
osWrite localVars to LOCAL_DUMP_ID$
|
||||
|
||||
return
|
||||
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
|
||||
dumpLabelledCommonVars:
|
||||
|
||||
lCommList = debugger_Fetch( "LISTLABELLED" )
|
||||
lCommVars = ""
|
||||
|
||||
xCount = count( lCommList, @fm ) + ( lCommList # "" )
|
||||
for x = 1 to xCount
|
||||
|
||||
var = lCommList<x>
|
||||
|
||||
commName = var[1,@vm]
|
||||
varName = var[col2()+1,@vm]
|
||||
varType = var[col2()+1,@vm]
|
||||
varDim = var[col2()+1,@vm]
|
||||
|
||||
begin case
|
||||
case ( varType = VAR_TYPE_DESC_UNASSIGNED$ )
|
||||
lCommVars := commName : @vm : varName : @vm : varType : @vm : "" : @fm
|
||||
|
||||
case ( varType = VAR_TYPE_DESC_IDISPATCH$ )
|
||||
lCommVars := commName : @vm : varName : @vm : varType : @vm : "" : @fm
|
||||
|
||||
case ( varType = VAR_TYPE_DESC_DIM_ARRAY$ )
|
||||
lCommVars := commName : @vm : varName : @vm : varType : @vm : "" : @fm
|
||||
|
||||
* // We need to iterate across the matrix ...
|
||||
dim1 = varDim[1,@svm]
|
||||
dim2 = varDim[col2()+1,@svm]
|
||||
|
||||
d1 = 0
|
||||
d2 = 0
|
||||
if len( dim2 ) then
|
||||
dVar = debugger_Fetch( "GETLABELLEDDIMTYPE", commName, varName, d1, d2 )
|
||||
goSub processLabelledCommonDimVar
|
||||
end else
|
||||
dVar = debugger_Fetch( "GETLABELLEDDIMTYPE", commName, varName, d1 )
|
||||
goSub processLabelledCommonDimVar
|
||||
end
|
||||
|
||||
for d1 = 1 to dim1
|
||||
if len( dim2 ) then
|
||||
for d2 = 1 to dim2
|
||||
dVar = debugger_Fetch( "GETLABELLEDDIMTYPE", commName, varName, d1, d2 )
|
||||
goSub processLabelledCommonDimVar
|
||||
next
|
||||
end else
|
||||
dVar = debugger_Fetch( "GETLABELLEDDIMTYPE", commName, varName, d1 )
|
||||
goSub processLabelledCommonDimVar
|
||||
end
|
||||
next
|
||||
|
||||
case OTHERWISE$
|
||||
varData = debugger_Fetch( "GETLABELLED", commName, varName )
|
||||
goSub escapeVarData
|
||||
|
||||
lCommVars := commName : @vm : varName : @vm : varType : @vm : varData : @fm
|
||||
|
||||
end case
|
||||
|
||||
next
|
||||
|
||||
lCommVars[-1,1] = ""
|
||||
|
||||
swap @fm with CRLF$ in lCommVars
|
||||
convert @vm to "|" in lCommVars
|
||||
|
||||
osWrite lCommVars to LCOMM_DUMP_ID$
|
||||
|
||||
return
|
||||
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
|
||||
processLocalDimVar:
|
||||
|
||||
dVarType = dVar<1>
|
||||
varData = ""
|
||||
|
||||
begin case
|
||||
case ( dVarType = VAR_TYPE_DESC_UNASSIGNED$ )
|
||||
null
|
||||
|
||||
case ( dVarType = VAR_TYPE_DESC_IDISPATCH$ )
|
||||
null
|
||||
|
||||
case ( dVarType = VAR_TYPE_DESC_DIM_ARRAY$ )
|
||||
* // This HAS to be an error!
|
||||
null
|
||||
|
||||
case OTHERWISE$
|
||||
varData = debugger_Fetch( "GETLOCAL", varName, d1, d2 )
|
||||
goSub escapeVarData
|
||||
|
||||
end case
|
||||
|
||||
dVarName = varName : "(" : d1
|
||||
if len( dim2 ) then
|
||||
dVarName := "," : d2
|
||||
end
|
||||
dVarName := ")"
|
||||
|
||||
localVars : = " " : dVarName : @vm : dVarType : @vm : varData : @fm
|
||||
|
||||
return
|
||||
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
|
||||
processLabelledCommonDimVar:
|
||||
|
||||
dVarType = dVar<1>
|
||||
varData = ""
|
||||
|
||||
begin case
|
||||
case ( dVarType = VAR_TYPE_DESC_UNASSIGNED$ )
|
||||
null
|
||||
|
||||
case ( dVarType = VAR_TYPE_DESC_IDISPATCH$ )
|
||||
null
|
||||
|
||||
case ( dVarType = VAR_TYPE_DESC_DIM_ARRAY$ )
|
||||
* // This HAS to be an error!
|
||||
null
|
||||
|
||||
case OTHERWISE$
|
||||
varData = debugger_Fetch( "GETLABELLED", commName, varName, d1, d2 )
|
||||
goSub escapeVarData
|
||||
|
||||
end case
|
||||
|
||||
dVarName = varName : "(" : d1
|
||||
if len( dim2 ) then
|
||||
dVarName := "," : d2
|
||||
end
|
||||
dVarName := ")"
|
||||
|
||||
lCommVars := " " : commName : @vm : dVarName : @vm : dVarType : @vm : varData : @fm
|
||||
|
||||
return
|
||||
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
|
||||
escapeVarData:
|
||||
swap "\" with "\\" in varData
|
||||
swap @rm with "\xFF" in varData
|
||||
swap @fm with "\xFE" in varData
|
||||
swap @vm with "\xFD" in varData
|
||||
swap @svm with "\xFC" in varData
|
||||
swap @tm with "\xFB" in varData
|
||||
swap \09\ with "\t" in varData
|
||||
swap \0A\ with "\n" in varData
|
||||
swap \0D\ with "\r" in varData
|
||||
swap \00\ with "\0" in varData
|
||||
return
|
||||
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
235
SYSPROG/STPROC/EMAIL_FORMAT.txt
Normal file
235
SYSPROG/STPROC/EMAIL_FORMAT.txt
Normal file
@ -0,0 +1,235 @@
|
||||
compile Subroutine EMAIL_FORMAT( charstr CONV, charstr ANS, charstr BRANCH, charstr RETURN_DATA)
|
||||
*
|
||||
* EMAIL_FORMAT is an example of a developer's custom prompt formatting
|
||||
* routine using the square brackets call.
|
||||
*
|
||||
* It should be placed in square brackets, like this:
|
||||
*
|
||||
* [EMAIL_FORMAT]
|
||||
*
|
||||
* This subroutine should be used as the first and only "Input Validation" in
|
||||
* a window prompt. Placed in "Output Format", it properly checks that
|
||||
* the string passed in is a valid Email address
|
||||
*
|
||||
!
|
||||
* MrC 3-23-21 Remove 3d Gray color from message and added icon
|
||||
* mtr 5-31-11 Changes subdomain to allow first chars to be numbers
|
||||
|
||||
* Subroutine declarations
|
||||
|
||||
$insert msg_equates
|
||||
declare function msg
|
||||
|
||||
* Local Equates
|
||||
* The STATUS() variable is used to indicated the error condition of the
|
||||
* pattern. They are:
|
||||
EQU VALID$ TO 0 ;* Successful
|
||||
EQU INVALID_MSG$ TO 1 ;* Bad Data - Print error message window
|
||||
EQU INVALID_CONV$ TO 2 ;* Bad Conversion - " "
|
||||
EQU INVALID_NOMSG$ TO 3 ;* Bad but do not print the error message window
|
||||
|
||||
EQU THREEDGRAY$ TO 192
|
||||
|
||||
* Begin Conversion
|
||||
*
|
||||
RETURN_DATA = ""
|
||||
|
||||
IF ANS NE "" THEN
|
||||
EMAIL = ANS
|
||||
ANS = ""
|
||||
|
||||
* mtr 1-19-07
|
||||
email = trim(Email)
|
||||
|
||||
STATUS() = VALID$
|
||||
|
||||
IF LEN( EMAIL ) THEN
|
||||
* Case statement to validate all possible types of Social Security numbers. If
|
||||
* a new format is required simply add another case.
|
||||
* The fall-through (CASE 1) traps invalid conversions.
|
||||
BEGIN CASE
|
||||
Case email
|
||||
error_flag = ''
|
||||
return_data = ''
|
||||
* per RFC #822 <http://www.isi.edu/in-notes/rfc822.txt>
|
||||
// Valid characters in an "atom"
|
||||
exclude_atom = '()<>@,:;\?".[]':char(27)
|
||||
exclude_quoted = '"\':char(13)
|
||||
atom_chars = ''; *[#33..#255] - ['(', ')', '<', '>', '@', ',', ';', ':', '\', '/', '"', '.', '[', ']', #127]
|
||||
quoted_string_chars = '';* [#0..#255] - ['"', #13, '\']
|
||||
For i = 0 To 255
|
||||
this_char = char(i)
|
||||
If Index(exclude_atom, this_char, 1) ELSE
|
||||
If i >=33 then
|
||||
atom_chars:=this_char
|
||||
end
|
||||
end
|
||||
If Index(exclude_quoted, this_char, 1) ELSE
|
||||
quoted_string_chars:=this_char
|
||||
end
|
||||
Next i
|
||||
|
||||
// Valid characters in a subdomain
|
||||
letters = @upper.Case:@lower.case
|
||||
letters_digits = letters:'0123456789'
|
||||
subdomain_chars = '-':letters_digits
|
||||
STATE_BEGIN = 1
|
||||
STATE_ATOM = 2
|
||||
STATE_QTEXT = 3
|
||||
STATE_QCHAR = 4
|
||||
STATE_QUOTE = 5
|
||||
STATE_LOCAL_PERIOD = 6
|
||||
STATE_EXPECTING_SUBDOMAIN= 7
|
||||
STATE_SUBDOMAIN = 8
|
||||
STATE_HYPHEN = 9
|
||||
|
||||
|
||||
State = STATE_BEGIN
|
||||
n = Len(email)
|
||||
i = 1
|
||||
subdomains = 1
|
||||
for i = 1 To n
|
||||
this_char = email[i, 1]
|
||||
Begin case
|
||||
Case State = STATE_BEGIN
|
||||
if index(atom_chars, this_char, 1) then
|
||||
State = STATE_ATOM
|
||||
End else
|
||||
if this_char = '"' then
|
||||
State = STATE_QTEXT
|
||||
End else
|
||||
error_flag = 1
|
||||
end
|
||||
end
|
||||
|
||||
Case State = STATE_ATOM
|
||||
if this_char = '@' then
|
||||
State = STATE_EXPECTING_SUBDOMAIN
|
||||
End else
|
||||
if this_char = '.' then
|
||||
State = STATE_LOCAL_PERIOD
|
||||
End else
|
||||
if index(atom_chars, this_char, 1) else
|
||||
error_flag = 1
|
||||
end
|
||||
end
|
||||
end
|
||||
|
||||
Case State = STATE_QTEXT
|
||||
if this_char = '\' then
|
||||
State = STATE_QCHAR
|
||||
End else
|
||||
if this_char = '"' then
|
||||
State := STATE_QUOTE
|
||||
End else
|
||||
if Index(quoted_string_chars, this_char, 1) else
|
||||
error_flag = 1
|
||||
end
|
||||
end
|
||||
end
|
||||
|
||||
Case State = STATE_QCHAR
|
||||
State = STATE_QTEXT
|
||||
|
||||
Case State = STATE_QUOTE
|
||||
if this_char = '@' then
|
||||
State = STATE_EXPECTING_SUBDOMAIN
|
||||
End else
|
||||
if this_char = '.' then
|
||||
State = STATE_LOCAL_PERIOD
|
||||
End else
|
||||
error_flag = 1
|
||||
end
|
||||
end
|
||||
|
||||
Case State = STATE_LOCAL_PERIOD
|
||||
if index(atom_chars, this_char, 1) then
|
||||
State = STATE_ATOM
|
||||
End else
|
||||
if this_char = '"' then
|
||||
State = STATE_QTEXT
|
||||
End else
|
||||
error_flag = 1
|
||||
end
|
||||
end
|
||||
|
||||
Case State = STATE_EXPECTING_SUBDOMAIN
|
||||
* mtr 5-31-11
|
||||
*If Index(letters, this_char, 1) Then
|
||||
If Index(letters_digits, this_char, 1) then
|
||||
State = STATE_SUBDOMAIN
|
||||
end else
|
||||
error_flag = 1
|
||||
end
|
||||
|
||||
Case State = STATE_SUBDOMAIN
|
||||
if this_char = '.' then
|
||||
subdomains += 1
|
||||
State = STATE_EXPECTING_SUBDOMAIN
|
||||
end else
|
||||
if this_char = '-' then
|
||||
State = STATE_HYPHEN
|
||||
end else
|
||||
if index(letters_digits, this_char, 1) else
|
||||
error_flag = 1
|
||||
end
|
||||
end
|
||||
end
|
||||
|
||||
Case State = STATE_HYPHEN
|
||||
if Index(letters_digits, this_char, 1) then
|
||||
State = STATE_SUBDOMAIN
|
||||
End else
|
||||
if this_char # '-' then
|
||||
error_flag = 1
|
||||
end
|
||||
end
|
||||
|
||||
|
||||
End case
|
||||
|
||||
next i
|
||||
|
||||
If error_flag then
|
||||
Gosub DisplayError
|
||||
STATUS() = INVALID_NOMSG$
|
||||
end else
|
||||
GoodEmail = (State = STATE_SUBDOMAIN) and (subdomains >= 2)
|
||||
If GoodEmail then
|
||||
return_data = email
|
||||
End else
|
||||
Gosub DisplayError
|
||||
STATUS() = INVALID_NOMSG$
|
||||
end
|
||||
end
|
||||
|
||||
|
||||
|
||||
CASE 1
|
||||
IF CONV = "ICONV" THEN
|
||||
gosub DisplayError
|
||||
END
|
||||
STATUS() = INVALID_NOMSG$
|
||||
END CASE
|
||||
END ELSE
|
||||
IF CONV = "ICONV" THEN
|
||||
gosub DisplayError
|
||||
END
|
||||
STATUS() = INVALID_NOMSG$
|
||||
END
|
||||
end
|
||||
|
||||
RETURN
|
||||
|
||||
DisplayError:
|
||||
msgrec = ""
|
||||
msgrec<MCAPTION$> = "Data Validation Error"
|
||||
msgrec<MTEXT$> = EMAIL : " is not a valid email address.||Please enter a email address with a name,|an '@' symbol, and a server/domain."
|
||||
// msgrec<MBKCOLOR$> = THREEDGRAY$:@VM:THREEDGRAY$:@VM:THREEDGRAY$
|
||||
msgrec<MJUST$> = 'C'
|
||||
msgRec<MICON$> = "!"
|
||||
result = msg( "", msgrec)
|
||||
Return
|
||||
|
||||
* Source Date: 13:55:58 17 SEP 2004 Build ID: OI*7.1 Level: 7.1
|
||||
|
||||
191
SYSPROG/STPROC/ERRMSG.txt
Normal file
191
SYSPROG/STPROC/ERRMSG.txt
Normal file
@ -0,0 +1,191 @@
|
||||
Compile Subroutine ErrMsg(ErrCodes)
|
||||
|
||||
Declare Subroutine Msg, Set_Status
|
||||
DECLARE FUNCTION Create_Dialog
|
||||
|
||||
$INSERT MSG_EQUATES
|
||||
|
||||
EQU MSGID$ TO 1 ;* First value in ErrCodes
|
||||
EQU MSGPARMS$ TO 2 ;* Second value in ErrCodes
|
||||
|
||||
EQU MSGTITLE$ TO 1 ;* Subvalue in MSGPARM
|
||||
EQU MSGTEXT$ TO 2 ;* Subvalue in MSGPARM
|
||||
|
||||
Equate CRLF$ to \0D0A\ ;* CHAR(13):CHAR(10) for multiline messages
|
||||
|
||||
IF NOT(ASSIGNED(ErrCodes)) THEN
|
||||
ErrCodes = 'Null Parameter Passed to ErrMsg Routine!'
|
||||
END
|
||||
|
||||
IF INDEX(ErrCodes,@VM,1) = 0 THEN ErrCodes = ErrCodes:@VM ;* Changed to an append from a prepend. 2/5/2005 JCH
|
||||
|
||||
IF ErrCodes[-1,1] = @FM THEN ErrCodes[-1,1] = ''
|
||||
|
||||
CONVERT ']' TO @SVM IN ErrCodes
|
||||
|
||||
ErrDispLines = ''
|
||||
ErrCodeCnt = COUNT(ErrCodes,@FM) + (ErrCodes NE '')
|
||||
|
||||
|
||||
FOR M = 1 TO ErrCodeCnt
|
||||
|
||||
MsgID = ErrCodes<M,MSGID$>
|
||||
MsgParms = FIELD(ErrCodes<M>,@VM,MSGPARMS$,99) ;* Added to pickup up additional parameters 10/03/2005 JCH
|
||||
|
||||
BEGIN CASE
|
||||
|
||||
CASE ErrCodes<M,MSGID$> = 'STPROC'
|
||||
MText = ErrCodes<M,MSGPARMS$,MSGTEXT$>
|
||||
MTitle = ErrCodes<M,MSGPARMS$,MSGTITLE$>
|
||||
MIcon = '!'
|
||||
|
||||
CASE ErrCodes<M,MSGID$> = ''
|
||||
IF INDEX(MsgParms,@SVM,1) THEN
|
||||
MText = ErrCodes<M,MSGPARMS$,MSGTEXT$>
|
||||
MTitle = ErrCodes<M,MSGPARMS$,MSGTITLE$>
|
||||
END ELSE
|
||||
MText = MsgParms
|
||||
MTitle = 'Application Error Message'
|
||||
END
|
||||
|
||||
MIcon = '!'
|
||||
|
||||
|
||||
CASE MsgID = 'FS414'
|
||||
|
||||
TextLine = ErrCodes<2,1,2>
|
||||
|
||||
TextLine := CRLF$:CRLF$
|
||||
TextLine := 'This record is locked by THIS workstation.':CRLF$:CRLF$
|
||||
TextLine := 'Check for minimized windows that have this record open and close the record.'
|
||||
|
||||
TypeOver = ''
|
||||
TypeOver<MTEXT$> = TextLine
|
||||
TypeOVer<MTEXTWIDTH$> = 450
|
||||
|
||||
Msg(@WINDOW,TypeOver,'LOCKS')
|
||||
|
||||
RETURN
|
||||
|
||||
|
||||
CASE MsgID = 'FS415'
|
||||
|
||||
|
||||
TextLine = ErrCodes<2,1,2>
|
||||
|
||||
TextLine := CRLF$:CRLF$
|
||||
TextLine := 'This record is locked by ANOTHER workstation.':CRLF$:CRLF$
|
||||
TextLine := 'Check other workstations for the open record.'
|
||||
|
||||
TypeOver = ''
|
||||
TypeOver<MTEXT$> = TextLine
|
||||
TypeOVer<MTEXTWIDTH$> = 450
|
||||
|
||||
Msg(@WINDOW,TypeOver,'LOCKS')
|
||||
|
||||
RETURN
|
||||
|
||||
|
||||
CASE 1
|
||||
|
||||
* Passed in MsgID must be a system generated error message
|
||||
|
||||
OSREAD Reverrors FROM 'REVERROR.DAT' THEN
|
||||
Pos = INDEX(Reverrors,MsgID,1)
|
||||
IF Pos THEN
|
||||
MText = Reverrors[Pos,CHAR(13)]
|
||||
MText = Field(MText,":",2)
|
||||
MText = Trim(MText)
|
||||
|
||||
FOR I = 1 TO COUNT(MsgParms,@VM) + (MsgParms NE '')
|
||||
SWAP '%':I:'%' WITH MsgParms<1,I> IN MText
|
||||
NEXT I
|
||||
|
||||
MText = Trim(MText)
|
||||
MTitle = 'System Error Message - ':MsgID
|
||||
MIcon = '!'
|
||||
|
||||
END ELSE
|
||||
IF INDEX(MsgID,@SVM,1) THEN ;* Updated 2/5/2005 to work with system messages
|
||||
MText = FIELD(MsgID,@SVM,2)
|
||||
MTitle = FIELD(MsgID,@SVM,1)
|
||||
END ELSE
|
||||
MText = MsgID
|
||||
MTitle = 'Application Message'
|
||||
END
|
||||
MIcon = '!'
|
||||
END
|
||||
END ELSE
|
||||
|
||||
MText = "OSREAD Error on file: REVERROR.DAT."
|
||||
MTitle = 'ERRMSG routine Error.'
|
||||
MIcon = 'H'
|
||||
|
||||
END
|
||||
|
||||
CASE 1
|
||||
|
||||
|
||||
END CASE
|
||||
|
||||
ErrDispLines := MTitle:@VM:MText:@FM ;* Added 1/20/2010 JCH
|
||||
|
||||
/*
|
||||
|
||||
* Display the message
|
||||
|
||||
BEGIN CASE
|
||||
CASE Len(MText) < 20 ; Msg_Len = 200
|
||||
CASE Len(MText) < 30 ; Msg_Len = 260
|
||||
CASE Len(MText) < 40 ; Msg_Len = 320
|
||||
CASE Len(MText) < 50 ; Msg_Len = 380
|
||||
CASE Len(MText) < 60 ; Msg_Len = 440
|
||||
CASE 1 ; Msg_Len = 450
|
||||
END CASE
|
||||
|
||||
TypeOver = ''
|
||||
TypeOver<MTEXT$> = MText
|
||||
TypeOver<MTYPE$> = 'BO'
|
||||
TypeOver<MICON$> = MIcon
|
||||
TypeOVer<MTEXTWIDTH$> = Msg_Len
|
||||
TypeOver<MBKCOLOR$> = 192:@VM:192:@VM:192
|
||||
TypeOver<MCAPTION$> = MTitle
|
||||
TypeOver<MJUST$> = 'L'
|
||||
|
||||
Msg('',TypeOver)
|
||||
*/
|
||||
|
||||
NEXT M
|
||||
|
||||
|
||||
IF ErrCodeCnt = 1 AND MTitle = 'Application Message' OR MTitle = 'Process Error' THEN
|
||||
|
||||
* Display the message
|
||||
|
||||
BEGIN CASE
|
||||
CASE Len(MText) < 20 ; Msg_Len = 200
|
||||
CASE Len(MText) < 30 ; Msg_Len = 260
|
||||
CASE Len(MText) < 40 ; Msg_Len = 320
|
||||
CASE Len(MText) < 50 ; Msg_Len = 380
|
||||
CASE Len(MText) < 60 ; Msg_Len = 440
|
||||
CASE 1 ; Msg_Len = 450
|
||||
END CASE
|
||||
|
||||
TypeOver = ''
|
||||
TypeOver<MTEXT$> = MText
|
||||
TypeOver<MTYPE$> = 'BO'
|
||||
TypeOver<MICON$> = MIcon
|
||||
TypeOVer<MTEXTWIDTH$> = Msg_Len
|
||||
TypeOver<MBKCOLOR$> = 192:@VM:192:@VM:192
|
||||
TypeOver<MCAPTION$> = MTitle
|
||||
TypeOver<MJUST$> = 'L'
|
||||
|
||||
Msg('',TypeOver)
|
||||
END ELSE
|
||||
CALL Set_Status(0)
|
||||
dummy = Create_Dialog('DIALOG_ERRMSG',@WINDOW,0,ErrDispLines)
|
||||
END
|
||||
|
||||
RETURN
|
||||
|
||||
|
||||
380
SYSPROG/STPROC/ERROR_SERVICES.txt
Normal file
380
SYSPROG/STPROC/ERROR_SERVICES.txt
Normal file
@ -0,0 +1,380 @@
|
||||
Function Error_Services(@Service, @Params)
|
||||
/***********************************************************************************************************************
|
||||
|
||||
This program is proprietary and is not to be used by or disclosed to others, nor is it to be copied without written
|
||||
permission from SRP Computer Solutions, Inc.
|
||||
|
||||
Name : Error_Services
|
||||
|
||||
Description : Handler program for all error services.
|
||||
|
||||
Notes : Application errors should be logged using the Error Services module. There are a few methodological
|
||||
assumptions built into way errors are managed which are important to understand in order to properly
|
||||
work with Error Services:
|
||||
|
||||
- The term 'top' refers to the originating procedure of a call stack and the term 'bottom' refers to
|
||||
the last routine (or the current routine) within a call stack. Within the OpenInsight Debugger
|
||||
this will appear backwards since the originating procedure always appears at the bottom of the
|
||||
list and the current routine appears at the top of the list. We are using this orientation because
|
||||
it is common to refer to the process of calling other procedures as 'drilling down'.
|
||||
|
||||
- The reason for defining the orientation of the call stack is because Error_Services allows for
|
||||
multiple error conditions to be appended to an original error. In most cases this will happen when
|
||||
a procedure at the bottom of the stack generates an error condition and then returns to its
|
||||
calling procedure. This higher level procedure can optionally add more information relevant to
|
||||
itself. This continues as the call stack 'bubbles' its way back to the top to where the
|
||||
originating procedure is waiting.
|
||||
|
||||
- Native OpenInsight commands that handle errors (e.g., Set_Status, Set_FSError, Set_EventStatus)
|
||||
preserve their error state until explicitly cleared. This can hinder the normal execution of code
|
||||
since subsequent procedures (usually SSPs) will fail if a pre-existing error condition exists.
|
||||
Our philosophy is that error conditions should automatically be cleared before a new procedure
|
||||
is executed to avoid this problem. However, the nature of Basic+ does not make this easy to
|
||||
automate for any given stored procedure. Therefore, if a stored procedure wants to conform to our
|
||||
philosophy then it should include a call into the 'Clear' service request at the top of the
|
||||
program. Alternatively this can be done through a common insert (see SERVICE_SETUP for example.)
|
||||
|
||||
- Service modules will use the SERVICE_SETUP insert and therefore automatically clear out any
|
||||
error conditions that were set before.
|
||||
|
||||
- The 'Set' service request is the equivelent to the various forms of setting an error within Basic+
|
||||
(e.g., Set_Status, Set_FSError, Set_EventStatus). This will clear out any pre-existing error(s)
|
||||
first (see 'Clear' service request description below). In most cases the 'Add' service request
|
||||
(see below) should be used since error conditions are intended to be automatically cleared by
|
||||
service modules or properly managed stored procedures.
|
||||
|
||||
- The 'Add' service request is similar to the 'Set' service request but it will not clear out any
|
||||
pre-existing errors. Using 'Add', the error conditions can be stacked allowing the higher level
|
||||
calling procedures the ability to contribute to the existing error or add additional errors.
|
||||
|
||||
- The 'Clear' service request will reset all of the error condition flags.
|
||||
|
||||
Parameters :
|
||||
Service [in] -- Name of the service being requested
|
||||
Param1-10 [in/out] -- Additional request parameter holders
|
||||
Response [out] -- Response to be sent back to the Controller (MCP) or requesting procedure
|
||||
|
||||
History : (Date, Initials, Notes)
|
||||
12/28/12 dmb Original programmer.
|
||||
12/31/12 dmb Add hooks for various service requests. Add comments in the Notes section to explain the
|
||||
theory of operation of Error Services.
|
||||
01/01/13 dmb Add functionality to the Set, Add, GetMessage, and GetMessages service requests.
|
||||
01/02/13 dmb Remove reference to SERVICES_SETUP and put the Assigned command lines directly into this
|
||||
code to avoid infinite loop problem.
|
||||
01/05/13 dmb Added HasError service request.
|
||||
03/13/13 dmb [SRPFW-9] Added NoError service request.
|
||||
10/01/13 dmb [SRPFW-18] Replace APP_INSERTS with LOGICAL and declare Error_Services.
|
||||
10/06/13 dmb [SRPFW-17] Retrofit to use the default FrameWorks system font.
|
||||
03/20/17 fjt [SRPFW-160] Conversion to EB+; addition of justification parameter to display.
|
||||
10/09/17 dmb Add SendRuntimeAlert service to act as a debugger intercept process.
|
||||
|
||||
***********************************************************************************************************************/
|
||||
|
||||
#pragma precomp SRP_PreCompiler
|
||||
|
||||
$insert LOGICAL
|
||||
$Insert MSG_EQUATES
|
||||
$insert RTI_DEBUG_COMMON
|
||||
$insert SRPMail_Inserts
|
||||
|
||||
Equ Segoe_UI$ to 'Segoe UI' : @SVM : -12 : @SVM : 400 : @SVM : 0 : @SVM : 0 : @SVM : 0 : @SVM : 0 : @SVM : 34 : @SVM : 0 : @SVM : 3 : @SVM : 2 : @SVM : 1 : @SVM : 0 : @SVM : 0 : @SVM : 0 : @SVM : 0
|
||||
|
||||
// Make sure any request parameters which have not been assigned are nulled.
|
||||
// Normally these would be referenced in the SERVICES_SETUP insert but there is a call to ERROR_SERVICES in that
|
||||
// insert which causes an infinite loop to occur.
|
||||
If Assigned(Service) else Service = ''
|
||||
If Assigned(Error) else Error = ''
|
||||
If Assigned(Param1) else Param1 = ''
|
||||
If Assigned(Param2) else Param2 = ''
|
||||
If Assigned(Param3) else Param3 = ''
|
||||
If Assigned(Param4) else Param4 = ''
|
||||
If Assigned(Param5) else Param5 = ''
|
||||
If Assigned(Param6) else Param6 = ''
|
||||
If Assigned(Param7) else Param7 = ''
|
||||
If Assigned(Param8) else Param8 = ''
|
||||
If Assigned(Param9) else Param9 = ''
|
||||
If Assigned(Param10) else Param10 = ''
|
||||
If Assigned(Response) else Response = ''
|
||||
|
||||
AutoDisplayErrors = False$ ; // Set this to True$ when debugging so all errors will automatically display.
|
||||
|
||||
Common /ErrorServices/ ErrorMessages@, ErrorSources@, ErrorCodes@, RetStacks@, Unused5@, Unused6@, Unused7@, Unused8@
|
||||
|
||||
Declare function RetStack, Error_Services, SRPSendMail
|
||||
Declare subroutine Error_Services
|
||||
|
||||
GoToService else
|
||||
Error_Services('Set', Service : ' is not a valid service request within the Error services module.')
|
||||
end
|
||||
|
||||
Return Response else ''
|
||||
|
||||
|
||||
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
|
||||
// Service Parameter Options
|
||||
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
|
||||
Options BOOLEAN = True$, False$
|
||||
|
||||
|
||||
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
|
||||
// Services
|
||||
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
|
||||
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
// Set
|
||||
//
|
||||
// Param1 - Error message. Messages should be fairly descriptive.
|
||||
//
|
||||
// Sets an error to the stack. This will automatically clear any existing error conditions first so this error will
|
||||
// be the only one on the stack.
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
Service Set(ErrorMessage)
|
||||
|
||||
Error_Services('Clear')
|
||||
Error_Services('Add', ErrorMessage)
|
||||
|
||||
If AutoDisplayErrors then Error_Services('DisplayError')
|
||||
|
||||
End Service
|
||||
|
||||
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
// Add
|
||||
//
|
||||
// Param1 - Error message. Messages should be fairly descriptive.
|
||||
//
|
||||
// Adds an error to the stack. This will not clear existing error conditions first. It is intended to allow higher level
|
||||
// routines to add more information to an existing error condition or simply to maintain an ongoing error log for some
|
||||
// troubleshooting or debugging purposes.
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
Service Add(ErrorMessage)
|
||||
|
||||
CurStack = RetStack()
|
||||
AtSelf = CurStack[1, @FM] ; // AtSelf should be the name of this routine (e.g., ERROR_SERVICES)
|
||||
Loop
|
||||
CurRoutine = CurStack[1, @FM] ; // Get the next routine from the program call stack.
|
||||
Until CurRoutine _NEC AtSelf
|
||||
CurStack = Delete(CurStack, 1, 0, 0) ; // Remove any self-references from the program call stack.
|
||||
Repeat
|
||||
Convert @FM to @VM in CurStack ; // Convert the delimiter so it can be added to the global common.
|
||||
|
||||
If Len(ErrorMessages@) then
|
||||
ErrorMessages@ := @FM : ErrorMessage
|
||||
RetStacks@ := @FM : CurStack
|
||||
end else
|
||||
ErrorMessages@ = ErrorMessage
|
||||
RetStacks@ = CurStack
|
||||
end
|
||||
|
||||
If AutoDisplayErrors then Error_Services('DisplayError')
|
||||
|
||||
End Service
|
||||
|
||||
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
// Clear
|
||||
//
|
||||
// Clears all error conditions and related information.
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
Service Clear()
|
||||
|
||||
ErrorMessages@ = ''
|
||||
ErrorSources@ = ''
|
||||
ErrorCodes@ = ''
|
||||
RetStacks@ = ''
|
||||
|
||||
End Service
|
||||
|
||||
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
// GetMessage
|
||||
//
|
||||
// Returns the most current error message.
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
Service GetMessage()
|
||||
|
||||
Response = ErrorMessages@[-1, 'B' : @FM]
|
||||
|
||||
End Service
|
||||
|
||||
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
// GetMessages
|
||||
//
|
||||
// Returns the stack of error messages. This will be @FM delimited.
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
Service GetMessages()
|
||||
|
||||
// Business logic goes here. Data that needs to be returned should be assigned to the Response parameter.
|
||||
Response = ErrorMessages@
|
||||
|
||||
End Service
|
||||
|
||||
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
// HasError
|
||||
//
|
||||
// Returns True if there is an error condition, False if there is no error condition. Caller will still need to use
|
||||
// the GetMessage or GetMessages service to determine what the error is. The HasError service allows the caller to
|
||||
// embed the Error_Services service call inside of a conditional statement like this:
|
||||
//
|
||||
// If Error_Services('HasError') then
|
||||
// * An error has occured. Proceed accordingly.
|
||||
// ErrorMessage = Error_Services('GetMessage')
|
||||
// end else
|
||||
// * No error has occured.
|
||||
// end
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
Service HasError()
|
||||
|
||||
If Len(ErrorMessages@) then
|
||||
Response = True$
|
||||
end else
|
||||
Response = False$
|
||||
end
|
||||
|
||||
End Service
|
||||
|
||||
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
// NoError
|
||||
//
|
||||
// Returns True if there are no error conditions, False if there is an error condition. This is the opposite of the
|
||||
// HasError service and exists for improved readability.
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
Service NoError()
|
||||
|
||||
If Len(ErrorMessages@) then
|
||||
Response = False$
|
||||
end else
|
||||
Response = True$
|
||||
end
|
||||
|
||||
End Service
|
||||
|
||||
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
// DisplayError
|
||||
//
|
||||
// Displays the current error message to the end user.
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
Service DisplayError(Justification)
|
||||
|
||||
ErrorMessage = Error_Services('GetMessage')
|
||||
If Len(ErrorMessage) then
|
||||
MsgStruct = ''
|
||||
MsgStruct<MTEXT$> = ErrorMessage
|
||||
MsgStruct<MTYPE$> = 'BO'
|
||||
MsgStruct<MMODAL$> = 'W'
|
||||
MsgStruct<MICON$> = '!'
|
||||
MsgStruct<MCOL$> = -1
|
||||
MsgStruct<MROW$> = -1
|
||||
MsgStruct<MJUST$> = Justification
|
||||
MsgStruct<MCAPTION$> = 'Error Services'
|
||||
MsgStruct<MFONT$> = Segoe_UI$
|
||||
Msg(@Window, MsgStruct)
|
||||
end
|
||||
|
||||
End Service
|
||||
|
||||
|
||||
Service GetSource()
|
||||
|
||||
// Business logic goes here. Data that needs to be returned should be assigned to the Response parameter.
|
||||
Response = '<Service Response>'
|
||||
|
||||
End Service
|
||||
|
||||
|
||||
Service GetSources()
|
||||
|
||||
// Business logic goes here. Data that needs to be returned should be assigned to the Response parameter.
|
||||
Response = '<Service Response>'
|
||||
|
||||
End Service
|
||||
|
||||
|
||||
Service GetCode()
|
||||
|
||||
// Business logic goes here. Data that needs to be returned should be assigned to the Response parameter.
|
||||
Response = '<Service Response>'
|
||||
|
||||
End Service
|
||||
|
||||
|
||||
Service GetCodes()
|
||||
|
||||
// Business logic goes here. Data that needs to be returned should be assigned to the Response parameter.
|
||||
Response = '<Service Response>'
|
||||
|
||||
End Service
|
||||
|
||||
|
||||
Service GetStackTrace()
|
||||
// Business logic goes here. Data that needs to be returned should be assigned to the Response parameter.
|
||||
Response = '<Service Response>'
|
||||
End Service
|
||||
|
||||
|
||||
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
|
||||
// Internal GoSubs
|
||||
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////?
|
||||
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
// SendRuntimeAlert
|
||||
//
|
||||
// Sends out an email alert when this service is called as a debugger intercept.
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
SendRuntimeAlert:
|
||||
|
||||
Done = False$
|
||||
Error = False$
|
||||
Program = Curr_Program@
|
||||
MsgSent = ''
|
||||
|
||||
If Program EQ '' then Program = 'Error Services'
|
||||
|
||||
ConfigFile = ''
|
||||
ConfigFile<1> = SendUsing_Port$
|
||||
ConfigFile<2> = ''
|
||||
ConfigFile<3> = '' ; // Server port
|
||||
ConfigFile<4> = '' ; // Mail server
|
||||
ConfigFile<5> = True$ ; // Authenticate
|
||||
ConfigFile<6> = '' ; // Username
|
||||
ConfigFile<7> = '' ; // Password
|
||||
ConfigFile<8> = False$ ; // Use SSL
|
||||
|
||||
Text = ''
|
||||
Text<-1> = 'App: ' : @APPID<1>
|
||||
Text<-1> = 'Window: ' : @WINDOW
|
||||
Text<-1> = 'User: ' : @USERNAME
|
||||
Text<-1> = 'Station: ' : @STATION
|
||||
Text<-1> = ' '
|
||||
Text<-1> = 'SP Status: ' : SPStatus@
|
||||
Text<-1> = 'SP Stat Code: ' : SPStatCode@
|
||||
Text<-1> = 'Program: ' : Program
|
||||
Text<-1> = 'Call Depth: ' : CallDepth@
|
||||
Text<-1> = 'Line No: ' : LineNo@
|
||||
Text<-1> = ' '
|
||||
Text<-1> = 'Stack: '
|
||||
Text<-1> = CallStack@
|
||||
Convert \00\ TO ',' in Text
|
||||
Swap @VM with ':@VM:' IN Text
|
||||
Swap @FM with Char(13) : Char(10) IN Text
|
||||
Swap @TM with Char(13) : Char(10) IN Text
|
||||
|
||||
SentFrom = ''
|
||||
SentTo = ''
|
||||
Message = ''
|
||||
Message<1> = '' : Program ; // Subject
|
||||
Message<2> = SentFrom ; // From (email address)
|
||||
Message<3> = SentTo ; // Send to (email address)
|
||||
Message<5> = '' ; // Blind Carbon Copy (email address)
|
||||
Message<6> = '' ; // Reply To (email address)
|
||||
Message<7> = 'TEXT' ; // Content Type (TEXT or HTML)
|
||||
Message<8> = Text ; // Content / Body
|
||||
Message<9> = '' ; // Attachment(s) (path to file name(s))
|
||||
|
||||
MsgSent = SRPSendMail(Message, ConfigFile)
|
||||
|
||||
return
|
||||
224
SYSPROG/STPROC/HTTPSVR_GETREPOSIMAGE.txt
Normal file
224
SYSPROG/STPROC/HTTPSVR_GETREPOSIMAGE.txt
Normal file
@ -0,0 +1,224 @@
|
||||
compile function httpSvr_GetReposImage( httpServer, requestID, requestHeaders )
|
||||
/*
|
||||
****************************************************************************
|
||||
** IF YOU WANT TO MODIFY THIS FOR YOUR OWN APPLICATIONS PLEASE USE A COPY **
|
||||
** DO NOT CHANGE THIS PROGRAM AS IT MAY BE OVERWRITTEN BY FUTURE UPDATES! **
|
||||
****************************************************************************
|
||||
|
||||
** Copyright (C) 2012-2022 Revelation Software Inc. All Rights Reserved **
|
||||
|
||||
Author : Wile C Coyote - Super Genius
|
||||
Date : August 2022
|
||||
Purpose : Simple function for the HTTPSERVER control to return
|
||||
: repository images.
|
||||
|
||||
Query Parameters
|
||||
================
|
||||
|
||||
classid : Repository CLASSID of the image (defaults to "PNG")
|
||||
[req] entid : Repository ENTITYID of the image
|
||||
useFile : If TRUE$ ("1") then return the image via the server's
|
||||
: SetResponseContentFile method, otherwise return via the
|
||||
: normal SetResponseContent method.
|
||||
dpi : Specifies the requested DPI for the image - this can be
|
||||
: an actual DPI (like 96,192 etc) or a percentage (100%,
|
||||
: 200%) etc (Defaults to 96)
|
||||
|
||||
Comments
|
||||
========
|
||||
|
||||
Amended Date Reason
|
||||
======= ==== ======
|
||||
*/
|
||||
#pragma precomp event_precomp
|
||||
|
||||
declare function repository, rti_ResolvePath, rti_ErrorText, rti_UC
|
||||
$insert ps_HTTPServer_Equates
|
||||
$insert repository_Equates
|
||||
$insert reposErrors
|
||||
$insert rti_SSP_Equates
|
||||
$insert logical
|
||||
|
||||
equ BASE_DPI$ to 96
|
||||
|
||||
errStat = FALSE$
|
||||
errInfo = ""
|
||||
|
||||
classID = ""
|
||||
entID = ""
|
||||
dpi = ""
|
||||
bUseFile = FALSE$
|
||||
mimeType = ""
|
||||
|
||||
// NOTE: We're expecting this to be a GET request - if it's POST then we
|
||||
// need to extract these arguments from the request content as they won't
|
||||
// be in the query names and values fields.
|
||||
|
||||
queryNames = requestHeaders<PS_HSVR_REQHDR_QUERYNAMES$>
|
||||
|
||||
locateC "classid" in queryNames using @vm setting pos then
|
||||
classID = rti_UC( trim( requestHeaders<PS_HSVR_REQHDR_QUERYVALUES$,pos> ) )
|
||||
end
|
||||
|
||||
locateC "entid" in queryNames using @vm setting pos then
|
||||
entID = rti_UC( trim( requestHeaders<PS_HSVR_REQHDR_QUERYVALUES$,pos> ) )
|
||||
end
|
||||
|
||||
locateC "useFile" in queryNames using @vm setting pos then
|
||||
bUseFile = trim( requestHeaders<PS_HSVR_REQHDR_QUERYVALUES$,pos> )
|
||||
end
|
||||
|
||||
locateC "dpi" in queryNames using @vm setting pos then
|
||||
dpi = trim( requestHeaders<PS_HSVR_REQHDR_QUERYVALUES$,pos> )
|
||||
end
|
||||
|
||||
if bLen( classID ) else
|
||||
classID = "PNG"
|
||||
end
|
||||
|
||||
if bLen( dpi ) then
|
||||
if ( dpi[-1,1] = "%" ) then
|
||||
convert "%" to "" in dpi
|
||||
if num( dpi ) then
|
||||
dpi = int( ( dpi / 100 ) * BASE_DPI$ )
|
||||
end else
|
||||
dpi = ""
|
||||
end
|
||||
end
|
||||
end
|
||||
|
||||
if ( dpi ) then
|
||||
if ( dpi < BASE_DPI$ ) then
|
||||
dpi = BASE_DPI$
|
||||
end
|
||||
end else
|
||||
dpi = BASE_DPI$
|
||||
end
|
||||
|
||||
begin case
|
||||
case ( classID == "JPG" )
|
||||
mimeType = "image/jpeg"
|
||||
case ( classID == "GIF" )
|
||||
mimeType = "image/gif"
|
||||
case ( classID == "BMP" )
|
||||
mimeType = "image/bmp"
|
||||
case ( classID == "PNG" )
|
||||
mimeType = "image/png"
|
||||
case OTHERWISE$
|
||||
null
|
||||
end case
|
||||
|
||||
if bLen( entID ) then
|
||||
reposID = @appID<1> : "*IMAGE*" : classID : "*" : entID
|
||||
|
||||
call set_Status( SETSTAT_OK$ )
|
||||
|
||||
fileNames = repository( "GETSUBKEY", reposID )
|
||||
if get_Status( errInfo ) then
|
||||
if ( errInfo<1,1> == REP_ENT_NOEXISTS_ERR$ ) then
|
||||
@httpServer->setResponseStatus( requestID, 404 )
|
||||
end else
|
||||
goSub setHTTPError
|
||||
end
|
||||
end else
|
||||
|
||||
goSub resolveFileNameForDPI
|
||||
|
||||
if bLen( filename ) then
|
||||
fileName = rti_ResolvePath( fileName, "" )
|
||||
|
||||
if bUseFile then
|
||||
|
||||
@httpServer->setResponseFile( requestID, fileName )
|
||||
@httpServer->setResponseHeader( requestID, "Content-Type", mimeType )
|
||||
|
||||
end else
|
||||
osRead fileContents from fileName then
|
||||
@httpServer->setResponseContent( requestID, fileContents )
|
||||
@httpServer->setResponseHeader( requestID, "Content-Type", mimeType )
|
||||
end else
|
||||
@httpServer->setResponseStatus( requestID, 404 )
|
||||
end
|
||||
end
|
||||
end else
|
||||
@httpServer->setResponseStatus( requestID, 404 )
|
||||
end
|
||||
|
||||
end
|
||||
end else
|
||||
@httpServer->setResponseStatus( requestID, 404 )
|
||||
end
|
||||
|
||||
return TRUE$
|
||||
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
// resolveFileNameForDPI subroutine
|
||||
//
|
||||
// Finds the best fitting image file for the DPI requested fro the list of
|
||||
// files defined in the repository:
|
||||
//
|
||||
// <0,1> 96 (100%)
|
||||
// <0,2> 120 (125%)
|
||||
// <0,3> 144 (150%)
|
||||
// <0,4> 168 (175%)
|
||||
// <0,5> 192 (200%) <-- After this point we step up in 50% increments
|
||||
// <0,6> 240 (250%)
|
||||
// <0,7> 288 (300%)
|
||||
// <0,8> 336 (350%)
|
||||
// <0,9> 384 (400%)
|
||||
// <0,10> 432 (450%)
|
||||
// <0,11> 480 (500%)
|
||||
//
|
||||
// If we can't find an exact match then we go for the next highest we can find
|
||||
//
|
||||
// ----------------------------------------------------------------------------
|
||||
// [i] dpi : DPI requested
|
||||
// [i] fileNames : @vm'd list of file names to search
|
||||
// [o] fileName : Resolved file name
|
||||
// ----------------------------------------------------------------------------
|
||||
resolveFileNameForDPI:
|
||||
|
||||
fileName = ""
|
||||
dpiTest = BASE_DPI$
|
||||
|
||||
eofNames = bLen( fileNames )
|
||||
pos = 1
|
||||
loop
|
||||
fileName_ = fileNames[pos,@vm,TRUE$]; pos = bCol2()+1
|
||||
if bLen( fileName_ ) then
|
||||
transfer fileName_ to fileName
|
||||
begin case
|
||||
case ( dpiTest == dpi )
|
||||
return
|
||||
case ( dpiTest > dpi )
|
||||
return
|
||||
case OTHERWISE$
|
||||
null
|
||||
end case
|
||||
end
|
||||
until ( pos > eofNames )
|
||||
// After 200% DPI we go up in 50% steps, otherwise we go up in 25% steps
|
||||
if ( dpiTest >= 192 ) then
|
||||
dpiTest += 48
|
||||
end else
|
||||
dpiTest += 24
|
||||
end
|
||||
repeat
|
||||
|
||||
return
|
||||
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
|
||||
setHTTPError:
|
||||
|
||||
errInfo = rti_ErrorText( "SP", errInfo )
|
||||
@httpServer->setResponseContent( requestID, errInfo )
|
||||
@httpServer->setResponseHeader( requestID, "Content-Type", "text/plain" )
|
||||
@httpServer->setResponseStatus( requestID, 500 )
|
||||
|
||||
return
|
||||
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
|
||||
|
||||
145
SYSPROG/STPROC/HTTPSVR_TRACE.txt
Normal file
145
SYSPROG/STPROC/HTTPSVR_TRACE.txt
Normal file
@ -0,0 +1,145 @@
|
||||
compile function httpSvr_Trace( httpServer, requestID, requestHeaders )
|
||||
/*
|
||||
****************************************************************************
|
||||
** IF YOU WANT TO MODIFY THIS FOR YOUR OWN APPLICATIONS PLEASE USE A COPY **
|
||||
** DO NOT CHANGE THIS PROGRAM AS IT MAY BE OVERWRITTEN BY FUTURE UPDATES! **
|
||||
****************************************************************************
|
||||
|
||||
** Copyright (C) 2012-2021 Revelation Software Inc. All Rights Reserved **
|
||||
|
||||
Author : Wile C Coyote - Super Genius
|
||||
Date : March 2021
|
||||
Purpose : "Trace" function for HTTPSERVER control requests.
|
||||
|
||||
|
||||
Comments
|
||||
========
|
||||
|
||||
This is a simple function designed to reflect the headers and content received
|
||||
by the HTTPSERVER control back to the client as an HTML page.
|
||||
|
||||
Modelled on the venerable "INET_TRACE" function.
|
||||
|
||||
Amended Date Reason
|
||||
======= ==== ======
|
||||
|
||||
*/
|
||||
|
||||
#pragma precomp event_precomp
|
||||
|
||||
declare function rti_XMLEncode, exec_Method
|
||||
$insert ps_HTTPServer_Equates
|
||||
$insert rti_Text_Equates
|
||||
$insert logical
|
||||
|
||||
varNames = "CONTENT_LENGTH" ; varIndexes = PS_HSVR_REQHDR_CONTENTLEN$
|
||||
varNames := @fm : "CONTENT_TYPE" ; varIndexes := @fm : PS_HSVR_REQHDR_CONTENTTYPE$
|
||||
varNames := @fm : "GATEWAY_INTERFACE" ; varIndexes := @fm : PS_HSVR_REQHDR_GATEWAYINTERFACE$
|
||||
varNames := @fm : "HTTPS" ; varIndexes := @fm : PS_HSVR_REQHDR_HTTPS$
|
||||
varNames := @fm : "HTTP_ACCEPT" ; varIndexes := @fm : PS_HSVR_REQHDR_HTTPACCEPT$
|
||||
varNames := @fm : "HTTP_COOKIE" ; varIndexes := @fm : PS_HSVR_REQHDR_HTTPCOOKIE$
|
||||
varNames := @fm : "HTTP_FROM" ; varIndexes := @fm : PS_HSVR_REQHDR_HTTPFROM$
|
||||
varNames := @fm : "HTTP_REFERER" ; varIndexes := @fm : PS_HSVR_REQHDR_HTTPREFERRER$
|
||||
varNames := @fm : "HTTP_USER_AGENT" ; varIndexes := @fm : PS_HSVR_REQHDR_HTTPUSERAGENT$
|
||||
varNames := @fm : "PATH_INFO" ; varIndexes := @fm : PS_HSVR_REQHDR_PATHINFO$
|
||||
varNames := @fm : "PATH_TRANSLATED" ; varIndexes := @fm : PS_HSVR_REQHDR_PATHTRANSLATED$
|
||||
varNames := @fm : "REMOTE_ADDR" ; varIndexes := @fm : PS_HSVR_REQHDR_REMOTEADDR$
|
||||
varNames := @fm : "REMOTE_HOST" ; varIndexes := @fm : PS_HSVR_REQHDR_REMOTEHOST$
|
||||
varNames := @fm : "REMOTE_IDENT" ; varIndexes := @fm : PS_HSVR_REQHDR_REMOTEIDENT$
|
||||
varNames := @fm : "REMOTE_USER" ; varIndexes := @fm : PS_HSVR_REQHDR_REMOTEUSER$
|
||||
varNames := @fm : "REQUEST_METHOD" ; varIndexes := @fm : PS_HSVR_REQHDR_REQUESTMETHOD$
|
||||
varNames := @fm : "SCRIPT_NAME" ; varIndexes := @fm : PS_HSVR_REQHDR_SCRIPTNAME$
|
||||
varNames := @fm : "SERVER_NAME" ; varIndexes := @fm : PS_HSVR_REQHDR_SERVERNAME$
|
||||
varNames := @fm : "SERVER_PORT" ; varIndexes := @fm : PS_HSVR_REQHDR_SERVERPORT$
|
||||
varNames := @fm : "SERVER_PROTOCOL" ; varIndexes := @fm : PS_HSVR_REQHDR_SERVERPROTOCOL$
|
||||
varNames := @fm : "SERVER_SOFTWARE" ; varIndexes := @fm : PS_HSVR_REQHDR_SERVERSOFTWARE$
|
||||
varNames := @fm : "SERVER_URL" ; varIndexes := @fm : PS_HSVR_REQHDR_SERVERURL$
|
||||
|
||||
content = "<html>"
|
||||
content<-1> = "<head>"
|
||||
content<-1> = "</head>"
|
||||
content<-1> = "<body>"
|
||||
|
||||
content<-1> = "<b>Environment Variables</b>"
|
||||
content<-1> = "<table border='1' cellpadding='2'>"
|
||||
content<-1> = "<tr><th>Name</th><th>Value</th></tr>"
|
||||
|
||||
xCount = fieldCount( varNames, @fm )
|
||||
for x = 1 to xCount
|
||||
row = "<tr><td>" : varNames<x> : "</td>"
|
||||
row := "<td>" : requestHeaders<varIndexes<x>> : "</td></tr>"
|
||||
|
||||
content<-1> = row
|
||||
next
|
||||
|
||||
content<-1> = "</table>"
|
||||
|
||||
content<-1> = "<br>"
|
||||
content<-1> = "<br>"
|
||||
|
||||
content<-1> = "<b>Request Headers</b>"
|
||||
content<-1> = "<table border='1' cellpadding='2'>"
|
||||
content<-1> = "<tr><th>Header Name</th><th>Header Value</th></tr>"
|
||||
|
||||
xCount = fieldCount( requestHeaders<PS_HSVR_REQHDR_HEADERNAMES$>, @vm )
|
||||
for x = 1 to xCount
|
||||
row = "<tr><td>" : requestHeaders<PS_HSVR_REQHDR_HEADERNAMES$,x> : "</td>"
|
||||
row := "<td>" : requestHeaders<PS_HSVR_REQHDR_HEADERVALUES$,x> : "</td></tr>"
|
||||
|
||||
content<-1> = row
|
||||
|
||||
next
|
||||
content<-1> = "</table>"
|
||||
|
||||
content<-1> = "<br>"
|
||||
content<-1> = "<br>"
|
||||
|
||||
content<-1> = "<b>Query Details</b>"
|
||||
content<-1> = "<table border='1' cellpadding='2'>"
|
||||
content<-1> = "<tr><th>Query Name</th><th>Query Value</th></tr>"
|
||||
|
||||
xCount = fieldCount( requestHeaders<PS_HSVR_REQHDR_QUERYNAMES$>, @vm )
|
||||
for x = 1 to xCount
|
||||
row = "<tr><td>" : requestHeaders<PS_HSVR_REQHDR_QUERYNAMES$,x> : "</td>"
|
||||
row := "<td>" : requestHeaders<PS_HSVR_REQHDR_QUERYVALUES$,x> : "</td></tr>"
|
||||
|
||||
content<-1> = row
|
||||
|
||||
next
|
||||
content<-1> = "</table>"
|
||||
|
||||
content<-1> = "<br>"
|
||||
content<-1> = "<br>"
|
||||
|
||||
content<-1> = "<b>Cookie Details</b>"
|
||||
content<-1> = "<table border='1' cellpadding='2'>"
|
||||
content<-1> = "<tr><th>Cookie Name</th><th>Cookie Value</th></tr>"
|
||||
|
||||
xCount = fieldCount( requestHeaders<PS_HSVR_REQHDR_COOKIENAMES$>, @vm )
|
||||
for x = 1 to xCount
|
||||
row = "<tr><td>" : requestHeaders<PS_HSVR_REQHDR_COOKIENAMES$,x> : "</td>"
|
||||
row := "<td>" : requestHeaders<PS_HSVR_REQHDR_COOKIEVALUES$,x> : "</td></tr>"
|
||||
|
||||
content<-1> = row
|
||||
|
||||
next
|
||||
content<-1> = "</table>"
|
||||
|
||||
// Add the request content - encode it to make sure it's safe to embed in
|
||||
// the returned HTML
|
||||
content<-1> = "<br/>"
|
||||
content<-1> = "<br/>"
|
||||
content<-1> = "<b>Request Content</b>"
|
||||
content<-1> = "<hr/>"
|
||||
|
||||
content<-1> = rti_XMLEncode( @httpServer->GetRequestContent( requestID ) )
|
||||
|
||||
content<-1> = "</body>"
|
||||
content<-1> = "</html>"
|
||||
|
||||
convert @fm to LF$ in content
|
||||
|
||||
@httpServer->SetResponseContent( requestID, content )
|
||||
@httpServer->SetResponseHeader( requestID, "Content-Type", "text/html" )
|
||||
|
||||
return TRUE$
|
||||
73
SYSPROG/STPROC/IFX_LDAP_GROUPS_FOR_USER.txt
Normal file
73
SYSPROG/STPROC/IFX_LDAP_GROUPS_FOR_USER.txt
Normal file
@ -0,0 +1,73 @@
|
||||
Compile Function IFX_LDAP_GROUPS_FOR_USER(inUser, inDomain)
|
||||
|
||||
$Insert REVDOTNETEQUATES
|
||||
|
||||
Declare subroutine Set_Property.Net
|
||||
Declare Function Active_Directory_Services, Unassigned, RetStack, GetNetworkUsername
|
||||
|
||||
Ans = ''
|
||||
If Not(Unassigned(inUser)) Then
|
||||
If Unassigned(inUser) Then inUser = ''
|
||||
If inUser = '' Then inUser = GetNetworkUsername()
|
||||
If Unassigned(inDomain) Then inDomain = ''
|
||||
If inDomain Eq '' Then inDomain = Active_Directory_Services('GetComputerDomain')
|
||||
Domain = inDomain
|
||||
Username = inUser
|
||||
ADGroups = ''
|
||||
DotNetHandle = StartDotNet("","4.0")
|
||||
DotNetDir = CheckDotNet('4.0'):'\'
|
||||
AccountMgmtDllPath = DotNetDir:'System.DirectoryServices.AccountManagement.dll'
|
||||
Set_Property.Net(DotNetHandle, "AssemblyName", AccountMgmtDllPath)
|
||||
If Not(Get_Status(errCode)) then
|
||||
Params = 'Domain':@FM:Domain
|
||||
ParamTypes = 'System.DirectoryServices.AccountManagement.ContextType':@FM:'System.String'
|
||||
objPC = Create_Class.Net(DotNetHandle, "System.DirectoryServices.AccountManagement.PrincipalContext", 0, Params, ParamTypes)
|
||||
If Not(Get_Status(errCode)) then
|
||||
objUserPrincipal = Create_Class.Net(DotNetHandle, "System.DirectoryServices.AccountManagement.UserPrincipal", 0, objPC, 'RevDotNet')
|
||||
If Not(Get_Status(errCode)) then
|
||||
Set_Property.Net(objUserPrincipal, 'Name', Username)
|
||||
objPrinSearcher = Create_Class.Net(DotNetHandle, "System.DirectoryServices.AccountManagement.PrincipalSearcher", 0, objUserPrincipal, 'RevDotNet')
|
||||
If Not(Get_Status(errCode)) then
|
||||
objPrin = Send_Message.Net(objPrinSearcher, 'FindOne', '', '', 1)
|
||||
If Not(Get_Status(errCode)) then
|
||||
Name = Get_Property.Net(objPrin, 'Name', 0)
|
||||
objPrinSearchResult = Send_Message.Net(objPrin, 'GetGroups', '', '', 1)
|
||||
If Not(Get_Status(errCode)) then
|
||||
objEnum = Send_Message.Net(objPrinSearchResult, 'GetEnumerator', '', '', 1)
|
||||
If Not(Get_Status(errCode)) then
|
||||
Loop
|
||||
Done = Send_Message.Net(objEnum, 'MoveNext', '', '', 0)
|
||||
Until Done EQ 'False'
|
||||
If Not(Get_Status(errCode)) then
|
||||
objCurrPrin = Get_Property.Net(objEnum, 'Current', 1)
|
||||
If Not(Get_Status(errCode)) then
|
||||
CurrPrinName = Get_Property.Net(objCurrPrin, 'Name', 0)
|
||||
If CurrPrinName NE 'Domain Users' then
|
||||
Locate CurrPrinName in ADGroups using @FM setting fPos else
|
||||
ADGroups<-1> = CurrPrinName
|
||||
end
|
||||
end
|
||||
Free_Class.Net(objCurrPrin)
|
||||
end
|
||||
end
|
||||
Repeat
|
||||
Free_Class.Net(objEnum)
|
||||
end
|
||||
Free_Class.Net(objPrinSearchResult)
|
||||
end
|
||||
Free_Class.Net(objPrin)
|
||||
end
|
||||
Free_class.Net(objPrinSearcher)
|
||||
end
|
||||
Free_Class.Net(objUserPrincipal)
|
||||
end
|
||||
Free_Class.Net(objPC)
|
||||
end
|
||||
End
|
||||
Free_Class.Net()
|
||||
Ans = ADGroups
|
||||
End
|
||||
|
||||
Swap @FM With @VM In Ans
|
||||
|
||||
Return Ans
|
||||
9
SYSPROG/STPROC/INETAPI_FINDMIMETYPE_HELPER.txt
Normal file
9
SYSPROG/STPROC/INETAPI_FINDMIMETYPE_HELPER.txt
Normal file
@ -0,0 +1,9 @@
|
||||
Function INETAPI_FINDMIMETYPE_HELPER(fileType)
|
||||
* Helper Function To Return user-specified mime types
|
||||
*
|
||||
RSLT = ""
|
||||
* example:
|
||||
* IF fileType _eqc "jpg" then rslt = "image/jpeg"
|
||||
*
|
||||
Return rslt
|
||||
|
||||
38
SYSPROG/STPROC/INET_ABORTED.txt
Normal file
38
SYSPROG/STPROC/INET_ABORTED.txt
Normal file
@ -0,0 +1,38 @@
|
||||
function INET_Aborted(Request, ProcErr)
|
||||
|
||||
***************************************************************************
|
||||
* Project : OpenInsight for Internet
|
||||
*
|
||||
* Name : INET_Aborted
|
||||
* Description: Called when an INET procedure has crashed and the Internet
|
||||
* Gateway recovers.
|
||||
*
|
||||
* Warning! : This procedure MUST NOT fail (i.e. go to the debugger) or
|
||||
* the Internet Services Gateway will be halted or go into an
|
||||
* infinite loop. The Gateway has no way to auto-recover from
|
||||
* a failure in this procedure!
|
||||
*
|
||||
* Returns : An HTML error message.
|
||||
*
|
||||
***************************************************************************
|
||||
|
||||
$insert Logical
|
||||
$insert Inet_Equates
|
||||
$insert Msg_Equates
|
||||
$Insert inet_headers
|
||||
|
||||
declare function INET_Msg
|
||||
|
||||
if assigned(ProcErr) then
|
||||
convert \00\:@fm:@vm:@svm to @tm:@tm:@tm:@tm in ProcErr
|
||||
end else
|
||||
ProcErr = ''
|
||||
end
|
||||
response = ''
|
||||
response<MTEXT$> = 'Fatal error while processing request':@tm:@tm:ProcErr
|
||||
response<MCAPTION$> = 'OpenInsight -- Server Error'
|
||||
|
||||
outmsg = Inet_Msg('', response)
|
||||
Call inetapi_setstatus("500")
|
||||
Return outmsg
|
||||
|
||||
23
SYSPROG/STPROC/INET_FINALIZE.txt
Normal file
23
SYSPROG/STPROC/INET_FINALIZE.txt
Normal file
@ -0,0 +1,23 @@
|
||||
subroutine INET_Finalize(Request, Response)
|
||||
|
||||
***************************************************************************
|
||||
* Project : OpenInsight for Internet
|
||||
*
|
||||
* Name : INET_Finalize
|
||||
* Description: Finalization of response to a request.
|
||||
*
|
||||
* Parameters:
|
||||
* Request [in/out] -- HTTP request (see INET_EQUATES)
|
||||
* Response [in/out] -- Response to request
|
||||
*
|
||||
***************************************************************************
|
||||
|
||||
$insert Logical
|
||||
$insert Inet_Equates
|
||||
|
||||
* put your response finalization code here
|
||||
* ...
|
||||
|
||||
Call Log_Inet_Transactions(Request)
|
||||
|
||||
return
|
||||
40
SYSPROG/STPROC/INET_SECURITY.txt
Normal file
40
SYSPROG/STPROC/INET_SECURITY.txt
Normal file
@ -0,0 +1,40 @@
|
||||
function INET_Security(Request, FnName)
|
||||
|
||||
***************************************************************************
|
||||
* Project : OpenInsight for Internet
|
||||
*
|
||||
* Name : INET_Security
|
||||
* Description: Security check point for a request
|
||||
*
|
||||
* Parameters:
|
||||
* Request [in/out] -- HTTP request (see INET_EQUATES)
|
||||
* FnName [in/out] -- name of a function that is
|
||||
* about to be executed (starts with INET_)
|
||||
* returns [out] -- emty string to allow request or
|
||||
* message in html format to stop the request
|
||||
* and pass it back to a client
|
||||
*
|
||||
* Note:
|
||||
* Parameters "Request" and "Function" are passed by reference
|
||||
* which makes it possible to change the function name and/or
|
||||
* request parameters on a fly by intelligent security procedure
|
||||
*
|
||||
***************************************************************************
|
||||
|
||||
$insert Logical
|
||||
$insert Inet_Equates
|
||||
|
||||
declare subroutine Send_Event
|
||||
|
||||
HtmlMessage = '' ;* assume success
|
||||
|
||||
* put your authorization check code here
|
||||
* ...
|
||||
*
|
||||
|
||||
* if authorization failed -- log the failure
|
||||
if len(HtmlMessage) then
|
||||
Send_Event(GS_MONITOR$, 'OMNIEVENT', 'OUTCOMING', 'Authorization failed')
|
||||
end
|
||||
|
||||
return HtmlMessage
|
||||
506
SYSPROG/STPROC/LOGGING_SERVICES.txt
Normal file
506
SYSPROG/STPROC/LOGGING_SERVICES.txt
Normal file
@ -0,0 +1,506 @@
|
||||
Function Logging_Services(@Service, @Params)
|
||||
/***********************************************************************************************************************
|
||||
|
||||
This program is proprietary and is not to be used by or disclosed to others, nor is it to be copied without written
|
||||
permission from SRP Computer Solutions, Inc.
|
||||
|
||||
Name : Logging_Services
|
||||
|
||||
Description : Handler program for all module related services.
|
||||
|
||||
Notes : The generic parameters should contain all the necessary information to process the services. Often
|
||||
this will be information like the data Record and Key ID.
|
||||
|
||||
Parameters :
|
||||
Service [in] -- Name of the service being requested
|
||||
Param1-10 [in/out] -- Additional request parameter holders
|
||||
Response [out] -- Response to be sent back to the Controller (MCP) or requesting procedure
|
||||
|
||||
Metadata :
|
||||
|
||||
History : (Date, Initials, Notes)
|
||||
08/30/17 dmb Original programmer.
|
||||
02/17/18 dmb Use the new named cache feature of Memory_Services so logging data is protected when other
|
||||
processes release a cache table.
|
||||
|
||||
***********************************************************************************************************************/
|
||||
|
||||
#pragma precomp SRP_PreCompiler
|
||||
|
||||
$insert LOGICAL
|
||||
$insert SERVICE_SETUP
|
||||
$insert SRPMail_Inserts
|
||||
|
||||
Equ CRLF$ to \0D0A\
|
||||
Equ CR$ to \0D\
|
||||
Equ LF$ to \0A\
|
||||
Equ TAB$ to \09\
|
||||
Equ COMMA$ to ','
|
||||
|
||||
Common /LogginServices/ Unused1@, Unused2@, Unused3@, Unused4@, Unused5@, Unused6@, Unused7@, Unused8@
|
||||
|
||||
Declare function Logging_Services, Memory_Services, SRP_Hash, SRP_Path, SRP_Send_Mail, Environment_Services
|
||||
Declare subroutine Logging_Services, Memory_Services, SetInitDirOptions
|
||||
|
||||
GoToService else
|
||||
Error_Services('Add', Service : ' is not a valid service request within the Logging services module.')
|
||||
end
|
||||
|
||||
Return Response OR ''
|
||||
|
||||
|
||||
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
|
||||
// Service Parameter Options
|
||||
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
|
||||
Options BOOLEAN = True$, False$
|
||||
|
||||
|
||||
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
|
||||
// Services
|
||||
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
|
||||
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
// NewLog
|
||||
//
|
||||
// LogPath - Path to where the log file is located. - [Required]
|
||||
// LogFileName - Name of the log file. - [Required]
|
||||
// RowDelimiter - Delimiter used to separate each log row. Default is CR/LF. - [Optional]
|
||||
// ColumnDelimiter - Delimiter used to separate each column value. If ColumnWidths is empty then this will default to a
|
||||
// comma. - [Optional]
|
||||
// ColumnHeaders - @FM list of Column headers to use in the log file. Default is no column headers will be used.
|
||||
// - [Optional]
|
||||
// ColumnWidths - @FM list of Column widths for each column data value. If empty then the entire column value will
|
||||
// be stored. - [Optional]
|
||||
// QuoteValues - Boolean flag to indicate if column values should be quoted. Default is false. - [Optional]
|
||||
// ClearLog - Boolean flag to indicate if any existing log file should be cleared. Default is false.
|
||||
// - [Optional]
|
||||
//
|
||||
// Returns an object handle to a log file.
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
Service NewLog(LogPath, LogFileName, RowDelimiter, ColumnDelimiter, ColumnHeaders, ColumnWidths, QuoteValues=BOOLEAN, ClearLog=BOOLEAN)
|
||||
|
||||
objLog = ''
|
||||
|
||||
If (LogPath NE '') AND (LogFileName NE '') then
|
||||
If SRP_Path('Exists', LogPath) then
|
||||
LogFullPath = SRP_Path('Combine', LogPath, LogFileName)
|
||||
If LogFullPath[1, 1] EQ '\' AND LogFullPath[2, 1] NE '\' then LogFullPath = '\' : LogFullPath
|
||||
objLog = SRP_Hash(LogFullPath, 'SHA-1', 'BASE32')
|
||||
Memory_Services('SetValue', objLog : '*LogPath', LogPath, ServiceModule)
|
||||
Memory_Services('SetValue', objLog : '*LogFileName', LogFileName, ServiceModule)
|
||||
Memory_Services('SetValue', objLog : '*LogFullPath', LogFullPath, ServiceModule)
|
||||
If Dir(LogFullPath) NE '' then
|
||||
If ClearLog then
|
||||
Logging_Services('CreateLogFile', objLog)
|
||||
end
|
||||
end else
|
||||
Logging_Services('CreateLogFile', objLog)
|
||||
end
|
||||
If Error_Services('NoError') then
|
||||
If RowDelimiter EQ '' then RowDelimiter = CRLF$
|
||||
Memory_Services('SetValue', objLog : '*RowDelimiter', RowDelimiter, ServiceModule)
|
||||
If (ColumnDelimiter EQ '') AND (ColumnWidths EQ '') then ColumnDelimiter = COMMA$
|
||||
Memory_Services('SetValue', objLog : '*ColumnDelimiter', ColumnDelimiter, ServiceModule)
|
||||
Memory_Services('SetValue', objLog : '*ColumnHeaders', ColumnHeaders, ServiceModule)
|
||||
Memory_Services('SetValue', objLog : '*ColumnWidths', ColumnWidths, ServiceModule)
|
||||
If QuoteValues NE True$ then QuoteValues = False$
|
||||
Memory_Services('SetValue', objLog : '*QuoteValues', QuoteValues, ServiceModule)
|
||||
If Dir(LogFullPath)<1> EQ 0 AND ColumnHeaders NE '' then
|
||||
// Add the column headers since this is a new log file.
|
||||
Logging_Services('AppendLog', objLog, ColumnHeaders, '', @FM, True$)
|
||||
end
|
||||
end
|
||||
end else
|
||||
Error_Services('Add', LogPath : ' does not exist.')
|
||||
end
|
||||
end else
|
||||
Error_Services('Add', 'LogPath or LogFileName argument was missing from the ' : Service : ' service.')
|
||||
end
|
||||
|
||||
Response = objLog
|
||||
|
||||
end service
|
||||
|
||||
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
// AppendLog
|
||||
//
|
||||
// objLog - Object handle to the log file. - [Required]
|
||||
// LogData - Data to be appended to the log file. - [Required]
|
||||
// IncomingRowDelimiter - Delimiter used to separate each log row coming in. This allows incoming log data to have
|
||||
// a different delimiter than what will be used in the log file. Default is the RowDelimiter
|
||||
// used for appending the log data. - [Optional]
|
||||
// IncomingColumnDelimiter - Delimiter used to separate each column value in the log data. This allows incoming log
|
||||
// data to have a different delimiter than what will be used in the log file. Default is the
|
||||
// column delimiter used to separate the log data or a comma if fixed widths only are
|
||||
// indicated. - [Optional]
|
||||
// IgnoreColumnHeaders - Boolean flag to indicate if the service should attempt to add column headers to an empty
|
||||
// log file. Default is false. - [Optional]
|
||||
// EmailAddresses - Comma delimited list of email addresses that should be notified when this log is appended.
|
||||
// - [Optional]
|
||||
// EmailMessage - Message to be sent to the email addresses.
|
||||
//
|
||||
// Appends data to the log file associated with the indicated log object handle.
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
Service AppendLog(objLog, LogData, IncomingRowDelimiter, IncomingColumnDelimiter, IgnoreColumnHeaders, EmailAddresses, EmailMessage)
|
||||
|
||||
If (objLog NE '') AND (LogData NE '') then
|
||||
If IgnoreColumnHeaders NE True$ then IgnoreColumnHeaders = False$
|
||||
LogFullPath = Logging_Services('GetLogFullPath', objLog)
|
||||
ColumnDelimiter = Logging_Services('GetColumnDelimiter', objLog)
|
||||
LenColDel = Len(ColumnDelimiter)
|
||||
ColumnHeaders = Logging_Services('GetColumnHeaders', objLog)
|
||||
ColumnWidths = Logging_Services('GetColumnWidths', objLog)
|
||||
QuoteValues = Logging_Services('GetQuoteValues', objLog)
|
||||
RowDelimiter = Logging_Services('GetRowDelimiter', objLog)
|
||||
If IncomingRowDelimiter EQ '' then IncomingRowDelimiter = RowDelimiter
|
||||
If (IncomingColumnDelimiter EQ '') AND (ColumnWidths EQ '') then IncomingColumnDelimiter = ColumnDelimiter
|
||||
LenRowDel = Len(RowDelimiter)
|
||||
FileInfo = Dir(LogFullPath)
|
||||
FileSize = FileInfo<1>
|
||||
Status() = 0
|
||||
OutData = ''
|
||||
OSOpen LogFullPath to hFile then
|
||||
If (FileSize EQ 0) AND (ColumnHeaders NE '') AND (Not(IgnoreColumnHeaders)) then
|
||||
Logging_Services('AppendLog', objLog, ColumnHeaders, @RM, @FM, True$)
|
||||
end
|
||||
For Each RowData in LogData using IncomingRowDelimiter
|
||||
If RowData NE '' then
|
||||
For Each ColumnData in RowData using IncomingColumnDelimiter setting cPos
|
||||
If ColumnWidths NE '' then
|
||||
ColumnWidth = ColumnWidths<cPos>
|
||||
ColumnData = ColumnData[1, ColumnWidth] : Str(' ', ColumnWidth - Len(ColumnData))
|
||||
end
|
||||
If QuoteValues then
|
||||
Swap '"' with '""' in ColumnData ; // Encode the quotes properly.
|
||||
ColumnData = Quote(ColumnData)
|
||||
end
|
||||
OutData := ColumnData : ColumnDelimiter
|
||||
Next ColumnData
|
||||
OutData[Neg(LenColDel), LenColDel] = '' ; // Strip off the last column delimiter.
|
||||
OutData := RowDelimiter ; // Append a row delimiter.
|
||||
end
|
||||
Next LogRow
|
||||
OutData[Neg(LenRowDel), LenRowDel] = '' ; // Strip off the last row delimiter.
|
||||
If (FileSize NE 0) then OutData = RowDelimiter : OutData ; // Prepend a row delimiter since there is existing data.
|
||||
OSBWrite OutData to hFile at FileSize
|
||||
OSError = Status()
|
||||
If OSError then
|
||||
Error_Services('Add', 'OSBWrite error code ' : OSError : ' in the ' : Service : ' service.')
|
||||
end
|
||||
OSClose hFile
|
||||
end else
|
||||
OSError = Status()
|
||||
Error_Services('Add', 'OSOpen error code ' : OSError : ' in the ' : Service : ' service.')
|
||||
end
|
||||
|
||||
end else
|
||||
Error_Services('Add', 'objLog argument was missing from the ' : Service : ' service.')
|
||||
end
|
||||
|
||||
If EmailAddresses NE '' then
|
||||
GoSub EmailMessage
|
||||
end
|
||||
|
||||
end service
|
||||
|
||||
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
// GetLogPath
|
||||
//
|
||||
// objLog - Object handle to the log file. - [Required]
|
||||
//
|
||||
// Returns the path for the log file associated with the indicated log object handle. This will not include the name of
|
||||
// the log file itself.
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
Service GetLogPath(objLog)
|
||||
|
||||
LogPath = ''
|
||||
|
||||
If objLog NE '' then
|
||||
LogPath = Memory_Services('GetValue', objLog : '*LogPath', '', '', ServiceModule)
|
||||
If LogPath EQ '' then
|
||||
Error_Services('Add', 'Log path not found in the ' : Service : ' service.')
|
||||
end
|
||||
end else
|
||||
Error_Services('Add', 'objLog argument was missing from the ' : Service : ' service.')
|
||||
end
|
||||
|
||||
Response = LogPath
|
||||
|
||||
end service
|
||||
|
||||
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
// GetLogFileName
|
||||
//
|
||||
// objLog - Object handle to the log file. - [Required]
|
||||
//
|
||||
// Returns the file name for the log file associated with the indicated log object handle. This will not include the
|
||||
// path to where the log file is located.
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
Service GetLogFileName(objLog)
|
||||
|
||||
LogFileName = ''
|
||||
|
||||
If objLog NE '' then
|
||||
LogFileName = Memory_Services('GetValue', objLog : '*LogFileName', '', '', ServiceModule)
|
||||
If LogFileName EQ '' then
|
||||
Error_Services('Add', 'Log file name not found in the ' : Service : ' service.')
|
||||
end
|
||||
end else
|
||||
Error_Services('Add', 'objLog argument was missing from the ' : Service : ' service.')
|
||||
end
|
||||
|
||||
Response = LogFileName
|
||||
|
||||
end service
|
||||
|
||||
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
// GetLogFullPath
|
||||
//
|
||||
// objLog - Object handle to the log file. - [Required]
|
||||
//
|
||||
// Returns the full path for the log file associated with the indicated log object handle.
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
Service GetLogFullPath(objLog)
|
||||
|
||||
LogFullPath = ''
|
||||
|
||||
If objLog NE '' then
|
||||
LogFullPath = Memory_Services('GetValue', objLog : '*LogFullPath', '', '', ServiceModule)
|
||||
If LogFullPath EQ '' then
|
||||
Error_Services('Add', 'Log full path not found in the ' : Service : ' service.')
|
||||
end
|
||||
end else
|
||||
Error_Services('Add', 'objLog argument was missing from the ' : Service : ' service.')
|
||||
end
|
||||
|
||||
Response = LogFullPath
|
||||
|
||||
end service
|
||||
|
||||
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
// GetRowDelimiter
|
||||
//
|
||||
// objLog - Object handle to the log file. - [Required]
|
||||
//
|
||||
// Returns the delimiter to use to separate each row in the log.
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
Service GetRowDelimiter(objLog)
|
||||
|
||||
RowDelimiter = ''
|
||||
|
||||
If objLog NE '' then
|
||||
RowDelimiter = Memory_Services('GetValue', objLog : '*RowDelimiter', '', '', ServiceModule)
|
||||
If RowDelimiter EQ '' then
|
||||
Error_Services('Add', 'Row delimiter not found in the ' : Service : ' service.')
|
||||
end
|
||||
end else
|
||||
Error_Services('Add', 'objLog argument was missing from the ' : Service : ' service.')
|
||||
end
|
||||
|
||||
Response = RowDelimiter
|
||||
|
||||
end service
|
||||
|
||||
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
// GetColumnDelimiter
|
||||
//
|
||||
// objLog - Object handle to the log file. - [Required]
|
||||
//
|
||||
// Returns the delimiter to use to separate each column in the log.
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
Service GetColumnDelimiter(objLog)
|
||||
|
||||
ColumnDelimiter = ''
|
||||
|
||||
If objLog NE '' then
|
||||
ColumnDelimiter = Memory_Services('GetValue', objLog : '*ColumnDelimiter', '', '', ServiceModule)
|
||||
If ColumnDelimiter EQ '' then
|
||||
Error_Services('Add', 'Column delimiter not found in the ' : Service : ' service.')
|
||||
end
|
||||
end else
|
||||
Error_Services('Add', 'objLog argument was missing from the ' : Service : ' service.')
|
||||
end
|
||||
|
||||
Response = ColumnDelimiter
|
||||
|
||||
end service
|
||||
|
||||
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
// GetColumnHeaders
|
||||
//
|
||||
// objLog - Object handle to the log file. - [Required]
|
||||
//
|
||||
// Returns the column headers that should be in the log.
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
Service GetColumnHeaders(objLog)
|
||||
|
||||
ColumnHeaders = ''
|
||||
|
||||
If objLog NE '' then
|
||||
ColumnHeaders = Memory_Services('GetValue', objLog : '*ColumnHeaders', '', '', ServiceModule)
|
||||
end else
|
||||
Error_Services('Add', 'objLog argument was missing from the ' : Service : ' service.')
|
||||
end
|
||||
|
||||
Response = ColumnHeaders
|
||||
|
||||
end service
|
||||
|
||||
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
// GetColumnWidths
|
||||
//
|
||||
// objLog - Object handle to the log file. - [Required]
|
||||
//
|
||||
// Returns the column widths that should be used to truncate or pad each column in the log.
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
Service GetColumnWidths(objLog)
|
||||
|
||||
ColumnWidths = ''
|
||||
|
||||
If objLog NE '' then
|
||||
ColumnWidths = Memory_Services('GetValue', objLog : '*ColumnWidths', '', '', ServiceModule)
|
||||
end else
|
||||
Error_Services('Add', 'objLog argument was missing from the ' : Service : ' service.')
|
||||
end
|
||||
|
||||
Response = ColumnWidths
|
||||
|
||||
end service
|
||||
|
||||
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
// GetQuoteValues
|
||||
//
|
||||
// objLog - Object handle to the log file. - [Required]
|
||||
//
|
||||
// Returns the flag to indicate whether column values should be quoted or not.
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
Service GetQuoteValues(objLog)
|
||||
|
||||
QuoteValues = ''
|
||||
|
||||
If objLog NE '' then
|
||||
QuoteValues = Memory_Services('GetValue', objLog : '*QuoteValues', '', '', ServiceModule)
|
||||
If QuoteValues NE True$ then QuoteValues = False$
|
||||
end else
|
||||
Error_Services('Add', 'objLog argument was missing from the ' : Service : ' service.')
|
||||
end
|
||||
|
||||
Response = QuoteValues
|
||||
|
||||
end service
|
||||
|
||||
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
// CreateLogFile
|
||||
//
|
||||
// objLog - Object handle to the log file. - [Required]
|
||||
//
|
||||
// Creates (or clears out) a log file associated with the indicated log object handle.
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
Service CreateLogFile(objLog)
|
||||
|
||||
If objLog NE '' then
|
||||
LogFullPath = Logging_Services('GetLogFullPath', objLog)
|
||||
If Error_Services('NoError') then
|
||||
Status() = 0
|
||||
OSWrite '' to LogFullPath
|
||||
Status = Status()
|
||||
If Status GT 0 then
|
||||
Error_Services('Add', 'Unable to clear ' : LogFullPath : ' in the ' : Service : ' service.')
|
||||
end
|
||||
end
|
||||
end else
|
||||
Error_Services('Add', 'objLog argument was missing from the ' : Service : ' service.')
|
||||
end
|
||||
|
||||
end service
|
||||
|
||||
|
||||
Service CleanLogFolders(NumDays)
|
||||
|
||||
FileExclusionList = 'Canary.txt':@VM:'Canary.vbs'
|
||||
AppRootPath = Environment_Services('GetApplicationRootPath')
|
||||
LogPath = AppRootPath : '\LogFiles\'
|
||||
SetInitDirOptions("D")
|
||||
InitDir LogPath:'*'
|
||||
FolderList = DirList()
|
||||
// Remove . directory listing
|
||||
FolderList = Delete(FolderList, 1, 0, 0)
|
||||
// Remove .. directory listing
|
||||
FolderList = Delete(FolderList, 1, 0, 0)
|
||||
Today = Date()
|
||||
SetInitDirOptions("")
|
||||
For each Folder in FolderList
|
||||
FolderPath = LogPath:Folder:'\'
|
||||
InitDir FolderPath:'*'
|
||||
FileList = DirList()
|
||||
If FileList NE '' then
|
||||
For each Filename in FileList
|
||||
Locate FileName in FileExclusionList using @VM setting vPos else
|
||||
FilePath = FolderPath:Filename
|
||||
FileInfo = Dir(FilePath)
|
||||
LastWriteDate = FileInfo<2>
|
||||
FileAge = Today - LastWriteDate
|
||||
If FileAge GT NumDays then
|
||||
OSDelete FilePath
|
||||
end
|
||||
end
|
||||
Next Filename
|
||||
end
|
||||
Next Folder
|
||||
|
||||
end service
|
||||
|
||||
|
||||
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
|
||||
// Internal GoSubs
|
||||
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
|
||||
|
||||
EmailMessage:
|
||||
|
||||
Done = False$
|
||||
Error = False$
|
||||
MsgSent = ''
|
||||
|
||||
ConfigFile = ''
|
||||
ConfigFile<1> = SendUsing_Port$
|
||||
ConfigFile<2> = ''
|
||||
ConfigFile<3> = 25 ; // Server port
|
||||
*ConfigFile<4> = 'appmail.eu.infineon.com' ; // Mail server
|
||||
ConfigFile<4> = 'mailrelay-external.infineon.com' ; // Mail server
|
||||
ConfigFile<5> = True$ ; // Authenticate
|
||||
ConfigFile<6> = 'oinotify@infineon.com' ; // Username
|
||||
ConfigFile<7> = 'oinotify1' ; // Password
|
||||
ConfigFile<8> = False$ ; // Use SSL
|
||||
|
||||
If EmailMessage EQ '' then
|
||||
EmailMessage = LogData : \0D0A0D0A\ : RetStack()<2>
|
||||
end else
|
||||
EmailMessage := \0D0A0D0A\ : LogData : \0D0A0D0A\ : RetStack()<2>
|
||||
end
|
||||
|
||||
SentFrom = ''
|
||||
SentTo = ''
|
||||
Message = ''
|
||||
Message<1> = 'AppendLog Message' ; // Subject
|
||||
Message<2> = 'oinotify@infineon.com' ; // From (email address)
|
||||
Message<3> = EmailAddresses ; // Send to (email address)
|
||||
Message<5> = '' ; // Blind Carbon Copy (email address)
|
||||
Message<6> = '' ; // Reply To (email address)
|
||||
Message<7> = 'TEXT' ; // Content Type (TEXT or HTML)
|
||||
Message<8> = EmailMessage ; // Content / Body
|
||||
Message<9> = '' ; // Attachment(s) (path to file name(s))
|
||||
|
||||
Result = SRP_Send_Mail(Message, ConfigFile)
|
||||
|
||||
return
|
||||
|
||||
17
SYSPROG/STPROC/LOG_INET_TRANSACTIONS.txt
Normal file
17
SYSPROG/STPROC/LOG_INET_TRANSACTIONS.txt
Normal file
@ -0,0 +1,17 @@
|
||||
Subroutine Log_Inet_Transactions(Request)
|
||||
|
||||
$Insert Inet_Equates
|
||||
|
||||
Open 'INET_LOG' To f_inet_log Then
|
||||
log_record = ''
|
||||
DATE = date()
|
||||
time = time()
|
||||
id = date:'.':time
|
||||
log_record<1> = request<REMOTE_USER$>
|
||||
log_record<2> = request<REMOTE_IDENT$>
|
||||
log_record<3> = request<12>
|
||||
write log_record On f_inet_log, id Else null
|
||||
End
|
||||
|
||||
|
||||
return
|
||||
408
SYSPROG/STPROC/MEMORY_SERVICES.txt
Normal file
408
SYSPROG/STPROC/MEMORY_SERVICES.txt
Normal file
@ -0,0 +1,408 @@
|
||||
Function Memory_Services(@Service, @Params)
|
||||
/***********************************************************************************************************************
|
||||
|
||||
This program is proprietary and is not to be used by or disclosed to others, nor is it to be copied without written
|
||||
permission from SRP Computer Solutions, Inc.
|
||||
|
||||
Name : Memory_Services
|
||||
|
||||
Description : Handler program for all module related services.
|
||||
|
||||
Notes : The generic parameters should contain all the necessary information to process the services. Often
|
||||
this will be information like the data Record and Key ID.
|
||||
|
||||
Parameters :
|
||||
Service [in] -- Name of the service being requested
|
||||
Error [out] -- Any errors that were created
|
||||
Param1-10 [in/out] -- Additional request parameter holders
|
||||
Response [out] -- Response to be sent back to the Controller (MCP) or requesting procedure
|
||||
|
||||
History : (Date, Initials, Notes)
|
||||
03/29/13 dmb [SRPFW-9] Original programmer.
|
||||
08/01/13 dmb [SRPFW-16] Add PM_CURRENT_IMAGE_PATH as an option to the GETVALUES list.
|
||||
10/01/13 dmb [SRPFW-18] Replace APP_INSERTS with LOGICAL and declare Error_Services. -
|
||||
10/05/13 dmb [SRPFW-18] Add the RemoveKey service.
|
||||
11/06/14 dmb [SRPFW-79] Add support to tag cached data with a time marker in the SetValue service so
|
||||
subsequent GetValue calls can avoid using data that might be too old.
|
||||
10/29/17 dmb Retrofit to use Enhanced BASIC+.
|
||||
02/17/18 dmb Add support to name specific memory service caches. This was to allow some memory service
|
||||
data to be protect from the ReleaseHashTable service. All services will default to the
|
||||
general cache if no cache name is specified. Added ReleaseAllHashTables to clear all caches.
|
||||
09/25/19 dmb [SRPFW-278] Update all services that support named caches so that whenever the named cache
|
||||
doesn't exist it will create one automatically rather than default to the primary cache.
|
||||
|
||||
***********************************************************************************************************************/
|
||||
|
||||
#pragma precomp SRP_PreCompiler
|
||||
|
||||
$insert LOGICAL
|
||||
$insert SERVICE_SETUP
|
||||
|
||||
Common /MemoryServices/ MemoryServicesManagers@, MemoryCacheNames@, Unused3@, Unused4@, Unused5@, Unused6@
|
||||
|
||||
Equ Day$ to 86400 ; // Seconds in one day.
|
||||
|
||||
// Self referencing declarations.
|
||||
Declare function Memory_Services
|
||||
Declare subroutine Memory_Services, Error_Services
|
||||
// SRP FastArray declarations.
|
||||
Declare function SRP_FastArray_Count, SRP_FastArray_Create, SRP_FastArray_Extract, SRP_FastArray_GetVariable,
|
||||
Declare subroutine SRP_FastArray_Delete, SRP_FastArray_Insert, SRP_FastArray_InsertFromList, SRP_FastArray_Release, SRP_FastArray_Replace, SRP_FastArray_ReplaceWithList
|
||||
// SRP HashTable declarations.
|
||||
Declare function SRP_HashTable_Create, SRP_HashTable_Contains, SRP_HashTable_Count, SRP_HashTable_Get, SRP_HashTable_GetKeys, SRP_HashTable_GetValues, SRP_HashTable_GetKeyValuePairs
|
||||
Declare subroutine SRP_HashTable_Set, SRP_HashTable_Release, SRP_HashTable_Remove
|
||||
// SRP List declarations.
|
||||
Declare function SRP_List_Create, SRP_List_CreateFromFastArray, SRP_List_Count, SRP_List_GetAt, SRP_List_GetVariable, SRP_List_Locate
|
||||
Declare subroutine SRP_List_Add, SRP_List_InsertAt, SRP_List_Release, SRP_List_RemoveAt, SRP_List_SetAt
|
||||
// SRP Array declarations.
|
||||
Declare function SRP_Clean_Array, SRP_Join_Arrays, SRP_Reorder_Array, SRP_Rotate_Array, SRP_Sort_Array
|
||||
|
||||
GoToService else
|
||||
Error_Services('Add', Service : ' is not a valid service request within the ' : ServiceModule : ' module.')
|
||||
end
|
||||
|
||||
Return Response OR ''
|
||||
|
||||
|
||||
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
|
||||
// Service Parameter Options
|
||||
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
|
||||
Options BOOLEAN = True$, False$
|
||||
|
||||
|
||||
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
|
||||
// Services
|
||||
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
|
||||
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
// KeyExists
|
||||
//
|
||||
// Returns a True or False depending on whether the Key ID exists.
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
Service KeyExists(KeyID, CacheName)
|
||||
|
||||
KeyExists = False$ ; // Assume it does not exist for now.
|
||||
|
||||
If Len(KeyID) then
|
||||
If CacheName EQ '' then
|
||||
HandlePos = 1
|
||||
end else
|
||||
Locate CacheName in MemoryCacheNames@ using @FM setting HandlePos else
|
||||
// The named cache does not exist so create it now.
|
||||
Memory_Services('CreateHashTable', CacheName)
|
||||
Locate CacheName in MemoryCacheNames@ using @FM setting HandlePos else
|
||||
HandlePos = 1
|
||||
end
|
||||
end
|
||||
end
|
||||
If Len(MemoryServicesManagers@<HandlePos>) then
|
||||
KeyExists = SRP_HashTable_Contains(MemoryServicesManagers@<HandlePos>, KeyID)
|
||||
end
|
||||
end else
|
||||
Error_Services('Set', 'Key ID did not contain a value in the KeyExists service request.')
|
||||
end
|
||||
|
||||
Response = KeyExists
|
||||
|
||||
end service
|
||||
|
||||
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
// GetValue
|
||||
//
|
||||
// Returns the value pair stored in the SRP Hash Table for the current Key ID. If the NotExpired flag is set, the
|
||||
// ExpirationDuration will be used to compare against the last time marker set for the current data.
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
Service GetValue(KeyID, NotExpired, ExpirationDuration, CacheName)
|
||||
|
||||
Value = '' ; // Assume the value is null for now.
|
||||
|
||||
If Len(KeyID) then
|
||||
If CacheName EQ '' then
|
||||
HandlePos = 1
|
||||
end else
|
||||
Locate CacheName in MemoryCacheNames@ using @FM setting HandlePos else
|
||||
// The named cache does not exist so create it now.
|
||||
Memory_Services('CreateHashTable', CacheName)
|
||||
Locate CacheName in MemoryCacheNames@ using @FM setting HandlePos else
|
||||
HandlePos = 1
|
||||
end
|
||||
end
|
||||
end
|
||||
If Len(MemoryServicesManagers@<HandlePos>) then
|
||||
If NotExpired then
|
||||
CurrMarker = (Date() * Day$) + Time()
|
||||
PrevMarker = SRP_HashTable_Get(MemoryServicesManagers@<HandlePos>, 'TIMEMARKER*' : KeyID)
|
||||
If (CurrMarker - PrevMarker) LT ExpirationDuration then
|
||||
Value = SRP_HashTable_Get(MemoryServicesManagers@<HandlePos>, KeyID)
|
||||
end
|
||||
end else
|
||||
Value = SRP_HashTable_Get(MemoryServicesManagers@<HandlePos>, KeyID)
|
||||
end
|
||||
end
|
||||
end else
|
||||
Error_Services('Set', 'Key ID did not contain a value in the GetValue service request.')
|
||||
end
|
||||
|
||||
Response = Value
|
||||
|
||||
end service
|
||||
|
||||
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
// SetValue
|
||||
//
|
||||
// Updates the value pair stored in the SRP Hash Table for the current Key ID.
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
Service SetValue(KeyID, Value, CacheName)
|
||||
|
||||
If Len(KeyID) then
|
||||
// If the Memory Services's hash table does not yet exist then create it now.
|
||||
If CacheName EQ '' then
|
||||
HandlePos = 1
|
||||
end else
|
||||
Locate CacheName in MemoryCacheNames@ using @FM setting HandlePos else
|
||||
// The named cache does not exist so create it now.
|
||||
Memory_Services('CreateHashTable', CacheName)
|
||||
Locate CacheName in MemoryCacheNames@ using @FM setting HandlePos else
|
||||
HandlePos = 1
|
||||
end
|
||||
end
|
||||
end
|
||||
If Len(MemoryServicesManagers@<HandlePos>) else
|
||||
Memory_Services('CreateHashTable', CacheName)
|
||||
end
|
||||
SRP_HashTable_Set(MemoryServicesManagers@<HandlePos>, KeyID, Value)
|
||||
// Set a time marker for this data in case future GetValue services need to know how old the data is.
|
||||
TimeMarker = (Date() * Day$) + Time()
|
||||
SRP_HashTable_Set(MemoryServicesManagers@<HandlePos>, 'TIMEMARKER*' : KeyID, TimeMarker)
|
||||
end else
|
||||
Error_Services('Set', 'Key ID did not contain a value in the SetValue service request.')
|
||||
end
|
||||
|
||||
end service
|
||||
|
||||
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
// IsValueExpired
|
||||
//
|
||||
// Returns a Boolean flag indicated whether the current value for the indicated KeyID has expired. This relies upon the
|
||||
// time marker set using the SetValue service. If this value has net yet been set then the value will be considered as
|
||||
// expired.
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
Service IsValueExpired(KeyID, ExpirationDuration, ResetAge, CacheName)
|
||||
|
||||
If Not(Num(ExpirationDuration)) then ExpirationDuration = 0
|
||||
ValueExpired = True$ ; // Assume the value has expired for now.
|
||||
If ResetAge NE True$ then ResetAge = False$ ; // Default is false unless otherwise specified.
|
||||
|
||||
If Len(KeyID) AND (ExpirationDuration GT 0) then
|
||||
If CacheName EQ '' then
|
||||
HandlePos = 1
|
||||
end else
|
||||
Locate CacheName in MemoryCacheNames@ using @FM setting HandlePos else
|
||||
// The named cache does not exist so create it now.
|
||||
Memory_Services('CreateHashTable', CacheName)
|
||||
Locate CacheName in MemoryCacheNames@ using @FM setting HandlePos else
|
||||
HandlePos = 1
|
||||
end
|
||||
end
|
||||
end
|
||||
If Len(MemoryServicesManagers@<HandlePos>) then
|
||||
PrevMarker = SRP_HashTable_Get(MemoryServicesManagers@<HandlePos>, 'TIMEMARKER*' : KeyID)
|
||||
If PrevMarker NE '' then
|
||||
TimeMarker = (Date() * Day$) + Time()
|
||||
If (TimeMarker - PrevMarker) LE ExpirationDuration then
|
||||
ValueExpired = False$
|
||||
If ResetAge EQ True$ then
|
||||
SRP_HashTable_Set(MemoryServicesManagers@<HandlePos>, 'TIMEMARKER*' : KeyID, TimeMarker)
|
||||
end
|
||||
end
|
||||
end
|
||||
end
|
||||
end else
|
||||
Error_Services('Set', 'KeyID or ExpirationDuraton was missing in the IsValueExpired service.')
|
||||
end
|
||||
|
||||
Response = ValueExpired
|
||||
|
||||
end service
|
||||
|
||||
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
// IsValueCurrent
|
||||
//
|
||||
// Returns a Boolean flag indicated whether the current value for the indicated KeyID is still current. This relies upon the
|
||||
// time marker set using the SetValue service. If this value has net yet been set then the value will be considered as
|
||||
// expired.
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
Service IsValueCurrent(KeyID, ExpirationDuration, ResetAge, CacheName)
|
||||
|
||||
If Not(Num(ExpirationDuration)) then ExpirationDuration = 0
|
||||
ValueCurrent = False$ ; // Assume the value is not current for now.
|
||||
If ResetAge NE True$ then ResetAge = False$ ; // Default is false unless otherwise specified.
|
||||
|
||||
If Len(KeyID) AND (ExpirationDuration GT 0) then
|
||||
If CacheName EQ '' then
|
||||
HandlePos = 1
|
||||
end else
|
||||
Locate CacheName in MemoryCacheNames@ using @FM setting HandlePos else
|
||||
// The named cache does not exist so create it now.
|
||||
Memory_Services('CreateHashTable', CacheName)
|
||||
Locate CacheName in MemoryCacheNames@ using @FM setting HandlePos else
|
||||
HandlePos = 1
|
||||
end
|
||||
end
|
||||
end
|
||||
If Len(MemoryServicesManagers@<HandlePos>) then
|
||||
PrevMarker = SRP_HashTable_Get(MemoryServicesManagers@<HandlePos>, 'TIMEMARKER*' : KeyID)
|
||||
If PrevMarker NE '' then
|
||||
TimeMarker = (Date() * Day$) + Time()
|
||||
If (TimeMarker - PrevMarker) LE ExpirationDuration then
|
||||
ValueCurrent = True$
|
||||
If ResetAge EQ True$ then
|
||||
SRP_HashTable_Set(MemoryServicesManagers@<HandlePos>, 'TIMEMARKER*' : KeyID, TimeMarker)
|
||||
end
|
||||
end
|
||||
end
|
||||
end
|
||||
end else
|
||||
Error_Services('Set', 'KeyID or ExpirationDuraton was missing in the IsValueCurrent service.')
|
||||
end
|
||||
|
||||
Response = ValueCurrent
|
||||
|
||||
end service
|
||||
|
||||
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
// RemoveKey
|
||||
//
|
||||
// Removes the Key ID, and its value pair, from the SRP Hash Table.
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
Service RemoveKey(KeyID, CacheName)
|
||||
|
||||
If Len(KeyID) then
|
||||
// If the Memory Services's hash table does not yet exist then create it now.
|
||||
If CacheName EQ '' then
|
||||
HandlePos = 1
|
||||
end else
|
||||
Locate CacheName in MemoryCacheNames@ using @FM setting HandlePos else
|
||||
// The named cache does not exist so create it now.
|
||||
Memory_Services('CreateHashTable', CacheName)
|
||||
Locate CacheName in MemoryCacheNames@ using @FM setting HandlePos else
|
||||
HandlePos = 1
|
||||
end
|
||||
end
|
||||
end
|
||||
If Len(MemoryServicesManagers@<HandlePos>) then
|
||||
SRP_HashTable_Remove(MemoryServicesManagers@<HandlePos>, KeyID)
|
||||
end
|
||||
end else
|
||||
Error_Services('Set', 'Key ID did not contain a value in the RemoveKey service request.')
|
||||
end
|
||||
|
||||
end service
|
||||
|
||||
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
// CreateHashTable
|
||||
//
|
||||
// Creates the SRP Hash Table that the Memory_Services module will use to manage various Key ID and Value pairs. A
|
||||
// check will first be made to see if the handle to the Hash Table already exists. If so then it will be released and
|
||||
// a new Hash Table will be created.
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
Service CreateHashTable(CacheName)
|
||||
|
||||
If CacheName EQ '' then
|
||||
HandlePos = 1
|
||||
If Len(MemoryServicesManagers@<HandlePos>) then
|
||||
Memory_Services('ReleaseHashTable')
|
||||
end
|
||||
end else
|
||||
Locate CacheName in MemoryCacheNames@ using @FM setting HandlePos then
|
||||
Memory_Services('ReleaseHashTable', CacheName)
|
||||
end else
|
||||
HandlePos = DCount(MemoryCacheNames@, @FM) + 1
|
||||
If HandlePos EQ 1 then HandlePos = 2 ; // Handle position 1 is reserved for the default cache.
|
||||
end
|
||||
end
|
||||
|
||||
MemoryServicesManagers@<HandlePos> = SRP_HashTable_Create()
|
||||
If HandlePos GT 1 then
|
||||
MemoryCacheNames@<HandlePos> = CacheName
|
||||
end
|
||||
|
||||
Response = MemoryServicesManagers@<HandlePos>
|
||||
|
||||
end service
|
||||
|
||||
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
// ReleaseHashTable
|
||||
//
|
||||
// Releases the SRP Hash Table handle. If CacheName is empty then the default handle is released.
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
Service ReleaseHashTable(CacheName)
|
||||
|
||||
HandlePos = ''
|
||||
If CacheName EQ '' then
|
||||
HandlePos = 1
|
||||
end else
|
||||
Locate CacheName in MemoryCacheNames@ using @FM setting HandlePos else Null
|
||||
end
|
||||
|
||||
If HandlePos GE 1 then
|
||||
SRP_HashTable_Release(MemoryServicesManagers@<HandlePos>)
|
||||
MemoryServicesManagers@<HandlePos> = ''
|
||||
MemoryCacheNames@<HandlePos> = ''
|
||||
end
|
||||
|
||||
end service
|
||||
|
||||
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
// ReleaseAllHashTables
|
||||
//
|
||||
// Releases all SRP Hash Table handles.
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
Service ReleaseAllHashTables(CacheName)
|
||||
|
||||
If MemoryServicesManagers@ NE '' then
|
||||
For Each Handle in MemoryServicesManagers@ using @FM
|
||||
If Handle NE '' then SRP_HashTable_Release(Handle)
|
||||
Next Handle
|
||||
end
|
||||
MemoryServicesManagers@ = ''
|
||||
MemoryCacheNames@ = ''
|
||||
|
||||
end service
|
||||
|
||||
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
// GetHandle
|
||||
//
|
||||
// Returns the handle to the SRP Hash Table used by Memory_Services.
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
Service GetHandle(CacheName)
|
||||
|
||||
HandlePos = ''
|
||||
If CacheName EQ '' then
|
||||
HandlePos = 1
|
||||
end else
|
||||
Locate CacheName in MemoryCacheNames@ using @FM setting HandlePos else Null
|
||||
end
|
||||
|
||||
If HandlePos GE 1 then
|
||||
Handle = MemoryServicesManagers@<HandlePos>
|
||||
end
|
||||
|
||||
Response = Handle
|
||||
|
||||
end service
|
||||
|
||||
|
||||
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
|
||||
// Internal GoSubs
|
||||
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////?
|
||||
|
||||
9
SYSPROG/STPROC/MFS_CODENAME.txt
Normal file
9
SYSPROG/STPROC/MFS_CODENAME.txt
Normal file
@ -0,0 +1,9 @@
|
||||
Function MFS_CODENAME(code)
|
||||
|
||||
names = "READ.RECORD,READO.RECORD,WRITE.RECORD,DELETE.RECORD,LOCK.RECORD,UNLOCK.RECORD,SELECT,READNEXT,CLEARSELECT"
|
||||
names:= ",CLEARFILE,OPEN.FILE,CREATE.FILE,RENAME.FILE,MOVE.FILE,DELETE.FILE,OPEN.MEDIA,CREATE.MEDIA,READ.MEDIA,WRITE.MEDIA"
|
||||
names:= ",UNLOCK.ALL,FLUSH,INSTALL,RESERVED,RESERVED,RESERVED,OMNI.SCRIPT,CLOSE.MEDIA,RECORD.COUNT,REMAKE.FILE,CREATE.INDEX,DELETE.INDEX,UPDATE.INDEX,SELECT.INDEX,READNEXT.INDEX"
|
||||
|
||||
ans = Field(names, ',',code)
|
||||
|
||||
Return ans
|
||||
136
SYSPROG/STPROC/MFS_SHELL1.txt
Normal file
136
SYSPROG/STPROC/MFS_SHELL1.txt
Normal file
@ -0,0 +1,136 @@
|
||||
Subroutine MFS_SHELL1(CODE, BFS, HANDLE, NAME, FMC, RECORD, STATUS)
|
||||
|
||||
/*******************************
|
||||
|
||||
|
||||
÷ VERSION : 1.0
|
||||
|
||||
÷ PURPOSE :
|
||||
|
||||
÷ AUTHOR :
|
||||
|
||||
÷ CREATED :
|
||||
|
||||
÷ PROCEDURES :
|
||||
|
||||
*÷ WARNINGS :
|
||||
|
||||
*÷ THEORY OF OPERATION :
|
||||
|
||||
÷ REVISION HISTORY (Most CURRENT first) :
|
||||
|
||||
DATE IMPLEMENTOR FUNCTION
|
||||
-------- ----------- --------
|
||||
MM-DD-YY initials Modification
|
||||
|
||||
*******************************/
|
||||
|
||||
*÷ COMMON Variables (Terminate with '%') :
|
||||
|
||||
*÷ LABELED COMMON Variables (Terminate with '@') :
|
||||
|
||||
*÷ EQUATE Variables (Terminate with '$') :
|
||||
|
||||
EQU RTI$ TO 'Copyright (C) 1990-2023, Revelation Technologies, Inc.'
|
||||
EQU TRUE$ TO 1
|
||||
EQU FALSE$ TO 0
|
||||
EQU YES$ TO 1
|
||||
EQU NO$ TO 0
|
||||
EQU OTHERWISE$ TO 1
|
||||
EQU NULL$ TO ""
|
||||
EQU SPACE$ TO \20\
|
||||
|
||||
$INSERT FILE.SYSTEM.EQUATES
|
||||
$INSERT FSERRORS_HDR
|
||||
|
||||
*÷ MESSAGES called (Terminate with '$') :
|
||||
|
||||
*÷ DECLARED - FUNCTIONS called :
|
||||
|
||||
*÷ DECLARED - SUBROUTINES called :
|
||||
|
||||
/*******************************
|
||||
÷ INDIRECT - FUNCTIONS/SUBROUTINES called if known (Make COMMENTS) :
|
||||
*******************************/
|
||||
|
||||
*÷÷ PROGRAM TOP
|
||||
|
||||
FS = DELETE(BFS,1,1,1)
|
||||
NEXTFS = FS<1,1,1>
|
||||
@FILE.ERROR = ""
|
||||
|
||||
$INSERT FILE.SYSTEM.ONGOSUB
|
||||
|
||||
RETURN
|
||||
|
||||
*----------------------------------------------------------------------------
|
||||
/* Put all the operations to capture in this section.*/
|
||||
*----------------------------------------------------------------------------
|
||||
|
||||
RETURN
|
||||
*----------------------------------------------------------------------------
|
||||
/* Media operations */
|
||||
CREATE.MEDIA:
|
||||
OPEN.MEDIA:
|
||||
READ.MEDIA:
|
||||
WRITE.MEDIA:
|
||||
CLOSE.MEDIA:
|
||||
|
||||
*----------------------------------------------------------------------------
|
||||
/* File oriented operations */
|
||||
CLEARFILE:
|
||||
CREATE.FILE:
|
||||
DELETE.FILE:
|
||||
MOVE.FILE:
|
||||
OPEN.FILE:
|
||||
REMAKE.FILE:
|
||||
RENAME.FILE:
|
||||
|
||||
*----------------------------------------------------------------------------
|
||||
/* Select operations */
|
||||
SELECT:
|
||||
READNEXT:
|
||||
CLEARSELECT:
|
||||
|
||||
*----------------------------------------------------------------------------
|
||||
/* Record oriented operations */
|
||||
READ.RECORD:
|
||||
READO.RECORD:
|
||||
WRITE.RECORD:
|
||||
DELETE.RECORD:
|
||||
|
||||
*----------------------------------------------------------------------------
|
||||
/* Lock operations */
|
||||
LOCK.RECORD:
|
||||
UNLOCK.RECORD:
|
||||
|
||||
*----------------------------------------------------------------------------
|
||||
/* Index operations */
|
||||
CREATE.INDEX:
|
||||
UPDATE.INDEX:
|
||||
DELETE.INDEX:
|
||||
SELECT.INDEX:
|
||||
READNEXT.INDEX:
|
||||
RESERVED:
|
||||
|
||||
*----------------------------------------------------------------------------
|
||||
/* Misc calls */
|
||||
OMNI.SCRIPT:
|
||||
RECORD.COUNT:
|
||||
|
||||
NEXT_FS:
|
||||
|
||||
CALL @NEXTFS(CODE, FS, HANDLE, NAME, FMC, RECORD, STATUS)
|
||||
|
||||
RETURN
|
||||
|
||||
*----------------------------------------------------------------------------
|
||||
/*
|
||||
Install, unlock all and flush are called directly, no need to call next FS.
|
||||
*/
|
||||
INSTALL:
|
||||
FLUSH:
|
||||
UNLOCK.ALL:
|
||||
|
||||
STATUS = TRUE$
|
||||
RETURN
|
||||
132
SYSPROG/STPROC/MFS_SHELL2.txt
Normal file
132
SYSPROG/STPROC/MFS_SHELL2.txt
Normal file
@ -0,0 +1,132 @@
|
||||
Subroutine MFS_SHELL2(CODE, BFS, HANDLE, NAME, FMC, RECORD, STATUS)
|
||||
|
||||
****************************************************************
|
||||
* MFS shell for making Modified Filing Systems
|
||||
*
|
||||
* this program is similar to MFS.SHELL1, except it uses CASE logic to
|
||||
* dispatch according to the value of the CODE argument.
|
||||
*
|
||||
* use this logic as the basis for your MFS. Insert the appropriate code
|
||||
* under the correct case below. For example, if your MFS traps READs to
|
||||
* a file, insert your trap code underneath the statement
|
||||
*
|
||||
* CASE CODE = READ.RECORD
|
||||
*
|
||||
* and with correct relationship (before or after) the statement:
|
||||
*
|
||||
* GOSUB NEXT.MFS
|
||||
*
|
||||
****************************************************************
|
||||
|
||||
EQU TRUE$ TO 1
|
||||
EQU FALSE$ TO 0
|
||||
|
||||
$Insert FILE.SYSTEM.EQUATES
|
||||
|
||||
|
||||
*-------------------
|
||||
BEGIN CASE
|
||||
CASE CODE = READ.RECORD
|
||||
GOSUB NEXT.MFS
|
||||
*
|
||||
CASE CODE = READO.RECORD
|
||||
GOSUB NEXT.MFS
|
||||
*
|
||||
CASE CODE = WRITE.RECORD
|
||||
GOSUB NEXT.MFS
|
||||
*
|
||||
CASE CODE = DELETE.RECORD
|
||||
GOSUB NEXT.MFS
|
||||
*
|
||||
CASE CODE = LOCK.RECORD
|
||||
GOSUB NEXT.MFS
|
||||
*
|
||||
CASE CODE = UNLOCK.RECORD
|
||||
GOSUB NEXT.MFS
|
||||
*
|
||||
CASE CODE = SELECT
|
||||
GOSUB NEXT.MFS
|
||||
*
|
||||
CASE CODE = READNEXT
|
||||
GOSUB NEXT.MFS
|
||||
*
|
||||
CASE CODE = CLEARSELECT
|
||||
GOSUB NEXT.MFS
|
||||
*
|
||||
CASE CODE = CLEARFILE
|
||||
GOSUB NEXT.MFS
|
||||
*
|
||||
CASE CODE = OPEN.FILE
|
||||
GOSUB NEXT.MFS
|
||||
*
|
||||
CASE CODE = CREATE.FILE
|
||||
GOSUB NEXT.MFS
|
||||
*
|
||||
CASE CODE = RENAME.FILE
|
||||
GOSUB NEXT.MFS
|
||||
*
|
||||
CASE CODE = MOVE.FILE
|
||||
GOSUB NEXT.MFS
|
||||
*
|
||||
CASE CODE = DELETE.FILE
|
||||
GOSUB NEXT.MFS
|
||||
*
|
||||
CASE CODE = OPEN.MEDIA
|
||||
GOSUB NEXT.MFS
|
||||
*
|
||||
CASE CODE = CREATE.MEDIA
|
||||
GOSUB NEXT.MFS
|
||||
*
|
||||
CASE CODE = READ.MEDIA
|
||||
GOSUB NEXT.MFS
|
||||
*
|
||||
CASE CODE = WRITE.MEDIA
|
||||
GOSUB NEXT.MFS
|
||||
*
|
||||
CASE CODE = UNLOCK.ALL
|
||||
STATUS = TRUE$
|
||||
*
|
||||
CASE CODE = FLUSH
|
||||
STATUS = TRUE$
|
||||
*
|
||||
CASE CODE = INSTALL
|
||||
STATUS = TRUE$
|
||||
*
|
||||
CASE CODE = RECORD.COUNT
|
||||
GOSUB NEXT.MFS
|
||||
*
|
||||
CASE CODE = REMAKE.FILE
|
||||
GOSUB NEXT.MFS
|
||||
*
|
||||
CASE CODE = CLOSE.MEDIA
|
||||
GOSUB NEXT.MFS
|
||||
*
|
||||
CASE CODE = OMNI.SCRIPT
|
||||
GOSUB NEXT.MFS
|
||||
*
|
||||
CASE CODE = CREATE.INDEX
|
||||
GOSUB NEXT.MFS
|
||||
*
|
||||
CASE CODE = DELETE.INDEX
|
||||
GOSUB NEXT.MFS
|
||||
*
|
||||
CASE CODE = UPDATE.INDEX
|
||||
GOSUB NEXT.MFS
|
||||
*
|
||||
CASE CODE = SELECT.INDEX
|
||||
GOSUB NEXT.MFS
|
||||
*
|
||||
CASE CODE = READNEXT.INDEX
|
||||
GOSUB NEXT.MFS
|
||||
*
|
||||
END CASE
|
||||
|
||||
RETURN ''
|
||||
|
||||
* ------------------
|
||||
NEXT.MFS:
|
||||
FS = DELETE(BFS,1,1,1)
|
||||
NEXTFS = FS<1,1,1>
|
||||
CALL @NEXTFS(CODE, FS, HANDLE, NAME, FMC, RECORD, STATUS)
|
||||
|
||||
RETURN
|
||||
130
SYSPROG/STPROC/NULL_MFS.txt
Normal file
130
SYSPROG/STPROC/NULL_MFS.txt
Normal file
@ -0,0 +1,130 @@
|
||||
Subroutine NULL_MFS(CODE, BFS, HANDLE, NAME, FMC, RECORD, STATUS)
|
||||
|
||||
/* Name : SYSLISTS_MFS
|
||||
* Description:
|
||||
* Cache Temporary lists in memory to speed selects, reduce load on network, reduce GFE chances
|
||||
|
||||
* Open -- put the cache number in the handle
|
||||
* Read/Reado -- add the record to the cache
|
||||
* write/delete/clear -- Update remote, local copy
|
||||
* omnievent -- fullcache
|
||||
*
|
||||
*
|
||||
* Side Effects:
|
||||
* Search of lists file will not show temp lists
|
||||
*
|
||||
|
||||
*/
|
||||
|
||||
Declare Function RTI_HASHTABLE2, RTI_MD5,RTI_crc32, rti_memcached
|
||||
Declare Subroutine RTI_HASHTABLE2, RTI_MD5, rti_memcached
|
||||
|
||||
$insert Logical
|
||||
$insert FSErrors_100
|
||||
$Insert FILE.SYSTEM.EQUATES
|
||||
$Insert memcached_mfs_Equates
|
||||
$Insert rti_memcached_equates
|
||||
|
||||
$Insert File.System.OnGoSub
|
||||
Return
|
||||
|
||||
|
||||
|
||||
|
||||
* -------------- Main Subs -----------------
|
||||
READ.RECORD:
|
||||
READO.RECORD:
|
||||
WRITE.RECORD:
|
||||
DELETE.RECORD:
|
||||
CLEARFILE:
|
||||
DELETE.FILE:
|
||||
GOSUB NEXT.MFS
|
||||
Return
|
||||
* ---------------------------------------
|
||||
* non-chained filing system calls
|
||||
* ---------------------------------------
|
||||
Flush:
|
||||
Unlock.All:
|
||||
Record = ""
|
||||
|
||||
Status = TRUE$
|
||||
Return
|
||||
|
||||
Install:
|
||||
Status = TRUE$
|
||||
Return
|
||||
* ---------------------------------------
|
||||
* ---------------------------------------
|
||||
* Chained Filing System Calls
|
||||
* ---------------------------------------
|
||||
LOCK.RECORD:
|
||||
UNLOCK.RECORD:
|
||||
GOSUB NEXT.MFS
|
||||
RETURN
|
||||
|
||||
*--------------------------------------------------
|
||||
SELECT:
|
||||
READNEXT:
|
||||
CLEARSELECT:
|
||||
RECORD.COUNT:
|
||||
* ---------------------------------------
|
||||
CREATE.INDEX:
|
||||
DELETE.INDEX:
|
||||
UPDATE.INDEX:
|
||||
SELECT.INDEX:
|
||||
READNEXT.INDEX:
|
||||
* ---------------------------------------
|
||||
GOSUB NEXT.MFS
|
||||
Return
|
||||
|
||||
|
||||
Omni.Script:
|
||||
GOSUB NEXT.MFS
|
||||
Return
|
||||
|
||||
|
||||
Reserved:
|
||||
* there is a critical error if this line is reached
|
||||
Status = FALSE$
|
||||
Return
|
||||
|
||||
* ---------------------------------------
|
||||
* On open, connect to a cache
|
||||
* Use a "namespace" prefix to separate this table's data from another
|
||||
* namespace rule is crc32 of handle+tablename, so if they attach the same table with a different volume they see different data
|
||||
|
||||
* Note - to "clear" a table from memcached you change the namespace
|
||||
* If we ever want to support clear_Table, we must make clear_table change the namespace, perhaps we use handle + name + a clear_counter in the dict.
|
||||
*
|
||||
OPEN.FILE:
|
||||
CREATE.FILE:
|
||||
RENAME.FILE:
|
||||
MOVE.FILE:
|
||||
REMAKE.FILE:
|
||||
* ----------------------------------------
|
||||
Open.Media:
|
||||
CREATE.MEDIA:
|
||||
READ.MEDIA:
|
||||
WRITE.MEDIA:
|
||||
Close.Media:
|
||||
gosub Next.MFS
|
||||
Return
|
||||
|
||||
|
||||
|
||||
|
||||
* ---------- End of Subroutine
|
||||
* ==================================
|
||||
* execute filing system chain
|
||||
* ==================================
|
||||
Next.MFS:
|
||||
|
||||
|
||||
* Strips this MFS leaving the next fs as first element in array
|
||||
FSList = delete(BFS, 1, 1, 1)
|
||||
NextFS = FSList<1,1,1>
|
||||
if len(NextFS) then
|
||||
call @NextFS(Code, FSList, Handle, Name, Fmc, Record, Status)
|
||||
End
|
||||
Return
|
||||
|
||||
71
SYSPROG/STPROC/O4WI_FILTER.txt
Normal file
71
SYSPROG/STPROC/O4WI_FILTER.txt
Normal file
@ -0,0 +1,71 @@
|
||||
Function O4WI_FILTER(ProcName, UDetails, Tablename)
|
||||
*#!Precompile
|
||||
/*
|
||||
* This program is proprietary and is not to be used by or disclosed to others, nor is it to be copied without
|
||||
* written permission from Revelation Technologies, Inc.
|
||||
!
|
||||
*
|
||||
* VERSION : 1.0
|
||||
*
|
||||
*
|
||||
* AUTHOR : Bryan Shumsky
|
||||
*
|
||||
* CREATED : September 23, 2009
|
||||
*
|
||||
*
|
||||
!
|
||||
*
|
||||
* REVISION HISTORY (Most CURRENT first) :
|
||||
*
|
||||
* DATE IMPLEMENTOR FUNCTION
|
||||
* -------- ----------- --------
|
||||
* 03 May 2010 bzs Added logic to respect environment security settings
|
||||
*
|
||||
*
|
||||
*/
|
||||
*
|
||||
$Insert ENVIRON_CONSTANTS
|
||||
*
|
||||
If Assigned(procname) Else procname = ""
|
||||
If Assigned(udetails) Else udetails = ""
|
||||
If Assigned(tablename) Else tablename = ""
|
||||
*
|
||||
* By default, no filters are applied EXCEPT for system-wide filters
|
||||
SecFlds = @ENVIRON_SET<ENV_EXCLUDE_FIELDS$>
|
||||
Sectbl = @ENVIRON_SET<ENV_EXCLUDE_FROM_REPORTS$>
|
||||
|
||||
rslt = ""
|
||||
Begin Case
|
||||
Case tableName = ""
|
||||
* return list of all tables
|
||||
* 121410 If these are used for the form or report or dashboard process, remove "!" and "DICT." tables
|
||||
bExclude = 0
|
||||
If procName = "O4W_DEFINE_FORM" Or procName = "O4W_DEFINE_REPORT" Or procName = "O4W_DEFINE_DASHBOARD" Then
|
||||
bExclude = 1
|
||||
End
|
||||
Call Rlist("SELECT SYSTABLES BY @ID", '5')
|
||||
DONE = 0
|
||||
Loop
|
||||
Readnext id Else DONE = 1
|
||||
Until DONE Do
|
||||
If bExclude=0 Or (id[1,1] <> "!" And id[1,5] <> "DICT.") then
|
||||
Locate id In SecTbl<1> Using @VM Setting dummy else
|
||||
rslt<1,-1> = id
|
||||
End
|
||||
end
|
||||
Repeat
|
||||
Case 1
|
||||
* return list of fields for specified table
|
||||
trslt = Xlate("DICT.":TableName, "%FIELDS%", "3", "X")
|
||||
num.flds = dcount(trslt, @VM)
|
||||
rslt = ""
|
||||
For each.fld = 1 To num.flds
|
||||
this.fld = trslt<1,each.fld>
|
||||
chkfld = tableName:@svm:this.fld
|
||||
Locate chkfld In secflds<1> Using @vm Setting chkpos Else
|
||||
rslt<1,-1> = this.fld
|
||||
End
|
||||
Next each.fld
|
||||
End Case
|
||||
*
|
||||
Return rslt
|
||||
312
SYSPROG/STPROC/O4WI_FORMDESIGNER_PAGE_XXX.txt
Normal file
312
SYSPROG/STPROC/O4WI_FORMDESIGNER_PAGE_XXX.txt
Normal file
@ -0,0 +1,312 @@
|
||||
Function O4WI_FORMDESIGNER_PAGE_XXX(ACTION, headerInfo, formInfo_Orig, uniqueid, ctlentid, event, param1, param2, param3, status)
|
||||
*#!Precompile
|
||||
|
||||
/*
|
||||
* This program is proprietary and is not to be used by or disclosed to others, nor is it to be copied without
|
||||
* written permission from Revelation Technologies, Inc.
|
||||
!
|
||||
*
|
||||
* VERSION : 1.0
|
||||
*
|
||||
*
|
||||
* AUTHOR : Revelation Software Inc., All Rights Reserved
|
||||
*
|
||||
* CREATED : July 20, 2015
|
||||
*
|
||||
*
|
||||
!
|
||||
*
|
||||
* REVISION HISTORY (Most CURRENT first) :
|
||||
*
|
||||
* DATE IMPLEMENTOR FUNCTION
|
||||
* -------- ----------- --------
|
||||
*
|
||||
*
|
||||
*/
|
||||
*
|
||||
$Insert o4wcommon
|
||||
$Insert o4wequates
|
||||
$Insert O4W_DESIGN_FORM_EQUATES
|
||||
$Insert O4W_COMMUTER_COMMON
|
||||
|
||||
Declare Function Repository, Function, RTI_VERIFY_PROC
|
||||
|
||||
If Assigned(ACTION) Else ACTION = ""
|
||||
If Assigned(HEADERINFO) Else HEADERINFO = ""
|
||||
If Assigned(FORMINFO_ORIG) Else FORMINFO_ORIG = ""
|
||||
If Assigned(UNIQUEID) Else UNIQUEID = ""
|
||||
If Assigned(param1) Else param1 = ""
|
||||
If Assigned(param2) Else param2 = ""
|
||||
If Assigned(param3) Else param3 = ""
|
||||
If Assigned(status) Else status = ""
|
||||
|
||||
If pageNo@ = "" Then pageNo@ = 1
|
||||
If pageNo@ <> headerinfo<HEADER_CURR_PAGE$> Then
|
||||
* must load in the current page
|
||||
Read formInfo From o4wtempfile%, uniqueID:"_PAGE_":pageNo@ Else formInfo = ""
|
||||
End Else
|
||||
formInfo = formInfo_Orig
|
||||
end
|
||||
|
||||
Equ page_desc$ To "Generic"
|
||||
If formInfo<FORMINFO_PAGE_CONTROL_HDR$> = "" Then
|
||||
Gosub setDefaults
|
||||
End Else
|
||||
Gosub updateHeader
|
||||
end
|
||||
|
||||
|
||||
RSLT = ""
|
||||
|
||||
If Not(Num(ACTION)) Or ACTION < PAGEWIDGET_ACTION_MIN_VALUE$ Or ACTION > PAGEWIDGET_ACTION_MAX_VALUE$ Then
|
||||
rslt = WIDGET_ACTION_INVALID$
|
||||
End Else
|
||||
On action Gosub doPreDraw, doDraw, handleResults, doPropsShow, doPropsSave, doSaveDefaults
|
||||
End
|
||||
|
||||
Return RSLT
|
||||
|
||||
|
||||
doPropsShow:
|
||||
O4WSectionStart("specialSection", o4wmarkedoptions(1):o4wresponseoptions())
|
||||
num.fields = dcount(formInfo<FORMINFO_ID$>, @VM)
|
||||
o4wtablestart("fieldTable")
|
||||
For each.Field = 1 To num.fields
|
||||
id = forminfo<FORMINFO_ID$, each.Field>
|
||||
type = formInfo<FORMINFO_TYPE$, each.Field>
|
||||
supportName = UCASE(DESIGN_SUPPORT_PREFIX$:Type)
|
||||
IF RTI_VERIFY_PROC(supportName, 0, 5) = 0 THEN
|
||||
CALL SET_STATUS(0)
|
||||
END Else
|
||||
pInfo = Function(@supportName(WIDGET_ACTION_INFO$, headerInfo, formInfo, id, WIDGET_INFO_DB$))
|
||||
If pInfo <> "" Then
|
||||
end
|
||||
end
|
||||
Next each.field
|
||||
o4wbutton("OK", "BTN_PPROPS_OK", O4WMARKEDOPTIONS(1))
|
||||
o4wspace(3)
|
||||
o4wbutton("Cancel", "BTN_DISCARD_NO")
|
||||
O4WQUALIFYEVENT("BTN_PPROPS_OK", "CLICK")
|
||||
O4WQUALIFYEVENT("BTN_DISCARD_NO", "CLICK")
|
||||
o4wsectionend("specialSection")
|
||||
o4wdialog("specialSection", page_desc$:" Properties")
|
||||
Return
|
||||
|
||||
doPropsSave:
|
||||
NAMES = "CLEAR"
|
||||
values = ""
|
||||
Gosub doUpdate2
|
||||
values = o4wgetvalue("KEYFIELD")
|
||||
names = "KEYFIELD"
|
||||
Gosub doUpdate2
|
||||
Return
|
||||
|
||||
doUpdate:
|
||||
names = param1
|
||||
values = param2
|
||||
doUpdate2:
|
||||
num.names = dcount(names, @FM)
|
||||
For each.name = 1 To num.names
|
||||
this.name = names<each.name>
|
||||
this.value = values<each.name>
|
||||
Begin Case
|
||||
Case this.name = "CLEAR"
|
||||
formInfo<FORMINFO_PAGE_CONTROL_HDR$> = HEADER_TAG_VERSION$
|
||||
formInfo<FORMINFO_PAGE_CONTROL$> = HEADER_TAG_VERSION_VALUE$
|
||||
Case this.name = "KEYFIELD"
|
||||
End Case
|
||||
Next each.name
|
||||
Return
|
||||
|
||||
doPreDraw:
|
||||
DRROOverrideFlag@ = ""
|
||||
DRShowNoneOverrideFlag@ = ""
|
||||
|
||||
Return
|
||||
|
||||
doDraw:
|
||||
Return
|
||||
|
||||
handleResults:
|
||||
runMode = param1
|
||||
bMobile = param2
|
||||
bHandled = 0
|
||||
|
||||
|
||||
If bHandled = 0 Then
|
||||
* call into the helper to handle this
|
||||
rslt = O4WI_FORMDESIGNER_PAGE_HELPER("EVENT", headerInfo, formInfo, errs, runMode, bMobile, ctlentid, event, uniqueID)
|
||||
end
|
||||
|
||||
Return
|
||||
|
||||
setDefaults:
|
||||
formInfo<FORMINFO_PAGE_CONTROL_HDR$> = HEADER_TAG_VERSION$
|
||||
formInfo<FORMINFO_PAGE_CONTROL$> = HEADER_TAG_VERSION_VALUE$
|
||||
num.fields = dcount(formInfo<FORMINFO_ID$>, @VM)
|
||||
buttons = ""
|
||||
firstField = ""
|
||||
For each.Field = 1 To num.fields
|
||||
id = forminfo<FORMINFO_ID$, each.Field>
|
||||
type = formInfo<FORMINFO_TYPE$, each.Field>
|
||||
supportName = UCASE(DESIGN_SUPPORT_PREFIX$:Type)
|
||||
IF RTI_VERIFY_PROC(supportName, 0, 5) = 0 THEN
|
||||
CALL SET_STATUS(0)
|
||||
END Else
|
||||
If type = CONTROL_TYPE_BUTTON$ Or type = CONTROL_TYPE_M_BUTTON$ Then
|
||||
pInfo = Function(@supportName(WIDGET_ACTION_INFO$, headerInfo, formInfo, id, WIDGET_INFO_NAME$))
|
||||
bName = ID
|
||||
If pInfo <> "" Then
|
||||
bName = pInfo<1>
|
||||
End
|
||||
buttons<1,-1> = id
|
||||
buttons<2,-1> = bName
|
||||
End else
|
||||
pInfo = Function(@supportName(WIDGET_ACTION_INFO$, headerInfo, formInfo, id, WIDGET_INFO_DB$:@FM:WIDGET_INFO_INPUT$))
|
||||
If pInfo<1,1> <> "" And pInfo[1,1] <> "<" And pInfo<2> = "1" Then
|
||||
Locate id In formInfo<FORMINFO_PAGE_CONTROL_HDR$> using @VM setting posn Else null
|
||||
formInfo<FORMINFO_PAGE_CONTROL_HDR$, posn> = id
|
||||
tableName = pInfo<1,1>
|
||||
fieldName = pInfo<1,2>
|
||||
conv_o = pInfo<1,5>
|
||||
pType = "0" ;* default to prompt
|
||||
skipIfNull = 1 ;* default to true
|
||||
sType = 0 ;* default to unchanged
|
||||
jType = "0" ;* default to and
|
||||
addl = ""
|
||||
details = "IMP":@SVM:ptype:@SVM:addl:@SVM:type:@SVM:tableName:@SVM:fieldName:@SVM:conv_o:@SVM:skipIfNull:@SVM:sType:@SVM:jType
|
||||
formInfo<FORMINFO_PAGE_CONTROL$, posn> = details
|
||||
If pInfo<2> = "1" And firstField = "" Then firstField = id
|
||||
End
|
||||
end
|
||||
End
|
||||
Next each.Field
|
||||
num.buttons = dcount(buttons<1>, @VM)
|
||||
For each.button = 1 To num.buttons
|
||||
this.button = buttons<1, each.button>
|
||||
this.button.name = buttons<2, each.button>
|
||||
If this.button = "" Then this.button = " "
|
||||
bType = ""
|
||||
unassignedCnt = 1
|
||||
Begin Case
|
||||
Case indexc(this.button.name, "read", 1) Or indexc(this.button.name, "go", 1)
|
||||
bType = TRIGGER_EVENT_READ$
|
||||
Case indexc(this.button.name, "search", 1)
|
||||
bType = TRIGGER_EVENT_SEARCH$
|
||||
Case indexc(this.button.name, "forward", 1) Or indexc(this.button.name, "next", 1)
|
||||
bType = TRIGGER_EVENT_FORWARD$
|
||||
Case indexc(this.button.name, "prev", 1) Or indexc(this.button.name, "back", 1)
|
||||
bType = TRIGGER_EVENT_BACK$
|
||||
Case indexc(this.button.name, "save", 1)
|
||||
btype = TRIGGER_EVENT_SAVE$
|
||||
Case indexc(this.button.name, "cancel", 1)
|
||||
btype = TRIGGER_EVENT_CANCEL$
|
||||
Case indexc(this.button.name, "del", 1)
|
||||
btype = TRIGGER_EVENT_DEL$
|
||||
Case indexc(this.button.name, "new", 1)
|
||||
btype = TRIGGER_EVENT_NEW$
|
||||
Case indexc(this.button.name, "qbf", 1)
|
||||
* not an assignable type
|
||||
CASE unassignedCnt = 1
|
||||
bType = TRIGGER_EVENT_SEARCH$
|
||||
unassignedCnt += 1
|
||||
CASE unassignedCnt = 2
|
||||
bType = TRIGGER_EVENT_CANCEL$
|
||||
unassignedCnt += 1
|
||||
CASE unassignedCnt = 3
|
||||
bType = TRIGGER_EVENT_FORWARD$
|
||||
unassignedCnt += 1
|
||||
CASE unassignedCnt = 4
|
||||
bType = TRIGGER_EVENT_BACK$
|
||||
unassignedCnt += 1
|
||||
CASE unassignedCnt = 5
|
||||
bType = TRIGGER_EVENT_NEW$
|
||||
unassignedCnt += 1
|
||||
CASE unassignedCnt = 6
|
||||
bType = TRIGGER_EVENT_DEL$
|
||||
unassignedCnt += 1
|
||||
CASE unassignedCnt = 7
|
||||
bType = TRIGGER_EVENT_READ$
|
||||
unassignedCnt += 1
|
||||
CASE unassignedCnt = 8
|
||||
btype = TRIGGER_EVENT_SAVE$
|
||||
unassignedCnt += 1
|
||||
End CASE
|
||||
If bType <> "" Then
|
||||
* bzs 011721 swapped for version 2.0
|
||||
formInfo = Insert(formInfo, FORMINFO_PAGE_CONTROL_HDR$, 1, 0, this.button)
|
||||
formInfo = Insert(formInfo, FORMINFO_PAGE_CONTROL$, 1, 0, bType)
|
||||
If bType = TRIGGER_EVENT_NEW$ Then
|
||||
* default to 'user entered' key
|
||||
formInfo = Insert(formInfo, FORMINFO_PAGE_CONTROL_HDR$, 1, 0, HEADER_TAG_NEW_DETAIL$)
|
||||
formInfo = Insert(formInfo, FORMINFO_PAGE_CONTROL$, 1, 0, "U")
|
||||
end
|
||||
end
|
||||
Next each.button
|
||||
If firstField <> "" Then
|
||||
formInfo<FORMINFO_PAGE_CONTROL_HDR$, -1> = HEADER_TAG_FOCUS$
|
||||
formInfo<FORMINFO_PAGE_CONTROL$, -1> = firstField
|
||||
end
|
||||
Return
|
||||
|
||||
updateHeader:
|
||||
* bzs 011721 make sure header info is in new format
|
||||
If formInfo<FORMINFO_PAGE_CONTROL_HDR$,1> <> HEADER_TAG_VERSION$ Or formInfo<FORMINFO_PAGE_CONTROL$,1> <> HEADER_TAG_VERSION_VALUE$ Then
|
||||
NUM.HDR = DCOUNT(forminfo<FORMINFO_PAGE_CONTROL_HDR$>, @VM)
|
||||
NEW.HDR = HEADER_TAG_VERSION$
|
||||
NEW.DETAILS = HEADER_TAG_VERSION_VALUE$
|
||||
For EACH.HDR = 1 To NUM.HDR
|
||||
this.element = formInfo<FORMINFO_PAGE_CONTROL_HDR$, each.hdr>
|
||||
this.detail = formInfo<FORMINFO_PAGE_CONTROL$, each.hdr>
|
||||
Begin Case
|
||||
Case THIS.ELEMENT = HEADER_TAG_VERSION$
|
||||
* ignored - already updated
|
||||
Case this.element = TRIGGER_EVENT_DEL$ Or this.element = TRIGGER_EVENT_CANCEL$ Or this.element = TRIGGER_EVENT_NEW$ Or this.element = TRIGGER_EVENT_SAVE$ Or this.element = TRIGGER_EVENT_READ$
|
||||
* swap these
|
||||
NEW.HDR<1,-1> = this.detail ;* button ID
|
||||
NEW.DETAILS<1,-1> = this.element ;* action name
|
||||
Case this.element = HEADER_TAG_FOCUS$ Or THIS.ELEMENT = HEADER_TAG_NEW_DETAIL$ Or THIS.ELEMENT = HEADER_TAG_PREDRAW_EVENT$ Or THIS.ELEMENT = HEADER_TAG_POSTDRAW_EVENT$ Or THIS.ELEMENT = HEADER_TAG_CUSTOM_EVENT$
|
||||
* these belong in the options
|
||||
formInfo<FORMINFO_PAGE_OPTIONS_HDR$, -1> = THIS.ELEMENT
|
||||
formInfo<FORMINFO_PAGE_OPTIONS$, -1> = THIS.DETAIL
|
||||
Case 1
|
||||
* these are OK
|
||||
NEW.HDR<1,-1> = this.element
|
||||
NEW.DETAILS<1,-1> = this.detail
|
||||
End case
|
||||
Next EACH.HDR
|
||||
formInfo<FORMINFO_PAGE_CONTROL_HDR$> = NEW.HDR
|
||||
formInfo<FORMINFO_PAGE_CONTROL$> = NEW.DETAILS
|
||||
NUM.OPTIONS = DCOUNT(formInfo<FORMINFO_PAGE_OPTIONS_HDR$>, @VM)
|
||||
NEW.HDR = ""
|
||||
NEW.DETAILS = ""
|
||||
For EACH.HDR = 1 To NUM.HDR
|
||||
THIS.ELEMENT = formInfo<FORMINFO_PAGE_OPTIONS_HDR$, each.hdr>
|
||||
THIS.DETAIL = formInfo<FORMINFO_PAGE_OPTIONS$, each.hdr>
|
||||
Begin Case
|
||||
Case this.element = "MAXSEARCH" Or THIS.element = "WARNSEARCH" Or this.element = "TRIGGER_TYPE"
|
||||
NEW.HDR<1,-1> = "<":THIS.ELEMENT:">"
|
||||
NEW.DETAILS<1,-1> = THIS.DETAIL
|
||||
Case this.element = "QBFDISABLE" or this.element = "NOSAVEOK" Or THIS.element = "REDIRECTTO"
|
||||
NEW.HDR<1,-1> = "<":THIS.ELEMENT:">"
|
||||
NEW.DETAILS<1,-1> = THIS.DETAIL
|
||||
Case 1
|
||||
* these are OK
|
||||
NEW.HDR<1,-1> = this.element
|
||||
NEW.DETAILS<1,-1> = this.detail
|
||||
End case
|
||||
Next EACH.HDR
|
||||
formInfo<FORMINFO_PAGE_OPTIONS_HDR$> = NEW.HDR
|
||||
formInfo<FORMINFO_PAGE_OPTIONS$> = NEW.DETAILS
|
||||
Gosub doSaveDefaults
|
||||
End
|
||||
return
|
||||
|
||||
|
||||
doSaveDefaults:
|
||||
* property defaults must already be set; just make sure To save them
|
||||
Write formInfo On o4wtempfile%, uniqueID:"_PAGE_":pageNo@
|
||||
If pageNo@ = headerInfo<HEADER_CURR_PAGE$> Then
|
||||
formInfo_ORIG = formInfo
|
||||
end
|
||||
return
|
||||
1203
SYSPROG/STPROC/O4WI_FORMDESIGNER_TEMPLATE_XXX.txt
Normal file
1203
SYSPROG/STPROC/O4WI_FORMDESIGNER_TEMPLATE_XXX.txt
Normal file
File diff suppressed because it is too large
Load Diff
736
SYSPROG/STPROC/O4WI_FORMDESIGNER_WIDGET_XXX.txt
Normal file
736
SYSPROG/STPROC/O4WI_FORMDESIGNER_WIDGET_XXX.txt
Normal file
@ -0,0 +1,736 @@
|
||||
Function O4WI_FORMDESIGNER_WIDGET_XXX(ACTION, headerInfo, formInfo, elementID, param1, param2, param3, param4, param5, param6, param7, param8)
|
||||
*#!Precompile
|
||||
|
||||
/*
|
||||
* This program is proprietary and is not to be used by or disclosed to others, nor is it to be copied without
|
||||
* written permission from Revelation Technologies, Inc.
|
||||
!
|
||||
*
|
||||
* VERSION : 1.0
|
||||
*
|
||||
*
|
||||
* AUTHOR : Revelation Software, Inc., All Rights Reserved
|
||||
*
|
||||
* CREATED : July 20, 2015
|
||||
*
|
||||
*
|
||||
!
|
||||
*
|
||||
* REVISION HISTORY (Most CURRENT first) :
|
||||
*
|
||||
* DATE IMPLEMENTOR FUNCTION
|
||||
* -------- ----------- --------
|
||||
*
|
||||
*
|
||||
*/
|
||||
*
|
||||
|
||||
$Insert o4wcommon
|
||||
$Insert o4wequates
|
||||
$Insert O4W_DESIGN_FORM_EQUATES
|
||||
|
||||
If Assigned(ACTION) Else ACTION = ""
|
||||
If Assigned(formInfo) Else formInfo = ""
|
||||
If Assigned(elementID) Else elementID = ""
|
||||
If Assigned(param1) Else param1 = ""
|
||||
If Assigned(param2) Else param2 = ""
|
||||
If Assigned(param3) Else param3 = ""
|
||||
If Assigned(param4) Else param4 = ""
|
||||
If Assigned(param5) Else param5 = ""
|
||||
If Assigned(param6) Else param6 = ""
|
||||
If Assigned(param7) Else param7 = ""
|
||||
If Assigned(param8) Else param8 = ""
|
||||
|
||||
|
||||
RSLT = ""
|
||||
elementName = "Control name here"
|
||||
|
||||
If Not(Num(action)) Or action < WIDGET_ACTION_MIN_VALUE$ Or action > WIDGET_ACTION_MAX_VALUE$ Then
|
||||
rslt = WIDGET_ACTION_INVALID$
|
||||
End Else
|
||||
On action Gosub doInit, getInfo, doDraw, getProps, doUpdate, doValidate, handleEvent, getPropsForTab, getValue, getRecordInfo
|
||||
End
|
||||
|
||||
Return RSLT
|
||||
|
||||
|
||||
doInit:
|
||||
title = elementName; text = elementName; image = "../images/widgets/jqm_radio_button.svg"
|
||||
param1 = title
|
||||
param2 = text
|
||||
param3 = image
|
||||
return
|
||||
|
||||
|
||||
GetInfo:
|
||||
Gosub getFormInfo
|
||||
infoTypes = param1
|
||||
num.info = dcount(infoTypes, @FM)
|
||||
For each.info = 1 To num.info
|
||||
infoType = infoTypes<each.info>
|
||||
Begin Case
|
||||
Case infoType = WIDGET_INFO_CONTAINER$
|
||||
* return "1" if a container and the childTYpe is allowed or Null
|
||||
* return "0" if a container and the childType is NOT allowed
|
||||
* return "" if not a container
|
||||
childType = param2<each.info>
|
||||
* DO CONTROL-SPECIFIC WORK
|
||||
|
||||
Case infoType = WIDGET_INFO_ASSOCIATED_LABEL$
|
||||
* return "1" if this is an element that can be associated with a label
|
||||
* return "" else
|
||||
* DO CONTROL-SPECIFIC WORK
|
||||
|
||||
Case infoType = WIDGET_INFO_CAN_DELETE$
|
||||
* return "1" if this element can be deleted
|
||||
* return "0" if it cannot
|
||||
* DO CONTROL-SPECIFIC WORK
|
||||
|
||||
Case infoType = WIDGET_INFO_DB$
|
||||
* return the table/fieldname for this element
|
||||
*If table <> "" then
|
||||
* rslt = table:@VM:fieldName
|
||||
*end
|
||||
|
||||
Case infoType = WIDGET_INFO_ID$
|
||||
Rslt<each.info> = elementID:DRSuffix@
|
||||
|
||||
Case infoType = WIDGET_INFO_DETAILS$
|
||||
* return generic info
|
||||
RSLT<each.info> = COMMENT
|
||||
If RSLT<each.info> = "" THEN
|
||||
* DO CONTROL-SPECIFIC WORK
|
||||
RSLT<each.info> = ELEMENTNAME
|
||||
End
|
||||
|
||||
Case infoType = WIDGET_INFO_INPUT$
|
||||
* return 1 if input element and enabled
|
||||
* return 0 if input element and disabled
|
||||
* return null otherwise
|
||||
If roFlag <> "1" Then
|
||||
rslt<each.info> = "1"
|
||||
End Else
|
||||
rslt<each.info> = "0"
|
||||
end
|
||||
|
||||
Case infoType = WIDGET_INFO_ALIGN$
|
||||
rslt<each.info> = controlalign
|
||||
|
||||
Case infoType = WIDGET_INFO_BGCOLOR$
|
||||
rslt<each.info> = bgcolor
|
||||
|
||||
Case infoType = WIDGET_INFO_EVENTS$
|
||||
If cmBefore Then
|
||||
rslt<each.info,1,-1> = WIDGET_EVENT_BEFORE$
|
||||
rslt<each.info,2,-1> = "N/A"
|
||||
End
|
||||
If cmAfter Then
|
||||
rslt<each.info,1,-1> = WIDGET_EVENT_AFTER$
|
||||
rslt<each.info,2,-1> = "N/A"
|
||||
End
|
||||
If cmChange Then
|
||||
rslt<each.info,1,-1> = WIDGET_EVENT_CHANGED$
|
||||
rslt<each.info,2,-1> = "N/A"
|
||||
End
|
||||
If updateAssociated <> "" Then
|
||||
rslt<each.info,1, -1> = WIDGET_EVENT_ASSOCIATED$
|
||||
rslt<each.info,2,-1> = updateAssociated
|
||||
End
|
||||
|
||||
Case infoType = WIDGET_INFO_NAME$
|
||||
rslt<each.info> = name
|
||||
|
||||
End Case
|
||||
Next each.info
|
||||
Return
|
||||
|
||||
|
||||
doValidate:
|
||||
Gosub getFormInfo
|
||||
updateList = ""
|
||||
|
||||
If COMMENT = "" And table <> "" Then
|
||||
comment = Xlate("DICT.":table, fieldname, 3, "X")
|
||||
Convert @VM:@SVM:@TM To " " In comment
|
||||
FORMINFO<FORMINFO_COMMENT$, POSN> = COMMENT
|
||||
End
|
||||
|
||||
* DO CONTROL-SPECIFIC WORK
|
||||
rslt = O4WI_FORMDESIGNER_WIDGET_HELPER("VALIDATE_ADV", headerInfo, formInfo, "","","", adv_props)
|
||||
|
||||
If rslt = "" then
|
||||
Gosub handleAssociated
|
||||
end
|
||||
|
||||
param1 = updateList
|
||||
Return
|
||||
|
||||
|
||||
handleEvent:
|
||||
setupInfo = param1
|
||||
event = setupInfo<1>
|
||||
runMode = setupInfo<2>
|
||||
bMobile = setupInfo<3>
|
||||
suffix = setupInfo<4>
|
||||
save.drrecords = DRRecords@
|
||||
save.keys = DRKeys@
|
||||
Gosub getValue
|
||||
DRRecords@ = param4
|
||||
DRKeys@ = param5
|
||||
|
||||
Begin Case
|
||||
Case event _eqc "CHANGE"
|
||||
If updateAssociated <> "" Then
|
||||
* tell all the associated fields that they must be redrawn
|
||||
numAssociated = dcount(updateAssociated, @TM)
|
||||
For each.associated = 1 To numAssociated
|
||||
this.other = Field(updateAssociated, @TM, each.associated)
|
||||
needRefresh = o4wi_formdesigner_helper(this.other, headerInfo, formInfo, "1", runMode, bMobile, err)
|
||||
Next each.associated
|
||||
rslt = 1 ;* report that this has been handled here
|
||||
End
|
||||
If cmChange Then
|
||||
* call the commuter module
|
||||
end
|
||||
Case event _eqc "PRE_FIELD"
|
||||
If cmBefore Then
|
||||
* call the commuter module
|
||||
end
|
||||
Case event _eqc "POST_FIELD"
|
||||
If cmAfter Then
|
||||
* call the commuter module
|
||||
end
|
||||
End Case
|
||||
DRRecords@ = save.DRRecords
|
||||
DRKeys@ = save.Keys
|
||||
Return
|
||||
|
||||
doDraw:
|
||||
setupInfo = param1
|
||||
isReplace = param4 + 0
|
||||
|
||||
runMode = setupInfo<1>
|
||||
bMobile = setupInfo<2>
|
||||
parentStyles = setupInfo<3>
|
||||
* if isReplace, and we can't just update our value/style, we have to redraw our parent and ourselves
|
||||
parentSectionID = setupInfo<4>
|
||||
parentSectionStyle = setupInfo<5>
|
||||
needRefresh = 0
|
||||
|
||||
Gosub getFormInfo
|
||||
Gosub getRecordInfo
|
||||
|
||||
oldUIFlag = headerInfo<HEADER_UI_MODE$>+0
|
||||
inlinePromptFlag = (headerInfo<HEADER_DEFAULT_LABELTYPE$> = HEADER_DEFAULT_LABELTYPE_INLINE$)
|
||||
|
||||
* DO CONTROL-SPECIFIC WORK
|
||||
If DRROOverrideFlag@ <> "" Then
|
||||
roFlag = DRROOverrideFlag@
|
||||
end
|
||||
If roFlag Then
|
||||
style := @SVM:"readOnly"
|
||||
End Else
|
||||
style := @SVM:"readWrite"
|
||||
end
|
||||
If oldUIFlag Then
|
||||
style := @SVM:"classicUI"
|
||||
End
|
||||
|
||||
Style := @SVM:classes
|
||||
num.data = dcount(datastyles_names, @TM)
|
||||
For each.data = 1 To num.data
|
||||
Style := @SVM:o4wdatastyle("", Field(datastyles_names, @TM, each.data), Field(datastyles_values, @TM, each.data))
|
||||
Next each.data
|
||||
|
||||
If isReplace Then
|
||||
* use o4wupdate
|
||||
End Else
|
||||
* draw for real
|
||||
If html_before <> "" Then
|
||||
o4wraw(html_before)
|
||||
End
|
||||
* element specific instructions
|
||||
If html_after <> "" Then
|
||||
o4wraw(html_after)
|
||||
end
|
||||
End
|
||||
|
||||
param2 = "0" ;* must call "buildParent"?
|
||||
param3 = "" ;*blankLine:@FM:sizeStyle:@FM:specialStyle:@FM:divHeader:@FM:divHeaderSize
|
||||
|
||||
rslt = needRefresh
|
||||
return
|
||||
|
||||
getValue:
|
||||
Gosub getFormInfo
|
||||
currentValue = ""
|
||||
iValue = ""
|
||||
dict.Info = ""
|
||||
atRecord = ""
|
||||
recordList = ""
|
||||
keyList = DRKeys@
|
||||
posn = ""
|
||||
convError = ""
|
||||
special.conv = ""
|
||||
If table <> "" And fieldName <> "" then
|
||||
Locate table In DRTables@ using @FM setting posn Else
|
||||
DRTables@<posn> = table
|
||||
end
|
||||
Open "DICT",table To @DICT Else null
|
||||
Read dict.info From @DICT, fieldName Else dict.Info = ""
|
||||
atrecord = Field(DRRecords@, @RM, posn)
|
||||
key = DRKeys@<posn, 1>
|
||||
end
|
||||
bUseDict = 0
|
||||
Begin Case
|
||||
Case conv_i = "NONE"
|
||||
conv_i = ""
|
||||
Case conv_i = "USER"
|
||||
*conv_i = conv_i_userdef
|
||||
Case conv_i = "-"
|
||||
conv_i =dict.info<11>
|
||||
bUseDict = 1
|
||||
End Case
|
||||
currentValue = o4wGetValue(name)
|
||||
iValue = currentValue
|
||||
If conv_i <> "" Then
|
||||
* Convert 'standard' user-defined formats to our own (non-ui) versions
|
||||
Swap "EMAIL_FORMAT" With "EMAIL_FORMAT_INTERNAL" In conv_i
|
||||
Swap "PHONE_FORMAT" With "PHONE_FORMAT_INTERNAL" In conv_i
|
||||
Swap "ZIP_FORMAT" With "ZIP_FORMAT_INTERNAL" In conv_i
|
||||
Swap "SSN_FORMAT" With "SSN_FORMAT_INTERNAL" In conv_i
|
||||
status() = 0
|
||||
If bUseDict Then
|
||||
* use in.value to handle the validation/input conversion
|
||||
Declare Function in.value
|
||||
bIsValid = 1
|
||||
num.vals = dcount(iValue, @VM)
|
||||
iNewValue = ""
|
||||
For each.val = 1 To num.vals While bIsValid
|
||||
this.newValue = iValue<1,each.val>
|
||||
this.iNewValue = in.value(this.newValue, conv_i, bIsValid)
|
||||
If bIsValid = 0 And conv_i[1,1] <> "(" Then
|
||||
bIsValid = 1
|
||||
this.iNewValue = in.value(this.newValue, "(":conv_i:")", bIsValid)
|
||||
End
|
||||
If (bIsValid = 0 Or status()) Then
|
||||
bIsValid = 0
|
||||
convError<1,-1> = "Error converting '":this.newValue:"' using conversion code '":conv_i:"'"
|
||||
End
|
||||
iValue<1, each.val> = this.iNewValue
|
||||
Next each.val
|
||||
End else
|
||||
iValue = Iconv(iValue, conv_i)
|
||||
If status() Then
|
||||
convError<1,-1> = "Error converting '":currentValue:"' using conversion code '":conv_i:"'"
|
||||
End
|
||||
End
|
||||
* don't really care (here) if it's an invalid value...
|
||||
status() = 0
|
||||
* special case for MC (masked character) conversions - ONLY operate as OCONV
|
||||
If (conv_i = "MCU" Or conv_i = "MCL") And special.conv = "" Then
|
||||
special.conv = conv_i[3,1]
|
||||
end
|
||||
end
|
||||
If special.conv <> "" Then
|
||||
* special.conv is either U or L to uppercase or lowercase the input value
|
||||
currentValue = Oconv(iValue, "MC":special.conv)
|
||||
end
|
||||
param1 = currentValue
|
||||
param2 = iValue
|
||||
If roFlag <> "1" And DRROOverrideFlag@ <> "1" And dict.Info <> "" Then
|
||||
If dict.info<1>[1,1] = "F" Or dict.info<1>[1,1] = "S" Then
|
||||
fieldNo = dict.info<2>
|
||||
If Num(fieldNo) And fieldNo <> "" Then
|
||||
If fieldNo = 0 Then
|
||||
keyPart = dict.info<5>
|
||||
If Num(keyPart) And keyPart <> "" And keyPart <> "0" Then
|
||||
key = fieldstore(key, "*", keyPart, 1, iValue)
|
||||
End Else
|
||||
key = iValue
|
||||
end
|
||||
keyList<posn, 1> = key
|
||||
End else
|
||||
atRecord<fieldNo> = iValue
|
||||
recordList = fieldstore(DRRecords@, @RM, posn, 1, atRecord)
|
||||
end
|
||||
end
|
||||
End
|
||||
End
|
||||
param3 = atRecord
|
||||
param4 = recordList
|
||||
param5 = keyList
|
||||
param6 = convError
|
||||
Return
|
||||
|
||||
getPropsForTab:
|
||||
passedInfo = param1
|
||||
currTab = param2
|
||||
|
||||
If currTab _nec PROPS_TAB_NAME_FMT$ Then Return ;* only care when we leave the db tab
|
||||
|
||||
* get the current info
|
||||
reqd_props = passedInfo<FORMINFO_PARAM_R$>
|
||||
opt_props = passedInfo<FORMINFO_PARAM_O$>
|
||||
db_props = passedInfo<FORMINFO_DB_INFO$>
|
||||
fmt_props = passedInfo<FORMINFO_FMT_INFO$>
|
||||
mob_props = passedInfo<FORMINFO_MOB_INFO$>
|
||||
evt_props = passedInfo<FORMINFO_EVT_INFO$>
|
||||
adv_props = passedInfo<FORMINFO_ADV_INFO$>
|
||||
parent = passedInfo<FORMINFO_PARENT$>
|
||||
|
||||
Gosub extractDetails
|
||||
|
||||
* something here has changed - reset the fields
|
||||
reqd_info = ""
|
||||
opts_info = ""
|
||||
db_info = ""
|
||||
fmt_info = ""
|
||||
mob_info = ""
|
||||
evt_info = ""
|
||||
adv_info = ""
|
||||
propName = elementName
|
||||
Gosub getPropsFmt
|
||||
|
||||
param3 = PROPS_TAB_NUM_FMT$
|
||||
param4 = FMT_info
|
||||
|
||||
Return
|
||||
|
||||
getProps:
|
||||
passedInfo = param1
|
||||
reqd_props = passedInfo<FORMINFO_PARAM_R$>
|
||||
opt_props = passedInfo<FORMINFO_PARAM_O$>
|
||||
db_props = passedInfo<FORMINFO_DB_INFO$>
|
||||
fmt_props = passedInfo<FORMINFO_FMT_INFO$>
|
||||
mob_props = passedInfo<FORMINFO_MOB_INFO$>
|
||||
evt_props = passedInfo<FORMINFO_EVT_INFO$>
|
||||
adv_props = passedInfo<FORMINFO_ADV_INFO$>
|
||||
parent = passedInfo<FORMINFO_PARENT$>
|
||||
|
||||
Gosub extractDetails
|
||||
|
||||
reqd_info = ""
|
||||
opts_info = ""
|
||||
db_info = ""
|
||||
fmt_info = ""
|
||||
mob_info = ""
|
||||
evt_info = ""
|
||||
adv_info = ""
|
||||
propName = ""
|
||||
|
||||
* DO CONTROL-SPECIFIC WORK
|
||||
adv_info = O4WI_FORMDESIGNER_WIDGET_HELPER("DISPLAY_ADV", headerInfo, formInfo, "","","", adv_props)
|
||||
|
||||
|
||||
* SET UP PROPNAME, XXX_INFO
|
||||
getPropsFmt:
|
||||
|
||||
param2 = reqd_info
|
||||
param3 = opts_info
|
||||
param4 = db_info
|
||||
param5 = fmt_info
|
||||
param6 = mob_info
|
||||
param7 = evt_info
|
||||
param8 = adv_info
|
||||
rslt = propName
|
||||
Return
|
||||
|
||||
getFormInfo:
|
||||
bFound = 0
|
||||
comment = ""
|
||||
ctype = ""
|
||||
parent = ""
|
||||
children = ""
|
||||
reqd_props = ""
|
||||
opt_props = ""
|
||||
db_props = ""
|
||||
fmt_props = ""
|
||||
mob_props = ""
|
||||
evt_props = ""
|
||||
adv_props = ""
|
||||
locn = ""
|
||||
associated = ""
|
||||
Locate elementID In formInfo<FORMINFO_ID$> using @VM setting posn Then
|
||||
bFound = 1
|
||||
COMMENT = FORMINFO<FORMINFO_COMMENT$, POSN>
|
||||
CTYPE = FORMINFO<FORMINFO_TYPE$, POSN>
|
||||
PARENT = FORMINFO<FORMINFO_PARENT$, POSN>
|
||||
CHILDREN = FORMINFO<FORMINFO_CHILDREN$, POSN>
|
||||
REQD_PROPS = FORMINFO<FORMINFO_PARAM_R$, POSN>
|
||||
OPT_PROPS = FORMINFO<FORMINFO_PARAM_O$, POSN>
|
||||
db_props = forminfo<FORMINFO_DB_INFO$, POSN>
|
||||
fmt_props = forminfo<FORMINFO_FMT_INFO$, POSN>
|
||||
mob_props = forminfo<FORMINFO_MOB_INFO$, POSN>
|
||||
evt_props = formInfo<FORMINFO_EVT_INFO$, POSN>
|
||||
adv_props = formInfo<FORMINFO_ADV_INFO$, POSN>
|
||||
LOCN = FORMINFO<FORMINFO_POSN$, POSN>
|
||||
ASSOCIATED = FORMINFO<FORMINFO_ASSOCIATED$, POSN>
|
||||
ASSOCIATED_LABEL_TYPE = FORMINFO<FORMINFO_LABEL_TYPE$, POSN>
|
||||
end
|
||||
* fall through to extractDetails
|
||||
|
||||
extractDetails:
|
||||
* PULL OUT CONTROL-SPECIFIC DETAILS
|
||||
dummy = O4WI_FORMDESIGNER_WIDGET_HELPER("EXTRACT_ADV", headerInfo, formInfo, "","","", adv_props, html_before, html_after, classes, datastyles_names, datastyles_values)
|
||||
|
||||
Return
|
||||
|
||||
/*
|
||||
AddElement:
|
||||
newPosn = o4wi_formdesigner_widget_new(headerInfo, formInfo, thisID, parent, childtype, prop_locn, elementID, bProtected, addBefore)
|
||||
Return
|
||||
*/
|
||||
|
||||
handleAssociated:
|
||||
If associated = "" Then return
|
||||
Locate associated<1,1,1> In formInfo<FORMINFO_ID$> using @VM setting aPos then
|
||||
CTYPE = formInfo<FORMINFO_TYPE$, aPos>
|
||||
supportName = UCASE(DESIGN_SUPPORT_PREFIX$:CTYPE)
|
||||
whichTypes = ""
|
||||
whichValues = ""
|
||||
* headerText = opt_props<1,1,2>
|
||||
* headerSize = opt_props<1,1,3>
|
||||
*whichTypes = "TEXT":@fm:"SIZE"
|
||||
*whichValues = headerText:@FM:headerSize
|
||||
call @supportName(WIDGET_ACTION_UPDATE$, headerInfo, formInfo, associated, elementID, whichTypes, whichValues)
|
||||
End
|
||||
Return
|
||||
|
||||
doUpdate:
|
||||
* our associated element has changed - update ourselves
|
||||
Gosub getFormInfo
|
||||
|
||||
associatedID = param1
|
||||
whichParameter = param2
|
||||
newValues = param3
|
||||
num.params = dcount(whichParameter, @FM)
|
||||
For each.param = 1 To num.params
|
||||
this.param = whichParameter<each.param>
|
||||
this.value = newValues<each.param>
|
||||
Begin Case
|
||||
case this.param = WIDGET_MSG_LABEL$ Or this.param = WIDGET_MSG_LEGEND$
|
||||
reqd_props<1,1,1> = this.value
|
||||
Case this.param = WIDGET_MSG_BTN_DEFAULT$
|
||||
If this.value = "0" Or this.value = "1" then
|
||||
reqd_props<1,1,2> = this.value
|
||||
end
|
||||
Case this.param = WIDGET_MSG_OMIT_LABEL$
|
||||
If this.value = "0" Or this.value = "1" then
|
||||
reqd_props<1,1,2> = this.value + 0
|
||||
End
|
||||
Case this.param = WIDGET_MSG_LABEL_PLACEMENT$
|
||||
reqd_props<1,1,3> = this.value
|
||||
Case this.param = WIDGET_MSG_NAME$
|
||||
reqd_props<1,1,4> = this.value
|
||||
|
||||
|
||||
Case this.param = WIDGET_MSG_FONT_NAME$
|
||||
fmt_props<1,1,1> = this.value
|
||||
Case this.param = WIDGET_MSG_FONT_COLOR_BG$
|
||||
fmt_props<1,1,2> = this.value
|
||||
Case this.param = WIDGET_MSG_FONT_COLOR_FG$
|
||||
fmt_props<1,1,3> = this.value
|
||||
Case this.param = WIDGET_MSG_FONT_BOLD$
|
||||
if this.value = "0" or this.value = "1" then
|
||||
fmt_props<1,1,4> = this.value
|
||||
end
|
||||
Case this.param = WIDGET_MSG_FONT_ITALIC$
|
||||
if this.value = "0" or this.value = "1" then
|
||||
fmt_props<1,1,5> = this.value
|
||||
end
|
||||
Case this.param = WIDGET_MSG_FONT_ALIGN$
|
||||
if num(this.value) then
|
||||
fmt_props<1,1,6> = this.value
|
||||
end
|
||||
Case this.param = WIDGET_MSG_FONT_SIZE$
|
||||
fmt_props<1,1,7> = this.value
|
||||
Case this.param = WIDGET_MSG_CONTROL_ALIGN$
|
||||
If Num(this.value) Then
|
||||
fmt_props<1,1,8> = this.value
|
||||
end
|
||||
|
||||
Case this.param = WIDGET_MSG_MOB_ICON$
|
||||
mob_props<1,1,1> = this.value
|
||||
Case this.param = WIDGET_MSG_MOB_THEME$
|
||||
mob_props<1,1,2> = this.value
|
||||
Case this.param = WIDGET_MSG_MOB_LAYOUT$
|
||||
mob_props<1,1,3> = this.value
|
||||
Case this.param = WIDGET_MSG_MOB_MINI$
|
||||
If this.value = "0" Or this.value = "1" then
|
||||
mob_props<1,1,4> = this.value
|
||||
end
|
||||
|
||||
Case this.param = WIDGET_MSG_OPT_HEIGHT$
|
||||
opt_props<1,1,1> = this.value
|
||||
Case this.param = WIDGET_MSG_OPT_WIDTH$
|
||||
opt_props<1,1,2> = this.value
|
||||
Case this.param = WIDGET_MSG_SELECT_MULTI$
|
||||
If this.value = "0" Or this.value = "1" then
|
||||
opt_props<1,1,3> = this.value
|
||||
end
|
||||
Case this.param = WIDGET_MSG_SUPPRESS_DESIGN$
|
||||
If this.value = "0" Or this.value = "1" then
|
||||
opt_props<1,1,4> = this.value
|
||||
End
|
||||
|
||||
Case this.param = WIDGET_MSG_DB_TABLE$
|
||||
db_props<1,1,1> = this.value
|
||||
Case this.param = WIDGET_MSG_DB_FIELD$
|
||||
db_props<1,1,2> = this.value
|
||||
Case this.param = WIDGET_MSG_DB_MV$
|
||||
If this.value = "0" Or this.value = "1" then
|
||||
db_props<1,1,3> = this.value + 0
|
||||
end
|
||||
Case this.param = WIDGET_MSG_CONV_O$
|
||||
db_props<1,1,4> = this.value
|
||||
Case this.param = WIDGET_MSG_CONV_O_USER$
|
||||
db_props<1,1,5> = this.value
|
||||
Case this.param = WIDGET_MSG_CONV_I$
|
||||
db_props<1,1,6> = this.value
|
||||
Case this.param = WIDGET_MSG_CONV_I_USER$
|
||||
db_props<1,1,5> = this.value
|
||||
|
||||
Case this.param = WIDGET_MSG_SET_SHOWNONE$
|
||||
If this.value = "0" Or this.value = "1" then
|
||||
db_props<1,1,5> = this.value
|
||||
End
|
||||
|
||||
|
||||
Case this.param = WIDGET_MSG_LINK$
|
||||
If this.value = "" Or this.value = "0" Then
|
||||
* no link here
|
||||
opt_props<1,1,1> = 0
|
||||
opt_props<1,1,2> = ""
|
||||
opt_props<1,1,3> = ""
|
||||
End Else If this.value = "1" then
|
||||
* link here
|
||||
opt_props<1,1,1> = 1
|
||||
end
|
||||
Case this.param = WIDGET_MSG_LINK_TYPE$
|
||||
If opt_props<1,1,1> = "1" Or opt_props<1,1,1> = "" Then
|
||||
opt_props<1,1,1> = "1"
|
||||
opt_props<1,1,2> = this.value
|
||||
End
|
||||
Case this.param = WIDGET_MSG_LINK_URL$
|
||||
If opt_props<1,1,1> = "1" Or opt_props<1,1,1> = "" Then
|
||||
opt_props<1,1,1> = "1"
|
||||
opt_props<1,1,3> = this.value
|
||||
End
|
||||
|
||||
|
||||
Case this.param = WIDGET_MSG_EVENT_POPUP$
|
||||
If this.value = "1" Or this.value = "0" Then
|
||||
evt_props<1,1,1> = this.value
|
||||
end
|
||||
Case this.param = WIDGET_MSG_EVENT_CLICK$
|
||||
If this.value = "1" Or this.value = "0" Then
|
||||
evt_props<1,1,2> = this.value
|
||||
end
|
||||
Case this.param = WIDGET_MSG_EVENT_UPDATE_ASSOCIATED$
|
||||
evt_props<1,1,1> = this.value
|
||||
Case this.param = WIDGET_MSG_EVENT_BEFORE$
|
||||
If this.value = "1" Or this.value = "0" Then
|
||||
evt_props<1,1,2> = this.value
|
||||
end
|
||||
Case this.param = WIDGET_MSG_EVENT_CHANGED$
|
||||
If this.value = "1" Or this.value = "0" Then
|
||||
evt_props<1,1,3> = this.value
|
||||
end
|
||||
Case this.param = WIDGET_MSG_EVENT_AFTER$
|
||||
If this.value = "1" Or this.value = "0" Then
|
||||
evt_props<1,1,4> = this.value
|
||||
end
|
||||
|
||||
|
||||
Case this.param = WIDGET_MSG_LIST_SOURCE$
|
||||
reqd_props<1,1,3> = this.value
|
||||
Case this.param = WIDGET_MSG_LIST_TABLE$ Or this.param = WIDGET_MSG_LIST_STPROC$
|
||||
reqd_props<1,1,4> = this.value
|
||||
Case this.param = WIDGET_MSG_LIST_CODE_RECORD$
|
||||
reqd_props<1,1,5> = this.value
|
||||
Case this.param = WIDGET_MSG_LIST_CODE_FIELD_VALUE$ Or this.param = WIDGET_MSG_LIST_SELECT$
|
||||
reqd_props<1,1,6> = this.value
|
||||
Case this.param = WIDGET_MSG_LIST_CODE_FIELD_DESC$
|
||||
If reqd_props<1,1,3> = "2" Then
|
||||
reqd_props<1,1,7> = this.value
|
||||
End Else
|
||||
reqd_props<1,1,5> = this.value
|
||||
End
|
||||
Case this.param = WIDGET_MSG_LABEL_TYPE$
|
||||
ASSOCIATED_LABEL_TYPE = this.value
|
||||
Case 1
|
||||
* see if these are advanced properties
|
||||
dummy = O4WI_FORMDESIGNER_WIDGET_HELPER("UPDATE_ADV", headerInfo, formInfo, "","","", adv_props, this.param, this.value)
|
||||
|
||||
End CASE
|
||||
Next each.param
|
||||
|
||||
* make sure forminfo is updated
|
||||
FORMINFO<FORMINFO_COMMENT$, POSN> = COMMENT
|
||||
FORMINFO<FORMINFO_TYPE$, POSN> = CTYPE
|
||||
FORMINFO<FORMINFO_PARENT$, POSN> = PARENT
|
||||
FORMINFO<FORMINFO_CHILDREN$, POSN> = CHILDREN
|
||||
FORMINFO<FORMINFO_PARAM_R$, POSN> = REQD_PROPS
|
||||
FORMINFO<FORMINFO_PARAM_O$, POSN> = OPT_PROPS
|
||||
forminfo<FORMINFO_DB_INFO$, POSN> = db_props
|
||||
forminfo<FORMINFO_FMT_INFO$, POSN> = fmt_props
|
||||
formInfo<FORMINFO_MOB_INFO$, POSN> = mob_props
|
||||
formInfo<FORMINFO_EVT_INFO$, POSN> = evt_props
|
||||
formInfo<FORMINFO_ADV_INFO$, POSN> = adv_props
|
||||
FORMINFO<FORMINFO_POSN$, POSN> = LOCN
|
||||
FORMINFO<FORMINFO_ASSOCIATED$, POSN> = ASSOCIATED
|
||||
FORMINFO<FORMINFO_LABEL_TYPE$, POSN> = ASSOCIATED_LABEL_TYPE
|
||||
|
||||
Return
|
||||
|
||||
|
||||
getRecordInfo:
|
||||
currentValue = ""
|
||||
iValue = ""
|
||||
If runMode = 1 then
|
||||
If Len(TABLE) then
|
||||
Locate table In DRTables@ using @FM setting posn Else posn = 1
|
||||
Open "DICT",table To @DICT then
|
||||
Read dict.info From @DICT, fieldName Else dict.Info = ""
|
||||
Begin Case
|
||||
Case conv_o = "NONE"
|
||||
conv_o = ""
|
||||
Case conv_o = "USER"
|
||||
*conv_o = conv_o_userdef
|
||||
Case conv_o = "-"
|
||||
conv_o = dict.info<7>
|
||||
End Case
|
||||
Begin Case
|
||||
Case conv_i = "NONE"
|
||||
conv_i = ""
|
||||
Case conv_i = "USER"
|
||||
*conv_i = conv_i_userdef
|
||||
Case conv_i = "-"
|
||||
conv_i = dict.info<11>
|
||||
End Case
|
||||
@record = Field(DRRecords@, @RM, posn)
|
||||
@id = DRKeys@<posn,1>
|
||||
valno = DRKeys@<posn, 2>
|
||||
iValue = calculate(fieldName)
|
||||
end
|
||||
End
|
||||
If bIsMV then
|
||||
DRNumMV@ = dcount(iValue, @VM)
|
||||
If DRMV@ + 0 Then
|
||||
iValue = iValue<1, DRMV@>
|
||||
End Else If DRNumMV@ > 1 Then
|
||||
If valno Then
|
||||
iValue = iValue<1, valno>
|
||||
DRNumMV@ = 1 ;* if we've got a valno in the key list, then we just want _this_ value
|
||||
End Else
|
||||
* TO DO
|
||||
end
|
||||
End
|
||||
end
|
||||
currentValue = iValue
|
||||
If conv_o <> "" then
|
||||
currentValue = Oconv(iValue, conv_o)
|
||||
end
|
||||
End
|
||||
return
|
||||
85
SYSPROG/STPROC/O4WI_UPLOAD_DROPBOX.txt
Normal file
85
SYSPROG/STPROC/O4WI_UPLOAD_DROPBOX.txt
Normal file
@ -0,0 +1,85 @@
|
||||
Subroutine O4WI_UPLOAD_DROPBOX(origvalue, destn, size, name, ID, StyleInfo)
|
||||
*#!Precompile
|
||||
/*
|
||||
* This program is proprietary and is not to be used by or disclosed to others, nor is it to be copied without
|
||||
* written permission from Revelation Technologies, Inc.
|
||||
!
|
||||
*
|
||||
* VERSION : 1.0
|
||||
*
|
||||
*
|
||||
* AUTHOR : Bryan Shumsky
|
||||
*
|
||||
* CREATED : November 6, 2019
|
||||
*
|
||||
*
|
||||
!
|
||||
*
|
||||
* REVISION HISTORY (Most CURRENT first) :
|
||||
*
|
||||
* DATE IMPLEMENTOR FUNCTION
|
||||
* -------- ----------- --------
|
||||
* 17 July 2020 bzs Fixed storage of data in preservedInfo dynamic array
|
||||
*
|
||||
*/
|
||||
*
|
||||
Equ DROPBOX_SAVED_KEY$ To "DROPBOX_UPLOAD"
|
||||
*
|
||||
$Insert O4WCommon
|
||||
$Insert O4WEquates
|
||||
*
|
||||
If Assigned(destn) Else destn = ""
|
||||
If Assigned(ID) Else ID = ""
|
||||
If Assigned(name) Else name = ""
|
||||
If Assigned(StyleInfo) Else StyleInfo = ""
|
||||
If Assigned(size) Else size = ""
|
||||
If Assigned(origvalue) Else origvalue = ""
|
||||
*
|
||||
Declare Function rti_util_dropbox, rti_get_cfg
|
||||
*
|
||||
dropboxInfo = rti_get_cfg("CFG_DROPBOX")
|
||||
* <1> URL for API request
|
||||
* <2> access token
|
||||
* <3> duration for link (optional)
|
||||
* <4> folder for output (optional)
|
||||
* <5> list of valid extensions (comma-delimited) (optional)
|
||||
*
|
||||
If dropboxinfo<1> = "" Or dropboxInfo<2> = "" Then Return
|
||||
|
||||
link = rti_util_dropbox("UPLOAD_LINK", origValue)
|
||||
|
||||
* parse new link and put into destn
|
||||
destn = ""
|
||||
If link <> "" Then
|
||||
* success
|
||||
* replace (or add) our special style
|
||||
Locate "o4wfile" In styleInfo<1,1> using @SVM setting dummy Else null
|
||||
styleInfo<1,1,dummy> = "o4wDropboxFile"
|
||||
|
||||
validExts = dropboxInfo<5>
|
||||
If validExts <> "" Then
|
||||
Convert @VM To "," In validExts ;* make sure we have the proper delimiter
|
||||
acceptTypes = validExts
|
||||
* so we have a list for example of jpg,jpeg,zip,bin
|
||||
Swap "," With ",." In acceptTypes
|
||||
* now the list is jpg,.jpeg,.zip,.bin
|
||||
acceptTypes = ".":acceptTypes
|
||||
styleInfo<1,1,-1> = o4wUploadBoxOptions("", acceptTypes)
|
||||
Convert "," To "|" In validExts
|
||||
o4wstore(validExts, id:"_dropbox_ext", id:"_dropbox_ext")
|
||||
end
|
||||
o4wstore(link, id:"_dropbox_url", id:"_dropbox_url")
|
||||
|
||||
Read preservedInfo From O4WTempFile%, O4WSessionId%:"*":DROPBOX_SAVED_KEY$ Else preservedInfo = ""
|
||||
Locate id In preservedInfo<1> using @VM setting dummy Then
|
||||
preservedInfo<2,dummy> = origValue
|
||||
End Else
|
||||
preservedInfo<1,-1> = id
|
||||
preservedInfo<2,-1> = origValue
|
||||
end
|
||||
Write preservedInfo On O4WTempFile%, O4WSessionId%:"*":DROPBOX_SAVED_KEY$
|
||||
|
||||
o4wstore(DROPBOX_SAVED_KEY$, "o4wOtherUploads")
|
||||
End
|
||||
|
||||
Return 0
|
||||
865
SYSPROG/STPROC/OBJ_APPWINDOW.txt
Normal file
865
SYSPROG/STPROC/OBJ_APPWINDOW.txt
Normal file
@ -0,0 +1,865 @@
|
||||
COMPILE FUNCTION obj_AppWindow(Method,Parms)
|
||||
|
||||
/*
|
||||
Methods for Application Windows
|
||||
|
||||
09/30/2001 by JCH - J.C. Henry, Inc
|
||||
|
||||
Properties:
|
||||
|
||||
|
||||
|
||||
Methods:
|
||||
|
||||
Create(Window) ;* ID of window to center
|
||||
Page(Window) ;* ID of window
|
||||
Read(Window) ;* Sets @PREV_ID & @PREV_REC if null after a read
|
||||
PreWrite(Window) ;* Sets @PREV_ID & @PREV_REC on write
|
||||
PrevRec(Window) ;* <ALT><C> - Copy previous record
|
||||
PrevVal(Window) ;* <ALT><O> - Copy old (previous) field value
|
||||
ReadOnly(Window,Clear) ;* Read Only
|
||||
LUValReturn(ValueReturned,FocusControl,FocusPos) ;* Return value and moves to next field with all events
|
||||
CardReturn()
|
||||
DetailReturn()
|
||||
SetDropDowns()
|
||||
|
||||
LoadFormKeys( FormName, FormKey)
|
||||
;* Parses and loads all or part of a multi part key into a form using that key then moves to next field.
|
||||
;* Triggers Read event if complete key is loaded.
|
||||
;* If a partial key is passed, the routine will sets focus to empty key field
|
||||
|
||||
ViewNewCard( CardWindow, CardKey, NewCardCtrl, RecalcCtrl, RecalcPos, [RetCtrl,RetPos] )
|
||||
|
||||
;* Views existing or creates new record in 'Card' type window. i.e. name,vendor, customer ...
|
||||
;* Cards have their ID used in a record and display information from the card.
|
||||
;* Card Records have single part keys and do not have a relational index to the table where used.
|
||||
|
||||
ViewNewDetail(DetWindow,DetKeys,DefaultRec,[RetKey,RetPage,RetCtrl,RetPos]) [optional parms]
|
||||
|
||||
;* Routine to Create or View 'Item Detail' type records from a master window.
|
||||
;* Used for things like Purchase Orders, Sales Orders, Parts and Part Revisions
|
||||
;* Detail records have a 2 part key and maintain a relational index back to the master table.
|
||||
;* This routine is used with an edit table in the Master Table window that displays the
|
||||
;* detail keys associated with it.
|
||||
|
||||
*/
|
||||
|
||||
DECLARE SUBROUTINE Set_Status,Set_Property, Send_Event, Start_Window, Post_Event
|
||||
DECLARE FUNCTION Get_Status,Get_Property, Utility
|
||||
|
||||
$INSERT Logical
|
||||
$INSERT CopyRight
|
||||
$INSERT DICT_EQUATES
|
||||
|
||||
EQU FIX_SUFFIX$ TO "_FIX"
|
||||
EQU TAB_PREFIX$ TO "PAGE_"
|
||||
EQU TAB_SUFFIX$ TO "_TAB"
|
||||
|
||||
EQU CRLF$ TO CHAR(13):CHAR(10)
|
||||
|
||||
EQU COL$ TO 1
|
||||
EQU ROW$ TO 2
|
||||
|
||||
EQU ReadOnlyStyle$ TO 2048
|
||||
|
||||
ErrTitle = 'Error in obj_AppWindows'
|
||||
|
||||
ErrorMsg = ''
|
||||
|
||||
IF NOT(ASSIGNED(Method)) THEN
|
||||
ErrorMsg = 'Unassigned parameter "Method" passed to subroutine.' ; Method = ''
|
||||
END ELSE
|
||||
IF Method = '' THEN
|
||||
ErrorMsg = 'Null parameter "Method" passed to subroutine'
|
||||
END
|
||||
END
|
||||
|
||||
IF ErrorMsg NE '' THEN
|
||||
stat = Set_Status(-1,ErrTitle:@SVM:ErrorMsg) ;* Initialization Errors
|
||||
RETURN ''
|
||||
END
|
||||
|
||||
IF NOT(ASSIGNED(Parms)) THEN Parms = ''
|
||||
|
||||
Result = ''
|
||||
|
||||
BEGIN CASE
|
||||
CASE Method = 'Create' ; GOSUB Create
|
||||
CASE Method = 'Page' ; GOSUB Page
|
||||
CASE Method = 'Read' ; GOSUB Read
|
||||
CASE Method = 'PreWrite' ; GOSUB PreWrite
|
||||
CASE Method = 'PrevRec' ; GOSUB PrevRec
|
||||
CASE Method = 'PrevVal' ; GOSUB PrevVal
|
||||
CASE Method = 'ReadOnly' ; GOSUB ReadOnly
|
||||
CASE Method = 'LUValReturn' ; GOSUB LUValReturn
|
||||
CASE Method = 'LoadFormKeys' ; GOSUB LoadFormKeys
|
||||
CASE Method = 'ViewNewCard' ; GOSUB ViewNewCard
|
||||
CASE Method = 'ViewNewDetail' ; GOSUB ViewNewDetail
|
||||
CASE Method = 'ViewRelated' ; GOSUB ViewRelated
|
||||
CASE Method = 'CardReturn' ; GOSUB CardReturn
|
||||
CASE Method = 'DetailReturn' ; GOSUB DetailReturn
|
||||
CASE Method = 'SetDropDowns' ; GOSUB SetDropDowns
|
||||
|
||||
CASE 1
|
||||
ErrMsg = 'Unknown Method ':QUOTE(Method):' passed to routine.'
|
||||
END CASE
|
||||
|
||||
IF ErrorMsg NE '' THEN
|
||||
stat = Set_Status(-1,ErrTitle:@SVM:ErrorMsg) ;* Initialization Errors
|
||||
END
|
||||
|
||||
RETURN Result
|
||||
|
||||
|
||||
* * * * * * *
|
||||
Create:
|
||||
* * * * * * *
|
||||
|
||||
* Center the window and make it visible
|
||||
* Cloned from RTI's supplied routine. Assumes window is NOT visible when called
|
||||
|
||||
Window = Parms[1,@RM]
|
||||
IF Window = '' THEN Window = @WINDOW
|
||||
|
||||
* Window id the name of the window to be centered
|
||||
* MDI_Name - the name of the MDI frame
|
||||
* SystemSize - the size of the system window
|
||||
* WindowSize - the size of the window to be cenered
|
||||
|
||||
MDI_Name = Get_Property(Window,'MDIFRAME')
|
||||
|
||||
* If the window is an MDI child, the name of the frame will be retrieved
|
||||
|
||||
WindowSize = Get_Property(Window,"SIZE")
|
||||
|
||||
IF MDI_Name EQ '' THEN
|
||||
SystemSize = Get_Property("SYSTEM","SIZE")
|
||||
xPos = SystemSize<1>/2 - WindowSize<3>/2
|
||||
yPos = SystemSize<2>/2 - WindowSize<4>/2
|
||||
END ELSE
|
||||
MDI_Size = Get_Property(MDI_Name,"CLIENTSIZE")
|
||||
xPos = MDI_Size<1>/2 - WindowSize<3>/2
|
||||
yPos = MDI_Size<2>/2 - WindowSize<4>/2
|
||||
END
|
||||
|
||||
Ctrls = Window:@RM
|
||||
Props = 'SIZE':@RM
|
||||
Vals = xPos:@FM:yPos:@FM:WindowSize<3>:@FM:WindowSize<4>:@RM ;* Center window in System Window
|
||||
|
||||
Ctrls := Window:@RM
|
||||
Props := 'VISIBLE':@RM
|
||||
Vals := '1':@RM ;* Make the window visible
|
||||
|
||||
CtrlList = ''
|
||||
cCtrlList = ''
|
||||
|
||||
CtrlList = Get_Property(Window,'CTRLMAP')
|
||||
|
||||
IF INDEX(CtrlList,'PAGE_1_TAB',1) THEN
|
||||
Send_Event(@WINDOW:'.PAGE_1_TAB','GOTFOCUS')
|
||||
END
|
||||
|
||||
FOR iCtrl = 1 TO COUNT(CtrlList,@FM) + (CtrlList NE '')
|
||||
|
||||
Ctrl = CtrlList<iCtrl>
|
||||
|
||||
IF Ctrl[-4, 4] = '_FIX' THEN
|
||||
Ctrls := Ctrl:@RM
|
||||
Props := "PAGELIST":@RM
|
||||
Vals := '-1':@RM ;* Show this control on all pages
|
||||
END
|
||||
|
||||
IF INDEX(Ctrl,'STATUSLINE',1) OR INDEX(Ctrl,'STATUSLINE_FIX',1) THEN
|
||||
Ctrls := Window:@RM
|
||||
Props := 'STATUSLINE':@RM
|
||||
Vals := Ctrl:@RM ;* Set window STATUSLINE to this control
|
||||
END
|
||||
IF INDEX(Ctrl,'STATUS_OUTLINE',1) OR INDEX(Ctrl,'STATUS_OUTLINE_FIX',1) THEN
|
||||
Ctrls := Ctrl:@RM
|
||||
Props := 'STYLE':@RM
|
||||
Vals := '0X50000008':@RM ;* Make background transparent
|
||||
END
|
||||
|
||||
NEXT iCtrl
|
||||
|
||||
Ctrls[-1,1] = '' ; Props[-1,1] = '' ; Vals[-1,1] = '' ;* Drop trailing Record Marks
|
||||
|
||||
Set_Property(Ctrls,Props,Vals)
|
||||
|
||||
* Build @ET_SYMBOLICS data structure for window
|
||||
|
||||
ETSymbolics = ''
|
||||
|
||||
EditTables = Utility ('OBJECTLIST', Window, 'EDITTABLE')
|
||||
|
||||
FOR I = 1 TO COUNT(EditTables,@FM) + (EditTables NE '')
|
||||
EditTable = EditTables<I>
|
||||
CtrlCols = Get_Property(EditTable,'COLUMN')
|
||||
CtrlTables = Get_Property(EditTable, 'TABLE')
|
||||
LastTable = ''
|
||||
FOR N = 1 TO COUNT(CtrlCols,@SVM) + (CtrlCols NE '')
|
||||
CtrlCol = CtrlCols<1,1,N>
|
||||
TableName = CtrlTables<1,1,N>
|
||||
IF TableName NE '' THEN
|
||||
IF TableName NE LastTable THEN
|
||||
DictStruct = XLATE('DICT.':TableName,'%FIELDS%','','X')
|
||||
LastTable = TableName
|
||||
END
|
||||
|
||||
LOCATE CtrlCol IN DictStruct<FIELDS_NAME$> USING @VM SETTING Pos THEN
|
||||
IF DictStruct<FIELDS_TYPE$,Pos> = 'S' THEN
|
||||
LOCATE EditTable IN ETSymbolics<1> USING @VM SETTING ETPos ELSE
|
||||
ETSymbolics = INSERT(ETSymbolics,1,ETPos,0,EditTable)
|
||||
END
|
||||
ETSymbolics<2,ETPos,-1> = N ;* Add Column Number to the list
|
||||
END
|
||||
END
|
||||
END
|
||||
NEXT N
|
||||
NEXT I
|
||||
|
||||
Set_Property(Window,'@ET_SYMBOLICS',ETSymbolics)
|
||||
|
||||
RETURN
|
||||
|
||||
|
||||
* * * * * * *
|
||||
Page:
|
||||
* * * * * * *
|
||||
|
||||
Page = Get_Property(@WINDOW, 'VPOSITION')<1>
|
||||
Set_Property(@WINDOW:".":TAB_PREFIX$:Page:TAB_SUFFIX$, 'CHECK',TRUE$)
|
||||
|
||||
RETURN
|
||||
|
||||
|
||||
* * * * * * *
|
||||
Read:
|
||||
* * * * * * *
|
||||
|
||||
Window = Parms[1,@RM]
|
||||
IF Window = '' THEN Window = @WINDOW
|
||||
|
||||
Ctrls = Window:@RM:Window:@RM:Window:@RM:Window
|
||||
Props = '@PREV_ID':@RM:'@PREV_REC':@RM:'ID':@RM:'RECORD'
|
||||
|
||||
Vals = Get_Property(Ctrls,Props)
|
||||
|
||||
PrevID = Vals[1,@RM]
|
||||
PrevRec = Vals[COL2()+1,@RM]
|
||||
ID = Vals[COL2()+1,@RM]
|
||||
Record = Vals[COL2()+1,@RM]
|
||||
|
||||
IF PrevID = '' THEN Set_Property(Window,'@PREV_ID',ID)
|
||||
IF PrevRec = '' THEN Set_Property(Window,'@PREV_REC',Record)
|
||||
|
||||
RETURN
|
||||
|
||||
|
||||
* * * * * * *
|
||||
PreWrite:
|
||||
* * * * * * *
|
||||
|
||||
Window = Parms[1,@RM]
|
||||
IF Window = '' THEN Window = @WINDOW
|
||||
|
||||
Ctrls = Window:@RM:Window
|
||||
Props = 'ID':@RM:'RECORD'
|
||||
|
||||
Vals = Get_Property(Ctrls,Props)
|
||||
|
||||
ID = Vals[1,@RM]
|
||||
Record = Vals[COL2()+1,@RM]
|
||||
|
||||
Props = '@PREV_ID':@RM:'@PREV_REC'
|
||||
Vals = ID:@RM:Record
|
||||
|
||||
Set_Property(Ctrls,Props,Vals) ;* Store off ID and record for defaults
|
||||
|
||||
RETURN
|
||||
|
||||
|
||||
|
||||
* * * * * * *
|
||||
PrevRec:
|
||||
* * * * * * *
|
||||
|
||||
* <ALT><C> - Copy previous record
|
||||
|
||||
Ctrls = @WINDOW:@RM:@WINDOW:@RM:@WINDOW
|
||||
Props = 'FOCUS':@RM:'@PREV_REC':@RM:'CTRLMAP'
|
||||
|
||||
Vals = Get_Property(Ctrls,Props)
|
||||
|
||||
CtrlName = Vals[1,@RM]
|
||||
PrevRec = Vals[COL2()+1,@RM]
|
||||
CtrlMap = Vals[COL2()+1,@RM]
|
||||
|
||||
CONVERT @FM TO @RM IN CtrlMap
|
||||
|
||||
PosList = Get_Property(CtrlMap,STR('POS':@RM,COUNT(CtrlMap,@RM)):'POS')
|
||||
ConvList = Get_Property(CtrlMap,STR('CONV':@RM,COUNT(CtrlMap,@RM)):'CONV')
|
||||
|
||||
Ctrls = ''
|
||||
Props = ''
|
||||
Vals = ''
|
||||
|
||||
FOR I = 1 TO COUNT(PosList,@RM) + (PosList NE '')
|
||||
|
||||
Pos = FIELD(PosList,@RM,I)
|
||||
|
||||
IF Pos NE '' AND Pos > 0 THEN
|
||||
Conv = FIELD(ConvList,@RM,I)
|
||||
Ctrl = FIELD(CtrlMap,@RM,I)
|
||||
|
||||
IF INDEX(Pos,@SVM,1) THEN
|
||||
|
||||
* We're in a Multivalued control i.e. edittable
|
||||
|
||||
CtrlArray = ''
|
||||
|
||||
FOR N = 1 TO COUNT(Pos,@SVM) + (Pos NE '')
|
||||
ColPos = FIELD(Pos,@SVM,N)
|
||||
ColConv = FIELD(Conv,@SVM,N)
|
||||
ColValues = PrevRec<ColPos>
|
||||
IF ColConv NE '' THEN
|
||||
ColValues = OCONV(ColValues,ColConv)
|
||||
END
|
||||
|
||||
CtrlArray<N> = ColValues
|
||||
NEXT N
|
||||
|
||||
Ctrls := Ctrl:@RM
|
||||
Props := 'DEFPROP':@RM
|
||||
Vals := CtrlArray:@RM
|
||||
|
||||
END ELSE
|
||||
|
||||
Value = PrevRec<Pos>
|
||||
|
||||
IF Conv NE '' THEN Value = OCONV(Value,Conv)
|
||||
|
||||
Ctrls := FIELD(CtrlMap,@RM,I):@RM
|
||||
Props := 'DEFPROP':@RM
|
||||
Vals := Value:@RM
|
||||
END
|
||||
|
||||
END
|
||||
NEXT I
|
||||
|
||||
Ctrls[-1,1] = ''
|
||||
Props[-1,1] = ''
|
||||
Vals[-1,1] = ''
|
||||
|
||||
Set_Property(Ctrls,Props,Vals)
|
||||
|
||||
RETURN
|
||||
|
||||
|
||||
* * * * * * *
|
||||
PrevVal:
|
||||
* * * * * * *
|
||||
|
||||
* <ALT><O> - Copy previous field value, also works in the keys fields
|
||||
|
||||
Ctrls = @WINDOW:@RM:@WINDOW:@RM:@WINDOW
|
||||
Props = 'FOCUS':@RM:'@PREV_ID':@RM:'@PREV_REC'
|
||||
|
||||
Vals = Get_Property(Ctrls,Props)
|
||||
|
||||
CtrlName = Vals[1,@RM]
|
||||
PrevID = Vals[COL2()+1,@RM]
|
||||
PrevRec = Vals[COL2()+1,@RM]
|
||||
|
||||
Ctrls = CtrlName:@RM:CtrlName:@RM:CtrlName
|
||||
Props = 'POS':@RM:'PART':@RM:'CONV'
|
||||
|
||||
Vals = Get_Property(Ctrls,Props)
|
||||
|
||||
Pos = Vals[1,@RM]
|
||||
Part = Vals[COL2()+1,@RM]
|
||||
Conv = Vals[COL2()+1,@RM]
|
||||
|
||||
IF Index(Pos,@SVM,1) THEN
|
||||
|
||||
* Multi-Valued control i.e. We're in an edit table
|
||||
|
||||
SelPos = Get_Property(CtrlName,'SELPOS')
|
||||
|
||||
SelCol = SelPos<COL$>
|
||||
SelRow = SelPos<ROW$>
|
||||
|
||||
ColPos = FIELD(Pos,@SVM,SelCol)
|
||||
ColConv = FIELD(Conv,@SVM,SelCol)
|
||||
|
||||
Value = PrevRec<ColPos,SelRow>
|
||||
|
||||
IF Conv NE '' THEN Value = OCONV(Value,ColConv)
|
||||
|
||||
Set_Property(CtrlName,'DEFPROP',Value,SelPos)
|
||||
Set_Property(CtrlName,'SELECTION',1,@FM:LEN(Value))
|
||||
|
||||
|
||||
END ELSE
|
||||
|
||||
* Single valued control
|
||||
|
||||
IF Pos = 0 THEN
|
||||
Value = FIELD(PrevID,'*',Part)
|
||||
END ELSE
|
||||
Value = PrevRec<Pos>
|
||||
END
|
||||
|
||||
IF Conv NE '' THEN Value = OCONV(Value,Conv)
|
||||
|
||||
Set_Property(CtrlName,'DEFPROP',Value)
|
||||
Set_Property(CtrlName,'SELECTION',1,@FM:LEN(Value))
|
||||
|
||||
END
|
||||
|
||||
RETURN
|
||||
|
||||
|
||||
* * * * * * *
|
||||
ReadOnly:
|
||||
* * * * * * *
|
||||
|
||||
thisFormName = Parms[1,@RM]
|
||||
ClearFlag = Parms[COL2()+1,@RM]
|
||||
|
||||
IF thisFormName = '' THEN thisFormName = @WINDOW
|
||||
|
||||
IF ClearFlag = '' THEN ClearFlag = 0
|
||||
|
||||
* Get control map and find key controls
|
||||
* Changed from Controlling ENABLE to setting STYLE ReadOnly bit - 09/30/2005 - JCH, J.C. Henry & Co., Inc.
|
||||
|
||||
CtrlMap = Get_Property(thisFormName,'CTRLMAP')
|
||||
|
||||
CONVERT @FM TO @RM IN CtrlMap
|
||||
|
||||
PosList = Get_Property(CtrlMap,STR('POS':@RM,COUNT(CtrlMap,@RM)):'POS')
|
||||
|
||||
WindowTitle = Get_Property(thisFormName,'TEXT')
|
||||
|
||||
IF ClearFlag THEN
|
||||
SWAP ' < V i e w O n l y >' WITH '' IN WindowTitle
|
||||
END ELSE
|
||||
IF NOT(INDEX(WindowTitle,'< V i e w',1)) THEN
|
||||
WindowTitle := ' < V i e w O n l y >'
|
||||
END
|
||||
END
|
||||
|
||||
Set_Property(thisFormName,'TEXT',WindowTitle)
|
||||
|
||||
FOR I = 1 TO COUNT(PosList,@RM) + (PosList NE '')
|
||||
|
||||
Pos = FIELD(PosList,@RM,I)
|
||||
|
||||
IF Pos NE 0 THEN
|
||||
Ctrl = FIELD(CtrlMap,@RM,I)
|
||||
CtrlType = Get_Property(Ctrl,'TYPE')
|
||||
|
||||
IF ClearFlag THEN
|
||||
|
||||
IF CtrlType = 'RADIOGROUP' OR CtrlType = 'CHECKBOX' THEN
|
||||
Set_Property(Ctrl,'ENABLED',1)
|
||||
END ELSE
|
||||
Style = Get_Property(Ctrl,'STYLE')
|
||||
IF Style[1,2] _eqc "0x" THEN
|
||||
CONVERT @LOWER.CASE TO @UPPER.CASE IN Style
|
||||
Style = ICONV(Style[3,99],'MX') ;* Convert from Hex to Decimal format for BITOR operation
|
||||
END
|
||||
|
||||
Style = BITAND(Style,BITNOT(ReadOnlyStyle$)) ;* Clear ReadOnly Style Bit
|
||||
Set_Property(Ctrl,'STYLE',Style)
|
||||
|
||||
END
|
||||
END ELSE
|
||||
IF CtrlType = 'RADIOGROUP' OR CtrlType = 'CHECKBOX' THEN
|
||||
Set_Property(Ctrl,'ENABLED',0)
|
||||
END ELSE
|
||||
Style = Get_Property(Ctrl,'STYLE')
|
||||
IF Style[1,2] _eqc "0x" THEN
|
||||
CONVERT @LOWER.CASE TO @UPPER.CASE IN Style
|
||||
Style = ICONV(Style[3,99],'MX')
|
||||
END
|
||||
|
||||
Style = BITOR(Style,ReadOnlyStyle$) ;* Set ReadOnly Style Bit
|
||||
Set_Property(Ctrl,'STYLE',Style)
|
||||
|
||||
END
|
||||
|
||||
END
|
||||
|
||||
END
|
||||
NEXT I
|
||||
|
||||
RETURN
|
||||
|
||||
|
||||
* * * * * * *
|
||||
LUValReturn:
|
||||
* * * * * * *
|
||||
|
||||
ValueReturned = Parms[1,@RM]
|
||||
FocusControl = Parms[COL2()+1,@RM]
|
||||
FocusPos = Parms[COL2()+1,@RM]
|
||||
SkipRecalc = Parms[COL2()+1,@RM]
|
||||
|
||||
IF NOT(ASSIGNED(SkipRecalc)) THEN SkipRecalc = 0
|
||||
|
||||
* Null values for ValueReturned are permitted
|
||||
|
||||
IF FocusControl = '' THEN
|
||||
FocusControl = Get_Property(@WINDOW,'FOCUS')
|
||||
END ELSE
|
||||
IF INDEX(FocusControl,'.',1) ELSE
|
||||
FocusControl = @WINDOW:'.':FocusControl
|
||||
END
|
||||
END
|
||||
|
||||
IF FocusPos = '' THEN
|
||||
Set_Property(FocusControl,'FOCUS',1)
|
||||
Set_Property(FocusControl,'DEFPROP',ValueReturned)
|
||||
NextControl = Get_Property(FocusControl,'NEXT')
|
||||
Send_Event(FocusControl,'LOSTFOCUS')
|
||||
Set_Property('SYSTEM','FOCUS',NextControl)
|
||||
END ELSE
|
||||
FocusCol = FocusPos[1,@FM]
|
||||
FocusRow = FocusPos[COL2()+1,@FM]
|
||||
|
||||
Set_Property(FocusControl,'SELPOS',FocusPos)
|
||||
Set_Property(FocusControl,'DEFPROP',ValueReturned,FocusPos)
|
||||
Set_Property(FocusControl,'SELPOS',FocusCol+1:@FM:FocusRow)
|
||||
IF NOT(SkipRecalc) THEN
|
||||
Send_Event(FocusControl,'CALCULATE',FocusCol+1)
|
||||
END
|
||||
END
|
||||
|
||||
RETURN
|
||||
|
||||
|
||||
* * * * * * *
|
||||
LoadFormKeys:
|
||||
* * * * * * *
|
||||
|
||||
IF NOT(ASSIGNED(thisFormName)) THEN thisFormName = Parms[1,@RM]
|
||||
IF NOT(ASSIGNED(thisFormKey)) THEN thisFormKey = Parms[COL2()+1,@RM]
|
||||
|
||||
IF thisFormName = '' THEN RETURN
|
||||
|
||||
* Get control map and find key controls
|
||||
|
||||
CtrlMap = Get_Property(thisFormName,'CTRLMAP')
|
||||
|
||||
CONVERT @FM TO @RM IN CtrlMap
|
||||
|
||||
PosList = Get_Property(CtrlMap,STR('POS':@RM,COUNT(CtrlMap,@RM)):'POS')
|
||||
PartList = Get_Property(CtrlMap,STR('PART':@RM,COUNT(CtrlMap,@RM)):'PART')
|
||||
ConvList = Get_Property(CtrlMap,STR('CONV':@RM,COUNT(CtrlMap,@RM)):'CONV')
|
||||
|
||||
Ctrls = ''
|
||||
Props = ''
|
||||
Vals = ''
|
||||
NullValueControl = ''
|
||||
|
||||
PosCount = DCount(PosList, @RM)
|
||||
|
||||
FOR I = 1 TO PosCount ; //COUNT(PosList,@RM) + (PosList NE '')
|
||||
|
||||
Pos = FIELD(PosList,@RM,I)
|
||||
|
||||
IF Pos = 0 THEN
|
||||
Part = FIELD(PartList,@RM,I)
|
||||
Conv = FIELD(ConvList,@RM,I)
|
||||
Ctrl = FIELD(CtrlMap,@RM,I)
|
||||
|
||||
IF INDEX(Pos,@SVM,1) THEN
|
||||
* We're in a Multivalued control i.e. edittable - skip it
|
||||
END ELSE
|
||||
|
||||
Value = FIELD(thisFormKey,'*',Part)
|
||||
|
||||
IF Conv NE '' THEN Value = OCONV(Value,Conv)
|
||||
|
||||
IF Value = '' THEN
|
||||
NullValueControl = FIELD(CtrlMap,@RM,I)
|
||||
END ELSE
|
||||
Ctrls := FIELD(CtrlMap,@RM,I):@RM
|
||||
Props := 'DEFPROP':@RM
|
||||
Vals := Value:@RM
|
||||
END
|
||||
END
|
||||
END
|
||||
UNTIL NullValueControl NE ''
|
||||
NEXT I
|
||||
|
||||
Ctrls[-1,1] = ''
|
||||
Props[-1,1] = ''
|
||||
Vals[-1,1] = ''
|
||||
|
||||
Set_Property(Ctrls,Props,Vals)
|
||||
|
||||
LastKeyCtrl = Ctrls[-1,'B':@RM] ;*
|
||||
|
||||
IF NullValueControl = '' THEN
|
||||
* Complete key was loaded
|
||||
NextCtrl = Get_Property(LastKeyCtrl,'NEXT')
|
||||
Send_Event( LastKeyCtrl, 'LOSTFOCUS') ;* Triggers form read
|
||||
Set_Property('SYSTEM','FOCUS',NextCtrl) ;* Move to next field preserving event chain
|
||||
END ELSE
|
||||
* Partial key was loaded
|
||||
Set_Property('SYSTEM','FOCUS',NullValueControl)
|
||||
END
|
||||
|
||||
RETURN
|
||||
|
||||
|
||||
* * * * * * *
|
||||
ViewNewCard:
|
||||
* * * * * * *
|
||||
|
||||
CardWindow = Parms[1,@RM]
|
||||
CardKey = Parms[COL2()+1,@RM] ;* Null values for CardKey creates new card
|
||||
NewCardCtrl = Parms[COL2()+1,@RM] ;* Name of button control to create new Card on Card window
|
||||
RecalcCtrl = Parms[COL2()+1,@RM] ;* Symbolic Control to recalculate upon return
|
||||
RecalcPos = Parms[COL2()+1,@RM] ;* Position in edit list or edit table for recalc
|
||||
RetCtrl = Parms[COL2()+1,@RM] ;* This can be called from both a window and a process
|
||||
RetPos = Parms[COL2()+1,@RM] ;* Position in edit list or edit table to return to
|
||||
|
||||
|
||||
IF CardWindow = '' THEN RETURN
|
||||
IF RetCtrl = '' THEN RetCtrl = Get_Property(@WINDOW,'FOCUS')
|
||||
IF RetPos = '' THEN RetPos = Get_Property(RetCtrl,'SELPOS')
|
||||
|
||||
thisFormName = CardWindow
|
||||
thisFormKey = CardKey
|
||||
|
||||
GOSUB AppChildWindow ;* Starts or Restores application window and gives user chance to save any changes
|
||||
|
||||
IF thisFormKey NE '' THEN
|
||||
GOSUB LoadFormKeys ;* Loads form keys and triggers READ event
|
||||
END ELSE
|
||||
IF NewCardCtrl NE '' THEN
|
||||
IF INDEX(NewCardCtrl,'.',1) THEN NewCardCtrl = FIELD(NewCardCtrl,'.',2)
|
||||
Send_Event(CardWindow:'.':NewCardCtrl,'CLICK') ;* 'Pushes' New button in card to trigger new record process
|
||||
END
|
||||
END
|
||||
|
||||
Set_Property(CardWindow,'@RETURN_CONTROL',RetCtrl)
|
||||
|
||||
IF RetPos NE '' THEN Set_Property(CardWindow,'@RETURN_POS',RetPos)
|
||||
|
||||
IF RecalcCtrl NE '' THEN Set_Property(CardWindow,'@RECALC_CONTROL',RecalcCtrl)
|
||||
IF RecalcPos NE '' THEN Set_Property(CardWindow,'@RECALC_POS',RecalcPos)
|
||||
|
||||
RETURN
|
||||
|
||||
|
||||
* * * * * * *
|
||||
ViewNewDetail:
|
||||
* * * * * * *
|
||||
|
||||
DetWindow = Parms[1,@RM]
|
||||
DetKeys = Parms[COL2()+1,@RM] ;* Multipart key to detail record
|
||||
DefaultRec = Parms[COL2()+1,@RM] ;* Used to set fields in @PREV_REC for defaults
|
||||
|
||||
RetKey = Parms[COL2()+1,@RM] ;* Key to the master record
|
||||
RetPage = Parms[COL2()+1,@RM] ;* Page in master form to return to
|
||||
RetCtrl = Parms[COL2()+1,@RM] ;* Leaves focus on window upon return
|
||||
RetPos = Parms[COL2()+1,@RM] ;* Used only for edit tables or lists
|
||||
|
||||
IF DetWindow = '' THEN RETURN
|
||||
|
||||
IF RetKey = '' THEN RetKey = Get_Property(RetWin,'ID')
|
||||
IF RetPage = '' THEN RetPage = Get_Property(RetWin,'VPOSITION')
|
||||
IF RetCtrl = '' THEN RetCtrl = Get_Property(RetWin,'FOCUS')
|
||||
IF RetPos = '' THEN RetPos = Get_Property(RetCtrl,'SELPOS')
|
||||
|
||||
thisFormName = DetWindow
|
||||
thisFormKey = DetKeys
|
||||
|
||||
GOSUB AppChildWindow ;* Starts or Restores application window and gives user chance to save any changes
|
||||
|
||||
* Load Key Controls with Key Parts
|
||||
|
||||
Ctrls = DetWindow:@RM ; Props = '@PREV_ID':@RM ; Vals = DetKeys:@RM
|
||||
Ctrls := DetWindow:@RM ; Props := '@PREV_REC':@RM ; Vals := DefaultRec:@RM
|
||||
Ctrls := DetWindow:@RM ; Props := '@RETURN_KEY':@RM ; Vals := RetKey:@RM
|
||||
Ctrls := DetWindow:@RM ; Props := '@RETURN_PAGE':@RM ; Vals := RetPage:@RM
|
||||
Ctrls := DetWindow:@RM ; Props := '@RETURN_CONTROL':@RM ; Vals := RetCtrl:@RM
|
||||
Ctrls := DetWindow ; Props := '@RETURN_POS' ; Vals := RetPos
|
||||
|
||||
Set_Property(Ctrls,Props,Vals)
|
||||
|
||||
GOSUB LoadFormKeys ;* Load key into form and triggers READ event or places focus on 1st empty key field.
|
||||
|
||||
RETURN
|
||||
|
||||
|
||||
* * * * * * *
|
||||
ViewRelated:
|
||||
* * * * * * *
|
||||
|
||||
RelatedWindow = Parms[1,@RM]
|
||||
RelatedKey = Parms[COL2()+1,@RM]
|
||||
RelatedParms = Parms[COL2()+1,@RM]
|
||||
|
||||
IF RelatedWindow = '' THEN RETURN ;* Master window
|
||||
IF RelatedKey = '' THEN RETURN ;* Must have at least a partial key
|
||||
|
||||
thisFormName = RelatedWindow
|
||||
thisFormKey = RelatedKey
|
||||
thisFormParms = RelatedParms
|
||||
|
||||
GOSUB AppChildWindow ;* Starts or Restores application window and gives user chance to save any changes
|
||||
|
||||
IF INDEX(RelatedKey,@VM,1) THEN
|
||||
Send_Event(RelatedWindow,'QBFINIT')
|
||||
Set_Property(RelatedWindow,'QBFLIST',RelatedKey)
|
||||
Send_Event(RelatedWindow,'QBFFIRST')
|
||||
END ELSE
|
||||
GOSUB LoadFormKeys ;* Load key into form and triggers READ event or places focus on 1st empty key field.
|
||||
END
|
||||
|
||||
RETURN
|
||||
|
||||
|
||||
|
||||
* * * * * * *
|
||||
CardReturn:
|
||||
* * * * * * *
|
||||
|
||||
CardKey = Parms[1,@RM]
|
||||
|
||||
IF NOT(ASSIGNED(CardKey)) THEN RETURN ;* Null values for CardKey are used when called from the delete event
|
||||
|
||||
ParentWindow = Get_Property(@WINDOW,'PARENT')
|
||||
|
||||
Ctrls = @WINDOW:@RM ; Props = '@RETURN_CONTROL':@RM
|
||||
Ctrls := @WINDOW:@RM ; Props := '@RETURN_POS':@RM
|
||||
Ctrls := @WINDOW:@RM ; Props := '@RECALC_CONTROL':@RM
|
||||
Ctrls := @WINDOW:@RM ; Props := '@RECALC_POS':@RM
|
||||
Ctrls := @WINDOW ; Props := '@SKIP_RETURN'
|
||||
|
||||
Vals = Get_Property(Ctrls,Props)
|
||||
|
||||
ReturnControl = Vals[1,@RM]
|
||||
ReturnPos = Vals[COL2()+1,@RM]
|
||||
RecalcControl = Vals[COL2()+1,@RM]
|
||||
RecalcPos = Vals[COL2()+1,@RM]
|
||||
SkipReturn = Vals[COL2()+1,@RM]
|
||||
|
||||
ResetVals = '':@RM:'':@RM:'':@RM:'':@RM:''
|
||||
|
||||
Set_Property(Ctrls,Props,Vals)
|
||||
|
||||
|
||||
IF SkipReturn THEN
|
||||
Set_Property(@WINDOW,'@SKIP_RETURN',0) ;* Set by routines issuing the WRITE command programmatically
|
||||
RETURN
|
||||
END
|
||||
|
||||
IF ReturnControl NE '' THEN
|
||||
Set_Property(ReturnControl,"DEFPROP",CardKey,ReturnPos)
|
||||
Set_Property(ReturnControl,'FOCUS',1)
|
||||
END
|
||||
IF RecalcControl NE '' THEN
|
||||
Post_Event(RecalcControl,'CALCULATE',RecalcPos) ;* Trigger any symbolic updates
|
||||
Post_Event(ParentWindow,'GOTFOCUS') ;* This causes Refresh
|
||||
END
|
||||
|
||||
IF ReturnControl NE '' OR RecalcControl NE '' THEN Post_Event(@WINDOW,'CLOSE')
|
||||
|
||||
RETURN
|
||||
|
||||
|
||||
* * * * * * *
|
||||
DetailReturn:
|
||||
* * * * * * *
|
||||
|
||||
|
||||
Ctrls = @WINDOW:@RM ; Props = '@RETURN_KEY':@RM
|
||||
Ctrls := @WINDOW:@RM ; Props := 'PARENT':@RM
|
||||
Ctrls := @WINDOW:@RM ; Props := '@RETURN_PAGE':@RM
|
||||
Ctrls := @WINDOW:@RM ; Props := '@RETURN_CONTROL':@RM
|
||||
Ctrls := @WINDOW:@RM ; Props := '@RETURN_POS':@RM
|
||||
Ctrls := @WINDOW ; Props := '@SKIP_RETURN'
|
||||
|
||||
Vals = Get_Property(Ctrls,Props)
|
||||
|
||||
ReturnKey = Vals[1,@RM]
|
||||
ReturnWindow = Vals[COL2()+1,@RM]
|
||||
ReturnPage = Vals[COL2()+1,@RM]
|
||||
ReturnControl = Vals[COL2()+1,@RM]
|
||||
ReturnPos = Vals[COL2()+1,@RM]
|
||||
SkipReturn = Vals[COL2()+1,@RM]
|
||||
|
||||
IF SkipReturn THEN
|
||||
Set_Property(@WINDOW,'@SKIP_RETURN',0) ;* Set by routines issuing the WRITE command programmatically
|
||||
RETURN
|
||||
END
|
||||
|
||||
IF ReturnKey NE '' THEN
|
||||
thisFormName = ReturnWindow
|
||||
thisFormKey = ReturnKey
|
||||
GOSUB LoadFormKeys
|
||||
END
|
||||
|
||||
IF ReturnPage NE '' THEN
|
||||
Send_Event(ReturnWindow,'PAGE',ReturnPage)
|
||||
END
|
||||
|
||||
IF ReturnControl THEN
|
||||
Set_Property(ReturnControl,'FOCUS',1)
|
||||
IF ReturnPos THEN
|
||||
Set_Property(ReturnControl,'SELPOS',ReturnPos)
|
||||
END
|
||||
END
|
||||
|
||||
RETURN
|
||||
|
||||
|
||||
|
||||
* * * * * * *
|
||||
AppChildWindow:
|
||||
* * * * * * *
|
||||
|
||||
thisFormWindowUp = Get_Property(thisFormName,'VISIBLE') ;* Returns 0 = hidden, 1 = visible, 2 = minimized, 3 = maximized
|
||||
|
||||
IF thisFormWindowUp = '' THEN Start_Window(thisFormName,@WINDOW,thisFormParms) ;* Put up the card window - added thisFormParms 3/22/2010 JCH
|
||||
IF thisFormWindowUp = 2 THEN Set_Property(thisFormName,'VISIBLE',9) ;* Restore the window if minimized
|
||||
|
||||
IF Get_Property(thisFormName,'SAVEWARN') THEN
|
||||
Set_Property(thisFormName,'@SKIP_CARD_RETURN',1) ;* This stops the Return behavior
|
||||
Send_Event(thisFormName,'CLEAR') ;* Clear anything existing (prompts for save first)
|
||||
END
|
||||
|
||||
RETURN
|
||||
|
||||
|
||||
* * * * * * *
|
||||
SetDropDowns:
|
||||
* * * * * * *
|
||||
|
||||
ComboBoxes = Utility('OBJECTLIST',@WINDOW,'COMBOBOX')
|
||||
ListBoxes = Utility('OBJECTLIST',@WINDOW,'LISTBOX')
|
||||
|
||||
ControlList = ComboBoxes:@FM:ListBoxes
|
||||
|
||||
CtrlCnt = Count(ControlList,@FM) + (ControlList NE '')
|
||||
|
||||
FOR I = 1 TO CtrlCnt
|
||||
thisControl = ControlList<I>
|
||||
UnqualCtrlName = Field(thisControl,'.',2)
|
||||
|
||||
ListData = XLATE('LISTBOX_CONFIG',UnqualCtrlName,1,'X')
|
||||
|
||||
CONVERT @VM TO @FM IN ListData
|
||||
Set_Property(thisControl,'LIST',ListData)
|
||||
NEXT I
|
||||
|
||||
RETURN
|
||||
|
||||
|
||||
395
SYSPROG/STPROC/OBJ_TABLES.txt
Normal file
395
SYSPROG/STPROC/OBJ_TABLES.txt
Normal file
@ -0,0 +1,395 @@
|
||||
COMPILE FUNCTION obj_Tables(Method,Parms)
|
||||
|
||||
/*
|
||||
Data Table Read, Write, Delete Lock, Unlock Methods
|
||||
|
||||
11/22/00 by JCH - J.C. Henry, Inc
|
||||
|
||||
Properties:
|
||||
|
||||
TableKey Record Key
|
||||
TableRec Record
|
||||
TableName Table Name
|
||||
TableVar Table Variable from OPEN statement (Optional)
|
||||
|
||||
Methods:
|
||||
|
||||
OpenTable(TableName) Open TableName and Return TableVar
|
||||
ReadOnlyRec(TableName,TableKey,TableVar) Read Record Returns TableRecord without Lock
|
||||
ReadRec(TableName,TableKey,TableVar) Read Record for update (with lock set)
|
||||
WriteRec(TableName,TableKey,TableVar,TableRec,Locked) Write Record
|
||||
DeleteRec(TableName,TableKey,TableVar) Delete Record
|
||||
LockRec(TableName,TableKey,TableVar) Lock Record
|
||||
UnlockRec(TableName,TableKey,TableVar) Unlock Record
|
||||
LockSet(TableName,TableKey(s)) Locks all Keys in list
|
||||
UnlockSet(TableName,TableKey(s),TableVar) Unlocks all Keys in list
|
||||
|
||||
|
||||
Records are checked for any contents prior to write. If there is no data in the
|
||||
record then the record is DELETED from the table.
|
||||
|
||||
History:
|
||||
|
||||
08/27/20 DJS Updated UnlockRec subroutine to utilize Database_Services and to only unlock a record
|
||||
if the record is locked in order to avoid setting an FS411 error uneccessarily.
|
||||
|
||||
|
||||
*/
|
||||
|
||||
DECLARE SUBROUTINE Set_Status, Set_FSError, Database_Services, Logging_Services
|
||||
DECLARE FUNCTION Set_Status, Database_Services, Logging_Services, Environment_Services
|
||||
|
||||
EQU Tab$ TO \09\
|
||||
EQU CRLF$ TO \0D0A\
|
||||
EQU LF$ TO \0A\
|
||||
EQU Comma$ TO ','
|
||||
|
||||
EQU TRUE$ TO 1
|
||||
EQU FALSE$ TO 0
|
||||
|
||||
EQU TABLE_NAME$ TO 1
|
||||
EQU TABLE_KEY$ TO 2
|
||||
EQU TABLE_VAR$ TO 3
|
||||
EQU TABLE_REC$ TO 4
|
||||
|
||||
$INSERT CopyRight
|
||||
$INSERT Msg_Equates
|
||||
|
||||
LogPath = Environment_Services('GetApplicationRootPath') : '\LogFiles\obj_Tables'
|
||||
LogDate = Oconv(Date(), 'D4/')
|
||||
LogTime = Oconv(Time(), 'MTS')
|
||||
LogFileName = LogDate[7, 4] : '-' : LogDate[1, 2] : '-' : LogDate[4, 2] : ' obj_Tables Log.csv'
|
||||
Headers = 'Logging DTM' : @FM : 'User' : @FM : 'Method' : @FM : 'TableName' : @FM : 'TableKey' : @FM : 'Notes'
|
||||
objLog = Logging_Services('NewLog', LogPath, LogFileName, CRLF$, Comma$, Headers, '', False$, False$)
|
||||
LoggingDTM = LogDate : ' ' : LogTime ; // Logging DTM
|
||||
|
||||
ErrTitle = 'Error in obj_Tables'
|
||||
|
||||
ErrorMsg = ''
|
||||
|
||||
IF NOT(ASSIGNED(Method)) THEN ErrorMsg = 'Unassigned parameter "Method" passed to subroutine.'
|
||||
IF NOT(ASSIGNED(Parms)) THEN ErrorMsg = 'Unassigned parameter "Parms" passed to subroutine.'
|
||||
|
||||
IF Method = '' THEN ErrorMsg = 'Null parameter "Method" passed to subroutine'
|
||||
IF Parms = '' THEN ErrorMsg = 'Null parameter "Parms" passed to subroutine.'
|
||||
|
||||
|
||||
IF ErrorMsg NE '' THEN
|
||||
stat = Set_Status(-1,ErrTitle:@SVM:ErrorMsg) ;* Initialization Errors
|
||||
RETURN ''
|
||||
END
|
||||
|
||||
Result = ''
|
||||
|
||||
TableName = Parms[1,@RM]
|
||||
TableKey = Parms[COL2()+1,@RM]
|
||||
TableVar = Parms[COL2()+1,@RM]
|
||||
TableRec = Parms[COL2()+1,@RM]
|
||||
|
||||
|
||||
BEGIN CASE
|
||||
CASE Method = 'OpenTable' ; GOSUB OpenTable
|
||||
CASE Method = 'ReadOnlyRec' ; GOSUB ReadOnlyRec
|
||||
CASE Method = 'ReadRec' ; GOSUB ReadRec
|
||||
CASE Method = 'WriteRec' ; GOSUB WriteRec
|
||||
CASE Method = 'WriteOnlyRec' ; GOSUB WriteOnlyRec
|
||||
CASE Method = 'DeleteRec' ; GOSUB DeleteRec
|
||||
CASE Method = 'LockRec' ; GOSUB LockRec
|
||||
CASE Method = 'UnlockRec' ; GOSUB UnlockRec
|
||||
CASE Method = 'LockSet' ; GOSUB LockSet
|
||||
CASE Method = 'UnlockSet' ; GOSUB UnlockSet
|
||||
CASE 1
|
||||
ErrorMsg = 'Method ':QUOTE(Method):' not defined in object.'
|
||||
|
||||
END CASE
|
||||
|
||||
|
||||
IF ErrorMsg = '' THEN
|
||||
Parms = FieldStore(Parms,@RM,TABLE_VAR$,0,TableVar)
|
||||
END ELSE
|
||||
stat = Set_Status(-1,ErrTitle:@SVM:ErrorMsg)
|
||||
RETURN ''
|
||||
END
|
||||
|
||||
RETURN Result
|
||||
|
||||
|
||||
* * * * * * *
|
||||
OpenTable:
|
||||
* * * * * * *
|
||||
|
||||
IF TableName = '' THEN ErrorMsg = 'Null parameter "TableName" passed to subroutine'
|
||||
|
||||
IF ErrorMsg = '' THEN
|
||||
OPEN TableName TO TableVar THEN
|
||||
Result = TableVar
|
||||
Parms = FieldStore(Parms,@RM,3,1,TableVar) ;* Added 1/22/2007 JCH
|
||||
END ELSE
|
||||
ErrorMsg = 'Unable to open Table ':QUOTE(TableName)
|
||||
END
|
||||
END
|
||||
|
||||
|
||||
RETURN
|
||||
|
||||
* * * * * * *
|
||||
ReadRec:
|
||||
* * * * * * *
|
||||
|
||||
GOSUB LockRec
|
||||
|
||||
IF ErrorMsg NE '' THEN RETURN
|
||||
|
||||
* * * * * * *
|
||||
ReadOnlyRec:
|
||||
* * * * * * *
|
||||
|
||||
IF TableName = '' THEN ErrorMsg = 'Null parameter "TableName" passed to subroutine'
|
||||
IF TableKey = '' THEN ErrorMsg = 'Null parameter "TableKey" passed to subroutine'
|
||||
IF TableVar = '' THEN
|
||||
GOSUB OpenTable
|
||||
IF ErrorMsg THEN RETURN
|
||||
END
|
||||
|
||||
READ TableRec FROM TableVar,TableKey THEN
|
||||
Result = TableRec
|
||||
END ELSE
|
||||
// Log failure to read
|
||||
LogData = ''
|
||||
LogData<1> = LoggingDTM
|
||||
LogData<2> = @User4
|
||||
LogData<3> = Method
|
||||
LogData<4> = TableName
|
||||
LogData<5> = TableKey
|
||||
LogData<6> = 'Error code: ':@FILE_ERROR<1>:' Error message: ':@FILE_ERROR<2>:' Error detail: ':@FILE_ERROR<3>
|
||||
Logging_Services('AppendLog', objLog, LogData, @RM, @FM)
|
||||
|
||||
IF @FILE_ERROR<1> = 100 THEN
|
||||
* Record doesn't exist
|
||||
* 04/20/2021 - DJS - Moved unlock call outside of this specific error condition so that the record is always
|
||||
* unlocked if the record fails to be read.
|
||||
* GOSUB UnlockRec
|
||||
Null
|
||||
END ELSE
|
||||
Set_FSError()
|
||||
ErrorMsg = 'Record ':QUOTE(TableKey):' not found in Table ':QUOTE(TableName)
|
||||
END
|
||||
Result = ''
|
||||
|
||||
If ( (TableName NE '') and (TableKey NE '') ) then
|
||||
RecordLocked = Database_Services('IsKeyIDLocked', TableName, TableKey, False$)
|
||||
If RecordLocked EQ True$ then Database_Services('ReleaseKeyIDLock', TableName, TableKey)
|
||||
end
|
||||
|
||||
END
|
||||
|
||||
RETURN
|
||||
|
||||
|
||||
* * * * * * *
|
||||
WriteRec:
|
||||
* * * * * * *
|
||||
|
||||
IF TableName = '' THEN ErrorMsg = 'Null parameter "TableName" passed to subroutine'
|
||||
IF TableKey = '' THEN ErrorMsg = 'Null parameter "TableKey" passed to subroutine'
|
||||
IF TableVar = '' THEN GOSUB OpenTable
|
||||
|
||||
IF ErrorMsg THEN RETURN
|
||||
|
||||
IF ErrorMsg = '' THEN
|
||||
|
||||
TestRec = TableRec
|
||||
|
||||
CONVERT @SVM:@VM:@FM TO '' IN TestRec
|
||||
|
||||
IF TestRec = '' THEN
|
||||
DELETE TableVar,TableKey ELSE Null
|
||||
* ErrorMsg = 'Blank table rec with ':QUOTE(TableKey):' on ':QUOTE(TableName):' table.'; *added 4/9/21 for debugging
|
||||
* Set_FSError()
|
||||
END ELSE
|
||||
Set_Status(0)
|
||||
rv = Get_Status(errCode)
|
||||
WRITE TableRec ON TableVar,TableKey THEN
|
||||
rv = Get_Status(errCode)
|
||||
END ELSE
|
||||
ErrorMsg = 'Unable to write ':QUOTE(TableKey):' on ':QUOTE(TableName):' table.'
|
||||
END
|
||||
|
||||
END
|
||||
|
||||
If ( (TableName NE '') and (TableKey NE '') ) then
|
||||
RecordLocked = Database_Services('IsKeyIDLocked', TableName, TableKey, False$)
|
||||
If RecordLocked EQ True$ then Database_Services('ReleaseKeyIDLock', TableName, TableKey)
|
||||
end
|
||||
|
||||
END
|
||||
|
||||
RETURN
|
||||
|
||||
|
||||
* * * * * * *
|
||||
WriteOnlyRec:
|
||||
* * * * * * *
|
||||
|
||||
IF TableName = '' THEN ErrorMsg = 'Null parameter "TableName" passed to subroutine'
|
||||
IF TableKey = '' THEN ErrorMsg = 'Null parameter "TableKey" passed to subroutine'
|
||||
IF TableVar = '' THEN GOSUB OpenTable
|
||||
|
||||
IF ErrorMsg THEN RETURN
|
||||
|
||||
IF ErrorMsg = '' THEN
|
||||
|
||||
TestRec = TableRec
|
||||
|
||||
CONVERT @SVM:@VM:@FM TO '' IN TestRec
|
||||
|
||||
IF TestRec = '' THEN
|
||||
DELETE TableVar,TableKey ELSE Null
|
||||
END ELSE
|
||||
WRITE TableRec ON TableVar,TableKey ELSE
|
||||
ErrorMsg = 'Unable to write ':QUOTE(TableKey):' on ':QUOTE(TableName):' table.'
|
||||
END
|
||||
END
|
||||
END
|
||||
|
||||
RETURN
|
||||
|
||||
|
||||
* * * * * * *
|
||||
DeleteRec:
|
||||
* * * * * * *
|
||||
|
||||
IF TableName = '' THEN ErrorMsg = 'Null parameter "TableName" passed to subroutine'
|
||||
IF TableKey = '' THEN ErrorMsg = 'Null parameter "TableKey" passed to subroutine'
|
||||
IF TableVar = '' THEN GOSUB OpenTable
|
||||
|
||||
IF ErrorMsg THEN RETURN
|
||||
|
||||
IF ErrorMsg = '' THEN
|
||||
DELETE TableVar,TableKey THEN
|
||||
GOSUB UnlockRec
|
||||
END
|
||||
END
|
||||
|
||||
RETURN
|
||||
|
||||
|
||||
|
||||
* * * * * * *
|
||||
LockRec:
|
||||
* * * * * * *
|
||||
|
||||
IF TableName = '' THEN ErrorMsg = 'Null parameter "TableName" passed to subroutine'
|
||||
IF TableKey = '' THEN ErrorMsg = 'Null parameter "TableKey" passed to subroutine'
|
||||
IF TableVar = '' THEN GOSUB OpenTable
|
||||
|
||||
IF ErrorMsg THEN RETURN
|
||||
|
||||
LockData = ''
|
||||
Locked = FALSE$
|
||||
RetryCnt = 0
|
||||
|
||||
LOOP
|
||||
|
||||
LOCK TableVar,TableKey THEN
|
||||
Locked = TRUE$
|
||||
END ELSE
|
||||
|
||||
BEGIN CASE
|
||||
CASE @FILE_ERROR NE ''
|
||||
Set_FSError()
|
||||
ErrorMsg = 'Unable to Lock ':QUOTE(TableKey):' in Table ':QUOTE(TableName)
|
||||
|
||||
CASE Get_Status(errCode)
|
||||
ErrorMsg = QUOTE(TableKey):' in Table ':QUOTE(TableName):' Locked by another workstation.'
|
||||
|
||||
CASE 1
|
||||
ErrorMsg = QUOTE(TableKey):' in Table ':QUOTE(TableName):' Locked by This workstation.'
|
||||
|
||||
END CASE
|
||||
|
||||
RetryCnt += 1
|
||||
END
|
||||
|
||||
UNTIL Locked OR RetryCnt = 10 REPEAT
|
||||
|
||||
|
||||
RETURN
|
||||
|
||||
|
||||
* * * * * * *
|
||||
UnlockRec:
|
||||
* * * * * * *
|
||||
|
||||
RecordLocked = Database_Services('IsKeyIDLocked', TableName, TableKey, False$)
|
||||
If RecordLocked EQ True$ then Database_Services('ReleaseKeyIDLock', TableName, TableKey)
|
||||
|
||||
RETURN
|
||||
|
||||
|
||||
* * * * * * *
|
||||
LockSet:
|
||||
* * * * * * *
|
||||
|
||||
IF TableName = '' THEN ErrorMsg = 'Null parameter "TableName" passed to subroutine'
|
||||
IF TableKey = '' THEN ErrorMsg = 'Null parameter "TableKey" passed to subroutine'
|
||||
IF TableVar = '' THEN GOSUB OpenTable
|
||||
|
||||
TableKeys = TableKey ;* Pass in @VM'd list of keys In TableKey
|
||||
|
||||
IF ErrorMsg THEN RETURN
|
||||
|
||||
IF TableKeys = '' THEN RETURN
|
||||
|
||||
Set_Status(0)
|
||||
|
||||
LockedTableKeys = ''
|
||||
|
||||
FOR I = 1 TO COUNT(TableKeys,@VM) + (TableKeys NE '')
|
||||
TableKey = TableKeys<1,I>
|
||||
GOSUB LockRec
|
||||
|
||||
If Locked THEN
|
||||
LockedTableKeys<1,-1> = TableKey
|
||||
End ELSE
|
||||
For N = 1 To Count(LockedTableKeys,@VM) + (LockedTableKeys NE '')
|
||||
TableKey = LockedTableKeys<1,N>
|
||||
Gosub UnlockRec
|
||||
Next N
|
||||
End
|
||||
|
||||
NEXT I
|
||||
|
||||
Result = TableVar
|
||||
|
||||
RETURN
|
||||
|
||||
|
||||
* * * * * * *
|
||||
UnlockSet:
|
||||
* * * * * * *
|
||||
|
||||
IF TableName = '' THEN ErrorMsg = 'Null parameter "TableName" passed to subroutine'
|
||||
IF TableKey = '' THEN ErrorMsg = 'Null parameter "TableKey" passed to subroutine'
|
||||
IF TableVar = '' THEN ErrorMsg = 'Null parameter "TableVar" passed to subroutine'
|
||||
|
||||
LockedTableKeys = TableKey ;* Pass in @VM'd list of keys In TableKey
|
||||
|
||||
IF ErrorMsg THEN RETURN
|
||||
|
||||
IF LockedTableKeys = '' THEN RETURN
|
||||
|
||||
Set_Status(0)
|
||||
|
||||
|
||||
FOR I = 1 TO COUNT(LockedTableKeys,@VM) + (LockedTableKeys NE '')
|
||||
TableKey = LockedTableKeys<1,I>
|
||||
GOSUB UnlockRec
|
||||
NEXT I
|
||||
|
||||
RETURN
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
459
SYSPROG/STPROC/OIPI_EXAMPLE1.txt
Normal file
459
SYSPROG/STPROC/OIPI_EXAMPLE1.txt
Normal file
@ -0,0 +1,459 @@
|
||||
subroutine OIPI_Example1(dummy)
|
||||
|
||||
/*
|
||||
|
||||
OIPI_Example1
|
||||
|
||||
|
||||
|
||||
This is an example program on how to use the OpenInsight Printer Interface.
|
||||
|
||||
This example uses most of the features of the OpenInsight Printer Interface, and
|
||||
|
||||
is a good place to start learning how to create reports with the OIPI.
|
||||
|
||||
*/
|
||||
|
||||
declare function Set_Printer, Get_Printer, RGB,Set_Property
|
||||
|
||||
declare function msg
|
||||
|
||||
$insert OIPRINT_EQUATES
|
||||
$Insert RTI_Postscript_Common
|
||||
|
||||
|
||||
Equ Portrait$ To 0
|
||||
Equ Landscape$ To 1
|
||||
|
||||
* print Setup Equate
|
||||
Equ Print_Style$ To 1
|
||||
Equ Print_Zoom$ To 2
|
||||
|
||||
Equ Print_ToPrinter$ To 0
|
||||
Equ Display_PrintSetup$ To 1
|
||||
Equ Preview_Normal$ To 2
|
||||
Equ Print_Mazimized$ To 3
|
||||
|
||||
Equ Display_AllButtons$ To 0
|
||||
Equ Hide_PrintButton$ To 1
|
||||
Equ Hide_PrintSetupButton$ To 2
|
||||
Equ Hide_AllButtons$ To 3
|
||||
|
||||
* Create the fonts for the OIPI report
|
||||
|
||||
* 18 point Arial font with left justified, bold and dark blue color
|
||||
Font1 = "Arial":@FM:18:@FM:"L":@FM:1:@FM:0:@FM:0:@FM:0:@FM:RGB(0, 0, 172)
|
||||
|
||||
* 16 point Times New Roman with left justified bold, italics, underline, and dark magenta
|
||||
Font2 = "Times New Roman":@FM:16:@FM:"L":@FM:1:@FM:1:@FM:1:@FM:0:@FM:RGB(192, 0, 172)
|
||||
|
||||
* 14 point Times New Roman with left justified
|
||||
Font3 = "Times New Roman":@FM:14
|
||||
|
||||
* Start the OIPI report with the INIT message
|
||||
FileName = "OIPI_Example1"
|
||||
|
||||
PrintTitle = "OIPI Printing..."
|
||||
PreviewTitle = "OIPI Print Preview"
|
||||
|
||||
Margins = .5:@FM:1:@FM:.5:@FM:1 ;* half inch margins On the sides, one inch margins On the top
|
||||
Orientation = Portrait$
|
||||
PrintSetup = ""
|
||||
PrintSetup<Print_Style$, 1> = Preview_normal$
|
||||
PrintSetup<Print_Style$, 2> = Display_AllButtons$
|
||||
PrintSetup<2> = -1 ;* Set initial zoom to PageWidth
|
||||
PrintSetup<3> = 5 ;* Set the Print Preview position at 5% from top and left
|
||||
PrintSetup<4> = 5
|
||||
PrintSetup<5> = 95
|
||||
PrintSetup<6> = 95
|
||||
|
||||
VAL = Set_Printer("INIT", FileName, PrintTitle:@FM:PreviewTitle, Margins, Orientation, PrintSetup)
|
||||
if VAL < 0 then
|
||||
* Always check the return value of the INIT message for error
|
||||
ErrorMsg = "Fatal error with the INIT message:":VAL
|
||||
goto fatalExit
|
||||
end
|
||||
|
||||
* Set the font for all of the headers and footers
|
||||
if Set_Printer("FONTHEADFOOT", "Arial":@FM:14:@FM:"L":@fm:1) < 0 then
|
||||
ErrorMsg = "Error with the FONTHEADFOOT message"
|
||||
goto fatalExit
|
||||
end
|
||||
|
||||
* Print the header with the file name centered on the first line and
|
||||
* the Long format of the date left justified and the page number right justified
|
||||
* on the second line.
|
||||
|
||||
x = Set_Printer("HEADER", @VM:"'F'":@FM:"'DL'":@VM:@VM:"Page 'P'":@FM)
|
||||
*x = Set_Printer("HEADER", "The Header Text")
|
||||
If x < 0 then
|
||||
ErrorMsg = "Error with the HEADER message"
|
||||
goto fatalExit
|
||||
end
|
||||
|
||||
if Set_Printer("FONT", Font1) < 0 then
|
||||
ErrorMsg = "Error with the FONT message"
|
||||
goto fatalExit
|
||||
End
|
||||
|
||||
|
||||
|
||||
if Set_Printer("TEXT", "Welcome to the OpenInsight Printer Interface!!!") < 0 then
|
||||
* I'm not going to check the remaining TEXT messages, because if the first one
|
||||
* works then the remaining TEXT messages should also work.
|
||||
ErrorMsg = "Error with the TEXT message"
|
||||
goto fatalExit
|
||||
end
|
||||
|
||||
Stat = Set_Printer('CALCTEXT',@Upper.Case)
|
||||
AA = Get_Printer('CALCTEXT')
|
||||
|
||||
|
||||
if Set_Printer("FONT", Font2) < 0 then
|
||||
|
||||
ErrorMsg = "Error with the FONT message"
|
||||
goto fatalExit
|
||||
end
|
||||
x = Set_Printer("TEXT", @FM:"Introduction")
|
||||
|
||||
if Set_Printer("FONT", Font3) < 0 then
|
||||
ErrorMsg = "Error with the FONT message"
|
||||
goto fatalExit
|
||||
end
|
||||
text = "This program will demonstrate the basic features of the OpenInsight Printer Interface. There are several new features in the OIPI 3.x, so please check the online help file for the latest message formats."
|
||||
|
||||
x = Set_Printer("TEXT", text)
|
||||
|
||||
|
||||
if Set_Printer("FONT", Font2) < 0 then
|
||||
|
||||
ErrorMsg = "Error with the FONT message"
|
||||
goto fatalExit
|
||||
end
|
||||
x = Set_Printer("TEXT", @FM:"Get_Printer for VERSION and SERIAL")
|
||||
|
||||
if Set_Printer("FONT", Font3) < 0 then
|
||||
ErrorMsg = "Error with the FONT message"
|
||||
goto fatalExit
|
||||
end
|
||||
ver = Get_Printer("VERSION")
|
||||
text = "You are currently using version '":ver<1>:"' of the OIPI, and the OIPI build number is '":ver<2>:"' and the VSVIEW control version is '":ver<3>:"'":@FM:"Your serial number is ":Get_Printer("SERIAL")
|
||||
|
||||
x = Set_Printer("TEXT", text)
|
||||
|
||||
if Set_Printer("FONT", Font2) < 0 then
|
||||
ErrorMsg = "Error with the FONT message"
|
||||
goto fatalExit
|
||||
end
|
||||
x = Set_Printer("TEXT", @FM:"BMP and TEXTXY")
|
||||
|
||||
if Set_Printer("FONT", Font3) < 0 then
|
||||
ErrorMsg = "Error with the FONT message"
|
||||
goto fatalExit
|
||||
end
|
||||
text = "This will demostrate the use of graphic files and the TEXTXY message. The graphic file (BANNER.WMF) is printed first, "
|
||||
text := "then the text is printed over it with the TEXTXY message. The text shadow is created by offsetting two separate TEXTXY messages."
|
||||
|
||||
text := "The current Y position is used to determine where to print the graphics and text using the Get_Printer POS message."
|
||||
text := "You can strectch the graphics with the BMP message.":@FM
|
||||
x = Set_Printer("TEXT", text)
|
||||
|
||||
* Print the banner.wmf and text inside
|
||||
pos = Get_Printer("POS")
|
||||
|
||||
if Set_Printer("BMP", "BANNER.WMF", 0:@FM:pos<2>:@FM:3.5:@FM:1, 1, 0) < 0 then
|
||||
ErrorMsg = "Error with the BMP message"
|
||||
goto fatalExit
|
||||
end
|
||||
|
||||
if Set_Printer("TEXTXY", "Banner Text", .77:@FM:pos<2>+0.48, "Arial":@FM:24:@FM:"L":@FM:1:@FM:0:@FM:0:@FM:0:@FM:RGB(192, 192, 192):@FM:100, 0) < 0 then
|
||||
|
||||
ErrorMsg = "Error with the TEXTXY message"
|
||||
goto fatalExit
|
||||
End
|
||||
|
||||
if Set_Printer("TEXTXY", "Banner Text", .80:@FM:pos<2>+0.45, "Arial":@FM:24:@FM:"L":@FM:1:@FM:0:@FM:0:@FM:0:@FM:RGB(128, 0, 128):@FM:100, 0) < 0 then
|
||||
ErrorMsg = "Error with the TEXTXY message"
|
||||
goto fatalExit
|
||||
end
|
||||
|
||||
if Set_Printer("BMP", "PRINTER.BMP", 4.0:@FM:pos<2>:@FM:1.6:@FM:1, 0, 0) < 0 then
|
||||
ErrorMsg = "Error with the BMP message"
|
||||
goto fatalExit
|
||||
end
|
||||
|
||||
* Reset the text position below the graphics by adding one inch to the last position
|
||||
|
||||
x = Set_Printer("POS", 0:@FM:pos<2> + 1)
|
||||
|
||||
if Set_Printer("FONT", Font2) < 0 then
|
||||
ErrorMsg = "Error with the FONT message"
|
||||
goto fatalExit
|
||||
end
|
||||
|
||||
x = Set_Printer("TEXT", @FM:"RECT, CALC_TEXT, POLYGON, and Colors")
|
||||
|
||||
if Set_Printer("FONT", Font3) < 0 then
|
||||
ErrorMsg = "Error with the FONT message"
|
||||
goto fatalExit
|
||||
end
|
||||
text = "The next section demonstrates how to use colors with the RECT message, and how to use the CALC_TEXT message to calculate the height and width of text and place a box around the text. "
|
||||
|
||||
text := "The POLYGON message is used to print the gray shading in the 3D button."
|
||||
x = Set_Printer("TEXT", text)
|
||||
|
||||
* Print pyramid
|
||||
if Set_Printer("LINESTYLE", PS_NULL) < 0 then
|
||||
ErrorMsg = "Error with the LINESTYLE message"
|
||||
goto fatalExit
|
||||
end
|
||||
pos = Get_Printer("POS")
|
||||
y = pos<2>
|
||||
offset = 0
|
||||
|
||||
for c = 0 to 128 step 12.8
|
||||
if Set_Printer("FILLSTYLE", BS_SOLID:@FM:RGB(0, 0, 128 + c)) < 0 then
|
||||
ErrorMsg = "Error with the FILLSTYLE message"
|
||||
goto fatalExit
|
||||
end
|
||||
R = 1+offset:@FM:y+offset:@FM:3-offset:@FM:y-offset+2
|
||||
if Set_Printer("RECT", 1+offset:@FM:y+offset:@FM:3-offset:@FM:y-offset+2, 0) < 0 then
|
||||
ErrorMsg = "Error with the RECT message"
|
||||
goto fatalExit
|
||||
end
|
||||
offset = offset + 0.05
|
||||
next c
|
||||
for c = 0 to 128 step 12.8
|
||||
if Set_Printer("FILLSTYLE", BS_SOLID:@FM:RGB(c, c, 255)) < 0 then
|
||||
ErrorMsg = "Error with the FILLSTYLE message"
|
||||
goto fatalExit
|
||||
end
|
||||
if Set_Printer("RECT", 1+offset:@FM:pos<2>+offset:@FM:3-offset:@FM:pos<2>+2-offset, 0) < 0 then
|
||||
ErrorMsg = "Error with the RECT message"
|
||||
|
||||
goto fatalExit
|
||||
end
|
||||
offset = offset + 0.05
|
||||
next c
|
||||
if Set_Printer("LINESTYLE", PS_SOLID:@FM:1:@FM:RGB(0, 0, 0)) < 0 then
|
||||
ErrorMsg = "Error with the LINESTYLE message"
|
||||
goto fatalExit
|
||||
end
|
||||
if Set_Printer("FILLSTYLE", BS_HOLLOW) < 0 then
|
||||
ErrorMsg = "Error with the FILLSTYLE message"
|
||||
goto fatalExit
|
||||
end
|
||||
if Set_Printer("RECT", 1:@FM:pos<2>:@FM:3:@FM:pos<2>+2, 0) < 0 then
|
||||
ErrorMsg = "Error with the RECT message"
|
||||
goto fatalExit
|
||||
end
|
||||
|
||||
if Set_Printer("LINE", 1:@FM:pos<2>:@FM:3:@FM:pos<2>+2, 0) < 0 then
|
||||
|
||||
ErrorMsg = "Error with the LINE message"
|
||||
goto fatalExit
|
||||
end
|
||||
if Set_Printer("LINE", 3:@FM:pos<2>:@FM:1:@FM:pos<2>+2, 0) < 0 then
|
||||
ErrorMsg = "Error with the LINE message"
|
||||
goto fatalExit
|
||||
end
|
||||
|
||||
* print 3D button
|
||||
text = "3D Button"
|
||||
if Set_Printer("FILLSTYLE", BS_SOLID:@FM:RGB(128, 128, 128)) < 0 then
|
||||
ErrorMsg = "Error with the FILLSTYLE message"
|
||||
goto fatalExit
|
||||
end
|
||||
if Set_Printer("FONT", "Arial":@FM:14) < 0 then
|
||||
ErrorMsg = "Error with the FONT message"
|
||||
|
||||
goto fatalExit
|
||||
end
|
||||
|
||||
if Set_Printer("CALCTEXT", text) < 0 then
|
||||
ErrorMsg = "Error with the CALCTEXT message"
|
||||
goto fatalExit
|
||||
end
|
||||
|
||||
size = Get_Printer("CALCTEXT")
|
||||
|
||||
width = size<1>
|
||||
height = size<2>
|
||||
poly = ""
|
||||
poly<1> = 3.5+width+.4:@VM:y
|
||||
poly<2> = 3.5+width+.4:@VM:y+height+.4
|
||||
poly<3> = 3.5:@VM:y+height+.4
|
||||
poly<4> = 3.5+.1:@VM:y+height+.3
|
||||
poly<5> = 3.5+width+.3:@VM:y+height+.3
|
||||
poly<6> = 3.5+width+.3:@VM:y+.1
|
||||
if Set_Printer("POLYGON", poly, 0) < 0 then
|
||||
goto fatalExit
|
||||
|
||||
end
|
||||
|
||||
xxx = get_printer("font")
|
||||
if Set_Printer("FILLSTYLE", BS_HOLLOW) < 0 then
|
||||
ErrorMsg = "Error with the FILLSTYLE message"
|
||||
goto fatalExit
|
||||
end
|
||||
|
||||
xxx = get_printer("font")
|
||||
if Set_Printer("RECT", 3.5:@FM:y:@FM:3.5+width+.4:@FM:y+height+.4, 0) < 0 then
|
||||
ErrorMsg = "Error with the RECT message"
|
||||
goto fatalExit
|
||||
end
|
||||
|
||||
xxx = get_printer("font")
|
||||
if Set_Printer("FILLSTYLE", BS_SOLID:@FM:RGB(192, 192, 192)) < 0 then
|
||||
ErrorMsg = "Error with the FILLSTYLE message"
|
||||
goto fatalExit
|
||||
end
|
||||
if Set_Printer("RECT", 3.5+.1:@FM:y+.1:@FM:3.5+width+.3:@FM:y+height+.3, 0) < 0 then
|
||||
|
||||
ErrorMsg = "Error with the RECT message"
|
||||
goto fatalExit
|
||||
end
|
||||
|
||||
xxx = get_printer("font")
|
||||
if Set_Printer("TEXTXY", text, 3.7:@FM:y+.2, "", 0) < 0 then
|
||||
ErrorMsg = "Error with the TEXTXY message"
|
||||
goto fatalExit
|
||||
end
|
||||
if Set_Printer("FONT", "Times New Roman":@FM:12) < 0 then
|
||||
ErrorMsg = "Error with the FONT message"
|
||||
goto fatalExit
|
||||
end
|
||||
|
||||
* Force a page break
|
||||
if Set_Printer("PAGEBREAK") < 0 then
|
||||
ErrorMsg = "Error with the PAGEBREAK message"
|
||||
goto fatalExit
|
||||
end
|
||||
|
||||
|
||||
if Set_Printer("FONT", Font2) < 0 then
|
||||
|
||||
ErrorMsg = "Error with the FONT message"
|
||||
goto fatalExit
|
||||
end
|
||||
|
||||
x = Set_Printer("TEXT", "POLYLINE, ADDTABLE, and TEXTXY")
|
||||
|
||||
if Set_Printer("FONT", Font3) < 0 then
|
||||
ErrorMsg = "Error with the FONT message"
|
||||
goto fatalExit
|
||||
end
|
||||
text = "The POLYLINE message is used to create this Graph, and the ADDTABLE message is used to create the Table. The TEXTXY message is used to print the labels."
|
||||
|
||||
x = Set_Printer("TEXT", text)
|
||||
|
||||
pos = Get_Printer("POS")
|
||||
y = pos<2>+.25
|
||||
if Set_Printer("FILLSTYLE", BS_SOLID:@FM:RGB(255, 255, 128)) < 0 then
|
||||
|
||||
ErrorMsg = "Error with the FILLSTYLE message"
|
||||
goto fatalExit
|
||||
end
|
||||
ErrorMsg = "There was some problem with the Graph part of the example"
|
||||
|
||||
|
||||
if Set_Printer("RECT", 3:@FM:y:@FM:6:@FM:y+2, 0) < 0 then goto fatalExit
|
||||
|
||||
if Set_Printer("RECT", 1:@FM:y:@FM:2.5:@FM:y+0.5, 0) < 0 then goto fatalExit
|
||||
if Set_Printer("LINESTYLE", PS_DOT:@FM:0:@FM:RGB(0, 0, 0)) < 0 then goto fatalExit
|
||||
if Set_Printer("LINE", 3:@FM:y+.5:@FM:6:@FM:y+.5, 0) < 0 then goto fatalExit
|
||||
if Set_Printer("LINE", 3:@FM:y+1:@FM:6:@FM:y+1, 0) < 0 then goto fatalExit
|
||||
|
||||
if Set_Printer("LINE", 3:@FM:y+1.5:@FM:6:@FM:y+1.5, 0) < 0 then goto fatalExit
|
||||
initrnd timedate()
|
||||
poly1 = ""
|
||||
for i = 0 to 12
|
||||
sx = i/4
|
||||
sy = y+1-rnd(100)/100
|
||||
poly1<i+1,1> = sx + 3
|
||||
poly1<i+1,2> = sy
|
||||
next i
|
||||
if Set_Printer("LINESTYLE", PS_SOLID:@FM:1:@FM:RGB(0, 128, 0)) < 0 then goto fatalExit
|
||||
if Set_Printer("POLYLINE", poly1, 0) < 0 then goto fatalExit
|
||||
|
||||
if Set_Printer("LINE", 1.2:@FM:y+0.15:@FM:1.5:@FM:y+0.15, 0) < 0 then goto fatalExit
|
||||
poly2 = ""
|
||||
for i = 0 to 12
|
||||
|
||||
sx = i/4
|
||||
sy = y+1-rnd(100)/100
|
||||
poly2<i+1,1> = sx + 3
|
||||
poly2<i+1,2> = sy
|
||||
next i
|
||||
if Set_Printer("LINESTYLE", PS_SOLID:@FM:1:@FM:RGB(128, 0, 0)) < 0 then goto fatalExit
|
||||
if Set_Printer("POLYLINE", poly2, 0) < 0 then goto fatalExit
|
||||
if Set_Printer("LINE", 1.2:@FM:y+0.35:@FM:1.5:@FM:y+0.35, 0) < 0 then goto fatalExit
|
||||
if Set_Printer("LINESTYLE", PS_SOLID:@FM:1:@FM:RGB(0, 0, 0)) < 0 then goto fatalExit
|
||||
if Set_Printer("FONT", "Arial":@FM:8) < 0 then goto fatalExit
|
||||
if Set_Printer("TEXTXY", "4.0", 2.8:@FM:y-.05, "", 0) < 0 then goto fatalExit
|
||||
|
||||
if Set_Printer("TEXTXY", "3.0", 2.8:@FM:y+.45, "", 0) < 0 then goto fatalExit
|
||||
if Set_Printer("TEXTXY", "2.0", 2.8:@FM:y+.95, "", 0) < 0 then goto fatalExit
|
||||
if Set_Printer("TEXTXY", "1.0", 2.8:@FM:y+1.45, "", 0) < 0 then goto fatalExit
|
||||
if Set_Printer("TEXTXY", "0.0", 2.8:@FM:y+1.95, "", 0) < 0 then goto fatalExit
|
||||
if Set_Printer("TEXTXY", "Years", 4.4:@FM:y+2.05, "", 0) < 0 then goto fatalExit
|
||||
if Set_Printer("TEXTXY", "$Millions", 2.8:@FM:y-.2, "", 0) < 0 then goto fatalExit
|
||||
|
||||
if Set_Printer("FONT", "Arial":@FM:10) < 0 then goto fatalExit
|
||||
if Set_Printer("TEXTXY", "XYZ Co.", 1.6:@FM:y+0.07, "", 0) < 0 then goto fatalExit
|
||||
if Set_Printer("TEXTXY", "ABC Co.", 1.6:@FM:y+0.27, "", 0) < 0 then goto fatalExit
|
||||
if Set_Printer("FILLSTYLE", BS_HOLLOW) < 0 then goto fatalExit
|
||||
if Set_Printer("RECT", 3:@FM:y:@FM:6:@FM:y+2, 0) < 0 then goto fatalExit
|
||||
|
||||
ErrorMsg = "There was some problem with the ADDTABLE part of the example"
|
||||
if Set_Printer("POS", 0:@FM:y+1) < 0 then goto fatalExit
|
||||
|
||||
header = "Year":@VM:"XYZ Co. Sales ($Mill)":@VM:"ABC Co. Sales ($Mill)":@FM
|
||||
table = ""
|
||||
for i = 0 to 12
|
||||
table<i+1,1> = 1990+i
|
||||
table<i+1,2> = 3.5+y-poly1<i+1,2>
|
||||
table<i+1,3> = 3.5+y-poly2<i+1,2>
|
||||
next i
|
||||
if Set_Printer("FONT", "Arial":@FM:10:@FM:"L":@FM:1) < 0 then goto fatalExit
|
||||
ColumnFormat = "_^770":@VM:"_>1080":@VM:"_>1080":@FM
|
||||
if Set_Printer("ADDTABLE", ColumnFormat, header, table, RGB(0, 222, 0), "", "", TB_BOX_COLUMNS) < 0 then goto fatalExit
|
||||
|
||||
if Set_Printer("CALCTABLE", ColumnFormat:header:table) < 0 then goto fatalExit
|
||||
|
||||
size = Get_Printer("CALCTABLE")
|
||||
|
||||
if Set_Printer("POS", 0:@FM:y+1+size<2>) < 0 then goto fatalExit
|
||||
|
||||
if Set_Printer("FONT", Font2) < 0 then
|
||||
ErrorMsg = "Error with the FONT message"
|
||||
goto fatalExit
|
||||
end
|
||||
x = Set_Printer("TEXT", @FM:"Other New Features in the OIPI")
|
||||
|
||||
if Set_Printer("FONT", Font3) < 0 then
|
||||
ErrorMsg = "Error with the FONT message"
|
||||
goto fatalExit
|
||||
end
|
||||
text = " * The OIPI 3.5 uses the newest VSVIEW.OCX control for the print engine.":@FM
|
||||
text := " * The OIPI 3.2 was rewritten in Microsoft Visual Basic 4.0.":@FM
|
||||
|
||||
text := " * The ADDTABLE message was added to improve the quality of tables. This message should be used to replace all TABLE and TEXTCOL messages.":@FM
|
||||
text := " * The Print Preview window can be scrolled with the mouse and all pages are viewable as soon as they are printed.":@FM
|
||||
text := " * The IMIT message can be used to change the size of the paper without using the Printer Setup dialog box.":@FM
|
||||
text := " * The CALCBMP and CALCTABLE messages were added.":@FM
|
||||
|
||||
text := " * The title of the Print Preview window can be customized.":@FM
|
||||
|
||||
x = Set_Printer("TEXT", text)
|
||||
|
||||
* End the report and tell the OIPI to completely shut down after the print preview is closed.
|
||||
x = Set_Printer("TERM", 1)
|
||||
|
||||
return
|
||||
|
||||
* jump here if any Set_Printer returns a value < 0
|
||||
fatalExit:
|
||||
x = msg("", ErrorMsg)
|
||||
x = Set_Printer("TERM", 1)
|
||||
return
|
||||
117
SYSPROG/STPROC/OIPI_EXAMPLE2.txt
Normal file
117
SYSPROG/STPROC/OIPI_EXAMPLE2.txt
Normal file
@ -0,0 +1,117 @@
|
||||
subroutine OIPI_Example2(dummy)
|
||||
|
||||
/*
|
||||
Printer_Example2
|
||||
|
||||
This is an example program on how to use the OpenInsight Printer Interface.
|
||||
This example creates a simple invoice using the Table Module.
|
||||
*/
|
||||
|
||||
declare function Set_Printer, Get_Printer, RGB, msg
|
||||
$insert OIPRINT_EQUATES
|
||||
$Insert msg_equates
|
||||
* Initialize the printing session with a name, dialog title, and margins
|
||||
name = "Sample Invoice"
|
||||
title = ""
|
||||
title<1> = "Printing Sample Invoice..."
|
||||
title<2> = "Example Print Preview"
|
||||
margin = 1:@FM:1.75:@FM:1:@FM:1
|
||||
* Gentlemen, start your engine.
|
||||
x = Set_Printer("START32")
|
||||
* Display report with Print Preview Window at the last size and position
|
||||
x = Set_Printer("INIT", name, title, margin, "", 4)
|
||||
if x < 0 Then
|
||||
unused = msg( "", "INIT ERROR = " : x )
|
||||
end
|
||||
*
|
||||
* Set the text font and the Header/footer font
|
||||
x = Set_Printer("FONTHEADFOOT", "Times New Roman":@FM:12)
|
||||
font = "Arial":@FM:12:@FM:"L"
|
||||
fontBold = "Arial":@FM:12:@FM:"L":@FM:1
|
||||
x = Set_Printer("FONT", font)
|
||||
if x < 0 Then
|
||||
x = msg("", "FONTHEADFOOT Error")
|
||||
end
|
||||
* Set the header with the text "Sample Invoice" centered , and "Page #" aligned To the right
|
||||
* margin on the first line. The text "for the OIPI 2.0" is centered on the second line.
|
||||
|
||||
x = Set_Printer("HEADER", @vm:"Sample Invoice":@vm:"Page 'P'":@FM:@vm:"for the OIPI 2.0":@FM)
|
||||
if x < 0 Then
|
||||
x = msg("", "HEADER Error")
|
||||
end
|
||||
|
||||
* Print a bitmap at 1 inch from the top and 1 inch from the left side of the page.
|
||||
* The left and top values are calculated from the margins. The width and height of the
|
||||
* bitmap will be 0.5 by 0.5 inches, and the bitmap will print on every page.
|
||||
x = Set_Printer("BMP", "PRINTER.BMP", 0:@FM:-0.75:@FM:0.5:@FM:0.5, 0, 1)
|
||||
if x < 0 Then
|
||||
x = msg("", "BMP Error")
|
||||
end
|
||||
* Set the text font to bold Arial to print the title of the Date/Invoice table. Then
|
||||
* print the date and invoice number with no bold. The first column of the table is blank
|
||||
* to place the date and invoice number in the correct location on the page. The date and
|
||||
* invoice number are centered and there is no border around this table. These tables have
|
||||
* no column headers.
|
||||
x = Set_Printer("FONT", fontBold)
|
||||
table1 = ",Date,Invoice No."
|
||||
convert "," to @vm in table1
|
||||
x = Set_Printer("ADDTABLE", ">5040":@VM:"^2160":@VM:"^2160":@FM, "", table1, "", "", "", TB_NONE)
|
||||
x = Set_Printer("FONT", font)
|
||||
table1 = ",01 Jan 1996,340082"
|
||||
convert "," to @vm in table1
|
||||
x = Set_Printer("ADDTABLE", ">5040":@VM:"^2160":@VM:"^2160":@FM, "", table1, "", "", "", TB_NONE)
|
||||
* Print a blank line then print the Bill To/From table. These tables have no column
|
||||
* headers. These tables have no borders and have left justified columns.
|
||||
x = Set_Printer("TEXT")
|
||||
x = Set_Printer("FONT", fontBold)
|
||||
table2 = "Bill To:,,Ship To:"
|
||||
convert "," to @vm in table2
|
||||
x = Set_Printer("ADDTABLE", "3600":@VM:"1440":@VM:"3600":@FM, "", table2, "", "", "", TB_NONE)
|
||||
x = Set_Printer("FONT", font)
|
||||
table2 = ""
|
||||
table2<1> = "Test Company 123//Test Company (Billing Dept)"
|
||||
table2<2> = "123 West Main Street//555 West Main Street, MS:123"
|
||||
table2<3> = "Portland, OR 97005//Portland, OR 97005"
|
||||
convert "/" to @vm in table2
|
||||
x = Set_Printer("ADDTABLE", "3600":@VM:"1440":@VM:"3600":@FM, "", table2, "", "", "", TB_NONE)
|
||||
* These tables have to column headers and have borders all sides of the tables. Every column
|
||||
* is center justified.
|
||||
x = Set_Printer("TEXT")
|
||||
x = Set_Printer("FONT", fontBold)
|
||||
table3 = "Terms,P.O. Number,Ship Date,Ship Via"
|
||||
convert "," to @vm in table3
|
||||
x = Set_Printer("ADDTABLE", "^2160":@VM:"^2160":@VM:"^2160":@VM:"^2160":@FM, "", table3, "", "", "", TB_ALL)
|
||||
x = Set_Printer("FONT", font)
|
||||
table3 = "Net 30,9500123,03 Jan 1996,UPS Next Day Delivery"
|
||||
convert "," to @vm in table3
|
||||
x = Set_Printer("ADDTABLE", "^2160":@VM:"^2160":@VM:"^2160":@VM:"^2160":@FM, "", table3, "", "", "", TB_ALL)
|
||||
* The position is set to 0 inches from the left margin, and 3 inches from the top margin. This
|
||||
* will guarentee the table will always start to print from the same location.
|
||||
x = Set_Printer("POS", 0:@FM:3)
|
||||
* Create the dummy data for the main table. This table has column headers, because the column
|
||||
* headers need to be printed at the to of each page if the main invoice table requies more
|
||||
* than one page. The rows will have borders.
|
||||
tableHead = "Quantity,Description,Unit Price,Ext Price"
|
||||
table = ""
|
||||
table<1> = "1,OpenInsight Printer Interface 2.0 -- Special limited time introductory price,$345.00,$345.00"
|
||||
table<2> = "2,Second line item here,$1.00,$2.00"
|
||||
table<3> = "1,Third line item here (no charge for this bonus item),$0.00,$0.00"
|
||||
for i = 4 to 30
|
||||
table<i> = "1,Test line item here":(i-3):",$0.00,$0.00"
|
||||
next i
|
||||
table<31> = ""
|
||||
table<32> = ",Merchandise Total,,$347.00"
|
||||
table<33> = ""
|
||||
table<34> = ",Tax,,$12.00"
|
||||
table<35> = ",Shipping,,$5.00"
|
||||
table<36> = ",Handling,,$5.00"
|
||||
table<37> = ""
|
||||
table<38> = ",,Sub Total,$369.00"
|
||||
table<39> = ""
|
||||
table<40> = ",,Total,$369.00"
|
||||
convert "," to @vm in table
|
||||
convert "," to @vm in tableHead
|
||||
x = Set_Printer("ADDTABLE", ">1080":@VM:"<4680":@VM:">1440":@VM:">1440":@FM, tableHead, table, RGB(192, 192, 192), "", "", TB_BOX_ROWS)
|
||||
* Finish this prining session.
|
||||
x = Set_Printer("TERM", 1)
|
||||
return
|
||||
44
SYSPROG/STPROC/OIPI_PIECHART_EXAMPLE.txt
Normal file
44
SYSPROG/STPROC/OIPI_PIECHART_EXAMPLE.txt
Normal file
@ -0,0 +1,44 @@
|
||||
Subroutine OIPI_Piechart_Example(void)
|
||||
|
||||
Declare Function Set_Printer
|
||||
|
||||
$Insert COLORS
|
||||
$insert OIPI_EQUATES
|
||||
$Insert OIPI_PIECHART_EQUATES
|
||||
|
||||
* Start the OIPI report with the INIT message
|
||||
|
||||
FileName = "OIPI_PIE_Example1"
|
||||
|
||||
PrintTitle = "OIPI Printing..."
|
||||
PreviewTitle = "OIPI Pie Chart Preview"
|
||||
|
||||
Margins = .5:@FM:.5:@FM:.5:@FM:.5 ;* half inch margins On the sides, one inch margins On the top
|
||||
Orientation = Portrait$
|
||||
PrintSetup = ""
|
||||
PrintSetup<Print_Style$, 1> = Preview_normal$
|
||||
PrintSetup<Print_Style$, 2> = Display_AllButtons$
|
||||
PrintSetup<2> = -1 ;* Set initial zoom to PageWidth
|
||||
PrintSetup<3> = 5 ;* Set the Print Preview position at 5% from top and left
|
||||
PrintSetup<4> = 5
|
||||
PrintSetup<5> = 95
|
||||
PrintSetup<6> = 95
|
||||
|
||||
VAL = Set_Printer("INIT", FileName, PrintTitle:@FM:PreviewTitle, Margins, Orientation, PrintSetup)
|
||||
if VAL < 0 then
|
||||
* Always check the return value of the INIT message for error
|
||||
ErrorMsg = "Fatal error with the INIT message:":VAL
|
||||
Return ''
|
||||
end
|
||||
|
||||
colors = ""
|
||||
colors = Red$ :@fm: Blue$ : @fm : ORANGE$ : @fm: MAGENTA$
|
||||
|
||||
wedges = ""
|
||||
wedges = 27:@fm:13:@fm:18:@fm:30
|
||||
rslt = oipi_piechart_helper(2,2,1,wedges, colors, LEGEND_DEFAULTS$)
|
||||
|
||||
X = Set_Printer('TERM')
|
||||
|
||||
Return ''
|
||||
|
||||
478
SYSPROG/STPROC/OIPI_TESTPATTERN.txt
Normal file
478
SYSPROG/STPROC/OIPI_TESTPATTERN.txt
Normal file
@ -0,0 +1,478 @@
|
||||
subroutine OIPI_TESTPATTERN(bShowHeader, whichPrinter, whichPages, outputTo)
|
||||
|
||||
/*
|
||||
|
||||
OIPI TestPattern
|
||||
|
||||
|
||||
|
||||
This is an example program on how to use the OpenInsight Printer Interface.
|
||||
|
||||
|
||||
*/
|
||||
|
||||
|
||||
If Assigned(bShowHeader) Else bShowHeader = ""
|
||||
If Assigned(whichPrinter) Else whichPrinter = ""
|
||||
If Assigned(whichPages) Else whichPages = ""
|
||||
If Assigned(outputTo) Else outputTo = ""
|
||||
|
||||
declare function Set_Printer, Get_Printer, RGB,Set_Property
|
||||
|
||||
declare function Msg, GET_PROPERTY
|
||||
|
||||
$insert OIPRINT_EQUATES
|
||||
$Insert Ps_oipi_common
|
||||
$Insert RTI_Postscript_Common
|
||||
|
||||
|
||||
Equ Portrait$ To 0
|
||||
Equ Landscape$ To 1
|
||||
|
||||
* print Setup Equate
|
||||
Equ Print_Style$ To 1
|
||||
Equ Print_Zoom$ To 2
|
||||
|
||||
Equ Print_ToPrinter$ To 0
|
||||
Equ Display_PrintSetup$ To 1
|
||||
Equ Preview_Normal$ To 2
|
||||
Equ Print_Mazimized$ To 3
|
||||
|
||||
Equ Display_AllButtons$ To 0
|
||||
Equ Hide_PrintButton$ To 1
|
||||
Equ Hide_PrintSetupButton$ To 2
|
||||
Equ Hide_AllButtons$ To 3
|
||||
|
||||
* Create the fonts for the OIPI report
|
||||
|
||||
* 14 point Arial font
|
||||
Font1 = "Arial":@FM:14
|
||||
|
||||
* 14 point Times New Roman
|
||||
Font2 = "Times New Roman":@FM:14
|
||||
|
||||
HeaderType = ""
|
||||
FooterType = ""
|
||||
HeaderText = ""
|
||||
FooterText = ""
|
||||
boxText = ""
|
||||
|
||||
If whichPages = "" Then whichpages = "1-3"
|
||||
|
||||
If bShowHeader = "CLICK" Then
|
||||
* this came from the form - get all the required details from there
|
||||
whichPrinterText = Get_Property(@Window:".CBO_PRINTER", "DEFPROP")
|
||||
headerType = Get_Property(@Window:".CBO_HEADER", "DEFPROP")
|
||||
footerType = Get_Property(@Window:".CBO_FOOTER", "DEFPROP")
|
||||
boxText = Get_Property(@Window:".CBO_BOX_TEXT", "DEFPROP")
|
||||
doPageLines = Get_Property(@Window:".CHK_PAGE_LINES", "DEFPROP")
|
||||
numLines = Get_Property(@Window:".TXT_NO_LINES", "TEXT")
|
||||
doPageMisc = Get_Property(@Window:".CHK_PAGE_MISC", "DEFPROP")
|
||||
doPageXY = Get_Property(@Window:".CHK_PAGE_TEXTXY", "DEFPROP")
|
||||
doPageSkipping = Get_Property(@Window:".CHK_PAGE_SKIPPING", "DEFPROP")
|
||||
Begin Case
|
||||
Case Index(whichPrinterText, "VSPRINTER1", 1)
|
||||
whichPrinter = "1"
|
||||
Case Index(whichPrinterText, "VSPRINTER2", 1)
|
||||
whichPrinter = "2"
|
||||
Case 1
|
||||
whichPrinter = ""
|
||||
End Case
|
||||
Begin Case
|
||||
Case indexc(headerType, "single", 1)
|
||||
HeaderText = "The Header Text"
|
||||
Case indexc(headerType, "multi", 1)
|
||||
HeaderText = @VM:"'F'":@FM:"'DL'":@VM:@VM:"Page 'P'":@FM
|
||||
Case indexc(headerType, "extra", 1)
|
||||
HeaderText = @VM:"'F'":@FM:"'DL'":@VM:@VM:"Page 'P'":@FM:"Another line":@FM:"And Another":@FM:"Final Header":@FM
|
||||
End Case
|
||||
Begin Case
|
||||
Case indexc(footerType, "single", 1)
|
||||
FooterText = "The Footer Text"
|
||||
Case indexc(footerType, "multi", 1)
|
||||
FooterText = @VM:"'F'":@FM:"'DL'":@VM:@VM:"Page 'P'":@FM
|
||||
End Case
|
||||
whichPages = ""
|
||||
delim = ""
|
||||
If doPageMisc = "1" Then
|
||||
whichPages = "1"
|
||||
delim = ","
|
||||
End
|
||||
If doPageSkipping = "1" Then
|
||||
whichPages := delim:"2"
|
||||
delim = ","
|
||||
End
|
||||
If doPageXY = "1" Then
|
||||
whichPages := delim:"3"
|
||||
delim = ","
|
||||
end
|
||||
End
|
||||
|
||||
call set_vsprinter(whichPrinter) ;* either set the override, or clear it if whichPrinter not specified
|
||||
|
||||
* Start the OIPI report with the INIT message
|
||||
FileName = "OIPI_TestPattern"
|
||||
|
||||
PrintTitle = "OIPI Test..."
|
||||
PreviewTitle = "OIPI Print Preview"
|
||||
|
||||
deviceSetup = ""
|
||||
|
||||
Margins = .5:@FM:1:@FM:.5:@FM:1 ;* half inch margins On the sides, one inch margins On the top
|
||||
Orientation = Portrait$
|
||||
PrintSetup = ""
|
||||
PrintSetup<Print_Style$, 2> = Display_AllButtons$
|
||||
PrintSetup<2> = -1 ;* Set initial zoom to PageWidth
|
||||
PrintSetup<3> = 5 ;* Set the Print Preview position at 5% from top and left
|
||||
PrintSetup<4> = 5
|
||||
PrintSetup<5> = 95
|
||||
PrintSetup<6> = 95
|
||||
|
||||
If outputTo <> "" Then
|
||||
If outputTo[1,1] = "!" Then
|
||||
deviceSetup<1,2> = 1
|
||||
End
|
||||
deviceSetup<1,1> = outputTo
|
||||
PrintSetup<Print_Style$, 1> = Print_ToPrinter$
|
||||
End Else
|
||||
PrintSetup<Print_Style$, 1> = Preview_normal$
|
||||
end
|
||||
|
||||
VAL = Set_Printer("INIT", FileName, PrintTitle:@FM:PreviewTitle, Margins, Orientation, PrintSetup, deviceSetup)
|
||||
if VAL < 0 then
|
||||
* Always check the return value of the INIT message for error
|
||||
ErrorMsg = "Fatal error with the INIT message:":VAL
|
||||
goto fatalExit
|
||||
end
|
||||
|
||||
* Set the font for all of the headers and footers
|
||||
if Set_Printer("FONTHEADFOOT", "Arial":@FM:14:@FM:"L":@fm:1) < 0 then
|
||||
ErrorMsg = "Error with the FONTHEADFOOT message"
|
||||
goto fatalExit
|
||||
end
|
||||
*
|
||||
|
||||
X=0
|
||||
Y=0
|
||||
If headerText = "" And footerText = "" then
|
||||
Begin Case
|
||||
Case bShowHeader = "1"
|
||||
* Print a simple one line header
|
||||
HeaderText = "The Header Text"
|
||||
Case bShowHeader = "2"
|
||||
* Print the header with the file name centered on the first line and
|
||||
* the Long format of the date left justified and the page number right justified
|
||||
* on the second line.
|
||||
HeaderText = @VM:"'F'":@FM:"'DL'":@VM:@VM:"Page 'P'":@FM:"Another line":@FM:"And Another":@FM:"Final Header":@FM
|
||||
Case bShowHeader = "3"
|
||||
FooterText = @VM:"This is a footer"
|
||||
Case bShowHeader = "4"
|
||||
HeaderText = "The Header Text"
|
||||
FooterText = @VM:"This is a footer"
|
||||
Case bShowHeader = "5"
|
||||
HeaderText = @VM:"'F'":@FM:"'DL'":@VM:@VM:"Page 'P'":@FM
|
||||
FooterText = @VM:"This is a footer"
|
||||
End Case
|
||||
End
|
||||
If headerText <> "" Then
|
||||
x = Set_Printer("HEADER", HeaderText)
|
||||
If x < 0 then
|
||||
ErrorMsg = "Error with the HEADER message"
|
||||
goto fatalExit
|
||||
End
|
||||
End
|
||||
If footerText <> "" Then
|
||||
Y = Set_Printer("FOOTER", FooterText)
|
||||
If y < 0 then
|
||||
ErrorMsg = "Error with the FOOTER message"
|
||||
goto fatalExit
|
||||
End
|
||||
End
|
||||
|
||||
If whichPages = "-1" Then
|
||||
doPageLines = 1
|
||||
NumLines = 300
|
||||
boxText = "No"
|
||||
End
|
||||
|
||||
|
||||
If boxText _nec "no" Then
|
||||
If Indexc(boxText, "all", 1) Then
|
||||
* show on all pages
|
||||
showOnAllPages = ""
|
||||
End Else
|
||||
* on first page only
|
||||
showOnAllPages = 0
|
||||
end
|
||||
textstring = 'Text in a box':@fm:'More text in a box'
|
||||
stat = Set_Printer("TEXTBOX", textstring, 1:@fm:1:@fm:1:@fm:1,"", showOnAllPages)
|
||||
end
|
||||
|
||||
|
||||
|
||||
If doPageLines Then
|
||||
If Not(Num(numLines)) Or numLines = "" Or NumLines < 0 Then
|
||||
numLines = 300
|
||||
end
|
||||
For each.row = 1 To numlines
|
||||
call Set_Printer("TEXT", "here at row ":each.row)
|
||||
Next each.row
|
||||
End
|
||||
|
||||
|
||||
call Set_Printer("POS", 0:@FM:0)
|
||||
|
||||
num.sections = dcount(whichPages, ",")
|
||||
For each.section = 1 To num.sections
|
||||
this.section = Field(whichPages, ",", each.section)
|
||||
beginPage = Field(this.section, "-", 1)
|
||||
endPage = Field(this.section, "-", 2)
|
||||
If endPage = "" Then endPage = beginPage
|
||||
If Num(beginPage) And beginPage <> "" And Num(endPage) And endPage <> "" Then
|
||||
If beginPage < 0 Then beginPage = 0
|
||||
If endPage > 3 Then endPage = 3
|
||||
For each.pg = beginPage To endPage
|
||||
If each.pg <> 0 then
|
||||
On each.pg Gosub doPage1, doPage2, doPage3
|
||||
end
|
||||
Next each.pg
|
||||
End
|
||||
Next each.section
|
||||
Goto doTerm
|
||||
|
||||
doPage1:
|
||||
|
||||
if Set_Printer("FONT", Font1) < 0 then
|
||||
ErrorMsg = "Error with the FONT message"
|
||||
goto fatalExit
|
||||
End
|
||||
For each.row = 1 To 5
|
||||
call Set_Printer("TEXT", "Arial 14 row ":each.row)
|
||||
call Set_Printer("TEXT", @upper.Case:@lower.Case)
|
||||
Next each.row
|
||||
|
||||
For each.row = 1 To 5
|
||||
call Set_Printer("TEXT",".")
|
||||
Next each.row
|
||||
|
||||
if Set_Printer("FONT", Font2) < 0 then
|
||||
ErrorMsg = "Error with the FONT message"
|
||||
goto fatalExit
|
||||
End
|
||||
For each.row = 1 To 5
|
||||
call Set_Printer("TEXT", "Times Roman 14 row ":each.row)
|
||||
call Set_Printer("TEXT", @upper.Case:@lower.Case)
|
||||
Next each.row
|
||||
Stat = Set_Printer('CALCTEXT',@Upper.Case)
|
||||
AA = Get_Printer('CALCTEXT')
|
||||
call Set_Printer("TEXT","CALCTEXT returns *":AA<1>:"x":AA<2>:"*")
|
||||
|
||||
CALL Set_Printer("POS", 2:@FM:6)
|
||||
* Print pyramid
|
||||
if Set_Printer("LINESTYLE", PS_NULL) < 0 then
|
||||
ErrorMsg = "Error with the LINESTYLE message"
|
||||
goto fatalExit
|
||||
end
|
||||
pos = Get_Printer("POS")
|
||||
y = pos<2>
|
||||
offset = 0
|
||||
|
||||
for c = 0 to 128 step 12.8
|
||||
if Set_Printer("FILLSTYLE", BS_SOLID:@FM:RGB(0, 0, 128 + c)) < 0 then
|
||||
ErrorMsg = "Error with the FILLSTYLE message"
|
||||
goto fatalExit
|
||||
end
|
||||
R = 1+offset:@FM:y+offset:@FM:3-offset:@FM:y-offset+2
|
||||
if Set_Printer("RECT", 1+offset:@FM:y+offset:@FM:3-offset:@FM:y-offset+2, 0) < 0 then
|
||||
ErrorMsg = "Error with the RECT message"
|
||||
goto fatalExit
|
||||
end
|
||||
offset = offset + 0.05
|
||||
next c
|
||||
for c = 0 to 128 step 12.8
|
||||
if Set_Printer("FILLSTYLE", BS_SOLID:@FM:RGB(c, c, 255)) < 0 then
|
||||
ErrorMsg = "Error with the FILLSTYLE message"
|
||||
goto fatalExit
|
||||
end
|
||||
if Set_Printer("RECT", 1+offset:@FM:pos<2>+offset:@FM:3-offset:@FM:pos<2>+2-offset, 0) < 0 then
|
||||
ErrorMsg = "Error with the RECT message"
|
||||
|
||||
goto fatalExit
|
||||
end
|
||||
offset = offset + 0.05
|
||||
next c
|
||||
if Set_Printer("LINESTYLE", PS_SOLID:@FM:1:@FM:RGB(0, 0, 0)) < 0 then
|
||||
ErrorMsg = "Error with the LINESTYLE message"
|
||||
goto fatalExit
|
||||
end
|
||||
if Set_Printer("FILLSTYLE", BS_HOLLOW) < 0 then
|
||||
ErrorMsg = "Error with the FILLSTYLE message"
|
||||
goto fatalExit
|
||||
end
|
||||
if Set_Printer("RECT", 1:@FM:pos<2>:@FM:3:@FM:pos<2>+2, 0) < 0 then
|
||||
ErrorMsg = "Error with the RECT message"
|
||||
goto fatalExit
|
||||
end
|
||||
|
||||
if Set_Printer("LINE", 1:@FM:pos<2>:@FM:3:@FM:pos<2>+2, 0) < 0 then
|
||||
|
||||
ErrorMsg = "Error with the LINE message"
|
||||
goto fatalExit
|
||||
end
|
||||
if Set_Printer("LINE", 3:@FM:pos<2>:@FM:1:@FM:pos<2>+2, 0) < 0 then
|
||||
ErrorMsg = "Error with the LINE message"
|
||||
goto fatalExit
|
||||
end
|
||||
|
||||
* print 3D button
|
||||
text = "3D Button"
|
||||
if Set_Printer("FILLSTYLE", BS_SOLID:@FM:RGB(128, 128, 128)) < 0 then
|
||||
ErrorMsg = "Error with the FILLSTYLE message"
|
||||
goto fatalExit
|
||||
end
|
||||
if Set_Printer("FONT", "Arial":@FM:14) < 0 then
|
||||
ErrorMsg = "Error with the FONT message"
|
||||
|
||||
goto fatalExit
|
||||
end
|
||||
|
||||
if Set_Printer("CALCTEXT", text) < 0 then
|
||||
ErrorMsg = "Error with the CALCTEXT message"
|
||||
goto fatalExit
|
||||
end
|
||||
|
||||
size = Get_Printer("CALCTEXT")
|
||||
|
||||
width = size<1>
|
||||
height = size<2>
|
||||
poly = ""
|
||||
poly<1> = 3.5+width+.4:@VM:y
|
||||
poly<2> = 3.5+width+.4:@VM:y+height+.4
|
||||
poly<3> = 3.5:@VM:y+height+.4
|
||||
poly<4> = 3.5+.1:@VM:y+height+.3
|
||||
poly<5> = 3.5+width+.3:@VM:y+height+.3
|
||||
poly<6> = 3.5+width+.3:@VM:y+.1
|
||||
if Set_Printer("POLYGON", poly, 0) < 0 then
|
||||
goto fatalExit
|
||||
|
||||
end
|
||||
|
||||
xxx = get_printer("font")
|
||||
if Set_Printer("FILLSTYLE", BS_HOLLOW) < 0 then
|
||||
ErrorMsg = "Error with the FILLSTYLE message"
|
||||
goto fatalExit
|
||||
end
|
||||
|
||||
xxx = get_printer("font")
|
||||
if Set_Printer("RECT", 3.5:@FM:y:@FM:3.5+width+.4:@FM:y+height+.4, 0) < 0 then
|
||||
ErrorMsg = "Error with the RECT message"
|
||||
goto fatalExit
|
||||
end
|
||||
|
||||
xxx = get_printer("font")
|
||||
if Set_Printer("FILLSTYLE", BS_SOLID:@FM:RGB(192, 192, 192)) < 0 then
|
||||
ErrorMsg = "Error with the FILLSTYLE message"
|
||||
goto fatalExit
|
||||
end
|
||||
if Set_Printer("RECT", 3.5+.1:@FM:y+.1:@FM:3.5+width+.3:@FM:y+height+.3, 0) < 0 then
|
||||
|
||||
ErrorMsg = "Error with the RECT message"
|
||||
goto fatalExit
|
||||
end
|
||||
|
||||
xxx = get_printer("font")
|
||||
if Set_Printer("TEXTXY", text, 3.7:@FM:y+.2, "", 0) < 0 then
|
||||
ErrorMsg = "Error with the TEXTXY message"
|
||||
goto fatalExit
|
||||
end
|
||||
|
||||
call Set_Printer("PAGEBREAK")
|
||||
Return
|
||||
|
||||
doPage2:
|
||||
|
||||
text = " * OIPI uses the newest VSPRINT or .NET control for the print engine.":@FM
|
||||
text := " * OIPI was rewritten in Basic+ from Microsoft Visual Basic.":@FM
|
||||
|
||||
text := " * The ADDTABLE message was added to improve the quality of tables. This message should be used to replace all TABLE and TEXTCOL messages.":@FM
|
||||
text := " * The Print Preview window can be scrolled with the mouse and all pages are viewable as soon as they are printed.":@FM
|
||||
text := " * The IMIT message can be used to change the size of the paper without using the Printer Setup dialog box.":@FM
|
||||
text := " * The CALCBMP and CALCTABLE messages were added.":@FM
|
||||
|
||||
text := " * The title of the Print Preview window can be customized.":@FM
|
||||
|
||||
x = Set_Printer("TEXT", "Text via 'Text' call: ":@FM:text)
|
||||
p1 = Get_Printer("POS")
|
||||
call Set_Printer("TEXT", "Position after 'Text': ":P1<1>:",":P1<2>)
|
||||
For x = 1 To 3
|
||||
call Set_Printer("TEXT", ".")
|
||||
Next x
|
||||
p1 = Get_Printer("POS")
|
||||
call Set_Printer("TEXT", "Position after dots: ":P1<1>:",":P1<2>)
|
||||
|
||||
/*
|
||||
x = Set_Printer("ADDTABLE", "9000":@FM, "", "Text via 'Addtable' call: ":@FM:text, "", "", "", TB_NONE)
|
||||
|
||||
p1 = Get_Printer("POS")
|
||||
call Set_Printer("TEXT", "Position after 'AddTable' call: ":P1<1>:",":P1<2>)
|
||||
|
||||
header = "Year":@VM:"XYZ Co. Sales ($Mill)":@VM:"ABC Co. Sales ($Mill)":@FM
|
||||
table = ""
|
||||
for i = 0 to 6
|
||||
table<i+1,1> = 2010+i
|
||||
table<i+1,2> = 3.5+(i-1)*10
|
||||
table<i+1,3> = 3.5+(i-1)*50+7
|
||||
next i
|
||||
if Set_Printer("FONT", "Arial":@FM:10:@FM:"L":@FM:1) < 0 then goto fatalExit
|
||||
ColumnFormat = "_^770":@VM:"_>1080":@VM:"_>1080":@FM
|
||||
if Set_Printer("ADDTABLE", ColumnFormat, header, table, RGB(0, 222, 0), "", "", TB_BOX_COLUMNS) < 0 then goto fatalExit
|
||||
|
||||
if Set_Printer("CALCTABLE", ColumnFormat:header:table) < 0 then goto fatalExit
|
||||
|
||||
size = Get_Printer("CALCTABLE")
|
||||
|
||||
call Set_Printer("TEXT", "Calctable returns *":size<1>:"x":size<2>:"*")
|
||||
*/
|
||||
|
||||
For j=1 To 50
|
||||
call Set_Printer("TEXT", "skipping...")
|
||||
Next j
|
||||
*CALL Set_Printer("PAGEBREAK")
|
||||
Return
|
||||
|
||||
doPage3:
|
||||
|
||||
startX = 0
|
||||
startY = 0
|
||||
endX = 7
|
||||
endY = 10
|
||||
|
||||
For Y = startY To endY step .5
|
||||
For X = startX To endX step .5
|
||||
If x<>int(x) Or y<>int(y) Then
|
||||
if Set_Printer("TEXTXY", "*", X:@FM:Y, "Arial":@FM:10, 0) < 0 then
|
||||
|
||||
ErrorMsg = "Error with the TEXTXY message"
|
||||
goto fatalExit
|
||||
End
|
||||
End else
|
||||
if Set_Printer("TEXTXY", "(":X:",":y:")", X:@FM:Y, "Arial":@FM:10, 0) < 0 then
|
||||
|
||||
ErrorMsg = "Error with the TEXTXY message"
|
||||
goto fatalExit
|
||||
End
|
||||
end
|
||||
Next X
|
||||
Next Y
|
||||
Return
|
||||
|
||||
doTerm:
|
||||
* End the report and tell the OIPI to completely shut down after the print preview is closed.
|
||||
x = Set_Printer("TERM", 1)
|
||||
return
|
||||
|
||||
* jump here if any Set_Printer returns a value < 0
|
||||
fatalExit:
|
||||
x = msg("", ErrorMsg)
|
||||
x = Set_Printer("TERM", 1)
|
||||
return
|
||||
552
SYSPROG/STPROC/PERIOD_FORMAT.txt
Normal file
552
SYSPROG/STPROC/PERIOD_FORMAT.txt
Normal file
@ -0,0 +1,552 @@
|
||||
Subroutine PERIOD_FORMAT( CONV, argANS, argBRANCH, RETURN_DATA)
|
||||
/*
|
||||
* PERIOD_FORMAT is an example of a developer's custom prompt formatting
|
||||
* routine using the square brackets call.
|
||||
*
|
||||
* It should be placed in square brackets, like this:
|
||||
*
|
||||
* [PERIOD_FORMAT,branch]
|
||||
*
|
||||
* See Iso 8601 -- This is not compliant, but could be made so
|
||||
* branch values
|
||||
branch result
|
||||
J yyyy mm
|
||||
J2- yy-mm
|
||||
J- yyyy-mm
|
||||
JM mm (current year assumed on input)
|
||||
JY yyyy (month 1 assumed on input)
|
||||
J2Y yy (month 1 assumed on input)
|
||||
JW ww week number, current year assumed on input, week1 is week containing jan4
|
||||
JW- yyyy-ww year, week number
|
||||
J2W
|
||||
J2W-
|
||||
JD yyyy-ddd year, day number
|
||||
JFD-
|
||||
J2D
|
||||
J2
|
||||
JQ yyyy Qqq
|
||||
JQ- yyyy-Qqq
|
||||
J2Q yy Qqq
|
||||
|
||||
*----------------------------------------------
|
||||
Example:
|
||||
*----------------------------------------------
|
||||
|
||||
given table person containing a date field named "CREATED",
|
||||
|
||||
make calculated columns like below
|
||||
|
||||
created_year ; @ans = oconv({CREATED},"[PERIOD_FORMAT,JY]")
|
||||
created_quarter; @ans = oconv({CREATED},"[PERIOD_FORMAT,JQ-]")
|
||||
created_month ; @ans = oconv({CREATED},"[PERIOD_FORMAT,JM-]")
|
||||
created_week ; @ans = oconv({CREATED},"[PERIOD_FORMAT,JW-]")
|
||||
|
||||
you can index these columns, then run reports like
|
||||
* ------------------------------------------------
|
||||
LIST PERSON WITH CREATED_MONTH EQ "2017-01" BY CREATED CREATED_YEAR CREATED_QUARTER BREAK-ON CREATED_MONTH BREAK-ON CREATED_WEEK CREATED TOTAL CNT
|
||||
* ------------------------------------------------
|
||||
|
||||
Key Year Quarter Month.. Week.. Created... Cnt
|
||||
456300 2017 2017-Q1 2017-01 2017-2 01/03/2017 1
|
||||
343420 2017 2017-Q1 2017-01 2017-2 01/04/2017 1
|
||||
235412 2017 2017-Q1 2017-01 2017-2 01/05/2017 1
|
||||
359226 2017 2017-Q1 2017-01 2017-2 01/05/2017 1
|
||||
386344 2017 2017-Q1 2017-01 2017-2 01/06/2017 1
|
||||
*** 5
|
||||
419290 2017 2017-Q1 2017-01 2017-3 01/09/2017 1
|
||||
371020 2017 2017-Q1 2017-01 2017-3 01/10/2017 1
|
||||
466330 2017 2017-Q1 2017-01 2017-3 01/10/2017 1
|
||||
460838 2017 2017-Q1 2017-01 2017-3 01/14/2017 1
|
||||
*** 4
|
||||
242294 2017 2017-Q1 2017-01 2017-4 01/15/2017 1
|
||||
451632 2017 2017-Q1 2017-01 2017-4 01/15/2017 1
|
||||
394126 2017 2017-Q1 2017-01 2017-4 01/16/2017 1
|
||||
408958 2017 2017-Q1 2017-01 2017-4 01/16/2017 1
|
||||
452012 2017 2017-Q1 2017-01 2017-4 01/17/2017 1
|
||||
373470 2017 2017-Q1 2017-01 2017-4 01/18/2017 1
|
||||
*** 6
|
||||
324396 2017 2017-Q1 2017-01 2017-5 01/25/2017 1
|
||||
255764 2017 2017-Q1 2017-01 2017-5 01/26/2017 1
|
||||
287786 2017 2017-Q1 2017-01 2017-5 01/26/2017 1
|
||||
343596 2017 2017-Q1 2017-01 2017-5 01/27/2017 1
|
||||
365166 2017 2017-Q1 2017-01 2017-5 01/28/2017 1
|
||||
*** 5
|
||||
249224 2017 2017-Q1 2017-01 2017-6 01/29/2017 1
|
||||
455278 2017 2017-Q1 2017-01 2017-6 01/29/2017 1
|
||||
235614 2017 2017-Q1 2017-01 2017-6 01/31/2017 1
|
||||
304394 2017 2017-Q1 2017-01 2017-6 01/31/2017 1
|
||||
*** 4
|
||||
*** 24
|
||||
|
||||
|
||||
|
||||
* ------------------------------------------------
|
||||
LIST PERSON WITH CREATED_QUARTER EQ "2017-Q1" BY CREATED BREAK-ON CREATED_YEAR "'V'" BREAK-ON CREATED_QUARTER "'V'" BREAK-ON CREATED_MONTH "'V'" BREAK-ON CREATED_WEEK "'V'" TOTAL CNT ID-SUPP DET-SUPP
|
||||
* ------------------------------------------------
|
||||
|
||||
Created Year Created Quarter Created Month CREATED_WEEK Cnt
|
||||
2017-2 3465
|
||||
2017-3 3526
|
||||
2017-4 3393
|
||||
2017-5 3585
|
||||
2017-6 1475
|
||||
|
||||
2017-01 15444
|
||||
|
||||
2017-6 2064
|
||||
2017-7 3432
|
||||
2017-8 3473
|
||||
2017-9 3423
|
||||
2017-10 1541
|
||||
|
||||
2017-02 13933
|
||||
|
||||
2017-10 1928
|
||||
2017-11 3527
|
||||
2017-12 3395
|
||||
2017-13 3543
|
||||
2017-14 3027
|
||||
|
||||
2017-03 15420
|
||||
|
||||
2017-Q1 44797
|
||||
|
||||
2017 44797
|
||||
|
||||
*** 44797
|
||||
|
||||
*----------------------------------------------
|
||||
|
||||
|
||||
|
||||
* 2006-08-27 rjc Created
|
||||
* 2017-12-27 rjc Cleaned up
|
||||
|
||||
*/
|
||||
|
||||
#pragma format_Indent_comments
|
||||
$insert msg_equates
|
||||
$insert logical
|
||||
$insert rti_HashTable_Equates
|
||||
$insert rti_SSP_Equates
|
||||
$insert logical
|
||||
|
||||
Declare Subroutine Set_Status
|
||||
Declare Function rti_HashTable_STL, get_status
|
||||
|
||||
/*
|
||||
*/
|
||||
|
||||
declare function Msg, rtp_65
|
||||
common /period_Format_Com/init%,hCache%
|
||||
If init% Else
|
||||
hCache% = rti_HashTable_STL(REVSTL_HTBLMTD_CREATETABLE$, REVSTL_HTBLTYPE_SPP$ )
|
||||
init% = ( hCache% gt 0 )
|
||||
end
|
||||
|
||||
* Local Equates
|
||||
* The STATUS() variable is used to indicated the error condition of the
|
||||
* pattern. They are:
|
||||
EQU VALID$ TO 0 ;* Successful
|
||||
EQU INVALID_MSG$ TO 1 ;* Bad Data - Print error message window
|
||||
EQU INVALID_CONV$ TO 2 ;* Bad Conversion - " "
|
||||
EQU INVALID_NOMSG$ TO 3 ;* Bad but do not print the error message window
|
||||
|
||||
|
||||
* Begin Conversion
|
||||
*
|
||||
if assigned(argAns) then ans = argAns else ans = ''
|
||||
if assigned(argBranch) then branch = argBranch else branch = ''
|
||||
RETURN_DATA = ""
|
||||
|
||||
|
||||
ans = trim(Ans)
|
||||
status() = valid$
|
||||
|
||||
|
||||
* parse for period, delim
|
||||
if branch[1,1] _nec 'J' then
|
||||
Status() = INVALID_CONV$
|
||||
return
|
||||
end
|
||||
|
||||
period_types = 'MYWDQ'
|
||||
period_type = ''
|
||||
delim = ''
|
||||
for i = 1 to len(period_types)
|
||||
this_type = period_types[i,1]
|
||||
period_pos = indexc(branch, this_Type, 1)
|
||||
if period_pos then
|
||||
period_type = this_type
|
||||
delim = branch[period_pos+1,1]
|
||||
end
|
||||
until period_type
|
||||
next
|
||||
|
||||
* J J2 J2- default to month
|
||||
if period_type = '' then
|
||||
period_type = 'M'
|
||||
if alpha(branch[2,1]) then
|
||||
delim = branch[2,1]
|
||||
end else
|
||||
delim = branch[3,1]
|
||||
end
|
||||
end
|
||||
|
||||
* default delim is space
|
||||
if delim = '' then
|
||||
delim = ' '
|
||||
end
|
||||
|
||||
* 4 digit year?
|
||||
begin case
|
||||
case Indexc('JM JW JD',branch,1)
|
||||
* Special cases, no display of year
|
||||
year_digits = 0
|
||||
case index(branch, 2, 1)
|
||||
year_digits = 2
|
||||
case otherwise$
|
||||
year_digits = 4
|
||||
end case
|
||||
|
||||
|
||||
begin case
|
||||
case conv = 'OCONV'
|
||||
GoSub OConv
|
||||
case conv = 'ICONV'
|
||||
GoSub Iconv
|
||||
case otherwise$
|
||||
Status() = INVALID_CONV$
|
||||
end case
|
||||
|
||||
return
|
||||
******
|
||||
|
||||
|
||||
|
||||
Iconv:
|
||||
/*
|
||||
** Iconv returns a standard serial date number ( day 0 = 12/31/1967 )
|
||||
** Where the date is the frst day of the period, i.e the first day of the year, month or week
|
||||
*/
|
||||
|
||||
cacheKey = ans:"*I":branch
|
||||
cacheVal = null$
|
||||
stl_ret = rti_HashTable_STL(REVSTL_HTBLMTD_READROW$, hCache%, cacheKey, cacheVal)
|
||||
If stl_Ret gt 0 then
|
||||
transfer cacheVal To return_data
|
||||
return
|
||||
End
|
||||
|
||||
* If they passed in a number, assume it is an iconv'd date already, oconv it, then iconv again.
|
||||
If Num(ans) And Len(ans) gt 4 Then
|
||||
ans = Oconv(ans,'D4-')
|
||||
end
|
||||
|
||||
begin case
|
||||
case branch _eqc 'JM'
|
||||
* Special case, no year supplied, just month
|
||||
month = ans[1,2]
|
||||
if num(month) else
|
||||
status()=Invalid_Msg$
|
||||
return
|
||||
end
|
||||
|
||||
odate = Oconv(date(),'D4-')
|
||||
odate[1,6] = month:'-01-'
|
||||
idate = Iconv(odate, 'D')
|
||||
if idate then
|
||||
return_data = idate
|
||||
end else
|
||||
status()=Invalid_Msg$
|
||||
end
|
||||
|
||||
case period_type = 'M'
|
||||
|
||||
if num(ans[3,1]) then
|
||||
delim = ans[5,1]
|
||||
end else
|
||||
delim = ans[3,1]
|
||||
end
|
||||
|
||||
year = field(ans, delim,1)
|
||||
month = field(ans, delim, 2 )
|
||||
|
||||
odate = month:'-01-':year
|
||||
idate = Iconv(odate, 'D')
|
||||
if idate then
|
||||
return_data = idate
|
||||
end else
|
||||
status()=Invalid_Msg$
|
||||
end
|
||||
|
||||
case period_type = 'Y'
|
||||
year = ans
|
||||
if num(year) else
|
||||
status()=Invalid_Msg$
|
||||
end
|
||||
|
||||
odate = '01-01-':year
|
||||
idate = Iconv(odate, 'D')
|
||||
if idate then
|
||||
return_data = idate
|
||||
end else
|
||||
status()=Invalid_Msg$
|
||||
end
|
||||
|
||||
|
||||
case period_type = 'W'
|
||||
|
||||
* Iconv is date of the sunday that starts the week.
|
||||
* Week 1 is assumed to start the sunday of the week in the year that contains Jan 4
|
||||
delim = ans
|
||||
Convert '0123456789' To '' In delim
|
||||
delim = delim[1,1]
|
||||
|
||||
|
||||
* Valid Year?
|
||||
If delim == '' then
|
||||
year = ''
|
||||
week_no = ans
|
||||
End else
|
||||
year = field(ans, delim,1)
|
||||
week_no = field(ans, delim,2)
|
||||
end
|
||||
|
||||
if year and num(year) else
|
||||
odate = Oconv(date(), 'D4-')
|
||||
year = odate[-4,4]
|
||||
end
|
||||
|
||||
* Valid week?
|
||||
begin case
|
||||
case week_no = ''
|
||||
idate = ''
|
||||
case alpha(week_no)
|
||||
idate = ''
|
||||
case week_no < 1
|
||||
idate = ''
|
||||
case week_no > 53
|
||||
idate = ''
|
||||
case otherwise$
|
||||
|
||||
* First week of year always has 1/4 in it
|
||||
first_day = Iconv('01/04/':year, 'D')
|
||||
day_nr = mod(first_Day,7)
|
||||
first_sunday = first_Day - day_nr
|
||||
|
||||
* Internal date is that number of weeks after first week
|
||||
* Adjust by one, so W1 is first week of year, not W0
|
||||
week_no -=1
|
||||
idate = first_sunday + 7 *week_no
|
||||
end case
|
||||
|
||||
if idate then
|
||||
return_data = idate
|
||||
end else
|
||||
status()=Invalid_Msg$
|
||||
end
|
||||
|
||||
case period_type = 'Q'
|
||||
|
||||
if num(ans[3,1]) then
|
||||
delim = ans[5,1]
|
||||
end else
|
||||
delim = ans[3,1]
|
||||
end
|
||||
|
||||
year = field(ans, delim,1)
|
||||
quarter = field(ans, delim, 2 )
|
||||
Convert 'Qq' To '' In quarter
|
||||
|
||||
quarter = ( int(month/4) ) + 1
|
||||
Begin Case
|
||||
Case quarter lt 2 ; qmonth = 3
|
||||
Case quarter lt 3 ; qmonth = 6
|
||||
Case quarter lt 4 ; qmonth = 9
|
||||
Case 1 ; qmonth = 12
|
||||
End case
|
||||
|
||||
odate = qmonth:'-01-':year
|
||||
idate = Iconv(odate, 'D')
|
||||
if idate then
|
||||
return_data = idate
|
||||
end else
|
||||
status()=Invalid_Msg$
|
||||
end
|
||||
|
||||
case period_type = 'D'
|
||||
|
||||
* Iconv is standard date
|
||||
|
||||
if year_digits = 0 or ( ans matches '(1,366)' ) then
|
||||
day_no = ans
|
||||
year = ''
|
||||
end else
|
||||
delim = ans[3,1]
|
||||
|
||||
* Valid Year?
|
||||
begin case
|
||||
case delim = ''
|
||||
year = ''
|
||||
day_no = ''
|
||||
case num(delim)
|
||||
year = ans[1,4]
|
||||
day_no = ans[5,len(ans)]
|
||||
if num(day_no[1,1]) else
|
||||
day_no[1,1] = ''
|
||||
end
|
||||
case otherwise$
|
||||
year = field(ans, delim,1)
|
||||
day_no = field(ans, delim,2)
|
||||
end case
|
||||
end
|
||||
|
||||
if year and num(year) else
|
||||
odate = Oconv(date(), 'D4-')
|
||||
year = odate[-4,4]
|
||||
end
|
||||
|
||||
* Valid day?
|
||||
is_leap = ( mod(year, 4) = 0 ) and not(mod(year, 100) = 0)
|
||||
begin case
|
||||
case day_no = ''
|
||||
idate = ''
|
||||
case alpha(day_no)
|
||||
idate = ''
|
||||
case day_no < 1
|
||||
idate = ''
|
||||
case is_leap and day_no > 366
|
||||
idate = ''
|
||||
case day_no > 365
|
||||
idate = ''
|
||||
case otherwise$
|
||||
first_day = Iconv('01/01/':year, 'D')
|
||||
zeroth_day = first_Day-1
|
||||
idate = zeroth_Day + day_no
|
||||
end case
|
||||
|
||||
if idate then
|
||||
return_data = idate
|
||||
unused = rti_HashTable_STL(REVSTL_HTBLMTD_WRITEROW$, hCache%, cacheKey, return_Data)
|
||||
|
||||
end else
|
||||
status()=Invalid_Msg$
|
||||
end
|
||||
end case
|
||||
|
||||
return
|
||||
|
||||
|
||||
Oconv:
|
||||
/*
|
||||
** Input is expected to be a serial date number
|
||||
** Output will be the requested format
|
||||
*/
|
||||
|
||||
return_Data = ''
|
||||
if num(ans) and ( ans # '' ) else
|
||||
return
|
||||
end
|
||||
|
||||
|
||||
cacheKey = ans:"*O":branch
|
||||
cacheVal = null$
|
||||
stl_ret = rti_HashTable_STL(REVSTL_HTBLMTD_READROW$, hCache%, cacheKey, cacheVal)
|
||||
If stl_Ret gt 0 then
|
||||
transfer cacheVal To return_data
|
||||
return
|
||||
End
|
||||
|
||||
begin case
|
||||
|
||||
case period_type = 'M'
|
||||
odate = Oconv(ans, 'D4-')
|
||||
month = odate[1,2]
|
||||
year = odate[7,4]
|
||||
begin case
|
||||
case year_digits = 4
|
||||
return_data = year : delim : month
|
||||
case year_Digits = 2
|
||||
return_data = year[-2,2] : delim : month
|
||||
case year_digits = 0
|
||||
return_data = month
|
||||
end case
|
||||
|
||||
case period_type = 'Y'
|
||||
|
||||
oDate = Oconv(ans, 'D4-')
|
||||
year = odate[-1,'B-']
|
||||
if year_Digits = 2 then
|
||||
return_Data = year[-2,2]
|
||||
end else
|
||||
return_Data = year
|
||||
end
|
||||
|
||||
case period_type = 'W'
|
||||
|
||||
* Get date of sunday for the week containing date
|
||||
day_nr = mod(ans, 7)
|
||||
sunday = ans - day_nr
|
||||
|
||||
* get date of sunday for date containing Jan 4 of same year
|
||||
odate = Oconv(ans, 'D4-')
|
||||
year = odate[-4,4]
|
||||
jan_4 = iconv('01/-04-':year, 'D')
|
||||
day_nr = mod(jan_4, 7)
|
||||
first_sunday = jan_4 - day_nr
|
||||
|
||||
* Calc week nr
|
||||
* Week 1 is assumed to start the sunday of the week in the year that contains Jan 4
|
||||
* Add one to result as first week is week one, not week zero
|
||||
|
||||
day_nr = int(sunday - first_sunday)
|
||||
week_no = Int(day_nr / 7) + 1
|
||||
week_no +=1
|
||||
begin case
|
||||
case year_digits = 4
|
||||
return_data = year : delim : week_no
|
||||
case year_Digits = 2
|
||||
return_data = year[-2,2] : delim : week_no
|
||||
case year_digits = 0
|
||||
return_data = week_no
|
||||
end Case
|
||||
case period_type = 'Q'
|
||||
odate = Oconv(ans, 'D4-')
|
||||
month = odate[1,2]
|
||||
quarter = int(month/4)+1
|
||||
year = odate[7,4]
|
||||
begin case
|
||||
case year_digits = 4
|
||||
return_data = year : delim : "Q":quarter
|
||||
case year_Digits = 2
|
||||
return_data = year[-2,2] : delim : "Q":quarter
|
||||
case year_digits = 0
|
||||
return_data = "Q":quarter
|
||||
end Case
|
||||
|
||||
case period_type = 'D'
|
||||
|
||||
odate = Oconv(ans, 'D4/')
|
||||
year = odate[-4,4]
|
||||
first_day = Iconv('01/01/':year, 'D')
|
||||
zeroth_day = first_Day-1
|
||||
day_no = ans - zeroth_Day
|
||||
day_no = fmt(day_no, 'R(0)#3')
|
||||
begin case
|
||||
case year_digits = 4
|
||||
return_data = year : delim : day_no
|
||||
case year_Digits = 2
|
||||
return_data = year[-2,2] : delim : day_no
|
||||
case year_digits = 0
|
||||
return_data = day_no
|
||||
end case
|
||||
|
||||
|
||||
end Case
|
||||
|
||||
|
||||
unused = rti_HashTable_STL(REVSTL_HTBLMTD_WRITEROW$, hCache%, cacheKey, return_Data)
|
||||
|
||||
|
||||
return
|
||||
101
SYSPROG/STPROC/PHONE_FORMAT.txt
Normal file
101
SYSPROG/STPROC/PHONE_FORMAT.txt
Normal file
@ -0,0 +1,101 @@
|
||||
compile SUBROUTINE PHONE_FORMAT( charstr CONV, charstr ANS, charstr BRANCH, charstr RETURN_DATA)
|
||||
*
|
||||
* PHONE_FORMAT is an example of a developer's custom prompt formatting
|
||||
* routine using the square brackets call.
|
||||
*
|
||||
* It should be placed in square brackets, like this:
|
||||
*
|
||||
* [PHONE_FORMAT]
|
||||
*
|
||||
* This subroutine should be used as the first and only "Input Validation" in
|
||||
* a window prompt. Placed in "Output Format", it properly formats any
|
||||
* reasonable string of numbers into a consistent US telephone number format.
|
||||
*
|
||||
* mtr 5-29-01 Changed @upper.case to @lower.case conversion
|
||||
* mtr 3-18-02 Added '.' as a valid delimiter.
|
||||
!
|
||||
begin condition
|
||||
pre:
|
||||
post:
|
||||
end condition
|
||||
|
||||
* Subroutine declarations
|
||||
|
||||
$insert msg_equates
|
||||
|
||||
declare function msg
|
||||
|
||||
* Local Equates
|
||||
* The STATUS() variable is used to indicated the error condition of the
|
||||
* pattern. They are:
|
||||
EQU VALID$ TO 0 ;* Successful
|
||||
EQU INVALID_MSG$ TO 1 ;* Bad Data - Print error message window
|
||||
EQU INVALID_CONV$ TO 2 ;* Bad Conversion - " "
|
||||
EQU INVALID_NOMSG$ TO 3 ;* Bad but do not print the error message window
|
||||
|
||||
EQU THREEDGRAY$ TO 192
|
||||
|
||||
* Begin Conversion
|
||||
*
|
||||
RETURN_DATA = ""
|
||||
IF ANS NE "" THEN
|
||||
TEL = ANS
|
||||
ANS = ""
|
||||
STATUS() = VALID$
|
||||
|
||||
*DFLT_AREA_CODE = ""
|
||||
* PHONE_FORMAT can support a default area code. To assign a default
|
||||
* simply set the variable DFLT_AREA_CODE. In this example it is set to
|
||||
* null.
|
||||
*CONVERT " -()" TO "" IN DFLT_AREA_CODE
|
||||
*IF NUM( DFLT_AREA_CODE ) ELSE DFLT_AREA_CODE = ""
|
||||
|
||||
CONVERT " -()." TO "" IN TEL
|
||||
* mtr
|
||||
CONVERT @LOWER.CASE TO @UPPER.CASE IN TEL
|
||||
CONVERT "ABCDEFGHIJKLMNOPQRSTUVWXYZ" TO "2223334445556667Q77888999Z" IN TEL
|
||||
|
||||
IF NUM( TEL ) THEN
|
||||
LENGTH = LEN( TEL )
|
||||
* Case statement to validate all possible types of phone numbers. If
|
||||
* a new format is required simply add another case.
|
||||
* The fall-through (CASE 1) traps invalid conversions.
|
||||
BEGIN CASE
|
||||
CASE LENGTH = 10
|
||||
IF CONV EQ "OCONV" THEN
|
||||
RETURN_DATA = FMT( TEL, "L(###) ###-####")
|
||||
END ELSE
|
||||
RETURN_DATA = TEL
|
||||
END
|
||||
CASE LENGTH EQ 7
|
||||
IF CONV EQ "OCONV" THEN
|
||||
RETURN_DATA = FMT( TEL, "L###-####")
|
||||
END ELSE
|
||||
RETURN_DATA = TEL
|
||||
END
|
||||
CASE 1
|
||||
IF CONV = "ICONV" THEN
|
||||
gosub DisplayError
|
||||
END
|
||||
STATUS() = INVALID_NOMSG$
|
||||
END CASE
|
||||
END ELSE
|
||||
IF CONV = "ICONV" THEN
|
||||
gosub DisplayError
|
||||
END
|
||||
STATUS() = INVALID_NOMSG$
|
||||
END
|
||||
END
|
||||
RETURN
|
||||
*}
|
||||
|
||||
DisplayError:
|
||||
msgrec = ""
|
||||
msgrec<MCAPTION$> = "Data Validation Error"
|
||||
msgrec<MTEXT$> = TEL : " is not a valid phone number. Please enter a seven or ten digit number in any format."
|
||||
msgrec<MBKCOLOR$> = THREEDGRAY$:@VM:THREEDGRAY$:@VM:THREEDGRAY$
|
||||
msgrec<MJUST$> = 'L'
|
||||
result = msg( "", msgrec)
|
||||
return
|
||||
|
||||
* Source Date: 11:16:17 21 OCT 1991 Build ID: AREV*2.12.5 Level: 2.12
|
||||
94
SYSPROG/STPROC/PROMOTED_CLEARFILE_ACTION.txt
Normal file
94
SYSPROG/STPROC/PROMOTED_CLEARFILE_ACTION.txt
Normal file
@ -0,0 +1,94 @@
|
||||
Function Promoted_ClearFile_Action(Action, Reserved1, FSList, Handle, Name, FMC, Record, Status, OrigRecord, Param1, Param2, Param3, Param4, Param5, Param6, Param7, Param8, Param9, Param10)
|
||||
/***********************************************************************************************************************
|
||||
|
||||
This program is proprietary and is not to be used by or disclosed to others, nor is it to be copied without written
|
||||
permission from SRP Computer Solutions, Inc.
|
||||
|
||||
Name : Promoted_ClearFile_Action
|
||||
|
||||
Description : Promoted (e.g. generic) handler for CLEARFILE action.
|
||||
|
||||
Notes : Typically called by BASE_MFS
|
||||
|
||||
Parameters :
|
||||
Action [in] -- Name of the action to be taken.
|
||||
Reserved1 [in] -- Currently being reserved.
|
||||
FSList [in] -- The list of MFSs and the BFS name for the current file or volume. This is an @SVM
|
||||
delimited array, with the current MFS name as the first value in the array, and the BFS
|
||||
name as the last value. Normally set by a calling MFS.
|
||||
Handle [in] -- The file handle of the file or media map being accessed. Note, this does contain the
|
||||
entire handle structure that the Basic+ Open statement would provide. Normally set by a
|
||||
calling MFS.
|
||||
Name [in] -- The name (key) of the record or file being accessed. Normally set by a calling MFS.
|
||||
FMC [in] -- Various functions. Normally set by a calling MFS.
|
||||
Record [in] -- The entire record (for record-oriented functions) or a newly-created handle (for
|
||||
"get handle" functions). Normally set by a calling MFS.
|
||||
Status [in/out] -- Indicator of the success or failure of an action. Normally set by the calling MFS but
|
||||
for some actions can be set by the action handler to indicate failure.
|
||||
OrigRecord [in] -- Original content of the record being processed by the current action. This is
|
||||
automatically being assigned by the WRITE_RECORD and DELETE_RECORD actions within
|
||||
BASE_MFS.
|
||||
Param1-10 [in/out] -- Additional request parameter holders
|
||||
ActionFlow [out] -- Used to control the action chain (see the ACTION_SETUP insert for more information.)
|
||||
Can also be used to return a special value, such as the results of the CalcField
|
||||
method.
|
||||
|
||||
History : (Date, Initials, Notes)
|
||||
03/07/20 dmb Original programmer.
|
||||
09/09/20 dmb Update the Post gosub logic to call the IsReplicationTable and IsTableAllowedToQueue
|
||||
services before calling the AddToReplicationQueueTable service.
|
||||
|
||||
***********************************************************************************************************************/
|
||||
|
||||
#pragma precomp SRP_PreCompiler
|
||||
|
||||
$insert LOGICAL
|
||||
$insert FILE.SYSTEM.EQUATES
|
||||
$insert ACTION_SETUP
|
||||
|
||||
Declare function Replication_Services
|
||||
Declare subroutine Replication_Services
|
||||
|
||||
If Action[-3, 3] EQ "PRE" then
|
||||
// This is a pre-BFS handler promoted action.
|
||||
GoSub Pre
|
||||
end else
|
||||
// This is a post-BFS handler promoted action.
|
||||
GoSub Post
|
||||
end
|
||||
|
||||
// If ActionFlow hasn't already been assigned then assume it should continue
|
||||
If Assigned(ActionFlow) else ActionFlow = ACTION_CONTINUE$
|
||||
|
||||
Return ActionFlow
|
||||
|
||||
|
||||
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
|
||||
// Actions
|
||||
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
|
||||
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
// Pre
|
||||
//
|
||||
// All pre-BFS action handler logic.
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
Pre:
|
||||
|
||||
return
|
||||
|
||||
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
// Post
|
||||
//
|
||||
// All post-BFS action handler logic.
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
Post:
|
||||
|
||||
If Replication_Services('IsReplicationTable', Tablename, AccountName) then
|
||||
If Replication_Services('IsTableAllowedToQueue', Tablename, AccountName) then
|
||||
TransactionID = 'CLEARFILE' : @FM : AccountName : @FM : Volume : @FM : Tablename : @FM : ''
|
||||
Replication_Services('AddToReplicationQueueTable', TransactionID)
|
||||
end
|
||||
end
|
||||
|
||||
return
|
||||
91
SYSPROG/STPROC/PROMOTED_DELETE_RECORD_ACTION.txt
Normal file
91
SYSPROG/STPROC/PROMOTED_DELETE_RECORD_ACTION.txt
Normal file
@ -0,0 +1,91 @@
|
||||
Function Promoted_Delete_Record_Action(Action, Reserved1, FSList, Handle, Name, FMC, Record, Status, OrigRecord, Param1, Param2, Param3, Param4, Param5, Param6, Param7, Param8, Param9, Param10)
|
||||
/***********************************************************************************************************************
|
||||
|
||||
This program is proprietary and is not to be used by or disclosed to others, nor is it to be copied without written
|
||||
permission from SRP Computer Solutions, Inc.
|
||||
|
||||
Name : Promoted_Delete_Record_Action
|
||||
|
||||
Description : Promoted (e.g. generic) handler for DELETE_RECORD action.
|
||||
|
||||
Notes : Typically called by BASE_MFS
|
||||
|
||||
Parameters :
|
||||
Action [in] -- Name of the action to be taken
|
||||
Reserved1 [in] -- Currently being reserved.
|
||||
FSList [in] -- The list of MFSs and the BFS name for the current file or volume. This is an @SVM
|
||||
delimited array, with the current MFS name as the first value in the array, and the BFS
|
||||
name as the last value. Normally set by a calling MFS.
|
||||
Handle [in] -- The file handle of the file or media map being accessed. Note, this does contain the
|
||||
entire handle structure that the Basic+ Open statement would provide. Normally set by a
|
||||
calling MFS.
|
||||
Name [in] -- The name (key) of the record or file being accessed. Normally set by a calling MFS.
|
||||
FMC [in] -- Various functions. Normally set by a calling MFS.
|
||||
Record [in] -- The entire record (for record-oriented functions) or a newly-created handle (for
|
||||
"get handle" functions). Normally set by a calling MFS.
|
||||
Status [in/out] -- Indicator of the success or failure of an action. Normally set by the calling MFS but
|
||||
for some actions can be set by the action handler to indicate failure.
|
||||
Param1-10 [in/out] -- Additional request parameter holders
|
||||
ActionFlow [out] -- Used to control the action chain (see the ACTION_SETUP insert for more information.)
|
||||
Can also be used to return a special value, such as the results of the CalcField
|
||||
method.
|
||||
|
||||
History : (Date, Initials, Notes)
|
||||
03/07/20 dmb Original programmer.
|
||||
09/09/20 dmb Update the Post gosub logic to call the IsReplicationTable and IsTableAllowedToQueue
|
||||
services before calling the AddToReplicationQueueTable service.
|
||||
|
||||
***********************************************************************************************************************/
|
||||
|
||||
#pragma precomp SRP_PreCompiler
|
||||
|
||||
$insert LOGICAL
|
||||
$insert FILE.SYSTEM.EQUATES
|
||||
$insert ACTION_SETUP
|
||||
|
||||
Declare function Replication_Services
|
||||
Declare subroutine Replication_Services
|
||||
|
||||
If Action[-3, 3] EQ "PRE" then
|
||||
// This is a pre-BFS handler promoted action.
|
||||
GoSub Pre
|
||||
end else
|
||||
// This is a post-BFS handler promoted action.
|
||||
GoSub Post
|
||||
end
|
||||
|
||||
// If ActionFlow hasn't already been assigned then assume it should continue
|
||||
If Assigned(ActionFlow) else ActionFlow = ACTION_CONTINUE$
|
||||
|
||||
Return ActionFlow
|
||||
|
||||
|
||||
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
|
||||
// Actions
|
||||
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
|
||||
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
// Pre
|
||||
//
|
||||
// All pre-BFS action handler logic.
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
Pre:
|
||||
|
||||
return
|
||||
|
||||
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
// Post
|
||||
//
|
||||
// All post-BFS action handler logic.
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
Post:
|
||||
|
||||
If Replication_Services('IsReplicationTable', Tablename, AccountName) then
|
||||
If Replication_Services('IsTableAllowedToQueue', Tablename, AccountName) then
|
||||
TransactionID = 'DELETE' : @FM : AccountName : @FM : Volume : @FM : Tablename : @FM : Name
|
||||
Replication_Services('AddToReplicationQueueTable', TransactionID)
|
||||
end
|
||||
end
|
||||
|
||||
return
|
||||
79
SYSPROG/STPROC/PROMOTED_READONLY_RECORD_ACTION.txt
Normal file
79
SYSPROG/STPROC/PROMOTED_READONLY_RECORD_ACTION.txt
Normal file
@ -0,0 +1,79 @@
|
||||
Function Promoted_ReadOnly_Record_Action(Action, Reserved1, FSList, Handle, Name, FMC, Record, Status, OrigRecord, Param1, Param2, Param3, Param4, Param5, Param6, Param7, Param8, Param9, Param10)
|
||||
/***********************************************************************************************************************
|
||||
|
||||
This program is proprietary and is not to be used by or disclosed to others, nor is it to be copied without written
|
||||
permission from SRP Computer Solutions, Inc.
|
||||
|
||||
Name : Promoted_ReadOnly_Record_Action
|
||||
|
||||
Description : Promoted (e.g. generic) handler for READONLY_RECORD action.
|
||||
|
||||
Notes : Typically called by BASE_MFS
|
||||
|
||||
Parameters :
|
||||
Action [in] -- Name of the action to be taken
|
||||
Reserved1 [in] -- Currently being reserved.
|
||||
FSList [in] -- The list of MFSs and the BFS name for the current file or volume. This is an @SVM
|
||||
delimited array, with the current MFS name as the first value in the array, and the BFS
|
||||
name as the last value. Normally set by a calling MFS.
|
||||
Handle [in] -- The file handle of the file or media map being accessed. Note, this does contain the
|
||||
entire handle structure that the Basic+ Open statement would provide. Normally set by a
|
||||
calling MFS.
|
||||
Name [in] -- The name (key) of the record or file being accessed. Normally set by a calling MFS.
|
||||
FMC [in] -- Various functions. Normally set by a calling MFS.
|
||||
Record [in] -- The entire record (for record-oriented functions) or a newly-created handle (for
|
||||
"get handle" functions). Normally set by a calling MFS.
|
||||
Status [in/out] -- Indicator of the success or failure of an action. Normally set by the calling MFS but
|
||||
for some actions can be set by the action handler to indicate failure.
|
||||
Param1-10 [in/out] -- Additional request parameter holders
|
||||
ActionFlow [out] -- Used to control the action chain (see the ACTION_SETUP insert for more information.)
|
||||
Can also be used to return a special value, such as the results of the CalcField
|
||||
method.
|
||||
|
||||
History : (Date, Initials, Notes)
|
||||
03/07/20 dmb Original programmer.
|
||||
|
||||
***********************************************************************************************************************/
|
||||
|
||||
#pragma precomp SRP_PreCompiler
|
||||
|
||||
$insert LOGICAL
|
||||
$insert FILE.SYSTEM.EQUATES
|
||||
$insert ACTION_SETUP
|
||||
|
||||
If Action[-3, 3] EQ "PRE" then
|
||||
// This is a pre-BFS handler promoted action.
|
||||
GoSub Pre
|
||||
end else
|
||||
// This is a post-BFS handler promoted action.
|
||||
GoSub Post
|
||||
end
|
||||
|
||||
// If ActionFlow hasn't already been assigned then assume it should continue
|
||||
If Assigned(ActionFlow) else ActionFlow = ACTION_CONTINUE$
|
||||
|
||||
Return ActionFlow
|
||||
|
||||
|
||||
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
|
||||
// Actions
|
||||
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
|
||||
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
// Pre
|
||||
//
|
||||
// All pre-BFS action handler logic.
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
Pre:
|
||||
|
||||
return
|
||||
|
||||
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
// Post
|
||||
//
|
||||
// All post-BFS action handler logic.
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
Post:
|
||||
|
||||
return
|
||||
79
SYSPROG/STPROC/PROMOTED_READ_RECORD_ACTION.txt
Normal file
79
SYSPROG/STPROC/PROMOTED_READ_RECORD_ACTION.txt
Normal file
@ -0,0 +1,79 @@
|
||||
Function Promoted_Read_Record_Action(Action, Reserved1, FSList, Handle, Name, FMC, Record, Status, OrigRecord, Param1, Param2, Param3, Param4, Param5, Param6, Param7, Param8, Param9, Param10)
|
||||
/***********************************************************************************************************************
|
||||
|
||||
This program is proprietary and is not to be used by or disclosed to others, nor is it to be copied without written
|
||||
permission from SRP Computer Solutions, Inc.
|
||||
|
||||
Name : Promoted_Read_Record_Action
|
||||
|
||||
Description : Promoted (e.g. generic) handler for READ_RECORD action.
|
||||
|
||||
Notes : Typically called by BASE_MFS
|
||||
|
||||
Parameters :
|
||||
Action [in] -- Name of the action to be taken
|
||||
Reserved1 [in] -- Currently being reserved.
|
||||
FSList [in] -- The list of MFSs and the BFS name for the current file or volume. This is an @SVM
|
||||
delimited array, with the current MFS name as the first value in the array, and the BFS
|
||||
name as the last value. Normally set by a calling MFS.
|
||||
Handle [in] -- The file handle of the file or media map being accessed. Note, this does contain the
|
||||
entire handle structure that the Basic+ Open statement would provide. Normally set by a
|
||||
calling MFS.
|
||||
Name [in] -- The name (key) of the record or file being accessed. Normally set by a calling MFS.
|
||||
FMC [in] -- Various functions. Normally set by a calling MFS.
|
||||
Record [in] -- The entire record (for record-oriented functions) or a newly-created handle (for
|
||||
"get handle" functions). Normally set by a calling MFS.
|
||||
Status [in/out] -- Indicator of the success or failure of an action. Normally set by the calling MFS but
|
||||
for some actions can be set by the action handler to indicate failure.
|
||||
Param1-10 [in/out] -- Additional request parameter holders
|
||||
ActionFlow [out] -- Used to control the action chain (see the ACTION_SETUP insert for more information.)
|
||||
Can also be used to return a special value, such as the results of the CalcField
|
||||
method.
|
||||
|
||||
History : (Date, Initials, Notes)
|
||||
03/07/20 dmb Original programmer.
|
||||
|
||||
***********************************************************************************************************************/
|
||||
|
||||
#pragma precomp SRP_PreCompiler
|
||||
|
||||
$insert LOGICAL
|
||||
$insert FILE.SYSTEM.EQUATES
|
||||
$insert ACTION_SETUP
|
||||
|
||||
If Action[-3, 3] EQ "PRE" then
|
||||
// This is a pre-BFS handler promoted action.
|
||||
GoSub Pre
|
||||
end else
|
||||
// This is a post-BFS handler promoted action.
|
||||
GoSub Post
|
||||
end
|
||||
|
||||
// If ActionFlow hasn't already been assigned then assume it should continue
|
||||
If Assigned(ActionFlow) else ActionFlow = ACTION_CONTINUE$
|
||||
|
||||
Return ActionFlow
|
||||
|
||||
|
||||
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
|
||||
// Actions
|
||||
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
|
||||
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
// Pre
|
||||
//
|
||||
// All pre-BFS action handler logic.
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
Pre:
|
||||
|
||||
return
|
||||
|
||||
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
// Post
|
||||
//
|
||||
// All post-BFS action handler logic.
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
Post:
|
||||
|
||||
return
|
||||
94
SYSPROG/STPROC/PROMOTED_WRITE_RECORD_ACTION.txt
Normal file
94
SYSPROG/STPROC/PROMOTED_WRITE_RECORD_ACTION.txt
Normal file
@ -0,0 +1,94 @@
|
||||
Function Promoted_Write_Record_Action(Action, Reserved1, FSList, Handle, Name, FMC, Record, Status, OrigRecord, Param1, Param2, Param3, Param4, Param5, Param6, Param7, Param8, Param9, Param10)
|
||||
/***********************************************************************************************************************
|
||||
|
||||
This program is proprietary and is not to be used by or disclosed to others, nor is it to be copied without written
|
||||
permission from SRP Computer Solutions, Inc.
|
||||
|
||||
Name : Promoted_Write_Record_Action
|
||||
|
||||
Description : Promoted (e.g. generic) handler for WRITE_RECORD action.
|
||||
|
||||
Notes : Typically called by BASE_MFS
|
||||
|
||||
Parameters :
|
||||
Action [in] -- Name of the action to be taken.
|
||||
Reserved1 [in] -- Currently being reserved.
|
||||
FSList [in] -- The list of MFSs and the BFS name for the current file or volume. This is an @SVM
|
||||
delimited array, with the current MFS name as the first value in the array, and the BFS
|
||||
name as the last value. Normally set by a calling MFS.
|
||||
Handle [in] -- The file handle of the file or media map being accessed. Note, this does contain the
|
||||
entire handle structure that the Basic+ Open statement would provide. Normally set by a
|
||||
calling MFS.
|
||||
Name [in] -- The name (key) of the record or file being accessed. Normally set by a calling MFS.
|
||||
FMC [in] -- Various functions. Normally set by a calling MFS.
|
||||
Record [in] -- The entire record (for record-oriented functions) or a newly-created handle (for
|
||||
"get handle" functions). Normally set by a calling MFS.
|
||||
Status [in/out] -- Indicator of the success or failure of an action. Normally set by the calling MFS but
|
||||
for some actions can be set by the action handler to indicate failure.
|
||||
OrigRecord [in] -- Original content of the record being processed by the current action. This is
|
||||
automatically being assigned by the WRITE_RECORD and DELETE_RECORD actions within
|
||||
BASE_MFS.
|
||||
Param1-10 [in/out] -- Additional request parameter holders
|
||||
ActionFlow [out] -- Used to control the action chain (see the ACTION_SETUP insert for more information.)
|
||||
Can also be used to return a special value, such as the results of the CalcField
|
||||
method.
|
||||
|
||||
History : (Date, Initials, Notes)
|
||||
03/07/20 dmb Original programmer.
|
||||
09/09/20 dmb Update the Post gosub logic to call the IsReplicationTable and IsTableAllowedToQueue
|
||||
services before calling the AddToReplicationQueueTable service.
|
||||
|
||||
***********************************************************************************************************************/
|
||||
|
||||
#pragma precomp SRP_PreCompiler
|
||||
|
||||
$insert LOGICAL
|
||||
$insert FILE.SYSTEM.EQUATES
|
||||
$insert ACTION_SETUP
|
||||
|
||||
Declare function Replication_Services, Environment_Services, Logging_Services
|
||||
Declare subroutine Replication_Services, Environment_Services, Logging_Services
|
||||
|
||||
If Action[-3, 3] EQ "PRE" then
|
||||
// This is a pre-BFS handler promoted action.
|
||||
GoSub Pre
|
||||
end else
|
||||
// This is a post-BFS handler promoted action.
|
||||
GoSub Post
|
||||
end
|
||||
|
||||
// If ActionFlow hasn't already been assigned then assume it should continue
|
||||
If Assigned(ActionFlow) else ActionFlow = ACTION_CONTINUE$
|
||||
|
||||
Return ActionFlow
|
||||
|
||||
|
||||
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
|
||||
// Actions
|
||||
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
|
||||
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
// Pre
|
||||
//
|
||||
// All pre-BFS action handler logic.
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
Pre:
|
||||
|
||||
return
|
||||
|
||||
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
// Post
|
||||
//
|
||||
// All post-BFS action handler logic.
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
Post:
|
||||
|
||||
If Replication_Services('IsReplicationTable', Tablename, AccountName) then
|
||||
If Replication_Services('IsTableAllowedToQueue', Tablename, AccountName) then
|
||||
TransactionID = 'WRITE' : @FM : AccountName : @FM : Volume : @FM : Tablename : @FM : Name
|
||||
Replication_Services('AddToReplicationQueueTable', TransactionID)
|
||||
end
|
||||
end
|
||||
|
||||
return
|
||||
3759
SYSPROG/STPROC/REPLICATION_SERVICES.txt
Normal file
3759
SYSPROG/STPROC/REPLICATION_SERVICES.txt
Normal file
File diff suppressed because it is too large
Load Diff
215
SYSPROG/STPROC/RTI_BRW_FILTER.txt
Normal file
215
SYSPROG/STPROC/RTI_BRW_FILTER.txt
Normal file
@ -0,0 +1,215 @@
|
||||
Function RTI_BRW_FILTER(invokingName, UDetails, Param1)
|
||||
*#!Precompile
|
||||
/*
|
||||
* This program is proprietary and is not to be used by or disclosed to others, nor is it to be copied without
|
||||
* written permission from Revelation Technologies, Inc.
|
||||
!
|
||||
*
|
||||
* VERSION : 1.0
|
||||
*
|
||||
*
|
||||
* AUTHOR : Bryan Shumsky
|
||||
*
|
||||
* CREATED : September 23, 2009
|
||||
*
|
||||
*
|
||||
!
|
||||
*
|
||||
* REVISION HISTORY (Most CURRENT first) :
|
||||
*
|
||||
* DATE IMPLEMENTOR FUNCTION
|
||||
* -------- ----------- --------
|
||||
* 09 Aug 2019 bzs Added note on INIT and TERM calls - extra flag passed on first (INIT) and last (TERM) calls in a group
|
||||
* 05 Feb 2019 bzs Added support for SYSDICT call
|
||||
* 10 Nov 2016 bzs Added support for "reports" call
|
||||
* 04 Oct 2012 bzs Added support for "definitions" call
|
||||
* 24 Feb 2012 bzs Added support for "term" call
|
||||
* 17 Jan 2012 bzs Added support for "init" call
|
||||
* 03 May 2010 bzs Added logic to respect environment security settings
|
||||
*
|
||||
*
|
||||
*/
|
||||
*
|
||||
$Insert ENVIRON_CONSTANTS
|
||||
*
|
||||
If Assigned(invokingname) Else invokingname = ""
|
||||
If Assigned(udetails) Else udetails = ""
|
||||
If Assigned(Param1) Else Param1 = ""
|
||||
*
|
||||
* By default, no filters are applied EXCEPT for system-wide filters
|
||||
SecFlds = @ENVIRON_SET<ENV_EXCLUDE_FIELDS$>
|
||||
Sectbl = @ENVIRON_SET<ENV_EXCLUDE_FROM_REPORTS$>
|
||||
|
||||
rslt = ""
|
||||
Begin Case
|
||||
Case uDetails = "REPORTS"
|
||||
* return list of report groups to provide to the report designer
|
||||
* Param1 is the full list of report groups available (@FM delimited)
|
||||
* Return modified list, or full list, or report groups
|
||||
* Note: to return NO report groups, explicitly return the string <<NONE>>
|
||||
rslt = param1
|
||||
|
||||
Case uDetails = "INIT"
|
||||
* perform any required initialization
|
||||
* note: "DESIGNER" may be passed as invoking name if called from BRWDesigner, otherwise invokingname is a unique identifier
|
||||
* if multiple reports from a report group are being generated at the same time, param1 will be "1" for the initial INIT call
|
||||
RSLT = ""
|
||||
|
||||
Case uDetails = "TERM"
|
||||
* perform any required wrapup
|
||||
* note: "DESIGNER" may be passed as invoking name if called from BRWDesigner, otherwise invokingname is a unique identifier
|
||||
* if multiple reports from a report group are being generated at the same time, param1 will be "1" for the final TERM call
|
||||
RSLT = ""
|
||||
|
||||
Case uDetails = "MSG_RENDERED"
|
||||
* perform any required operation when display to screen is generated
|
||||
* note: "DESIGNER" may be passed as invoking name if called from BRWDesigner, otherwise invokingname is a unique identifier
|
||||
RSLT = ""
|
||||
|
||||
Case uDetails = "STPROC"
|
||||
* return list of stored procedures to use as a data source
|
||||
RSLT = ""
|
||||
*RSLT = "@RTI_BRW_SAMPLEDATASOURCE"
|
||||
|
||||
Case uDetails = "TABLES"
|
||||
* return list of all tables (except "!" and "DICT." tables)
|
||||
bExclude = 1
|
||||
Call Rlist("SELECT SYSTABLES BY @ID", '5')
|
||||
DONE = 0
|
||||
Loop
|
||||
Readnext id Else DONE = 1
|
||||
Until DONE Do
|
||||
If bExclude=0 Or (id[1,1] <> "!" And id[1,5] <> "DICT.") then
|
||||
Locate id In SecTbl<1> Using @VM Setting dummy else
|
||||
rslt<1,-1> = id
|
||||
End
|
||||
end
|
||||
Repeat
|
||||
|
||||
Case uDetails = "FIELDS" Or uDetails = "MVFIELDS"
|
||||
* return list of fields for specified table
|
||||
* Param1 is the name of the table
|
||||
trslt = Xlate("DICT.":Param1, "%FIELDS%", "", "X")
|
||||
num.flds = dcount(trslt<3>, @VM)
|
||||
rslt = ""
|
||||
For each.fld = 1 To num.flds
|
||||
this.fld = trslt<3,each.fld>
|
||||
ismv = trslt<9,each.fld>
|
||||
If (uDetails = "FIELDS") Or (uDetails = "MVFIELDS" And isMV) Then
|
||||
chkfld = Param1:@svm:this.fld
|
||||
Locate chkfld In secflds<1> Using @vm Setting chkpos Else
|
||||
rslt<1,-1> = this.fld
|
||||
End
|
||||
End
|
||||
Next each.fld
|
||||
|
||||
Case uDetails = "SYSDICT"
|
||||
* Return list of SYSDICT items to make available to reports
|
||||
* return explicit "<<NONE>>" to return nothing, otherwise default %FIELDS% record will be used
|
||||
*
|
||||
* rslt = "<<NONE>>"
|
||||
*
|
||||
Open "SYSDICT" To sysdict.fl Then
|
||||
done = 0
|
||||
CALL Rlist("SELECT SYSDICT BY @ID", 5)
|
||||
//Select sysdict.fl
|
||||
Loop
|
||||
Readnext id Else done = 1
|
||||
Until done do
|
||||
Read dInfo From sysdict.fl, id Then
|
||||
If dInfo[1,1] = "F" Or dInfo[1,1] = "S" Then
|
||||
rslt<1,-1> = ID
|
||||
end
|
||||
End
|
||||
Repeat
|
||||
end
|
||||
*
|
||||
|
||||
Case uDetails = "DEFINITIONS"
|
||||
Begin Case
|
||||
Case INVOKINGNAME _eqc "LABEL"
|
||||
* Return overriding list of label definitions
|
||||
* Read from a record in the system, or hard-code
|
||||
* format of the lines:
|
||||
/*
|
||||
// ID label id
|
||||
// DESC description
|
||||
// ACROSS labels across a page
|
||||
// METRIC metric/english units
|
||||
// WID label width (all measurements in twips)
|
||||
// HEI label height
|
||||
// XSPC horz space between labels
|
||||
// YSPC vert space between labels
|
||||
// MLEFT page margin left
|
||||
// MRIGHT page margin right
|
||||
// MTOP page margin top
|
||||
// MLEFTLBL label margin left
|
||||
// MTOPLBL label margin top
|
||||
// CONT continuous/sheet
|
||||
// PORTRAIT portrait orientation
|
||||
*
|
||||
* for example:
|
||||
*
|
||||
rslt = "OML 101,24 mm x 102 mm,1,1,5783,1503,0,0,709,709,71,340,113,1,1"
|
||||
rslt<-1> = "OML 102,37 mm x 102 mm,1,1,5783,2240,0,0,709,709,71,340,113,1,1"
|
||||
rslt<-1> = "OML 103,49 mm x 102 mm,1,1,5783,2920,0,0,709,709,71,340,113,1,1"
|
||||
rslt<-1> = "OML 105,49 mm x 127 mm,1,1,7201,2920,0,0,709,709,71,340,113,1,1"
|
||||
rslt<-1> = "OML 202,37 mm x 102 mm,2,1,5874,2240,91,0,675,675,71,340,113,1,1"
|
||||
rslt<-1> = "OML 203,49 mm x 102 mm,2,1,5874,2920,91,0,675,675,71,340,113,1,1"
|
||||
*/
|
||||
Case INVOKINGNAME _eqc "PAPER"
|
||||
* Return overriding list of paper definitions
|
||||
|
||||
Case INVOKINGNAME _Eqc "THEMES"
|
||||
* Return overriding list of themes
|
||||
*
|
||||
/*
|
||||
* format of the lines:
|
||||
* themeName<space>{ReportHeader_theme}{PageHeader_theme}{GroupHeader_theme}{Detail_theme}{PageFooter_theme}
|
||||
* where each section_theme contains:
|
||||
* fontName;fontSize;fontStyle;foreColor;backColor;lineInfo;alternateColor
|
||||
* fontStyle: null or style bits
|
||||
* lineInfo: null or "a" (lineAbove), "b" (lineBelow), or "c" (lineAbove and lineBelow) followed by lineColor
|
||||
* alternateColor: null or "striping" color
|
||||
*
|
||||
* for example:
|
||||
*
|
||||
rslt = "Access 2007 {Segoe UI;20;;#000000;;;}{Segoe UI;9;;#204D89;#C2DCFF;;}{Segoe UI;9;Bold;#000000;;;}{Segoe UI;9;;#000000;;;#F0F0F0}{Segoe UI;8;;#000000;;;}"
|
||||
rslt<-1> = "Access 2003 {Tahoma;24;;#000000;;;}{Tahoma;8;;#000000;;;}{Tahoma;8;Bold;#000000;;;}{Tahoma;8;;#000000;;;}{Tahoma;8;;#000000;;;}"
|
||||
rslt<-1> = "Apex {Lucida Sans;20;;#69676D;;;}{Book Antiqua;10;;#CEB966;#69676D;;}{Book Antiqua;10;Bold;#69676D;;a#69676D;}{Book Antiqua;10;;#000000;;;}{Book Antiqua;9;;#A0A0A0;;;}"
|
||||
rslt<-1> = "Aspect {Verdana;18;;#323232;#E3DED1;;}{Verdana;8;;#E3DED1;#323232;;}{Verdana;8;Bold;#604878;;;}{Verdana;8;;#000000;;;}{Verdana;7;;#323232;;;}"
|
||||
rslt<-1> = "Civic {Georgia;20;;#D6614A;;;}{Georgia;8;;#E4EEF3;#8CAEAD;;}{Georgia;8;Bold;#090000;;b#000000;}{Georgia;8;;#000000;;b#73A8D4;}{Georgia;7;;#000000;;;}"
|
||||
rslt<-1> = "Concourse {Eras Medium ITC;20;;#282828;#2DA2BF;;}{Eras Medium ITC;9;;#EEEEEE;#282828;;}{Eras Medium ITC;9;Bold;#576793;;;}{Eras Medium ITC;9;;#282828;;;#EEEEEE}{Eras Medium ITC;8;;#2DA2BF;;;}"
|
||||
rslt<-1> = "ComponentOne {Eras Medium ITC;20;;;#DD0000;;}{Eras Medium ITC;10;;#EEEEEE;#282828;;}{Eras Medium ITC;10;Bold;#576793;;;}{Eras Medium ITC;10;;#282828;;;#EEEEEE}{Eras Medium ITC;9;;#404040;;;}"
|
||||
rslt<-1> = "Equity {Franklin Gothic Book;20;;;#D34817;;}{Perpetua;11;;#E9E5DC;#855D5D;;}{Perpetua;11;Bold;#9B2D1F;;;}{Perpetua;11;;#696464;;b#E9E5DC;}{Perpetua;10;;#BFBFBF;;;}"
|
||||
rslt<-1> = "Flow {Calibri;20;;#04617B;#D1EAF0;;}{Constantia;9;;#04617B;;;}{Constantia;9;Bold;#04617B;;;}{Constantia;9;;#000000;;;}{Constantia;8;;#04617B;;;}"
|
||||
rslt<-1> = "Foundry {Rockwell;20;;;#676A55;;}{Rockwell;9;;#EAEBDE;#676A55;;}{Rockwell;9;Bold;#EAEBDE;#676A55;;}{Rockwell;9;;#000000;;b#72A376;}{Rockwell;8;;#72A376;;;}"
|
||||
rslt<-1> = "Median {Tw Cen Mt;20;;#FBEEC9;#775F55;;}{Tw Cen Mt;10;;#FBEEC9;#94B6D2;;}{Tw Cen Mt;10;Bold;#775F55;;;}{Tw Cen Mt;10;;#000000;;;}{Tw Cen Mt;8;;#775F55;;;}"
|
||||
rslt<-1> = "Metro {Constantia;20;;;#000000;;}{Constantia;9;;;#000000;;}{Constantia;9;Bold;#4E5B6F;;;}{Constantia;9;;#000000;;;}{Constantia;9;;#000000;;;}"
|
||||
rslt<-1> = "Module {Corbel;20;;;#383265;;}{Corbel;10;;;#383265;;}{Corbel;10;Bold;#000000;;;}{Corbel;10;;#000000;;;#EFEFEF}{Corbel;9;;#000000;;;}"
|
||||
rslt<-1> = "None {Calibri;20;;#000000;;;}{Calibri;11;;#000000;;;}{Calibri;11;Bold;#000000;;;}{Calibri;11;;#000000;;;}{Calibri;11;;#000000;;;}"
|
||||
rslt<-1> = "Northwind {Trebuchet;20;;#7F001B;;;}{Arial;9;;#F9F9F7;#C7C5BC;;}{Arial;9;Bold;#CF5216;;;}{Arial;9;;#000000;;;}{Arial;8;;#C7C5BC;;;}"
|
||||
rslt<-1> = "Office {Cambria;20;Bold;#00224D;;;}{Calibri;9;Bold;#00224D;#79A7E3;;}{Calibri;9;Bold;#5C83B4;;;}{Calibri;9;;#000000;;;}{Calibri;8;;#000000;;;}"
|
||||
rslt<-1> = "Opulent {Trebuchet;20;;#660066;#E9F7DD;;}{Trebuchet;9;;;#B13F9A;;}{Trebuchet;9;Bold;#B13F9A;;;}{Trebuchet;9;;#000000;;;#E9F7DD}{Trebuchet;8;;#000000;;;}"
|
||||
rslt<-1> = "Oriel {Century Schoolbook;20;;#575F6D;;;}{Century Schoolbook;9;;#000000;;a#FF7D26;}{Century Schoolbook;9;Bold;#FF7D26;;a#000000;}{Century Schoolbook;9;;#000000;;;#FFF3EB}{Century Schoolbook;8;;#FF7D26;;;}"
|
||||
rslt<-1> = "Origin {Bookman Old Style;20;;#DDE9EC;#46465D;;}{Gill Sans MT;10;;#DDE9EC;#46465D;;}{Gill Sans MT;10;Bold;#727CA3;;;}{Gill Sans MT;10;;#46465D;;;#DDE9EC}{Gill Sans MT;9;;#000000;;;}"
|
||||
rslt<-1> = "Paper {Constantia;20;;#000000;#EFF2F5;;}{Constantia;9;;#EFF2F5;#4A606E;;}{Constantia;9;Bold;#4A606E;;b#000000;}{Constantia;9;;#000000;;b#95AEB1;}{Constantia;8;;#95AEB1;;;}"
|
||||
rslt<-1> = "Solstice {Gill Sans MT;20;;#4F271C;#E7DEC9;;}{Gill Sans MT;10;;#4F271C;#E7DEC9;;}{Gill Sans MT;10;Bold;#3891A7;;;}{Gill Sans MT;10;;#4F271C;;;#E7DEC9}{Gill Sans MT;9;;#9F8D69;;;}"
|
||||
rslt<-1> = "Technic {Franklin Gothic Book;20;;;#3B3B3B;;}{Arial;9;;#D4D2D0;#000000;;}{Arial;9;Bold;#979EA8;;b#979EA8;}{Arial;9;;#3B3B3B;;b#979EA8;}{Arial;8;;#000000;;;}"
|
||||
rslt<-1> = "Trek {Franklin Gothic Book;20;;#4E3B30;;;}{Franklin Gothic Book;10;Bold;#4E3B30;;;}{Franklin Gothic Book;10;Bold;#A5644E;;;}{Franklin Gothic Book;10;;#4E3B30;;;#FBEEC9}{Franklin Gothic Book;9;;#000000;;;}"
|
||||
rslt<-1> = "Urban {Trebuchet;20;;#42415A;;;}{Georgia;9;;#DEDEDE;#42415A;;}{Georgia;9;Bold;#42415A;;b#000000;}{Georgia;9;;#000000;;;#DEDEDE}{Georgia;8;;#438086;;;}"
|
||||
rslt<-1> = "Verve {Century Gothic;20;;;#666666;;}{Century Gothic;8;;;#666666;;}{Century Gothic;8;Bold;#666666;;;}{Century Gothic;8;;#000000;;;#D2D2D2}{Century Gothic;7;;#000000;;;}"
|
||||
rslt<-1> = "Windows Vista {Segoe UI;20;;;#000000;;}{Segoe UI;9;;#FFFFFF;#000000;;}{Segoe UI;9;Bold;#616A76;;;}{Segoe UI;9;;#373C43;;;#EBEBEB}{Segoe UI;8;;#000000;;;}"
|
||||
rslt<-1> = "Bold {Times New Roman;20;Bold;#800000;;;}{Arial;10;Bold;#000000;;;}{Arial;10;Bold;#000000;;a#000000;}{Times New Roman;9;;#000000;;;}{Times New Roman;8;;#000000;;;}"
|
||||
rslt<-1> = "Casual {Tahoma;24;Bold;#008080;;;}{Arial;10;;#000000;;;}{Arial;10;Bold;#000000;;b#008080;}{Times New Roman;9;;#000000;;;}{Times New Roman;8;;#000000;;;}"
|
||||
rslt<-1> = "Compact {Haettenschweiler;26;Bold;#000000;;;}{Haettenschweiler;14;;#000000;;;}{Haettenschweiler;12;;#000000;;;}{Arial;9;;#000000;;;}{Arial;8;;#000000;;;}"
|
||||
rslt<-1> = "Corporate {Times New Roman;20;Bold-Italic;#000080;;;}{Times New Roman;9;Bold-Italic;#000080;;;}{Times New Roman;9;Bold-Italic;#000080;;b#808080;}{Arial;9;;#000000;;;}{Arial;8;;#000000;;;}"
|
||||
rslt<-1> = "Formal {Times New Roman;20;;#000000;;;}{Times New Roman;9;Bold;#000000;;;}{Times New Roman;9;Bold;#000000;;;}{Arial;9;;#000000;;;}{Arial;8;;#000000;;;}"
|
||||
rslt<-1> = "Soft Gray {Arial;24;Bold;;#C0C0C0;;}{Arial;9;;#000000;;a#C0C0C0;}{Arial;9;Bold;#000000;;;}{Times New Roman;9;;#000000;;;}{Times New Roman;8;;#000000;;;}"
|
||||
rslt<-1> = "Verdana {Verdana;18;Bold;;#4580B5;;}{Verdana;9;Bold;#4580B5;;a#000000;}{Verdana;9;;#4580B5;;;}{Verdana;9;;#000000;;;}{Verdana;8;;#000000;;;}"
|
||||
rslt<-1> = "Web Report {Verdana;18;Bold;#50308C;#F5F5DC;;}{Verdana;9;Bold;#50308C;;a#000000;}{Verdana;9;;#4580B5;;;}{Verdana;9;;#000000;;;}{Verdana;8;;#000000;;;}"
|
||||
*/
|
||||
End CASE
|
||||
End Case
|
||||
*
|
||||
Return rslt
|
||||
95
SYSPROG/STPROC/RTI_COMPRESS_STRING.txt
Normal file
95
SYSPROG/STPROC/RTI_COMPRESS_STRING.txt
Normal file
@ -0,0 +1,95 @@
|
||||
function rti_compress_string(inString, status)
|
||||
*#!Precompile
|
||||
/*
|
||||
* This program is proprietary and is not to be used by or disclosed to others, nor is it to be copied without
|
||||
* written permission from Revelation Technologies, Inc.
|
||||
!
|
||||
* No warranties, express or implied, are conveyed by the use of this routine
|
||||
!
|
||||
* VERSION : 1.0
|
||||
*
|
||||
*
|
||||
* AUTHOR : Bryan Shumsky
|
||||
*
|
||||
* CREATED : February 16, 2022
|
||||
*
|
||||
*
|
||||
!
|
||||
*
|
||||
* REVISION HISTORY (Most CURRENT first) :
|
||||
*
|
||||
* DATE IMPLEMENTOR FUNCTION
|
||||
* -------- ----------- --------
|
||||
*
|
||||
*/
|
||||
|
||||
$Insert RevDotNetEquates
|
||||
|
||||
If Assigned(inString) Else inString = ""
|
||||
Status = 0
|
||||
rslt = ""
|
||||
|
||||
If inString = "" Then
|
||||
Status = "-2"
|
||||
Return rslt
|
||||
End
|
||||
|
||||
dotNetHandle = ""
|
||||
dotNetVersion = "4.0"
|
||||
oNet = StartDotNet("", dotNetVersion, dotNetHandle)
|
||||
if Get_Status(errcode) Then
|
||||
Goto returnErr
|
||||
End
|
||||
netLocn = CheckDotNet(dotNetVersion)
|
||||
If netLocn <> "0" And netLocn <> "" Then
|
||||
If netLocn[-1,1] <> "\" Then netLocn := "\"
|
||||
End Else netLocn = ""
|
||||
oiLocn = drive()
|
||||
If oiLocn[-1,1] <> "\" Then oiLocn := "\"
|
||||
x = set_property.net(oNet, "AssemblyName", netLocn:"System.dll":@fm:netLocn:"mscorlib.dll", dotNetHandle)
|
||||
If Get_Status(errcode) Then Goto returnErr
|
||||
|
||||
* step 1: convert incoming string into an array of UTF8 bytes, and make a "memory stream" from that byte array
|
||||
oEncoding = create_class.net(oNet, "System.Text.UTF8Encoding", 0, "", "", dotNetHandle)
|
||||
If Get_Status(errcode) Then Goto returnErr
|
||||
oBytes = send_message.net(oEncoding, "GetBytes", inString, "System.String", 1, dotNetHandle)
|
||||
If Get_Status(errcode) Then Goto returnErr
|
||||
oInputStream = create_class.net(oNet, "System.IO.MemoryStream", 0, oBytes, "", dotNetHandle)
|
||||
If Get_Status(errcode) Then Goto returnErr
|
||||
|
||||
* step 2: use gzipstream to compress the incoming memory stream to an outgoing memory stream
|
||||
oOutputStream = create_class.net(oNet, "System.IO.MemoryStream", 0, "", "", dotNetHandle)
|
||||
If Get_Status(errcode) Then Goto returnErr
|
||||
oCompressor = create_class.net(oNet, "System.IO.Compression.GZipStream", 0, oOutputStream:@FM:"1":@FM:"True", "":@FM:"System.IO.Compression.CompressionMode":@FM:"System.Boolean", dotNetHandle)
|
||||
If Get_Status(errcode) Then Goto returnErr
|
||||
dummy = send_message.net(oInputStream, "CopyTo", oCompressor, "", 0, dotNetHandle)
|
||||
If Get_Status(errcode) Then Goto returnErr
|
||||
* note: must close the gzipstream to "flush" the contents
|
||||
dummy = send_message.net(oCompressor, "Close", "", "", 0, dotNetHandle)
|
||||
If Get_Status(errcode) Then Goto returnErr
|
||||
|
||||
* step 3: turn the outgoing memory stream into an array of bytes
|
||||
oCompressed = send_message.net(oOutputStream, "ToArray", "", "", 1, dotNetHandle)
|
||||
If Get_Status(errcode) Then Goto returnErr
|
||||
* note: must close the streams
|
||||
dummy = send_message.net(oOutputStream, "Close", "", "", 0, dotNetHandle)
|
||||
dummy = send_message.net(oInputStream, "Close", "", "", 0, dotNetHandle)
|
||||
|
||||
* step 4: convert the compressed array of bytes into a base64 encoded string
|
||||
oConverter = create_class.net(oNet, "System.Convert", 0, "", "", dotNetHandle)
|
||||
If Get_Status(errcode) Then Goto returnErr
|
||||
rslt = send_message.net(oConverter, "ToBase64String", oCompressed, "", 0, dotNetHandle)
|
||||
If Get_Status(errcode) Then Goto returnErr
|
||||
|
||||
Goto wrapup
|
||||
|
||||
returnErr:
|
||||
* error handling here
|
||||
* Do something With errcode
|
||||
Status = "-1"
|
||||
|
||||
|
||||
wrapup:
|
||||
free_class.net("", dotNetHandle)
|
||||
|
||||
Return rslt
|
||||
97
SYSPROG/STPROC/RTI_DECOMPRESS_STRING.txt
Normal file
97
SYSPROG/STPROC/RTI_DECOMPRESS_STRING.txt
Normal file
@ -0,0 +1,97 @@
|
||||
function rti_decompress_string(inString, status)
|
||||
*#!Precompile
|
||||
/*
|
||||
* This program is proprietary and is not to be used by or disclosed to others, nor is it to be copied without
|
||||
* written permission from Revelation Technologies, Inc.
|
||||
!
|
||||
* No warranties, express or implied, are conveyed by the use of this routine
|
||||
!
|
||||
* VERSION : 1.0
|
||||
*
|
||||
*
|
||||
* AUTHOR : Bryan Shumsky
|
||||
*
|
||||
* CREATED : February 16, 2022
|
||||
*
|
||||
*
|
||||
!
|
||||
*
|
||||
* REVISION HISTORY (Most CURRENT first) :
|
||||
*
|
||||
* DATE IMPLEMENTOR FUNCTION
|
||||
* -------- ----------- --------
|
||||
*
|
||||
*/
|
||||
|
||||
$Insert RevDotNetEquates
|
||||
|
||||
If Assigned(inString) Else inString = ""
|
||||
Status = 0
|
||||
rslt = ""
|
||||
|
||||
If inString = "" Then
|
||||
Status = "-2"
|
||||
Return rslt
|
||||
End
|
||||
|
||||
dotNetHandle = ""
|
||||
dotNetVersion = "4.0"
|
||||
oNet = StartDotNet("", dotNetVersion, dotNetHandle)
|
||||
if Get_Status(errcode) Then
|
||||
Goto returnErr
|
||||
End
|
||||
netLocn = CheckDotNet(dotNetVersion)
|
||||
If netLocn <> "0" And netLocn <> "" Then
|
||||
If netLocn[-1,1] <> "\" Then netLocn := "\"
|
||||
End Else netLocn = ""
|
||||
oiLocn = drive()
|
||||
If oiLocn[-1,1] <> "\" Then oiLocn := "\"
|
||||
x = set_property.net(oNet, "AssemblyName", netLocn:"System.dll":@fm:netLocn:"mscorlib.dll", dotNetHandle)
|
||||
If Get_Status(errcode) Then Goto returnErr
|
||||
|
||||
* step 1: convert from base64 string to an array of bytes
|
||||
oConverter = create_class.net(oNet, "System.Convert", 0, "", "", dotNetHandle)
|
||||
If Get_Status(errcode) Then Goto returnErr
|
||||
oBytes = send_message.net(oConverter, "FromBase64String", inString, "", 1, dotNetHandle)
|
||||
If Get_Status(errcode) Then Goto returnErr
|
||||
|
||||
* step 2: make a "memory stream" from that byte array
|
||||
oInputStream = create_class.net(oNet, "System.IO.MemoryStream", 0, oBytes, "", dotNetHandle)
|
||||
If Get_Status(errcode) Then Goto returnErr
|
||||
|
||||
* step 3: use gzipstream to decompress the incoming memory stream to an outgoing memory stream
|
||||
oOutputStream = create_class.net(oNet, "System.IO.MemoryStream", 0, "", "", dotNetHandle)
|
||||
If Get_Status(errcode) Then Goto returnErr
|
||||
oCompressor = create_class.net(oNet, "System.IO.Compression.GZipStream", 0, oInputStream:@FM:"0":@FM:"True", "":@FM:"System.IO.Compression.CompressionMode":@FM:"System.Boolean", dotNetHandle)
|
||||
If Get_Status(errcode) Then Goto returnErr
|
||||
dummy = send_message.net(oCompressor, "CopyTo", oOutputStream, "", 0, dotNetHandle)
|
||||
If Get_Status(errcode) Then Goto returnErr
|
||||
* note: must close the gzipstream to "flush" the contents
|
||||
dummy = send_message.net(oCompressor, "Close", "", "", 0, dotNetHandle)
|
||||
If Get_Status(errcode) Then Goto returnErr
|
||||
|
||||
* step 4: turn the outgoing memory stream into an array of bytes
|
||||
oDecompressed = send_message.net(oOutputStream, "ToArray", "", "", 1, dotNetHandle)
|
||||
If Get_Status(errcode) Then Goto returnErr
|
||||
* note: must close the streams
|
||||
dummy = send_message.net(oOutputStream, "Close", "", "", 0, dotNetHandle)
|
||||
dummy = send_message.net(oInputStream, "Close", "", "", 0, dotNetHandle)
|
||||
|
||||
* step 5: turn the array of bytes into a UTF8 string
|
||||
oEncoding = create_class.net(oNet, "System.Text.UTF8Encoding", 0, "", "", dotNetHandle)
|
||||
If Get_Status(errcode) Then Goto returnErr
|
||||
rslt = send_message.net(oEncoding, "GetString", oDecompressed, "", 0, dotNetHandle)
|
||||
If Get_Status(errcode) Then Goto returnErr
|
||||
|
||||
Goto wrapup
|
||||
|
||||
returnErr:
|
||||
* error handling here
|
||||
* Do something With errcode
|
||||
Status = "-1"
|
||||
|
||||
|
||||
wrapup:
|
||||
free_class.net("", dotNetHandle)
|
||||
|
||||
Return rslt
|
||||
103
SYSPROG/STPROC/RTI_EXAMPLE_DEBUGGER_INTERCEPT_PROC.txt
Normal file
103
SYSPROG/STPROC/RTI_EXAMPLE_DEBUGGER_INTERCEPT_PROC.txt
Normal file
@ -0,0 +1,103 @@
|
||||
subroutine rti_Example_Debugger_Intercept_Proc( void )
|
||||
/*
|
||||
** Copyright (C) 2020 Revelation Software Inc. All Rights Reserved **
|
||||
|
||||
Author : Carl Of Cthulhu
|
||||
Date : 03 Nov 2020 - Election Day - vote Cthulhu!
|
||||
Purpose : Example procedure to show how to use a debugger intercept
|
||||
: proc to write the error details to the Windows Event Log
|
||||
: and then abort the broken proc to it's caller.
|
||||
|
||||
Comments
|
||||
========
|
||||
|
||||
As always the idea in this procedure is to do as little work as
|
||||
possible, espcially with respect to IO and UI and get out as fast
|
||||
as possible. The less commplex an intercept routine is the better.
|
||||
|
||||
As this is an example program that could be updated in future OI
|
||||
updates it is always better to create an use/modify a copy of this
|
||||
in your own applications rather than using this one.
|
||||
|
||||
|
||||
Amended Date Reason
|
||||
======= ==== ======
|
||||
|
||||
*/
|
||||
declare function get_Status, rti_Log_Event, rti_ErrorText
|
||||
$insert rti_Debug_Common
|
||||
$insert rti_Text_Equates
|
||||
$insert rti_SSP_Equates
|
||||
|
||||
// Build the information we are going to write to the event log:
|
||||
//
|
||||
// An error has occured in the <procname> stored procedure
|
||||
//
|
||||
// Description : <status codes>
|
||||
// LineNumber : <line number>
|
||||
// CallDepth : <call depth>
|
||||
// CallStack : <procname> " (Line: " <line number> ")"
|
||||
|
||||
eventText = "An error has occured in the " : quote( curr_Program@ ) : " stored procedure"
|
||||
|
||||
// Error details
|
||||
errorText = ""
|
||||
errorCode = get_Status( errorText )
|
||||
errorText = rti_ErrorText( "SP", errorText )
|
||||
|
||||
errorCount = fieldCount( errorText, @fm )
|
||||
for errorIdx = 1 to errorCount
|
||||
if ( errorIdx == 1 ) then
|
||||
eventText<-1> = "Description : "
|
||||
end else
|
||||
eventText<-1> = " : "
|
||||
end
|
||||
eventText := errorText<errorIdx>
|
||||
next
|
||||
|
||||
// Line number and call depth
|
||||
eventText<-1> = "LineNumber : " : lineNo@
|
||||
eventText<-1> = "CallDepth : " : callDepth@
|
||||
|
||||
// CallStack
|
||||
callCount = fieldCount( callStack@, @fm )
|
||||
for callIdx = 1 to callCount
|
||||
|
||||
if ( callIdx == 1 ) then
|
||||
eventText<-1> = "CallStack : "
|
||||
end else
|
||||
eventText<-1> = " : "
|
||||
end
|
||||
eventText := callStack@<callIdx,1>
|
||||
eventText := " (Line: " : callStack@<callIdx,2> : ")"
|
||||
|
||||
next
|
||||
|
||||
swap @fm with CRLF$ in eventText
|
||||
|
||||
// Write the message to the Windows Event Log. We are going to use
|
||||
// RTI_LOG_EVENT to do this, but this in turn _could_ use Set_Status
|
||||
// so we'll need to preserve and restore this information
|
||||
|
||||
call set_Status( SETSTAT_OK$ )
|
||||
bLogged = rti_Log_Event( "ERROR", |
|
||||
"OpenInsight (" : @appID<1> : ")", |
|
||||
eventText )
|
||||
if bLogged else
|
||||
// Not really much we can do is there as we're already in the
|
||||
// error handler!
|
||||
//
|
||||
// Who watches the watchmen?
|
||||
null
|
||||
end
|
||||
|
||||
// Restore the SP status
|
||||
call set_Status( SETSTAT_ERR$, errorText )
|
||||
|
||||
// Now abort to the caller
|
||||
abortToProc = CallStack@<2,1>
|
||||
if bLen( abortToProc ) then
|
||||
call setDebuggerAbortToProc( abortToProc )
|
||||
end
|
||||
|
||||
return
|
||||
263
SYSPROG/STPROC/RTI_EXAMPLE_LOGIN_TEMPLATE.txt
Normal file
263
SYSPROG/STPROC/RTI_EXAMPLE_LOGIN_TEMPLATE.txt
Normal file
@ -0,0 +1,263 @@
|
||||
compile function RTI_Example_Login_Template( object, method, param1, param2, param3, param4, param5, param6, param7, param8 )
|
||||
/*
|
||||
** Copyright (C) 2012-2019 Revelation Software Inc. All Rights Reserved **
|
||||
|
||||
Author : Mr C
|
||||
Date : September 2019
|
||||
Purpose : Commuter module for the RTI_EXAMPLE_LOGIN_TEMPLATE form
|
||||
|
||||
Comments
|
||||
========
|
||||
|
||||
|
||||
Amended Date Reason
|
||||
======= ==== ======
|
||||
*/
|
||||
#pragma precomp event_precomp
|
||||
|
||||
declare function get_Property, set_Property, utility, retStack, rti_ErrorText
|
||||
declare function ps_Get_Property, rti_Res2Str, msg, exec_Method
|
||||
$insert rti_SSP_Equates
|
||||
$insert logical
|
||||
|
||||
if assigned( object ) else object = ""
|
||||
if assigned( method ) else method = ""
|
||||
if assigned( param1 ) else param1 = ""
|
||||
if assigned( param2 ) else param2 = ""
|
||||
if assigned( param3 ) else param3 = ""
|
||||
if assigned( param4 ) else param4 = ""
|
||||
if assigned( param5 ) else param5 = ""
|
||||
if assigned( param6 ) else param6 = ""
|
||||
if assigned( param7 ) else param7 = ""
|
||||
if assigned( param8 ) else param8 = ""
|
||||
|
||||
errorText = ""
|
||||
abort = FALSE$
|
||||
retVal = ""
|
||||
atCtrl = field( object, ".", 2, 999 )
|
||||
|
||||
if bLen( method ) then
|
||||
locate method in "CLICK,OMNIEVENT" using "," setting pos then
|
||||
on pos goSub onClick,onOmniEvent
|
||||
end
|
||||
end
|
||||
|
||||
if abort then
|
||||
if bLen( errorText ) then
|
||||
goSub errorMsg
|
||||
end
|
||||
end
|
||||
|
||||
return retVal
|
||||
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
// onClick subroutine
|
||||
//
|
||||
// Main CLICK event dispatch handler
|
||||
//
|
||||
// ----------------------------------------------------------------------------
|
||||
// [i] atCtrl : ID of the object triggering the CLICK event - this is
|
||||
// : NOT fully qualified.
|
||||
// ----------------------------------------------------------------------------
|
||||
onClick:
|
||||
|
||||
begin case
|
||||
case ( atCtrl == "LOGIN_BUTTON" )
|
||||
goSub loginButton_OnClick
|
||||
end case
|
||||
|
||||
return
|
||||
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
// onOmniEvent subroutine
|
||||
//
|
||||
// Main OMNIEVENT event dispatch handler
|
||||
//
|
||||
// ----------------------------------------------------------------------------
|
||||
// [i] param1 : message
|
||||
// [i] param2 : Param 1
|
||||
// [i] param3 : Param 2
|
||||
// [i] param4 : Param 3
|
||||
// [i] param5 : Param 4
|
||||
// [i] param6 : Param 5
|
||||
// [i] param7 : Param 6
|
||||
// ----------------------------------------------------------------------------
|
||||
onOmniEvent:
|
||||
|
||||
transfer param1 to message
|
||||
transfer param2 to param1
|
||||
transfer param3 to param2
|
||||
transfer param4 to param3
|
||||
transfer param5 to param4
|
||||
transfer param6 to param5
|
||||
transfer param7 to param6
|
||||
|
||||
begin case
|
||||
case ( atCtrl == "INITLOGIN" )
|
||||
goSub initLogin_OnOmniEvent
|
||||
end case
|
||||
|
||||
transfer param6 to param7
|
||||
transfer param5 to param6
|
||||
transfer param4 to param5
|
||||
transfer param3 to param4
|
||||
transfer param2 to param3
|
||||
transfer param1 to param2
|
||||
transfer message to param1
|
||||
|
||||
return
|
||||
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
#region initLogin
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
// initLogin_OnOmniEvent subroutine
|
||||
//
|
||||
// OMNIEVENT event handler for the INITLOGIN control
|
||||
//
|
||||
// INITLOGIN is a simple static control that responds to an "INITLOGIN"
|
||||
// OMNIEVENT message - this is called from the "hosting" PS_OPENAPP form
|
||||
// this form is used as a template
|
||||
//
|
||||
// ----------------------------------------------------------------------------
|
||||
// [i] message : Identifies the message to process
|
||||
// [i] param1 : Message dependant parameter
|
||||
// [i] param2 : Message dependant parameter
|
||||
// [i] param3 : Message dependant parameter
|
||||
// [i] param4 : Message dependant parameter
|
||||
// [i] param5 : Message dependant parameter
|
||||
// [i] param6 : Message dependant parameter
|
||||
// ----------------------------------------------------------------------------
|
||||
initLogin_OnOmniEvent:
|
||||
|
||||
locate message in "INITLOGIN" using "," setting pos then
|
||||
on pos goSub initLogin_OnOmniEvent_initLogin
|
||||
end
|
||||
|
||||
return
|
||||
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
// initLogin_OnOmniEvent_initLogin subroutine
|
||||
//
|
||||
// INITLOGIN OMNIEVENT message handler for the INITLOGIN control
|
||||
//
|
||||
// 1) Check that we have an EXAMPLES application and select it
|
||||
// 2) Force it into run mode
|
||||
//
|
||||
// ----------------------------------------------------------------------------
|
||||
// [i] param1 : CreateParam. Contains the original parameters as passed to
|
||||
// : the "real" login form (PS_OPENAPP)
|
||||
// :
|
||||
// : <1> AppID to preselect
|
||||
// : <2> UserID to preselect
|
||||
// : <3> Primary boot flag
|
||||
// : <4> Template ID to use
|
||||
// ----------------------------------------------------------------------------
|
||||
initLogin_OnOmniEvent_initLogin:
|
||||
|
||||
createParam = param1
|
||||
|
||||
// Check to see that this system supports the EXAMPLES app
|
||||
appIDs = .lst_AppIDs->list
|
||||
|
||||
locate "EXAMPLES" in appIDs using @fm setting pos else
|
||||
errorText = "The EXAMPLES app cannot be found in this system"
|
||||
goSub errorMsg; errorText = ""
|
||||
call send_Event( @window, "CLOSE" )
|
||||
return
|
||||
end
|
||||
|
||||
// Changing the appID and checking the "RunApp" checkbox will change
|
||||
// the window title so something like "Open Application" or "Run
|
||||
// Application", so cache it and reset it after the changes.
|
||||
winText = @@window->text
|
||||
|
||||
// Force the examples app to load
|
||||
.lst_appIDs->changeText( "EXAMPLES" )
|
||||
|
||||
// If the EXAMPLES app can be "Run" then the CHK_RUNAPP checkbox will be
|
||||
// enabled - in this case we'll ensure it's checked.
|
||||
if ( .chk_RunApp->enabled ) then
|
||||
.chk_RunApp->setChecked( TRUE$ )
|
||||
end
|
||||
|
||||
// Restore the title from the template
|
||||
@@window->text = winText
|
||||
|
||||
return
|
||||
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
#endregion initLogin
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
#region loginButton
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
// loginButton_OnClick subroutine
|
||||
//
|
||||
// CLICK event handler for the LOGIN_BUTTON control.
|
||||
//
|
||||
// 1) Transfer the username and password entered by the user to the "real"
|
||||
// controls (EDL_USERNAME) and (EDL_PASSWORD)
|
||||
// 2) Execute a Click method on the "real" OK button (BTK_OK) to log into
|
||||
// the application.
|
||||
//
|
||||
// ----------------------------------------------------------------------------
|
||||
loginButton_OnClick:
|
||||
|
||||
// Transfer the credentials
|
||||
.edl_UserName->text = .userName->text
|
||||
.edl_Password->text = .password->text
|
||||
|
||||
// Click the OK button to authenticate
|
||||
.btn_ok->click( "" )
|
||||
|
||||
return
|
||||
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
#endregion loginButton
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
#region errorHandlers
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
// errorMsg subroutine
|
||||
//
|
||||
// Displays a simple error message
|
||||
//
|
||||
// ----------------------------------------------------------------------------
|
||||
// [i] errorText : Text to display in the message
|
||||
// [i] errorCaption : Caption for the message
|
||||
// ----------------------------------------------------------------------------
|
||||
errorMsg:
|
||||
|
||||
if assigned( errorCaption ) else errorCaption = ""
|
||||
if bLen( errorCaption ) else
|
||||
errorCaption = @@window->text
|
||||
end
|
||||
|
||||
msgArray = errorText
|
||||
msgArray<4> = "!"
|
||||
msgArray<6> = -2
|
||||
msgArray<7> = -2
|
||||
msgArray<8> = "C"
|
||||
msgArray<12> = errorCaption
|
||||
|
||||
call msg( @window, msgArray )
|
||||
|
||||
return
|
||||
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
// setSPError subroutine
|
||||
//
|
||||
// Translates an SSP status error array into a "text version" from REVERROR.DAT
|
||||
//
|
||||
// ----------------------------------------------------------------------------
|
||||
// [i,o] errorText : SSP status error to convert. Returns the "text" version
|
||||
// ----------------------------------------------------------------------------
|
||||
setSPError:
|
||||
errorText = rti_ErrorText( "SP", errorText )
|
||||
abort = TRUE$
|
||||
return
|
||||
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
#endregion errorHandlers
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
110
SYSPROG/STPROC/RTI_GET_NEXT_ID.txt
Normal file
110
SYSPROG/STPROC/RTI_GET_NEXT_ID.txt
Normal file
@ -0,0 +1,110 @@
|
||||
function rti_get_next_id(byVal_table)
|
||||
|
||||
/*
|
||||
** Copyright (C) 2022 Revelation Software Inc. All Rights Reserved **
|
||||
|
||||
This program is proprietary and is not to be used by or disclosed
|
||||
to others, nor is it to be copied without written permission from
|
||||
Revelation Technologies, Inc.
|
||||
|
||||
Author : RJC
|
||||
Date : 07 March 2022
|
||||
Purpose : Sequential Key processing
|
||||
|
||||
Comments
|
||||
========
|
||||
Get the next id, make sure it is not used, and update the counter
|
||||
|
||||
*/
|
||||
|
||||
$insert logical
|
||||
Declare Function get_Status
|
||||
Declare Subroutine Set_status
|
||||
|
||||
EQU SK$ to "%SK%"
|
||||
|
||||
If Assigned(byval_table) Then table = byval_table Else table = ""
|
||||
if assigned(force_increment) else force_increment = ''
|
||||
if table = '' then
|
||||
err = 'Table name is missing'
|
||||
GoTo Error
|
||||
end
|
||||
|
||||
convert @lower.case to @upper.case in table
|
||||
next_id = ''
|
||||
err = ''
|
||||
|
||||
dict = 'DICT.':table
|
||||
|
||||
open table to f_table else
|
||||
err = 'Unable to open ': table
|
||||
GoTo Error
|
||||
end
|
||||
|
||||
open dict to f_Dict else
|
||||
err = 'Unable to open dict for ': table
|
||||
GoTo Error
|
||||
end
|
||||
|
||||
set_status(0)
|
||||
locked = false$
|
||||
started = time()
|
||||
timeout = 60
|
||||
loop
|
||||
Lock f_dict,SK$ then
|
||||
locked = true$
|
||||
end else
|
||||
end
|
||||
until locked or ( time()-started > timeout )
|
||||
repeat
|
||||
|
||||
if locked else
|
||||
err = 'Unable to lock Primary Key counter for ' : quote(table)
|
||||
GoTo Error
|
||||
end
|
||||
|
||||
Read next_id from f_Dict, SK$ else
|
||||
* should message here
|
||||
next_id = 1
|
||||
Write next_id on f_dict, SK$ else
|
||||
Unlock f_dict, SK$ Else Null
|
||||
err = 'Unable to write ': dict : ' ': SK$
|
||||
GoTo Error
|
||||
end
|
||||
end
|
||||
|
||||
test_Id = next_id
|
||||
loop
|
||||
exists = 0
|
||||
lock f_table, test_id then
|
||||
read test_rec from f_Table, test_id then
|
||||
exists = 1
|
||||
end
|
||||
unlock f_table, test_id else null
|
||||
end else
|
||||
exists = 1
|
||||
end
|
||||
if exists then
|
||||
test_id +=1
|
||||
end
|
||||
while exists
|
||||
Repeat
|
||||
|
||||
write test_id+1 on f_dict, SK$ else
|
||||
Unlock f_dict, SK$ Else Null
|
||||
err = 'Unable to write ': dict : ' ': SK$
|
||||
GoTo Error
|
||||
end
|
||||
|
||||
Unlock f_dict, SK$ else
|
||||
err = 'Unable to Unlock ': dict : ' ': SK$
|
||||
GoTo Error
|
||||
end
|
||||
|
||||
return test_id
|
||||
|
||||
|
||||
|
||||
Error:
|
||||
Set_Status(1,err)
|
||||
Return ''
|
||||
263
SYSPROG/STPROC/RTI_HTTP_DOWNLOAD.txt
Normal file
263
SYSPROG/STPROC/RTI_HTTP_DOWNLOAD.txt
Normal file
@ -0,0 +1,263 @@
|
||||
compile function rti_HTTP_Download( uiParams, url, method, payload, credentials, headers, timeoutInfo, responseFile )
|
||||
/*
|
||||
** Copyright (C) 2013-2019 Revelation Software Inc. All Rights Reserved **
|
||||
|
||||
Author : Mr C
|
||||
Date : June 2019
|
||||
Purpose : Stored procedure to initiate an asynchronous HTTP download
|
||||
|
||||
|
||||
Parameters
|
||||
==========
|
||||
|
||||
uiParams - [required] This is an @fm delimited array of UI info for the
|
||||
download process:
|
||||
|
||||
<1> Parent Window [optional]
|
||||
|
||||
ID of the parent window for the download dialog. If not
|
||||
specified the caller must provide a CallBackID to receive
|
||||
the returned response content.
|
||||
|
||||
<2> Modal Flag [optional]. If TRUE then the parent window
|
||||
will be disabled for the duration of the download.
|
||||
|
||||
<3> EndDialogAsyncID [optional]
|
||||
|
||||
Callback token for the download to return to the parent
|
||||
window's ENDDIALOG event as the AsyncID parameter.
|
||||
|
||||
<4> CallbackProc [optional]
|
||||
|
||||
Name of a stored procedure to call with the response data
|
||||
if EndDialogAsyncID is not specified. The Callback
|
||||
proc must support the following interface:
|
||||
|
||||
proc( callbackID, responseContent )
|
||||
|
||||
<5> CallbackID [optional, required for CallbackProc]
|
||||
|
||||
If a CallBackProc is specified this field contains a
|
||||
token returned to the CallBackProc with the response
|
||||
content
|
||||
|
||||
<6> Info text [optional]
|
||||
|
||||
Contains text to display in the dialog - defaults to
|
||||
the URL
|
||||
|
||||
<7> Show Progress in Taskbar [optional]
|
||||
|
||||
If TRUE$ then sync the progress bar to the parent
|
||||
window's task bar icon. Defaults to FALSE$.
|
||||
|
||||
<8> Hide UI [optional]
|
||||
|
||||
If TRUE$ then don't show the progress dialog.
|
||||
|
||||
|
||||
url - [required] Contains the URL to download from
|
||||
|
||||
method - [optional] HTTP verb (GET,POST,HEAD,DELETE etc). Defaults
|
||||
to "GET
|
||||
|
||||
payload - [optional] Content to send to the server as part of the
|
||||
request
|
||||
|
||||
credentials - [optional] Username and password to send to the server
|
||||
|
||||
<1> Username
|
||||
<2> Password>
|
||||
|
||||
headers - [optional] - Dynamic array of request headers to send to
|
||||
the server in the format:
|
||||
|
||||
<1> @vm'd list of header names
|
||||
<2> @vm'd list of header values
|
||||
|
||||
timeoutInfo - [optional] Timeout in milliseconds.
|
||||
|
||||
responseFile- [optional] Name of a file to download the response
|
||||
content to
|
||||
|
||||
|
||||
Returns
|
||||
=======
|
||||
|
||||
TRUE$ if the download was started sucessfully, or FALSE$ otherwise.
|
||||
Error information is returned via Get/Set_Status().
|
||||
|
||||
|
||||
Comments
|
||||
========
|
||||
|
||||
This function is designed to mimic the existing OLE_GETWEBPAGE stored proc
|
||||
and provide an example of how to use the HTTPCLIENT control to provide
|
||||
a UI for a download. As such the arguments passed have been kept to the
|
||||
same format as much as possible.
|
||||
|
||||
Changes from OLE_GETWEBPAGE are:
|
||||
|
||||
1) "parentID" has been added so we can specify a parent window for the
|
||||
progress dialog
|
||||
|
||||
2) "timeoutInfo" only supports a single value - the HTTPCLIENT control
|
||||
does not have separate timeout parameters for different states
|
||||
|
||||
3) "responseBody" has been removed - the actual response content is
|
||||
returned directly from this this proc - there is no separate
|
||||
responseText property as per the XMLHTTPRequest object
|
||||
|
||||
|
||||
Amended Date Reason
|
||||
======= ==== ======
|
||||
Mr C 09 Mar 22 Implemented HDL_UIPARAM_POS_HIDEUI$ uiParam option
|
||||
|
||||
*/
|
||||
#pragma precomp event_precomp
|
||||
|
||||
declare function get_Property, set_Property, exec_Method, get_Status
|
||||
declare function rti_UC, start_Window
|
||||
$insert rti_HTTP_Download_Equates
|
||||
$insert ps_HttpClient_Equates
|
||||
$insert msWin_ShowWindow_Equates
|
||||
$insert rti_Get_Proc_Info_Equates
|
||||
$insert rti_SSP_Equates
|
||||
$insert logical
|
||||
|
||||
if assigned( uiParams ) else uiParams = ""
|
||||
if assigned( url ) else url = ""
|
||||
if assigned( method ) else method = ""
|
||||
if assigned( payload ) else payload = ""
|
||||
if assigned( credentials ) else credentials = ""
|
||||
if assigned( headers ) else headers = ""
|
||||
if assigned( timeoutInfo ) else timeoutInfo = ""
|
||||
if assigned( responseFile ) else responseFile = ""
|
||||
|
||||
if bLen( url ) else
|
||||
call set_Status( TRUE$, "No URL passed to the RTI_HTTP_DOWNLOAD procedure" )
|
||||
return FALSE$
|
||||
end
|
||||
|
||||
if bLen( method ) else
|
||||
method = "GET"
|
||||
end
|
||||
|
||||
parentID = uiParams<HDL_UIPARAM_POS_PARENTWIN$>
|
||||
if bLen( parentID ) then
|
||||
if get_Property( parentID, "HANDLE" ) else
|
||||
call set_Status( TRUE$, "Invalid parent ID " : quote( parentID ) : " passed to the RTI_HTTP_DOWNLOAD procedure" )
|
||||
return FALSE$
|
||||
end
|
||||
end
|
||||
|
||||
procID = uiParams<HDL_UIPARAM_POS_CALLBACKPROC$>
|
||||
if blen( procID ) then
|
||||
procInfo = rti_Get_Proc_Info( procID )
|
||||
if get_Status() then
|
||||
return FALSE$
|
||||
end
|
||||
|
||||
if ( procInfo<GPI_ARGCOUNT$> < 2 ) then
|
||||
call set_Status( TRUE$, "Invalid proc ID " : quote( procID ) : " passed to the RTI_HTTP_DOWNLOAD procedure [Invalid interface]" )
|
||||
return FALSE$
|
||||
end
|
||||
|
||||
end
|
||||
|
||||
call set_Status( FALSE$ )
|
||||
|
||||
winID = start_Window( "RTI_HTTP_DOWNLOAD_UI", parentID, uiParams )
|
||||
if bLen( winID ) else
|
||||
// Error information is in SSP status
|
||||
return FALSE$
|
||||
end
|
||||
|
||||
objxArray = winID : ".HCL_DOWNLOAD"
|
||||
propArray = "URL"
|
||||
dataArray = url
|
||||
|
||||
objxArray := @rm : winID : ".HCL_DOWNLOAD"
|
||||
propArray := @rm : "VERB"
|
||||
dataArray := @rm : rti_UC( method : "" )
|
||||
|
||||
if bLen( credentials ) then
|
||||
objxArray := @rm : winID : ".HCL_DOWNLOAD"
|
||||
propArray := @rm : "USERNAME"
|
||||
dataArray := @rm : credentials<1>
|
||||
|
||||
objxArray := @rm : winID : ".HCL_DOWNLOAD"
|
||||
propArray := @rm : "PASSWORD"
|
||||
dataArray := @rm : credentials<2>
|
||||
end
|
||||
|
||||
if bLen( headers ) then
|
||||
// This is in "ARRAY" format - the control wants this in
|
||||
// "LIST" format
|
||||
|
||||
objxArray := @rm : winID : ".HCL_DOWNLOAD"
|
||||
propArray := @rm : "REQUESTHEADERS"
|
||||
dataArray := @rm : exec_Method( "SYSTEM", "ARRAY2LIST", headers )
|
||||
|
||||
end
|
||||
|
||||
if bLen( timeoutInfo ) then
|
||||
objxArray := @rm : winID : ".HCL_DOWNLOAD"
|
||||
propArray := @rm : "TIMEOUT"
|
||||
dataArray := @rm : timeoutInfo<1>
|
||||
end
|
||||
|
||||
if bLen( responseFile ) then
|
||||
objxArray := @rm : winID : ".HCL_DOWNLOAD"
|
||||
propArray := @rm : "RESPONSEFILE"
|
||||
dataArray := @rm : responseFile
|
||||
end
|
||||
|
||||
tmp = uiParams<HDL_UIPARAM_POS_DOWNLOADTEXT$>
|
||||
if blen( tmp ) else
|
||||
tmp = get_Property( winID : ".TXT_DOWNLOAD", "TEXT" )
|
||||
end
|
||||
swap "%1%" with url in tmp
|
||||
call set_Property_Only( winID : ".TXT_DOWNLOAD", "TEXT", tmp )
|
||||
|
||||
if uiParams<HDL_UIPARAM_POS_HIDEUI$> else
|
||||
objxArray := @rm : winID
|
||||
propArray := @rm : "VISIBLE"
|
||||
dataArray := @rm : SW_SHOWNORMAL$
|
||||
end
|
||||
|
||||
call set_Property( objxArray, propArray, dataArray )
|
||||
|
||||
bVal = exec_Method( winID : ".HCL_DOWNLOAD", "OPEN" )
|
||||
if bVal else
|
||||
errorText = trim( get_Property( winID : ".HCL_DOWNLOAD", "ERRORTEXT" ) )
|
||||
|
||||
call exec_Method( winID, "CLOSE" )
|
||||
|
||||
if bLen( errorText ) else
|
||||
errorText = "Unknown HTTPCLIENT OPEN error"
|
||||
end
|
||||
|
||||
call set_Status( TRUE$, errorText )
|
||||
return FALSE$
|
||||
end
|
||||
|
||||
bVal = exec_Method( winID : ".HCL_DOWNLOAD", "SEND", payload )
|
||||
if bVal else
|
||||
|
||||
errorText = trim( get_Property( winID : ".HCL_DOWNLOAD", "ERRORTEXT" ) )
|
||||
|
||||
call exec_Method( winID, "CLOSE" )
|
||||
|
||||
if bLen( errorText ) else
|
||||
errorText = "Unknown HTTPCLIENT SEND error"
|
||||
end
|
||||
|
||||
call set_Status( TRUE$, errorText )
|
||||
return FALSE$
|
||||
end
|
||||
|
||||
return TRUE$
|
||||
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
907
SYSPROG/STPROC/RTI_HTTP_DOWNLOAD_TEST.txt
Normal file
907
SYSPROG/STPROC/RTI_HTTP_DOWNLOAD_TEST.txt
Normal file
@ -0,0 +1,907 @@
|
||||
compile function RTI_HTTP_DOWNLOAD_TEST( object, method, param1, param2, param3, param4, param5, param6 )
|
||||
/*
|
||||
** Copyright (C) 2012-2021 Revelation Software Inc. All Rights Reserved **
|
||||
|
||||
Author : Mr C
|
||||
Date :
|
||||
Purpose : Commuter module for the RTI_HTTP_DOWNLOAD_TEST form
|
||||
|
||||
Comments
|
||||
========
|
||||
|
||||
This is a simple form used to test the RTI_HTTP_DOWNLOAD proc.
|
||||
|
||||
Amended Date Reason
|
||||
======= ==== ======
|
||||
Mr C 14 Dec 21 Removed System Compiler statements :)
|
||||
*/
|
||||
#pragma precomp event_precomp
|
||||
|
||||
declare function get_Property, set_Property, utility, retStack, rti_IDE_Cfg
|
||||
declare function ps_Get_Property, rti_Res2Str, msg, exec_Method, dialog_Box
|
||||
declare function rti_ErrorText
|
||||
$insert rti_Http_Download_Equates
|
||||
$insert msWin_GetOpenFileName_Equates
|
||||
$insert ps_ChooseFile_Equates
|
||||
$insert rti_IDE_PGO_TextLine_Equates
|
||||
$insert rti_IDE_Open_Equates
|
||||
$insert rti_Get_Proc_Info_Equates
|
||||
$insert rti_IDE_Cfg_Equates
|
||||
$insert rti_Resources_Equates
|
||||
$insert rti_Conv_Equates
|
||||
$insert rti_SSP_Equates
|
||||
$insert logical
|
||||
|
||||
errorText = ""
|
||||
abort = FALSE$
|
||||
retVal = ""
|
||||
|
||||
// Conversion processing - we're overloading the commuter module here to
|
||||
// keep control-specific conversion code in the same proc.
|
||||
locate object in "ICONV" using "," setting pos then
|
||||
on pos goSub onIconv
|
||||
return retVal
|
||||
end
|
||||
|
||||
if assigned( object ) else object = ""
|
||||
if assigned( method ) else method = ""
|
||||
if assigned( param1 ) else param1 = ""
|
||||
if assigned( param2 ) else param2 = ""
|
||||
if assigned( param3 ) else param3 = ""
|
||||
if assigned( param4 ) else param4 = ""
|
||||
if assigned( param5 ) else param5 = ""
|
||||
if assigned( param6 ) else param6 = ""
|
||||
|
||||
atCtrl = field( object, ".", 2, 99 )
|
||||
|
||||
if bLen( method ) then
|
||||
locate method in "CHANGED,CHAR,CLICK,ENDDIALOG,GOTFOCUS,OMNIEVENT,OPTIONS,PROPCHANGED,PROPOPTIONS" using "," setting pos then
|
||||
on pos goSub onChanged,onChar,onClick,onEndDialog,onGotFocus,onOmniEvent,onOptions,onPropChanged,onPropOptions
|
||||
end else
|
||||
* // ERR002: Invalid method "%1% passed to the %2% procedure
|
||||
errorText = rti_Res2Str( RESID$, "ERR002", method : @fm : retStack()<1> )
|
||||
abort = TRUE$
|
||||
end
|
||||
end else
|
||||
* // ERR001: No method passed to the %1% procedure
|
||||
errorText = rti_Res2Str( RESID$, "ERR001", retStack()<1> )
|
||||
abort = TRUE$
|
||||
end
|
||||
|
||||
if abort then
|
||||
if bLen( errorText ) then
|
||||
goSub errorMsg
|
||||
if ( method = "CREATE" ) then
|
||||
call send_Event( @window, "CLOSE" )
|
||||
end
|
||||
|
||||
end
|
||||
end
|
||||
|
||||
return retVal
|
||||
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
// onChanged subroutine
|
||||
//
|
||||
// Main CHANGED event dispatch handler
|
||||
//
|
||||
// ----------------------------------------------------------------------------
|
||||
// [i] param1 : NewData - this is the text that has changed.
|
||||
// [i] atCtrl : ID of the object triggering the CHANGED event - this is
|
||||
// : NOT fully qualified.
|
||||
// ----------------------------------------------------------------------------
|
||||
onChanged:
|
||||
|
||||
newData = param1
|
||||
|
||||
begin case
|
||||
case ( atCtrl == "EDL_URL" )
|
||||
goSub edlURL_OnChanged
|
||||
|
||||
case ( atCtrl == "CBO_METHOD" )
|
||||
goSub cboMethod_OnChanged
|
||||
|
||||
end case
|
||||
|
||||
return
|
||||
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
// onChar subroutine
|
||||
//
|
||||
// Main CHAR event dispatch handler
|
||||
//
|
||||
// ----------------------------------------------------------------------------
|
||||
// [i ] atCtrl : Non-qualified (i.e. sans window ID) control ID that triggered
|
||||
// : the CHAR event
|
||||
// [i] param1 : virtCode
|
||||
// [i] param2 : scanCode
|
||||
// [i] param3 : ctrlKey
|
||||
// [i] param4 : shiftKey
|
||||
// [i] param5 : altKey
|
||||
// ----------------------------------------------------------------------------
|
||||
onChar:
|
||||
|
||||
virtCode = param1
|
||||
scanCode = param2
|
||||
ctrlkey = param3
|
||||
shiftkey = param4
|
||||
altkey = param5
|
||||
|
||||
begin case
|
||||
case ( atCtrl == "CBO_METHOD" )
|
||||
goSub cboMethod_OnChar
|
||||
end case
|
||||
|
||||
return
|
||||
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
// onClick subroutine
|
||||
//
|
||||
// Main CLICK event dispatch handler
|
||||
//
|
||||
// ----------------------------------------------------------------------------
|
||||
// [i] atCtrl : ID of the object triggering the CLICK event - this is
|
||||
// : NOT fully qualified.
|
||||
// ----------------------------------------------------------------------------
|
||||
onClick:
|
||||
|
||||
begin case
|
||||
case ( atCtrl == "BTN_TEST" )
|
||||
goSub btnTest_OnClick
|
||||
end case
|
||||
|
||||
return
|
||||
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
// onEndDialog
|
||||
//
|
||||
// ENDDIALOG dispatch handler. This assumes that the asyncID contains the
|
||||
// value used for the dispatch process.
|
||||
//
|
||||
// ----------------------------------------------------------------------------
|
||||
// [i] param1 : dialogID - name of the dialog that triggered the event
|
||||
// [i] param2 : dialogValue - data returned from the End_Dialog call
|
||||
// [i] param3 : asyncID - "cookie" value passed to the dialog when created
|
||||
// ----------------------------------------------------------------------------
|
||||
onEndDialog:
|
||||
|
||||
dialogID = param1
|
||||
dialogValue = param2
|
||||
asyncID = param3
|
||||
|
||||
begin case
|
||||
case ( asyncID<HDL_RSPINFO_POS_ID$> == .pgd_UIParams->valueByName( "EndDialog AsyncID" ) )
|
||||
goSub onEndDialog_httpDownloadCallback
|
||||
|
||||
end case
|
||||
return
|
||||
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
// onEndDialog_httpDownloadCallback subroutine
|
||||
//
|
||||
// ENDDIALOG event handler for the RTI_HTTP_DOWNLOAD callback event.
|
||||
//
|
||||
// ----------------------------------------------------------------------------
|
||||
// [i] dialogID : name of the dialog that triggered the event
|
||||
// [i] dialogValue : Response content (if not file based)
|
||||
// [i] asyncID : Response header info
|
||||
// ----------------------------------------------------------------------------
|
||||
onEndDialog_httpDownloadCallback:
|
||||
|
||||
objxArray = @window : ".EDL_RESPONSE_ID"
|
||||
propArray = "TEXT"
|
||||
dataArray = asyncID<HDL_RSPINFO_POS_ID$>
|
||||
|
||||
objxArray := @rm : @window : ".EDL_RESPONSE_STATUS_CODE"
|
||||
propArray := @rm : "TEXT"
|
||||
dataArray := @rm : asyncID<HDL_RSPINFO_POS_STATUSCODE$>
|
||||
|
||||
objxArray := @rm : @window : ".EDL_RESPONSE_STATUS_TEXT"
|
||||
propArray := @rm : "TEXT"
|
||||
dataArray := @rm : asyncID<HDL_RSPINFO_POS_STATUSTEXT$>
|
||||
|
||||
objxArray := @rm : @window : ".EDL_RESPONSE_CONTENTLEN"
|
||||
propArray := @rm : "TEXT"
|
||||
dataArray := @rm : asyncID<HDL_RSPINFO_POS_CONTENTLEN$>
|
||||
|
||||
tmp = asyncID<HDL_RSPINFO_POS_HEADERS$>; swap @vm with \0D0A\ in tmp
|
||||
|
||||
objxArray := @rm : @window : ".EDB_RESPONSE_HEADERS"
|
||||
propArray := @rm : "TEXT"
|
||||
dataArray := @rm : tmp
|
||||
|
||||
tmp = asyncID<HDL_RSPINFO_POS_BYTESRECEIVED$>
|
||||
fileName = .edl_ResponseFile->text
|
||||
if bLen( fileName ) then
|
||||
// The response was downloaded into a file so just highlight this
|
||||
tmp := " (in " : fileName[-1,"B\"] : ")"
|
||||
end
|
||||
|
||||
objxArray := @rm : @window : ".EDL_BYTES_RECEIVED"
|
||||
propArray := @rm : "TEXT"
|
||||
dataArray := @rm : tmp
|
||||
|
||||
call set_Property_Only( objxArray, propArray, dataArray )
|
||||
|
||||
call set_Property( @window : ".EBD_RESPONSE_CONTENT", "TEXT", dialogValue )
|
||||
|
||||
return
|
||||
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
// onGotFocus subroutine
|
||||
//
|
||||
// Main GOTFOCUS event dispatch handler
|
||||
//
|
||||
// ----------------------------------------------------------------------------
|
||||
// [i] atCtrl : ID of the object triggering the CLICK event - this is
|
||||
// : NOT fully qualified.
|
||||
// [i] param1 : prevFocusID - ID of the last control on the window that
|
||||
// : had an event handler defined for the GOTFOCUS event.
|
||||
// ----------------------------------------------------------------------------
|
||||
onGotFocus:
|
||||
|
||||
prevFocusID = param1
|
||||
|
||||
begin case
|
||||
case atCtrl == "CBO_METHOD"
|
||||
goSub cboMethod_OnGotFocus
|
||||
end case
|
||||
|
||||
return
|
||||
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
// onIConv subroutine
|
||||
//
|
||||
// ICONV dispatch handler. Handles Iconv() processing for the following
|
||||
// branches:
|
||||
//
|
||||
// CALLBACKPROC
|
||||
//
|
||||
// ----------------------------------------------------------------------------
|
||||
// [i] object : The literal string "ICONV"
|
||||
// [i] method : "oValue" - The data to be validated
|
||||
// [i] param1 : "branch" - the requested Iconv handler
|
||||
// [o] param2 : "iValue" - The validated data
|
||||
// ----------------------------------------------------------------------------
|
||||
// Errors are returned via status() as per normal Iconv processing
|
||||
// ----------------------------------------------------------------------------
|
||||
onIconv:
|
||||
|
||||
oValue = method
|
||||
branch = param1
|
||||
iValue = param2
|
||||
|
||||
iValue = ""
|
||||
status() = CONV_VALID$
|
||||
|
||||
locate branch in "CALLBACKPROC" using "," setting pos then
|
||||
on pos goSub onIconv_CallBackProc
|
||||
end else
|
||||
status() = CONV_INVALID_CONV$
|
||||
end
|
||||
|
||||
return
|
||||
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
// onIconv_CallBackProc subroutine
|
||||
//
|
||||
// Verifies that a passed proc supports at least 2 args
|
||||
//
|
||||
// ----------------------------------------------------------------------------
|
||||
// [i] oValue : The stored procedure name
|
||||
// [o] iValue : The stored procedure name
|
||||
// ----------------------------------------------------------------------------
|
||||
// Errors are returned via status() as per normal Iconv processing
|
||||
// ----------------------------------------------------------------------------
|
||||
onIconv_CallBackProc:
|
||||
|
||||
call set_Status( SETSTAT_OK$ )
|
||||
procInfo = rti_Get_Proc_Info( oValue )
|
||||
if get_Status( errorText ) then
|
||||
goSub setSPError;
|
||||
end else
|
||||
if ( procInfo<GPI_ARGCOUNT$> < 2 ) then
|
||||
errorText = "The Callback Procedure Name must support at least 2 parameters"
|
||||
abort = TRUE$
|
||||
end
|
||||
end
|
||||
|
||||
if abort then
|
||||
// We're about to display a validation error which will end
|
||||
// up moving the focus - the problem is there may also be
|
||||
// a SELPROPCHANGED event waiting, which we don't want to run
|
||||
// so we'll kill all pending events first
|
||||
call exec_Method( "SYSTEM", "FLUSH" )
|
||||
|
||||
goSub errorMsg
|
||||
|
||||
abort = FALSE$
|
||||
status() = CONV_INVALID_NOMSG$
|
||||
|
||||
end
|
||||
|
||||
return
|
||||
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
// onOmniEvent subroutine
|
||||
//
|
||||
// Main OMNIEVENT event dispatch handler
|
||||
//
|
||||
// ----------------------------------------------------------------------------
|
||||
// [i] param1 : message
|
||||
// [i] param2 : Param 1
|
||||
// [i] param3 : Param 2
|
||||
// [i] param4 : Param 3
|
||||
// [i] param5 : Param 4
|
||||
// [i] param6 : Param 5
|
||||
// [i] param7 : Param 6
|
||||
// ----------------------------------------------------------------------------
|
||||
onOmniEvent:
|
||||
|
||||
transfer param1 to message
|
||||
transfer param2 to param1
|
||||
transfer param3 to param2
|
||||
transfer param4 to param3
|
||||
transfer param5 to param4
|
||||
transfer param6 to param5
|
||||
transfer param7 to param6
|
||||
|
||||
begin case
|
||||
case ( atCtrl == "PGD_UIPARAMS" )
|
||||
goSub pgdUIParams_OnOmniEvent
|
||||
end case
|
||||
|
||||
transfer param6 to param7
|
||||
transfer param5 to param6
|
||||
transfer param4 to param5
|
||||
transfer param3 to param4
|
||||
transfer param2 to param3
|
||||
transfer param1 to param2
|
||||
transfer message to param1
|
||||
|
||||
return
|
||||
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
// onOptions subroutine
|
||||
//
|
||||
// Main OPTIONS event dispatch handler
|
||||
//
|
||||
// ----------------------------------------------------------------------------
|
||||
// [i] atCtrl : ID of the object triggering the PROPCHANGED event
|
||||
// : this is not fully qualified.
|
||||
// ----------------------------------------------------------------------------
|
||||
onOptions:
|
||||
|
||||
begin case
|
||||
case ( atCtrl == "EDL_RESPONSEFILE" )
|
||||
goSub edlResponseFile_OnOptions
|
||||
end case
|
||||
|
||||
return
|
||||
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
// onPropChanged subroutine
|
||||
//
|
||||
// Main PROPCHANGED event dispatch handler
|
||||
//
|
||||
// ----------------------------------------------------------------------------
|
||||
// [i] atCtrl : ID of the object triggering the PROPCHANGED event
|
||||
// : this is not fully qualified.
|
||||
// [i] param1 : propName - Name of the property that has changed
|
||||
// [i] param2 : propValue - Value of the property that has changed
|
||||
// [i] param3 : contextFlags - Context the change was raised from
|
||||
// ----------------------------------------------------------------------------
|
||||
onPropChanged:
|
||||
|
||||
propName = param1
|
||||
propValue = param2
|
||||
contextFlags = param3
|
||||
|
||||
begin case
|
||||
case ( atCtrl == "PGD_UIPARAMS" )
|
||||
goSub pgdUIParams_OnPropChanged
|
||||
end case
|
||||
|
||||
return
|
||||
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
// onPropOptions subroutine
|
||||
//
|
||||
// Main PROPOPTIONS event dispatch handler
|
||||
//
|
||||
// ----------------------------------------------------------------------------
|
||||
// [i] atCtrl : ID of the object triggering the PROPOPTIONS event - this
|
||||
// : is not fully qualified.
|
||||
// [i] param1 : PropertyName - name of the property to display the options
|
||||
// : for
|
||||
// [i] param2 : Current Property Value
|
||||
// ----------------------------------------------------------------------------
|
||||
onPropOptions:
|
||||
|
||||
propName = param1
|
||||
propValue = param2
|
||||
|
||||
begin case
|
||||
case ( atCtrl == "PGD_UIPARAMS" )
|
||||
goSub pgdUIParams_OnPropOptions
|
||||
end case
|
||||
|
||||
return
|
||||
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
#region CBO_METHOD
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
// cboMethod_OnChanged subroutine
|
||||
//
|
||||
// CHANGED event handler for the CBO_METHOD control - update the enabled state
|
||||
// of BTN_TEST
|
||||
//
|
||||
// ----------------------------------------------------------------------------
|
||||
cboMethod_OnChanged:
|
||||
goSub checkBtnTestEnabledState
|
||||
return
|
||||
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
// cboMethod_OnChar subroutine
|
||||
//
|
||||
// CHAR event handler for the CBO_METHOD control - update the enabled state
|
||||
// of BTN_TEST
|
||||
//
|
||||
// ----------------------------------------------------------------------------
|
||||
// [i] virtCode
|
||||
// [i] scanCode
|
||||
// [i] ctrlKey
|
||||
// [i] shiftKey
|
||||
// [i] altKey
|
||||
// ----------------------------------------------------------------------------
|
||||
cboMethod_OnChar:
|
||||
goSub checkBtnTestEnabledState
|
||||
return
|
||||
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
// cboMethod_OnGotFocus subroutine
|
||||
//
|
||||
// GOTFOCUS event handler for the CBO_METHOD control - Using the "default"
|
||||
// handler to load the verb doesn't trigger the CHANGED event so we do it
|
||||
// manually here.
|
||||
//
|
||||
// ----------------------------------------------------------------------------
|
||||
// [i] prevFocusID : ID of the last control on the window that
|
||||
// : had an event handler defined for the GOTFOCUS event.
|
||||
// ----------------------------------------------------------------------------
|
||||
cboMethod_OnGotFocus:
|
||||
goSub checkBtnTestEnabledState
|
||||
return
|
||||
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
#endregion
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
#region BTN_TEST
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
// btnTest_OnClick subroutine
|
||||
//
|
||||
// CLICK event handler for the BTN_TEST button: Extracts the list of arguments
|
||||
// from the form and calls RTI_HTTP_DOWNLOAD to run the test.
|
||||
//
|
||||
// ----------------------------------------------------------------------------
|
||||
btnTest_OnClick:
|
||||
|
||||
useED = .pgd_UIParams->valueByName( "Use EndDialog event" )
|
||||
asyncID = ""
|
||||
callBackProc = ""
|
||||
callBackID = ""
|
||||
|
||||
if useED then
|
||||
asyncID = trim( .pgd_UIParams->valueByName( "EndDialog AsyncID" ) )
|
||||
end else
|
||||
callbackProc = trim( .pgd_UIParams->valueByName( "Procedure Name" ) )
|
||||
callBackID = trim( .pgd_UIParams->valueByName( "Callback ID" ) )
|
||||
end
|
||||
|
||||
objxArray = @window : ".EDL_URL"
|
||||
propArray = "TEXT"
|
||||
|
||||
objxArray := @rm : @window : ".CBO_METHOD"
|
||||
propArray := @rm : "TEXT"
|
||||
|
||||
objxArray := @rm : @window : ".EDL_TIMEOUT"
|
||||
propArray := @rm : "TEXT"
|
||||
|
||||
objxArray := @rm : @window : ".EDL_PAYLOAD"
|
||||
propArray := @rm : "TEXT"
|
||||
|
||||
objxArray := @rm : @window : ".EDL_USERNAME"
|
||||
propArray := @rm : "TEXT"
|
||||
|
||||
objxArray := @rm : @window : ".EDL_PASSWORD"
|
||||
propArray := @rm : "TEXT"
|
||||
|
||||
objxArray := @rm : @window : ".EDT_REQUESTHEADERS"
|
||||
propArray := @rm : "ARRAY"
|
||||
|
||||
objxArray := @rm : @window : ".EDL_RESPONSEFILE"
|
||||
propArray := @rm : "TEXT"
|
||||
|
||||
dataArray = get_Property( objxArray, propArray )
|
||||
|
||||
url = dataArray[1,@rm,TRUE$]
|
||||
method = dataArray[bCol2()+1,@rm,TRUE$]
|
||||
timeoutInfo = dataArray[bCol2()+1,@rm,TRUE$]
|
||||
payload = dataArray[bCol2()+1,@rm,TRUE$]
|
||||
userName = trim( dataArray[bCol2()+1,@rm,TRUE$] )
|
||||
password = dataArray[bCol2()+1,@rm,TRUE$]
|
||||
headers = dataArray[bCol2()+1,@rm,TRUE$]
|
||||
responseFile = dataArray[bCol2()+1,@rm,TRUE$]
|
||||
|
||||
uiParams = ""
|
||||
|
||||
if ( .pgd_UIParams->valueByName( "Use Parent Window" ) ) then
|
||||
uiParams<HDL_UIPARAM_POS_PARENTWIN$> = @window
|
||||
end
|
||||
uiParams<HDL_UIPARAM_POS_MODAL$> = .pgd_UIParams->valueByName( "Modal" )
|
||||
uiParams<HDL_UIPARAM_POS_ENDDIALOGASYNCID$> = asyncID
|
||||
uiParams<HDL_UIPARAM_POS_CALLBACKPROC$> = callbackProc
|
||||
uiParams<HDL_UIPARAM_POS_CALLBACKID$> = callBackID
|
||||
uiParams<HDL_UIPARAM_POS_DOWNLOADTEXT$> = .pgd_UIParams->valueByName( "Loading Text" )
|
||||
uiParams<HDL_UIPARAM_POS_SYNCPROGRESS$> = .pgd_UIParams->valueByName( "Sync Taskbar" )
|
||||
|
||||
if bLen( userName ) then
|
||||
credentials = userName : @fm : password
|
||||
end else
|
||||
credentials = ""
|
||||
end
|
||||
|
||||
tmp = headers
|
||||
convert " ":@fm:@vm to "" in tmp
|
||||
if bLen( tmp ) else
|
||||
headers = ""
|
||||
end
|
||||
|
||||
call set_Status( SETSTAT_OK$ )
|
||||
call rti_HTTP_Download( uiParams, url, method, payload, credentials, |
|
||||
headers, timeoutInfo, responseFile )
|
||||
if get_Status( errorText ) then
|
||||
goSub setSPError
|
||||
end
|
||||
|
||||
return
|
||||
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
#endregion
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
#region EDL_RESPONSEFILE
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
// edlResponseFile_OnOptions subroutine
|
||||
//
|
||||
// OPTIONS event handler for the EDL_RESPONSEFILE button - displays the
|
||||
// standard File Open dialog for the user to choose a file to write the
|
||||
// content to.
|
||||
//
|
||||
// ----------------------------------------------------------------------------
|
||||
edlResponseFile_OnOptions:
|
||||
|
||||
cfFlags = bitOr( OFN_HIDEREADONLY$, OFN_NOCHANGEDIR$ )
|
||||
|
||||
fileName = @object->text
|
||||
|
||||
if index( fileName, "\", 1 ) then
|
||||
defName = fileName[-1,"B\"]
|
||||
filePath = fileName[1,col1()-1]
|
||||
if index( defName, ".", 1 ) else
|
||||
if ( $fileSystem->dirExists( fileName ) ) then
|
||||
defName = "ResponseContent.txt"
|
||||
filePath = fileName
|
||||
end
|
||||
end
|
||||
end else
|
||||
filePath = drive()
|
||||
defName = fileName
|
||||
end
|
||||
|
||||
cfOptions = ""
|
||||
cfOptions<CHFILE_POS_MODE$> = CHFILE_MODE_SAVEAS$
|
||||
cfOptions<CHFILE_POS_FILTERSTRING$> = "All Files (*.*)/*.*/"
|
||||
cfOptions<CHFILE_POS_FILTERINDEX$> = 1
|
||||
cfOptions<CHFILE_POS_DFLTNAME$> = defName
|
||||
cfOptions<CHFILE_POS_FLAGS$> = cfFlags
|
||||
cfOptions<CHFILE_POS_INITDIR$> = filePath
|
||||
cfOptions<CHFILE_POS_TITLE$> = "Specify Response File"
|
||||
|
||||
fileName = $fileSystem->chooseFile( @window, cfOptions )
|
||||
if bLen( fileName ) then
|
||||
@object->text = fileName
|
||||
end
|
||||
|
||||
return
|
||||
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
#endregion
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
#region EDL_URL
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
// edlURL_OnChanged subroutine
|
||||
//
|
||||
// CHANGED event handler for the EDL_URL control - update the enabled state
|
||||
// of BTN_TEST
|
||||
//
|
||||
// ----------------------------------------------------------------------------
|
||||
edlURL_OnChanged:
|
||||
goSub checkBtnTestEnabledState
|
||||
return
|
||||
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
#endregion
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
#region PDG_UIPARAMS
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
// pgdUIParams_OnOmniEvent subroutine
|
||||
//
|
||||
// PGD_UIPARAMS OMNIEVENT handler
|
||||
//
|
||||
// ----------------------------------------------------------------------------
|
||||
// [i] message : Identifies the OMNIEVENT message
|
||||
// [i] param1 : Polymorphic message parameters
|
||||
// ... ... : ...
|
||||
// [i] param8 : Polymorphic message parameters
|
||||
// ----------------------------------------------------------------------------
|
||||
pgdUIParams_OnOmniEvent:
|
||||
|
||||
begin case
|
||||
case ( message == "PGO_ENDDIALOG" )
|
||||
goSub pgdUIParams_OnOmniEvent_PGO_EndDialog
|
||||
|
||||
end case
|
||||
|
||||
return
|
||||
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
// pgdUIParams_OnOmniEvent_PGO_EndDialog subroutine
|
||||
//
|
||||
// OMNIEVENT PGO_ENDDIALOG handler - updates the property grid with the results
|
||||
// of a PGO non-modal dialog
|
||||
//
|
||||
// ----------------------------------------------------------------------------
|
||||
// [i] param1 : Property name
|
||||
// [1] param2 : New property value
|
||||
// ----------------------------------------------------------------------------
|
||||
pgdUIParams_OnOmniEvent_PGO_EndDialog:
|
||||
|
||||
@object->valueByName( param1, param2 )
|
||||
goSub checkBtnTestEnabledState
|
||||
|
||||
return
|
||||
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
// pgdUIParams_onPropChanged subroutine
|
||||
//
|
||||
// PROPCHANGED event handler for the PGD_UIPARAMS property grid.
|
||||
//
|
||||
// ----------------------------------------------------------------------------
|
||||
// [i] propName - Name of the property that has changed
|
||||
// [i] propValue - Value of the property that has changed
|
||||
// [i] contextFlags - Context the change was raised from
|
||||
// ----------------------------------------------------------------------------
|
||||
pgdUIParams_onPropChanged:
|
||||
|
||||
begin case
|
||||
case ( propName == "Use EndDialog event" )
|
||||
// If this is enabled then:
|
||||
//
|
||||
// EndDialog AsyncID should be enabled
|
||||
// Procedure Name CallBack ID should be disabled
|
||||
//
|
||||
// else
|
||||
// EndDialog AsyncID should be disabled
|
||||
// Procedure Name CallBack ID should be enabled
|
||||
|
||||
@object{"EndDialog AsyncID"}->enabled = propValue
|
||||
@object{"Procedure Name"}->enabled = not( propValue )
|
||||
@object{"CallBack ID"}->enabled = not( propValue )
|
||||
|
||||
end case
|
||||
|
||||
goSub checkBtnTestEnabledState
|
||||
|
||||
return
|
||||
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
// pgdUIParams_OnPropOptions subroutine
|
||||
//
|
||||
// PROPOPTIONS event handler for the PDG_UIPARAMS property grid control
|
||||
//
|
||||
// ----------------------------------------------------------------------------
|
||||
// [i] propName : Name of the property to display the options
|
||||
// [i] propValue : Current Property Value
|
||||
// ----------------------------------------------------------------------------
|
||||
pgdUIParams_OnPropOptions:
|
||||
|
||||
begin case
|
||||
case propName == "EndDialog AsyncID"
|
||||
// Display the RTI_IDE_PGO_TEXTLINE dialog
|
||||
goSub pgdUIParams_OnPropOptions_Display_TextLine_Dlg
|
||||
case propName == "Procedure Name"
|
||||
// Display the RTI_IDE_OPEN dialog with STPROCEXES loaded
|
||||
goSub pgdUIParams_OnPropOptions_Display_EntOpen_Dlg
|
||||
case propName == "Callback ID"
|
||||
// Display the RTI_IDE_PGO_TEXTLINE dialog
|
||||
goSub pgdUIParams_OnPropOptions_Display_TextLine_Dlg
|
||||
case propName == "Loading Text"
|
||||
// Display the RTI_IDE_PGO_TEXTLINE dialog
|
||||
goSub pgdUIParams_OnPropOptions_Display_TextLine_Dlg
|
||||
end case
|
||||
|
||||
return
|
||||
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
// pgdUIParams_OnPropOptions_Display_TextLine_Dlg subroutine
|
||||
//
|
||||
// Display the RTI_IDE_PGO_TEXTLINE dialog to allow the user to enter a larger
|
||||
// display a larger amount of text.
|
||||
// ----------------------------------------------------------------------------
|
||||
// [i] propName : Name of the property to display the options
|
||||
// [i] propValue : Current Property Value
|
||||
// ----------------------------------------------------------------------------
|
||||
pgdUIParams_OnPropOptions_Display_TextLine_Dlg:
|
||||
|
||||
dlgParam = ""
|
||||
dlgParam<PGOTEXTLINE_CREATEPARAM_PROPGRID$> = object
|
||||
dlgParam<PGOTEXTLINE_CREATEPARAM_PROPNAME$> = propName
|
||||
dlgParam<PGOTEXTLINE_CREATEPARAM_TEXT$> = propValue
|
||||
dlgParam<PGOTEXTLINE_CREATEPARAM_CACHEID$> = "RTI_HTTP_DOWNLOAD_TEST"
|
||||
|
||||
call start_Window( "RTI_IDE_PGO_TEXTLINE", @window, dlgParam )
|
||||
|
||||
return
|
||||
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
// pgdUIParams_OnPropOptions_Display_EntOpen_Dlg subroutine
|
||||
//
|
||||
// Display the RTI_IDE_OPEN dialog to allow the user to select an STPROCEXE
|
||||
// ----------------------------------------------------------------------------
|
||||
// [i] propName : Name of the property to display the options
|
||||
// [i] propValue : Current Property Value
|
||||
// ----------------------------------------------------------------------------
|
||||
pgdUIParams_OnPropOptions_Display_EntOpen_Dlg:
|
||||
|
||||
dlgID = rti_IDE_CFG( "GETDIALOG", IDE_CFG_GETDLG_T_OPENENT$ )
|
||||
|
||||
itemSize = @object->screenSizeByName( propName )
|
||||
|
||||
xPos = itemSize<1> + itemSize<3>
|
||||
yPos = itemSize<2> + itemSize<4>
|
||||
|
||||
dlgParam = ""
|
||||
dlgParam<IDE_OPN_CREATEPARAM_TYPEID$> = "STPROCEXE"
|
||||
dlgParam<IDE_OPN_CREATEPARAM_ENTITYID$> = propValue
|
||||
dlgParam<IDE_OPN_CREATEPARAM_MODE$> = FALSE$
|
||||
dlgParam<IDE_OPN_CREATEPARAM_XPOS$> = xPos : @vm : TRUE$ : @vm : TRUE$
|
||||
dlgParam<IDE_OPN_CREATEPARAM_YPOS$> = yPos : @vm : FALSE$ : @vm : TRUE$
|
||||
dlgParam<IDE_OPN_CREATEPARAM_NONSEL$> = TRUE$
|
||||
dlgParam<IDE_OPN_CREATEPARAM_TITLE$> = propName
|
||||
|
||||
propValue = dialog_Box( dlgID, @window, dlgParam )
|
||||
if bLen( propValue ) then
|
||||
// Verify that it can take at least 2 args for the callback from the
|
||||
// download form
|
||||
|
||||
propValue = field( propValue, "*", 4, 9999 )
|
||||
|
||||
call set_Status( SETSTAT_OK$ )
|
||||
procInfo = rti_Get_Proc_Info( propValue )
|
||||
if get_Status( errorText ) then
|
||||
goSub setSPError
|
||||
return
|
||||
end
|
||||
|
||||
if ( procInfo<GPI_ARGCOUNT$> < 2 ) then
|
||||
errorText = "The Callback Procedure Name must support at least 2 parameters"
|
||||
abort = TRUE$
|
||||
return
|
||||
end
|
||||
|
||||
@object->valueByName( propName, propValue )
|
||||
goSub checkBtnTestEnabledState
|
||||
|
||||
end
|
||||
|
||||
return
|
||||
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
#endregion
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
// checkBtnTestEnabledState subroutine
|
||||
//
|
||||
// This subroutine scans the Request parameters and enables the BTN_TEST
|
||||
// button if there is enough information to conduct a RTI_HTTP_DOWNLOAD test.
|
||||
//
|
||||
// We have to meet the following criteria:
|
||||
//
|
||||
// 1) We have a URL
|
||||
// 2) We have a method (verb)
|
||||
// 3) We have one of the following:
|
||||
// i) An End Dialog AsyncID, or
|
||||
// ii) A CallbackProcID
|
||||
//
|
||||
// ----------------------------------------------------------------------------
|
||||
checkBtnTestEnabledState:
|
||||
|
||||
enableTest = TRUE$
|
||||
useED = .pgd_UIParams->valueByName( "Use EndDialog event" )
|
||||
if useED then
|
||||
asyncID = trim( .pgd_UIParams->valueByName( "EndDialog AsyncID" ) )
|
||||
if bLen( asyncID ) else
|
||||
enableTest = FALSE$
|
||||
end
|
||||
end else
|
||||
callbackProc = trim( .pgd_UIParams->valueByName( "Procedure Name" ) )
|
||||
if bLen( callbackProc ) else
|
||||
enableTest = FALSE$
|
||||
end
|
||||
end
|
||||
|
||||
if enableTest then
|
||||
if bLen( trim( .edl_URL->text ) ) then
|
||||
if bLen( trim( .cbo_Method->text ) ) else
|
||||
enableTest = FALSE$
|
||||
end
|
||||
end else
|
||||
enableTest = FALSE$
|
||||
end
|
||||
end
|
||||
|
||||
.btn_Test->enabled = enableTest
|
||||
|
||||
return
|
||||
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
// errorMsg subroutine
|
||||
//
|
||||
// Displays a simple error message
|
||||
//
|
||||
// ----------------------------------------------------------------------------
|
||||
// [i] errorText : Text to display in the message
|
||||
// [i] errorCaption : Caption for the message
|
||||
// ----------------------------------------------------------------------------
|
||||
errorMsg:
|
||||
|
||||
if assigned( errorCaption ) else errorCaption = ""
|
||||
if bLen( errorCaption ) else
|
||||
errorCaption = @@window->text
|
||||
end
|
||||
|
||||
msgArray = errorText
|
||||
msgArray<4> = "!"
|
||||
msgArray<6> = -2
|
||||
msgArray<7> = -2
|
||||
msgArray<8> = "C"
|
||||
msgArray<12> = errorCaption
|
||||
|
||||
call msg( @window, msgArray )
|
||||
|
||||
return
|
||||
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
// setSPError subroutine
|
||||
//
|
||||
// Translates an SSP status error array into a "text version" from REVERROR.DAT
|
||||
//
|
||||
// ----------------------------------------------------------------------------
|
||||
// [i,o] errorText : SSP status error to convert. Returns the "text" version
|
||||
// ----------------------------------------------------------------------------
|
||||
setSPError:
|
||||
errorText = rti_ErrorText( "SP", errorText )
|
||||
abort = TRUE$
|
||||
return
|
||||
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
|
||||
477
SYSPROG/STPROC/RTI_HTTP_DOWNLOAD_UI.txt
Normal file
477
SYSPROG/STPROC/RTI_HTTP_DOWNLOAD_UI.txt
Normal file
@ -0,0 +1,477 @@
|
||||
compile function rti_HTTP_Download_UI( object, method, param1, param2, param3, param4, param5, param6, param7, param8 )
|
||||
/*
|
||||
** Copyright (C) 2012-2019 Revelation Software Inc. All Rights Reserved **
|
||||
|
||||
Author : Captain C
|
||||
Date : June 2019
|
||||
Purpose : Commuter module for the RTI_HTTP_DOWNLOAD_UI form
|
||||
|
||||
|
||||
Comments
|
||||
========
|
||||
|
||||
|
||||
Amended Date Reason
|
||||
======= ==== ======
|
||||
Mr C 09 Mar 22 The form's visibility is controlled from it's caller
|
||||
(i.e. rti_HTTP_Download)
|
||||
*/
|
||||
#pragma precomp event_precomp
|
||||
|
||||
declare function get_Property, retStack, rti_Res2Str, rti_ErrorText
|
||||
declare function rti_Convert, msWin_GetTickCount64, exec_Method
|
||||
$insert rti_HTTP_Download_Equates
|
||||
$insert ps_HTTPClient_Equates
|
||||
$insert rti_Resources_Equates
|
||||
$insert rti_SSP_Equates
|
||||
$insert logical
|
||||
|
||||
equ UDP_TIMEDATA$ to "@_TIMEDATA"
|
||||
|
||||
if assigned( object ) else object = ""
|
||||
if assigned( method ) else method = ""
|
||||
if assigned( param1 ) else param1 = ""
|
||||
if assigned( param2 ) else param2 = ""
|
||||
if assigned( param3 ) else param3 = ""
|
||||
if assigned( param4 ) else param4 = ""
|
||||
if assigned( param5 ) else param5 = ""
|
||||
if assigned( param6 ) else param6 = ""
|
||||
if assigned( param7 ) else param7 = ""
|
||||
if assigned( param8 ) else param8 = ""
|
||||
|
||||
errorText = ""
|
||||
abort = FALSE$
|
||||
retVal = ""
|
||||
|
||||
atWindow = object[1,"."]
|
||||
atCtrl = object[col2()+1,\00\]
|
||||
if bLen( atWindow ) else
|
||||
atWindow = @window
|
||||
end
|
||||
|
||||
if bLen( method ) then
|
||||
locate method in "CREATE,CLOSE,PROGRESS,READYSTATECHANGED,TIMEOUT" using "," setting pos then
|
||||
on pos goSub onCreate,onClose,onProgress,onReadyStateChanged,onTimeout
|
||||
end else
|
||||
// ERR002: Invalid method "%1% passed to the %2% procedure
|
||||
errorText = rti_Res2Str( RESID$, "ERR002", method : @fm : retStack()<1> )
|
||||
abort = TRUE$
|
||||
end
|
||||
end else
|
||||
// ERR001: No method passed to the %1% procedure
|
||||
errorText = rti_Res2Str( RESID$, "ERR001", retStack()<1> )
|
||||
abort = TRUE$
|
||||
end
|
||||
|
||||
return retVal
|
||||
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
// onClose subroutine
|
||||
//
|
||||
// CLOSE event handler for the
|
||||
//
|
||||
// ----------------------------------------------------------------------------
|
||||
onClose:
|
||||
|
||||
rs = .hcl_Download->readyState
|
||||
begin case
|
||||
case ( rs == PS_HCL_RS_UNSENT$ )
|
||||
null
|
||||
case ( rs == PS_HCL_RS_DONE$ )
|
||||
null
|
||||
case OTHERWISE$
|
||||
@@window->$@_ABORT = TRUE$
|
||||
.hcl_Download->abort( "" )
|
||||
goSub hclDownload_ReturnResponse
|
||||
end case
|
||||
|
||||
return
|
||||
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
// onCreate subroutine
|
||||
//
|
||||
// CREATE event handler
|
||||
//
|
||||
// ----------------------------------------------------------------------------
|
||||
// [i] param1 : CreateParam. Contains an @fm delimited list UI information
|
||||
// : as passed to the RTI_HTTP_DOWNLOAD proc
|
||||
// ----------------------------------------------------------------------------
|
||||
onCreate:
|
||||
|
||||
@@window->$@_CREATEPARAM = param1
|
||||
|
||||
startTime = msWin_GetTickCount64()
|
||||
prevTime = startTime
|
||||
timeData = startTime : @fm : prevTime
|
||||
|
||||
@@window->$@_TIMEDATA = timeData
|
||||
|
||||
if ( param1<HDL_UIPARAM_POS_SYNCPROGRESS$> ) then
|
||||
.prb_Download->SyncTaskBar = TRUE$
|
||||
end
|
||||
|
||||
// The form's visibility is controlled from rti_HTTP_Download()
|
||||
// @atWindow->visible = TRUE$
|
||||
|
||||
if ( param1<HDL_UIPARAM_POS_MODAL$> ) then
|
||||
call set_Property( param1<HDL_UIPARAM_POS_PARENTWIN$>, "ENABLED", FALSE$ )
|
||||
end
|
||||
|
||||
// We're all set - return to the caller to set the HCL_DOWNLOAD properties
|
||||
// execute the OPEN/SEND methods ...
|
||||
|
||||
return
|
||||
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
// onProgress subroutine
|
||||
//
|
||||
// PROGRESS event dispatch handler
|
||||
//
|
||||
// ----------------------------------------------------------------------------
|
||||
// [i] param1 : bytesReceived. Number of bytes received between this PROGRESS
|
||||
// : event and the previous one
|
||||
// [i] param2 : bytesDownloaded. Total Number of bytes downloaded so far
|
||||
// [i] param3 : bytesExpected. Total number of bytes expected from the server
|
||||
// ----------------------------------------------------------------------------
|
||||
onProgress:
|
||||
|
||||
bytesReceived = param1
|
||||
bytesDownloaded = param2
|
||||
bytesExpected = param3
|
||||
|
||||
begin case
|
||||
case ( atCtrl == "HCL_DOWNLOAD" )
|
||||
goSub hclDownload_OnProgress
|
||||
end case
|
||||
|
||||
return
|
||||
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
// onReadyStateChanged subroutine
|
||||
//
|
||||
// READYSTATECHANGED event dispatch handler
|
||||
//
|
||||
// ----------------------------------------------------------------------------
|
||||
// [i] param1 : newState
|
||||
// ----------------------------------------------------------------------------
|
||||
onReadyStateChanged:
|
||||
|
||||
newState = param1
|
||||
|
||||
begin case
|
||||
case ( atCtrl == "HCL_DOWNLOAD" )
|
||||
goSub hclDownload_OnReadyStateChanged
|
||||
end case
|
||||
|
||||
return
|
||||
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
// onTimeout subroutine
|
||||
//
|
||||
// TIMEOUT event dispatch handler
|
||||
//
|
||||
// ----------------------------------------------------------------------------
|
||||
// [i] param1 : StatusID, identifies the handle that timed out (connect, open,
|
||||
// : request)
|
||||
// ----------------------------------------------------------------------------
|
||||
onTimeout:
|
||||
|
||||
statusID = param1
|
||||
|
||||
begin case
|
||||
case ( atCtrl == "HCL_DOWNLOAD" )
|
||||
goSub hclDownload_OnTimeout
|
||||
end case
|
||||
|
||||
return
|
||||
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
#region HCL_DOWNLOAD
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
// hclDownload_OnProgress subroutine
|
||||
//
|
||||
// PROGRESS event handler for the HCL_DOWNLOAD control
|
||||
//
|
||||
// * Update the progress bar
|
||||
// * Update the Estimated Time Left (ETL)
|
||||
// * Update the Transfer Rate
|
||||
//
|
||||
// ----------------------------------------------------------------------------
|
||||
// [i] : bytesReceived. Number of bytes received between this PROGRESS event
|
||||
// : and the previous one
|
||||
// [i] : bytesDownloaded. Total Number of bytes downloaded so far
|
||||
// [i] : bytesExpected. Total number of bytes expected from the server
|
||||
// ----------------------------------------------------------------------------
|
||||
hclDownload_OnProgress:
|
||||
|
||||
timeData = @@window->$@_TIMEDATA
|
||||
|
||||
startTime = timeData<1>
|
||||
prevTime = timeData<2>
|
||||
prevRate = timeData<3>
|
||||
|
||||
now = msWin_GetTickCount64()
|
||||
|
||||
if ( now > prevTime ) else
|
||||
now = prevTime + 1
|
||||
end
|
||||
|
||||
elapsedTime = now - startTime
|
||||
transferRate = int( ( bytesDownloaded / elapsedTime ) * 1000 ) ; // in secs
|
||||
|
||||
etlText = ""
|
||||
trText = ""
|
||||
|
||||
if ( bytesExpected ) then
|
||||
|
||||
// If we know how much we're expected to deal with we can
|
||||
// calculate how much time is left and ho far we are
|
||||
// through
|
||||
|
||||
if ( .prb_download->marquee ) then
|
||||
.prb_download->marquee = 0 ; // ms
|
||||
.prb_download->showText = TRUE$
|
||||
end
|
||||
|
||||
.prb_download->value = int( ( bytesDownloaded / bytesExpected ) * 100 )
|
||||
|
||||
etlSecs = ( bytesExpected - bytesDownloaded ) / transferRate ; // seconds to complete
|
||||
|
||||
etlHours = 0
|
||||
etlMins = 0
|
||||
|
||||
if ( etlSecs > 3600 ) then
|
||||
etlHours = int( etlSecs / 3600 )
|
||||
etlSecs = mod( etlSecs , 3600 )
|
||||
end
|
||||
|
||||
if ( etlSecs > 60 ) then
|
||||
etlMins = int( etlSecs / 60 )
|
||||
etlSecs = mod( etlSecs , 60 )
|
||||
end
|
||||
|
||||
etlSecs = int( etlSecs )
|
||||
|
||||
if ( etlHours ) then
|
||||
etlText := etlHours : " hours "
|
||||
end
|
||||
|
||||
if ( etlMins ) then
|
||||
etlText := etlMins : " minutes "
|
||||
end
|
||||
|
||||
if ( etlSecs ) then
|
||||
etlText := etlSecs : " seconds "
|
||||
end
|
||||
|
||||
cb = bytesDownloaded
|
||||
goSub hclDownload_OnProgress_bytesToText
|
||||
|
||||
etlText := " (" : cb : " " : sf : " of "
|
||||
|
||||
cb = bytesExpected
|
||||
goSub hclDownload_OnProgress_bytesToText
|
||||
|
||||
etlText := cb : " " : sf : " downloaded)"
|
||||
|
||||
end else
|
||||
// We can't calculate the ETL or the progress done because we don't
|
||||
// how much we've got left to down load
|
||||
|
||||
// Ensure we set the progress bar to a marquee
|
||||
if ( .prb_download->marquee ) else
|
||||
.prb_download->showText = FALSE$
|
||||
.prb_download->marquee = 20 ; // ms
|
||||
end
|
||||
|
||||
// We can however show the amount copied....
|
||||
|
||||
cb = bytesDownloaded
|
||||
goSub hclDownload_OnProgress_bytesToText
|
||||
|
||||
etlText = cb : " " : sf : " downloaded"
|
||||
|
||||
end
|
||||
|
||||
cb = transferRate
|
||||
goSub hclDownload_OnProgress_bytesToText
|
||||
|
||||
begin case
|
||||
case ( transferRate > 0x100000 )
|
||||
// We're working in MB
|
||||
sf = "Mb/s"
|
||||
|
||||
case ( transferRate > 0x400 )
|
||||
// We're working in KB
|
||||
sf = "Kb/s"
|
||||
|
||||
case OTHERWISE$
|
||||
sf = "b/s"
|
||||
|
||||
end case
|
||||
|
||||
trText = cb : " " : sf
|
||||
|
||||
.txt_ETL->text = etlText
|
||||
.txt_TR->text = trText
|
||||
|
||||
timeData<2> = now
|
||||
timeData<3> = transferRate
|
||||
|
||||
@@window->$@_TIMEDATA = timeData
|
||||
|
||||
return
|
||||
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
// hclDownload_OnProgress_bytesToText subroutine
|
||||
//
|
||||
// Simple routine to translate the number of bytes into MB, KB etc ...
|
||||
//
|
||||
// ----------------------------------------------------------------------------
|
||||
// [i,o] cb : Number of bytes in, translated amount out
|
||||
// [o] sf : Suffic to append to the translated amount - MB, KB or "Bytes"
|
||||
// ----------------------------------------------------------------------------
|
||||
hclDownload_OnProgress_bytesToText:
|
||||
|
||||
// We can however show the amount copied....
|
||||
begin case
|
||||
case ( cb > 0x100000 )
|
||||
cb = oconv( ( cb / 0x100000 ) * 100, "MD2" )
|
||||
sf = "MB"
|
||||
|
||||
case ( cb > 0x400 )
|
||||
cb = oconv( ( cb / 0x400 ) * 100, "MD2" )
|
||||
sf = "KB"
|
||||
|
||||
case OTHERWISE$
|
||||
sf = "Bytes"
|
||||
|
||||
end case
|
||||
|
||||
return
|
||||
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
|
||||
hclDownload_OnReadyStateChanged:
|
||||
|
||||
begin case
|
||||
case ( newState == PS_HCL_RS_DONE$ )
|
||||
// When we get this notification the client has finished downloading
|
||||
// from theserver so we need to grab the content and then pass it to
|
||||
// the parent's ENDDIALOG event or the specified callback proc.
|
||||
goSub hclDownload_ReturnResponse
|
||||
|
||||
case OTHERWISE$
|
||||
null
|
||||
|
||||
end case
|
||||
|
||||
return
|
||||
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
// hclDownload_OnTimeout subroutine
|
||||
//
|
||||
// TIMEOUT event handler for the HCL_DOWNLOAD control
|
||||
//
|
||||
// Return what we have to the caller - the status code returned should be 408
|
||||
//
|
||||
// ----------------------------------------------------------------------------
|
||||
hclDownload_OnTimeout:
|
||||
goSub hclDownload_ReturnResponse
|
||||
return
|
||||
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
// hclDownload_ReturnResponse subroutine
|
||||
//
|
||||
// Call back with the reponse content and close the dialog.
|
||||
//
|
||||
// ----------------------------------------------------------------------------
|
||||
hclDownload_ReturnResponse:
|
||||
|
||||
// Details we need were passed to the create event which we saved in a UDP:
|
||||
createParam = @@window->$@_CREATEPARAM
|
||||
|
||||
parentID = createParam<HDL_UIPARAM_POS_PARENTWIN$>
|
||||
bModal = createParam<HDL_UIPARAM_POS_MODAL$>
|
||||
asyncID = createParam<HDL_UIPARAM_POS_ENDDIALOGASYNCID$>
|
||||
|
||||
// Renable the parent window if we have one...
|
||||
if bLen( parentID ) then
|
||||
if bModal then
|
||||
@parentID->enabled = TRUE$
|
||||
end
|
||||
end
|
||||
|
||||
// Remove this dialog from screen
|
||||
@@window->hide( "" )
|
||||
|
||||
if ( createParam<HDL_UIPARAM_POS_SYNCPROGRESS$> ) then
|
||||
.prb_Download->value = 0
|
||||
.prb_Download->syncTaskbar = FALSE$
|
||||
end
|
||||
|
||||
// We send back two parameters to the callback event/proc
|
||||
//
|
||||
// 1) An array of response data
|
||||
//
|
||||
// <1> AsyncID or CallBackID
|
||||
// <2> Response Status Code
|
||||
// <3> Response Status Text
|
||||
// <4> Content Length
|
||||
// <5> Response Header Names
|
||||
// <6> Bytes received for the response content
|
||||
//
|
||||
// 2) The response content (unless this was a file download)
|
||||
|
||||
rspInfo = ""
|
||||
|
||||
tmp = .hcl_Download->responseStatus
|
||||
|
||||
rspInfo<HDL_RSPINFO_POS_STATUSCODE$> = tmp<PS_HCL_RSPSTAT_POS_CODE$>
|
||||
rspInfo<HDL_RSPINFO_POS_STATUSTEXT$> = tmp<PS_HCL_RSPSTAT_POS_TEXT$>
|
||||
rspInfo<HDL_RSPINFO_POS_CONTENTLEN$> = tmp<PS_HCL_RSPSTAT_POS_CNTLEN$>
|
||||
rspInfo<HDL_RSPINFO_POS_HEADERS$> = rti_Convert( .hcl_Download->responseHeaders, @fm, @vm )
|
||||
|
||||
responseFile = .hcl_Download->responseFile
|
||||
if bLen( responseFile ) then
|
||||
rspInfo<HDL_RSPINFO_POS_BYTESRECEIVED$> = dir( responseFile )<1>
|
||||
rspContent = ""
|
||||
end else
|
||||
rspContent = .hcl_Download->GetResponseContent( "" )
|
||||
rspInfo<HDL_RSPINFO_POS_BYTESRECEIVED$> = bLen( rspContent )
|
||||
end
|
||||
|
||||
// If ww're here because of an Abort() call then we don't bother closing...
|
||||
if ( @@window->$@_ABORT ) else
|
||||
call post_Event( @window, "CLOSE" )
|
||||
end
|
||||
|
||||
// Now decide where to send the data
|
||||
if bLen( asyncID ) then
|
||||
// Send to the parent's ENDDIALOG
|
||||
if ( @parentID->handle ) then
|
||||
|
||||
rspInfo<HDL_RSPINFO_POS_ID$> = asyncID
|
||||
call send_Event( parentID, "ENDDIALOG", atWindow, rspContent, rspInfo )
|
||||
|
||||
end
|
||||
end else
|
||||
// Send to the callback proc
|
||||
procID = createParam<HDL_UIPARAM_POS_CALLBACKPROC$>
|
||||
if bLen( procID ) then
|
||||
rspInfo<HDL_RSPINFO_POS_ID$> = createParam<HDL_UIPARAM_POS_CALLBACKID$>
|
||||
call @procID( rspInfo, rspContent )
|
||||
end
|
||||
end
|
||||
|
||||
return
|
||||
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
#endregion HCL_DOWNLOAD
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
$insert copyright
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
10
SYSPROG/STPROC/RTI_LDAP_GROUPS_FOR_USER_HOOK.txt
Normal file
10
SYSPROG/STPROC/RTI_LDAP_GROUPS_FOR_USER_HOOK.txt
Normal file
@ -0,0 +1,10 @@
|
||||
Function RTI_LDAP_Groups_For_User_Hook(inUser, inDomain)
|
||||
|
||||
Declare function RTI_LDAP_Groups_For_User_RTI
|
||||
|
||||
If @UserName EQ 'MESCATXMUSER' then Debug
|
||||
|
||||
Ans = RTI_LDAP_Groups_For_User_RTI(inUser, inDomain)
|
||||
|
||||
Return Ans
|
||||
|
||||
1117
SYSPROG/STPROC/RTI_POPUP_DATETIME.txt
Normal file
1117
SYSPROG/STPROC/RTI_POPUP_DATETIME.txt
Normal file
File diff suppressed because it is too large
Load Diff
113
SYSPROG/STPROC/RTI_RUN_HTTPSERVER_REQUEST.txt
Normal file
113
SYSPROG/STPROC/RTI_RUN_HTTPSERVER_REQUEST.txt
Normal file
@ -0,0 +1,113 @@
|
||||
compile function rti_Run_HTTPServer_Request( httpServer, requestID, requestHeaders )
|
||||
/*
|
||||
****************************************************************************
|
||||
** IF YOU WANT TO MODIFY THIS FOR YOUR OWN APPLICATIONS PLEASE USE A COPY **
|
||||
** DO NOT CHANGE THIS PROGRAM AS IT MAY BE OVERWRITTEN BY FUTURE UPDATES! **
|
||||
****************************************************************************
|
||||
|
||||
** Copyright (C) 2012-2022 Revelation Software Inc. All Rights Reserved **
|
||||
|
||||
Author : Mr C
|
||||
Date : March 2021 - Lockdown 3 (still)
|
||||
Purpose : Core handler for running HTTPSERVER requests
|
||||
|
||||
Comments
|
||||
========
|
||||
|
||||
This is basically an analog of RUN_OECGI_REQUEST and is intended to be
|
||||
called from the HTTPREQUEST event of an HTTPSERVER control.
|
||||
|
||||
Assumptions:
|
||||
|
||||
1) This proc is always in EventContext from an HTTPREQUEST event, and
|
||||
2) This proc is called as a quick event
|
||||
|
||||
This has error-handling implications due to the fact that:
|
||||
|
||||
1) The promoted handler forwards the event to a QE handler and then
|
||||
checks EventStatus() to see if it should continue.
|
||||
|
||||
2) If so then it executes a SENDRESPONSE method to return content to the
|
||||
client.
|
||||
|
||||
We don't want to stop that last step otherwise the client will time out, so
|
||||
_this_ proc will _not_ set the EventStatus() if it encounters an error -
|
||||
instead it will raise an HTTPERROR event on the server and ensure that
|
||||
the SP Status is also cleared.
|
||||
|
||||
If the handler proc wants to issue it's own send and set the EventStatus then
|
||||
it is free to do so.
|
||||
|
||||
|
||||
Amended Date Reason
|
||||
======= ==== ======
|
||||
*/
|
||||
|
||||
#pragma precomp event_precomp
|
||||
|
||||
declare function rti_Convert, rti_Verify_Proc, rti_UC, rti_ErrorText
|
||||
$insert ps_HTTPServer_Equates
|
||||
$insert rti_SSP_Equates
|
||||
$insert rti_Text_Equates
|
||||
$insert logical
|
||||
|
||||
equ HTTPSVR_PREFIX$ to "HTTPSVR_"
|
||||
|
||||
errStat = FALSE$
|
||||
errInfo = ""
|
||||
|
||||
retVal = TRUE$
|
||||
|
||||
procID = rti_UC( requestHeaders<PS_HSVR_REQHDR_PATHINFO$> )[-1, "B/"]
|
||||
if ( procID[1,8] != HTTPSVR_PREFIX$ ) then
|
||||
procID = HTTPSVR_PREFIX$ : procID
|
||||
end
|
||||
|
||||
call set_Status( SETSTAT_OK$ )
|
||||
if rti_Verify_Proc( procID, FALSE$, 3, "" ) else
|
||||
// Not a valid HTTPSVR_ proc ...
|
||||
call get_status( errInfo ) ; goSub setHTTPError
|
||||
|
||||
@httpServer->SetResponseStatus( requestID, 404 ) ; // HTTP 404 - not found
|
||||
|
||||
return FALSE$
|
||||
|
||||
end
|
||||
|
||||
call @procID( httpServer, requestID, requestHeaders )
|
||||
if get_Status( errInfo ) then
|
||||
// Something got away from the handler? Make a note and then let it
|
||||
// through.
|
||||
call set_Status( SETSTAT_OK$ )
|
||||
goSub setHTTPError
|
||||
return FALSE$
|
||||
end
|
||||
|
||||
return TRUE$
|
||||
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
// setHTTPError subroutine
|
||||
//
|
||||
// This subroutine raises an HTTPERROR event for each error string contained
|
||||
// in the errInfo var.
|
||||
//
|
||||
// ----------------------------------------------------------------------------
|
||||
// [i] errInfo : @fm'd list of errors to report
|
||||
// ----------------------------------------------------------------------------
|
||||
setHTTPError:
|
||||
|
||||
errInfo = rti_ErrorText( "SP", errInfo )
|
||||
pos = 1
|
||||
loop
|
||||
tmp = errInfo[pos,@fm,TRUE$]; pos += bCol2()+1
|
||||
if bLen( tmp ) then
|
||||
@httpServer->postEvent( "HTTPERROR", requestID, errInfo )
|
||||
end
|
||||
while ( pos < bLen( errInfo ) )
|
||||
repeat
|
||||
|
||||
return
|
||||
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
48
SYSPROG/STPROC/RTI_VSPRINTER_CUTEPDF.txt
Normal file
48
SYSPROG/STPROC/RTI_VSPRINTER_CUTEPDF.txt
Normal file
@ -0,0 +1,48 @@
|
||||
subroutine RTI_VSPRINTER_CUTEPDF(pdfPrinterName, pdfOutputName, destFilePath, bDoCopy, bPostGeneration)
|
||||
/* --------------------------------------------------------------------------
|
||||
|
||||
|
||||
PURPOSE : Sample "helper" routine to generate PDF Output from OIPI "Classic" in 10.0.x using CutePDF Writer
|
||||
|
||||
AUTHOR : Bryan Shumsky
|
||||
|
||||
CREATED : September 23, 2020
|
||||
|
||||
REVISION HISTORY (Most CURRENT first) :
|
||||
|
||||
DATE IMPLEMENTOR FUNCTION
|
||||
-------- ----------- ------------------------------------------------------------------------------------------------
|
||||
MM-DD-YY initials Modification
|
||||
11-19-20 bzs Allow for "post generation" flag
|
||||
|
||||
|
||||
-------------------------------------------------------------------------- */
|
||||
* CutePDF (v4.0+) allows you to specify a location for PDF output
|
||||
* HKEY_CURRENT_USER\Software\CutePDF Writer\
|
||||
* BypassSaveAs (string value): 0=no/1=yes
|
||||
* OutputFile (string value): full path and file name
|
||||
* bPostGeneration (string value): 0=no (pre)/1=yes (post)
|
||||
|
||||
If Assigned(bPostGeneration) Else bPostGeneration = ""
|
||||
|
||||
Declare Function REGISTRY_METHOD
|
||||
|
||||
Begin Case
|
||||
Case bPostGeneration = "1"
|
||||
* PDF generation should be complete - do we need to do anything?
|
||||
* Delay for a few seconds so it can "wrap up" processing
|
||||
call delay(2)
|
||||
|
||||
Case 1
|
||||
* called before PDF generation has happened
|
||||
* set us up for processing
|
||||
rslt = registry_method("WRITE", "HKEY_CURRENT_USER\Software\CutePDF Writer\BypassSaveAs", "1")
|
||||
rslt = registry_method("WRITE", "HKEY_CURRENT_USER\Software\CutePDF Writer\OutputFile", destFilePath)
|
||||
|
||||
* set bDoCopy to 1 if we want OIPI to copy from pdfOutputName to destFilePath
|
||||
* set bDoCopy to 0 if our helper program means no copy is necessary
|
||||
|
||||
bDoCopy = 0
|
||||
End Case
|
||||
|
||||
Return 0
|
||||
101
SYSPROG/STPROC/SEND_EMAIL_SAMPLE.txt
Normal file
101
SYSPROG/STPROC/SEND_EMAIL_SAMPLE.txt
Normal file
@ -0,0 +1,101 @@
|
||||
Compile function Send_Email_Sample(SendTo, CC, Subject, Body, From, ReplyTo, SRPMailAttach, ConfigFile, Bcc)
|
||||
|
||||
************************************************************************************************
|
||||
*
|
||||
* This program is proprietary and is not to be used by or disclosed to others, nor is it to
|
||||
* be copied without written permission from SRP Computer Solutions.
|
||||
*
|
||||
* Name : Send_Email_Sample
|
||||
*
|
||||
* Description: Sends an email via the SRPMail.dll
|
||||
*
|
||||
* Notes : Please refer to the SRPMail.chm
|
||||
*
|
||||
* Parameters :
|
||||
* MsgSent [out] -- Returns a boolean value as to whether or not the message was sent
|
||||
* successfully
|
||||
* SendTo [in] -- An @VM delimited list of email addresses; required parameter
|
||||
* CC [in] -- An @VM delimited list of email addresses
|
||||
* Subject [in] -- Text that will appear in the subject line of the email
|
||||
* Body [in] -- The actual text of the email; use CRLF$ to break or insert lines;
|
||||
* required parameter
|
||||
* From [in] -- The account to send the email from
|
||||
* ReplyTo [in] -- The account that all replies should go to.
|
||||
* SRPMailAttach [in] -- The file to be used as an attachment for the SRPMail program.
|
||||
* ConfigFile [in] -- The record which contains the SRPMail Config variables.
|
||||
* Bcc [in] -- An @VM delimited list of email address
|
||||
*
|
||||
* History (Date, Initials, Notes)
|
||||
* 01/05/04 ps Sample version created.
|
||||
************************************************************************************************
|
||||
|
||||
$insert SRPMAIL_INSERTS
|
||||
$insert LOGICAL
|
||||
|
||||
Process = 0
|
||||
Error = No$
|
||||
Loop
|
||||
Process += 1
|
||||
Until Error OR Process GT 2
|
||||
On Process GoSub SET, SEND
|
||||
Repeat
|
||||
|
||||
Return MsgSent
|
||||
|
||||
SET:
|
||||
MsgSent = No$
|
||||
If Assigned(SendTo) else SendTo = ""
|
||||
If Assigned(CC) else CC = ""
|
||||
If Assigned(From) else From = ""
|
||||
If Assigned(Subject) else Subject = ""
|
||||
If Assigned(Body) else Body = ""
|
||||
If Assigned(aTitle) else aTitle = ""
|
||||
If Assigned(aPath) else aPath = ""
|
||||
If Assigned(eDialog) else eDialog = Yes$
|
||||
If Assigned(From) else From = ""
|
||||
If Assigned(ReplyTo) else ReplyTo = ""
|
||||
If Assigned(SRPMailAttach) else SRPMailAttach = ""
|
||||
If Assigned(ConfigFile) else ConfigFile = ""
|
||||
If Assigned(Bcc) else Bcc = ""
|
||||
If Assigned(HistoryTable) else HistoryTable = ""
|
||||
If SendTo EQ "" then Error = Yes$
|
||||
MsgSent = ""
|
||||
return
|
||||
|
||||
|
||||
SEND:
|
||||
Swap @VM with @FM in ConfigFile
|
||||
If ConfigFile then
|
||||
GoSub Send_SRP_Mail
|
||||
end else
|
||||
Error = Yes$
|
||||
end
|
||||
return
|
||||
|
||||
Send_SRP_Mail:
|
||||
Swap @VM with ", " in SendTo
|
||||
Swap @VM with ", " in CC
|
||||
Swap @VM with ", " in Bcc
|
||||
Swap @VM with ", " in SRPMailAttach
|
||||
Swap @FM with ", " in SendTo
|
||||
Swap @FM with ", " in CC
|
||||
Swap @FM with ", " in Bcc
|
||||
Swap @FM with @VM in SRPMailAttach
|
||||
Message = ""
|
||||
Message<1> = Subject
|
||||
Message<2> = From
|
||||
Message<3> = SendTo
|
||||
Message<4> = CC
|
||||
Message<5> = Bcc
|
||||
Message<6> = ReplyTo
|
||||
HTMLCheck = Body[1, 6]
|
||||
Convert @LOWER_CASE to @UPPER_CASE in HTMLCheck
|
||||
If HTMLCheck EQ "<HTML>" then
|
||||
Message<7> = "HTML"
|
||||
end else
|
||||
Message<7> = "TEXT"
|
||||
end
|
||||
Message<8> = Body
|
||||
Message<9> = SRPMailAttach
|
||||
MsgSent = SRP_Send_Mail(Message, ConfigFile)
|
||||
return
|
||||
3658
SYSPROG/STPROC/SQL_SERVICES.txt
Normal file
3658
SYSPROG/STPROC/SQL_SERVICES.txt
Normal file
File diff suppressed because it is too large
Load Diff
398
SYSPROG/STPROC/SRP_EDITTABLE_MANAGER.txt
Normal file
398
SYSPROG/STPROC/SRP_EDITTABLE_MANAGER.txt
Normal file
@ -0,0 +1,398 @@
|
||||
Function SRP_EditTable_Manager(Method, CtrlEntId, Param1, Param2, Param3, Param4, Param5, Param6, Param7, Param8, Param9, Param10)
|
||||
|
||||
/***********************************************************************************************************************
|
||||
|
||||
This program is proprietary and is not to be used by or disclosed to others, nor is it to be copied without written
|
||||
permission from SRP Computer Solutions, Inc.
|
||||
|
||||
Name : SRP_EditTable_Manager
|
||||
|
||||
Description : Provides common setup and event features for the SRP OLE EditTable.
|
||||
|
||||
Notes : This is desiged to eliviate the need to duplicate large amounts of code to manage the SRP OLE
|
||||
EditTable. Review the list of options in the top-level case statement of this program to see what is
|
||||
available.
|
||||
|
||||
Some methods will call other methods. For instance, the BeforeUpdate method will call the Validate
|
||||
method.
|
||||
|
||||
Parameters :
|
||||
Method [in] -- A specific setup or event action to execute.
|
||||
CtrlEntId [in] -- The full control entity ID for the SRP OLE EditTable.
|
||||
Param2 [in] -- Generic parameter.
|
||||
Param3 [in] -- Generic parameter.
|
||||
Param4 [in] -- Generic parameter.
|
||||
Param5 [in] -- Generic parameter.
|
||||
Param6 [in] -- Generic parameter.
|
||||
Param7 [in] -- Generic parameter.
|
||||
Param8 [in] -- Generic parameter.
|
||||
Param9 [in] -- Generic parameter.
|
||||
Param10 [in] -- Generic parameter.
|
||||
EventFlow [out] -- Flag to indicate how the calling routine should continue. This will return a 1 if everything
|
||||
is successful.
|
||||
|
||||
History : (Date, Initials, Notes)
|
||||
01/22/08 dmb Original programmer. Start with the Validate method.
|
||||
01/24/08 dmb Add Clear and Read methods. Updated the WritePre method.
|
||||
01/25/08 dmb Add GridLine color defaults for Setup1.
|
||||
01/26/08 dmb Add Fill flag for Clear method.
|
||||
01/26/08 dmb Add PopulateData method.
|
||||
01/26/08 dmb Move LostFocus transfer data logic into its own gosub.
|
||||
02/14/08 dmb Add support for custom clear fills (used by the Clear method). Add support for
|
||||
@ROWSASCOLUMNS and @CELLSASFIELDS UDPs (used by Set_Record).
|
||||
02/14/08 dmb Update Style1 to default all header row and data rows to 19 pixels and not resizeable.
|
||||
02/16/08 dmb Add support for new UpdateCellEdit parameter in Transfer_EditTable_Data function. Only set
|
||||
it to Yes$ during the WritePre method.
|
||||
|
||||
***********************************************************************************************************************/
|
||||
|
||||
$insert LOGICAL
|
||||
|
||||
GoSub Check_Variable_Assignments
|
||||
|
||||
Declare function SRP_Edittable_Manager, Get_Property, Send_Message
|
||||
Declare subroutine Transfer_Edittable_Data, SRP_Edittable_Manager, Set_Record, Send_Message, Set_Property
|
||||
|
||||
Begin Case
|
||||
// EditTable Events
|
||||
Case Method EQ "BeforeUpdate" ; GoSub BeforeUpdate
|
||||
Case Method EQ "AfterUpdate" ; GoSub AfterUpdate
|
||||
Case Method EQ "PosChanged" ; GoSub PosChanged
|
||||
Case Method EQ "AfterDeleteRecords" ; GoSub AfterDeleteRecords
|
||||
Case Method EQ "LostFocus" ; GoSub LostFocus
|
||||
|
||||
// Window Events
|
||||
Case Method EQ "WritePre" ; GoSub WritePre
|
||||
Case Method EQ "Read" ; GoSub Read
|
||||
Case Method EQ "Clear" ; GoSub Clear
|
||||
|
||||
// Event actions
|
||||
Case Method EQ "Validate" ; GoSub Validate
|
||||
Case Method EQ "Convert" ; GoSub Convert
|
||||
|
||||
// Data population
|
||||
Case Method EQ "PopulateData" ; GoSub PopulateData
|
||||
|
||||
// Setup options
|
||||
Case Method EQ "Setup1" ; GoSub Setup1
|
||||
End Case
|
||||
|
||||
If Assigned(EventFlow) else EventFlow = 1 ; // If not method set this then assume all is well
|
||||
|
||||
Return EventFlow
|
||||
|
||||
Validate:
|
||||
//////////////////////////////////////////////////////////////////////////////////////
|
||||
//
|
||||
// The Validate method requires the following parameters to be populated:
|
||||
//
|
||||
// Param1 = SelPos
|
||||
// Param2 = Data
|
||||
// Param3 = Validation
|
||||
//
|
||||
// Optionally, these parameters can also be use to override default settings:
|
||||
//
|
||||
// Param4 = ValidationMessage
|
||||
// Param5 = ValidationTitle
|
||||
// Param6 = ValidationDisplayLength
|
||||
//
|
||||
// If ValidationMessage is populated then the ShowBalloonTooltip will be used.
|
||||
// Otherwise, it is assumed tha the validation method will display its own
|
||||
// message, which is the case for many UDCs.
|
||||
//
|
||||
//////////////////////////////////////////////////////////////////////////////////////
|
||||
|
||||
Transfer Param1 to SelPos
|
||||
Transfer Param2 to Data
|
||||
Transfer Param3 to Validation
|
||||
Transfer Param4 to ValidationMessage
|
||||
|
||||
If Len(Param5) then Transfer Param5 to ValidationTitle else ValidationTitle = "Validation Error"
|
||||
If Len(Param6) then Transfer Param6 to ValidationDisplayLength else ValidationDisplayLength = 2000
|
||||
|
||||
Status() = 0
|
||||
iData = IConv(Data, Validation)
|
||||
If Status() NE 0 then
|
||||
// Validation failed.
|
||||
|
||||
If Len(ValidationMessage) then
|
||||
// Use the ShowBalloonTooltip to alert the user of the validation error.
|
||||
Convert ";" to @FM in SelPos
|
||||
Swap "@DATA" with Data in ValidationMessage
|
||||
Config = ""
|
||||
Config<1> = ValidationMessage ; // Message to display.
|
||||
Config<2> = ValidationTitle ; // Title of the message.
|
||||
Config<3> = 3 ; // Use the Error icon.
|
||||
Config<4> = ValidationDisplayLength ; // Display for 2 seconds unless user clicks to close first.
|
||||
Send_Message(CtrlEntId, "OLE.ShowBalloonTooltip", SelPos, Config)
|
||||
end
|
||||
|
||||
Set_Property(CtrlEntId, "OLE.Cancel", 2) ; // This forces the focus to return to the current cell and highlight the cell text.
|
||||
EventFlow = 0 ; // Indicate that this event chain needs to abort.
|
||||
end
|
||||
return
|
||||
|
||||
Convert:
|
||||
//////////////////////////////////////////////////////////////////////////////////////
|
||||
//
|
||||
// The Convert method requires the following parameters to be populated:
|
||||
//
|
||||
// Param1 = SelPos
|
||||
// Param2 = Data
|
||||
// Param3 = Conversion
|
||||
//
|
||||
//////////////////////////////////////////////////////////////////////////////////////
|
||||
|
||||
Transfer Param1 to SelPos
|
||||
Transfer Param2 to Data
|
||||
Transfer Param3 to Conversion
|
||||
|
||||
NewData = Oconv(Iconv(Data, Conversion), Conversion) ; // Internally convert then externally convert the data to make sure it is formatted correctly.
|
||||
Set_Property(CtrlEntId, "OLE.CellText[":SelPos:"]", NewData)
|
||||
return
|
||||
|
||||
BeforeUpdate:
|
||||
// The BeforeUpdate event can be used for validation checking.
|
||||
Transfer Param1 to SelPos
|
||||
Transfer Param2 to Data
|
||||
Transfer Param3 to Validation
|
||||
|
||||
CellConv = Get_Property(CtrlEntId, "OLE.CellConv[":SelPos:"]")
|
||||
ValidationMessage = CellConv<3>
|
||||
|
||||
// If the Validation parameter has something, do a validation check.
|
||||
If Len(Validation) then
|
||||
EventFlow = SRP_EditTable_Manager("Validate", CtrlEntId, SelPos, Data, Validation, ValidationMessage)
|
||||
end
|
||||
return
|
||||
|
||||
AfterUpdate:
|
||||
// The AfterUpdate event can be used for conversion.
|
||||
Transfer Param1 to SelPos
|
||||
Transfer Param2 to Data
|
||||
Transfer Param3 to Conversion
|
||||
|
||||
// If the Conversion parameter has something, perform the conversion.
|
||||
If Len(Conversion) then SRP_EditTable_Manager("Convert", CtrlEntId, SelPos, Data, Conversion)
|
||||
return
|
||||
|
||||
PosChanged:
|
||||
// The PosChanged event can be used for defaults.
|
||||
Transfer Param1 to SelPos
|
||||
Transfer Param2 to PrevSelPos
|
||||
Transfer Param3 to Cause
|
||||
Transfer Param4 to Default ; // Note: this parameter is not a part of the PosChanged event
|
||||
// but the calling routine can pass this in to allow default handling.
|
||||
|
||||
// Get the data in the current cell. If null and a default value has been passed in then update the cell text.
|
||||
Data = Get_Property(CtrlEntId, "OLE.CellText[":SelPos:"]")
|
||||
If Data EQ "" AND Len(Default) then
|
||||
Set_Property(CtrlEntId, "OLE.CellText[":SelPos:"]", Default)
|
||||
Send_Message(CtrlEntId, "OLE.EditCell", "")
|
||||
end
|
||||
|
||||
// Since the PosChanged event can add default data make sure these changes are transferred to the OI EditTable.
|
||||
UpdateCellEdit = No$
|
||||
GoSub Update_Databound_EditTable
|
||||
return
|
||||
|
||||
AfterDeleteRecords:
|
||||
// Since deleting a record from the EditTable changes data make sure these changes are transferred to the OI
|
||||
// EditTable.
|
||||
UpdateCellEdit = No$
|
||||
GoSub Update_Databound_EditTable
|
||||
return
|
||||
|
||||
LostFocus:
|
||||
UpdateCellEdit = No$
|
||||
GoSub Update_Databound_EditTable
|
||||
return
|
||||
|
||||
Read:
|
||||
Record = Param1
|
||||
Set_Record(Record, "", Yes$)
|
||||
return
|
||||
|
||||
Clear:
|
||||
// Find all the OLE EditTables and Clear them.
|
||||
Transfer Param1 to DefaultClearFill
|
||||
If DefaultClearFill EQ "" then DefaultClearFill = 1
|
||||
|
||||
CtrlMap = Get_Property(@Window, "CTRLMAP")
|
||||
Convert @FM to @RM in CtrlMap
|
||||
ProgIDs = Get_Property(CtrlMap, "OLE.ProgID")
|
||||
BytePos = 1 ; // Byte position within the string. Used by the Remove statement
|
||||
Flag = "" ; // Flag used by the Remove statement
|
||||
RPos = 0 ; // Record position within the @RM delimited string
|
||||
Loop
|
||||
Remove ProgID from ProgIDs at BytePos setting Flag
|
||||
RPos += 1
|
||||
If ProgID _EQC "SRP.EditTable.1" then
|
||||
// This is an OLE EditTable so send the Clear method.
|
||||
Ctrl = Field(CtrlMap, @RM, RPos)
|
||||
ClearFill = Get_Property(Ctrl, "@CLEARFILL")
|
||||
If ClearFill EQ "" then ClearFill = DefaultClearFill
|
||||
Send_Message(Ctrl, "OLE.Clear", ClearFill)
|
||||
end
|
||||
While Flag
|
||||
Repeat
|
||||
return
|
||||
|
||||
WritePre:
|
||||
CtrlEntId = Get_Property(@Window, "FOCUS")
|
||||
ProgID = Get_Property(CtrlEntId, "OLE.ProgID")
|
||||
If ProgID _EQC "SRP.EditTable.1" then
|
||||
// Control with focus is an SRP OLE EditTable. Before the system event handler executes, update the current cell
|
||||
// text and then transfer the data from the OLE EditTable to the OI EditTable.
|
||||
CellContents = Send_Message(CtrlEntId, "OLE.UpdateCellEdit")
|
||||
If CellContents<2> EQ "" then
|
||||
// The attempt to update the cell failed. Probably due to a validation error. Abort the event.
|
||||
EventFlow = 0
|
||||
end else
|
||||
// Cell update was successful. Transfer data to OI EditTable.
|
||||
UpdateCellEdit = Yes$
|
||||
GoSub Update_Databound_EditTable
|
||||
end
|
||||
end
|
||||
return
|
||||
|
||||
PopulateData:
|
||||
// It is assumed that @ID, @RECORD, and @DICT is already populated. This method uses
|
||||
// the Calculate function which requires these system variables.
|
||||
Transfer Param1 to DataArray ; // Dynamic array of field names. Used by the Calculate function to compute the value.
|
||||
DictFields = Param2 ; // The %FIELDS% record from the dictionary table. Used to get the output conversion format.
|
||||
Transfer Param3 to ArrayFlag ; // Flag that indicates if the DataArray is in Array or List format. Default is Array.
|
||||
|
||||
If ArrayFlag EQ "" then ArrayFlag = Yes$
|
||||
|
||||
NumRows = FieldCount(DataArray, @FM)
|
||||
For RowCnt = 1 to NumRows
|
||||
NumCols = FieldCount(DataArray<RowCnt>, @VM)
|
||||
For ColCnt = 1 to NumCols
|
||||
FieldName = DataArray<RowCnt, ColCnt>
|
||||
Locate FieldName in DictFields<3> using @VM setting vPos then
|
||||
FieldData = Calculate(FieldName)
|
||||
Format = DictFields<12, vPos>
|
||||
If Len(Format) then FieldData = Oconv(FieldData, Format)
|
||||
DataArray<RowCnt, ColCnt> = FieldData
|
||||
end
|
||||
Next ColCnt
|
||||
Next RowCnt
|
||||
|
||||
If ArrayFlag then Prop = "OLE.Array" else Prop = "OLE.List"
|
||||
Set_Property(CtrlEntId, Prop, DataArray)
|
||||
return
|
||||
|
||||
Setup1:
|
||||
Transfer Param1 to ArrayDimension
|
||||
Transfer Param2 to TitleList
|
||||
Transfer Param3 to ColumnWidths
|
||||
Transfer Param4 to ColumnAlignments
|
||||
Transfer Param5 to VirtualPos
|
||||
Transfer Param6 to RowsAsColumns
|
||||
Transfer Param7 to CellsAsFields
|
||||
Transfer Param8 to ClearFill
|
||||
Transfer Param9 to RowsToRecord
|
||||
|
||||
// Set up general properties that affect the entire EditTable.
|
||||
Set_Property(CtrlEntId, "OLE.BorderType", "XP Flat") ; // XP border when possible.
|
||||
Set_Property(CtrlEntId, "OLE.WorkspaceBkColor", "Window") ; // Fill in the space with no cells with the current theme's Window color.
|
||||
If ArrayDimension then Set_Property(CtrlEntId, "OLE.Dimension", ArrayDimension) ; // Create the number of columns and rows for this EditTable.
|
||||
If RowsToRecord then Set_Property(CtrlEntId, "OLE.RowsToRecords", RowsToRecord) ; // Set up RowsToRecord if required.
|
||||
// Set up properties that affect navigation functional and visual behavior.
|
||||
Set_Property(CtrlEntId, "OLE.QuickTabOut", Yes$) ; // Force the focus to move to the next control if the user tries to navigate on an empty row (i.e. just like AREV). "Yes" is the default, but it is added here anyway to help explain what the EditTable can do.
|
||||
Set_Property(CtrlEntId, "OLE.CellEditMode[All; All]", "Edit") ; // Put the cell into edit mode upon entry. Notice that properties that accept coordinates can accept the keyword "All".
|
||||
Set_Property(CtrlEntId, "OLE.AutoColors" , "Row(Auto; Auto; Auto; 3DFace L=95; 1)") ; // Automatically alternate the color of every other row. This makes different rows easier to identify, especially since we have set 2 RowsToRecord.
|
||||
Set_Property(CtrlEntId, "OLE.SelectionStyle", @VM:"S L=80":@FM:@VM:"S L=95") ; // Automatically highlight the current row with one color and highlight the current row with another color.
|
||||
// Set up the Column and Row headers.
|
||||
If Len(TitleList) then
|
||||
If TitleList then Set_Property(CtrlEntId, "OLE.TitleList", TitleList) ; // Set up the text to be displayed in each column header.
|
||||
end else
|
||||
Set_Property(CtrlEntId, "OLE.HeaderRow[1]", @FM:No$) ; // Hide the header row if no TitleList was passed in.
|
||||
end
|
||||
Set_Property(CtrlEntId, 'OLE.HeaderFont[All;All]', 'Segoe UI' : @SVM : 9)
|
||||
Set_Property(CtrlEntId, 'OLE.CellFont[All;All]', 'Segoe UI' : @SVM : 9)
|
||||
Set_Property(CtrlEntId, "OLE.HeaderRow[All]", "19":@FM:"":@FM:No$) ; // Make all column header rows to be 19 pixels tall and unable to be resized.
|
||||
Set_Property(CtrlEntId, "OLE.DataRow[All]", "19":@FM:"":@FM:No$) ; // Make all data rows to be 19 pixels tall and unable to be resized.
|
||||
Set_Property(CtrlEntId, "OLE.HeaderColumn[1]", "20":@FM:"":@FM:No$) ; // Make the row header column to be 20 pixels wide and unable to be resized.
|
||||
Set_Property(CtrlEntId, "OLE.AutoNumbers", "I":@VM:1) ; // Make the row header column auto number with an integer starting with 1.
|
||||
// Set up column properties.
|
||||
If ColumnWidths then
|
||||
NumColumns = Count(ColumnWidths, @FM) + (ColumnWidths NE "")
|
||||
CharPos = 1
|
||||
For ColPos = 1 to NumColumns
|
||||
Remove ColWidth from ColumnWidths at CharPos setting Flag
|
||||
Begin Case
|
||||
Case Num(ColWidth) ; Set_Property(CtrlEntId, "OLE.DataColumn[":ColPos:"]", ColWidth) ; // Set column to fixed width
|
||||
Case ColWidth EQ "A" ; Set_Property(CtrlEntId, "OLE.DataColumn[":ColPos:"]", @FM:@FM:@FM:Yes$) ; // Set column to autosized
|
||||
End Case
|
||||
Next ColPos
|
||||
end
|
||||
If ColumnAlignments then
|
||||
NumColumns = Count(ColumnAlignments, @FM) + (ColumnAlignments NE "")
|
||||
CharPos = 1
|
||||
For ColPos = 1 to NumColumns
|
||||
Remove ColumnAlignment from ColumnAlignments at CharPos setting Flag
|
||||
If Len(ColumnAlignment) then Set_Property(CtrlEntId, "OLE.CellAlignment[":ColPos:"; All]", @FM:ColumnAlignment) ; // Set the column alignment
|
||||
Next ColPos
|
||||
end
|
||||
// Set up the @POS UDP for Set_Record
|
||||
If VirtualPos then Set_Property(CtrlEntId, "@POS", VirtualPos)
|
||||
If RowsAsColumns then Set_Property(CtrlEntId, "@ROWSASCOLUMNS", RowsAsColumns)
|
||||
If CellsAsFields then Set_Property(CtrlEntId, "@CELLSASFIELDS", CellsAsFields)
|
||||
If ClearFill then Set_Property(CtrlEntId, "@CLEARFILL", ClearFill)
|
||||
|
||||
GoSub Qualify_Events
|
||||
return
|
||||
|
||||
//////////////////////////////////////////////////////////////////
|
||||
///////////////// Internal methods ///////////////////////////////
|
||||
//////////////////////////////////////////////////////////////////
|
||||
|
||||
Check_Variable_Assignments:
|
||||
If Assigned(Method) else Method = ""
|
||||
If Assigned(CtrlEntId) else CtrlEntId = ""
|
||||
If Assigned(Param1) else Param1 = ""
|
||||
If Assigned(Param2) else Param2 = ""
|
||||
If Assigned(Param3) else Param3 = ""
|
||||
If Assigned(Param4) else Param4 = ""
|
||||
If Assigned(Param5) else Param5 = ""
|
||||
If Assigned(Param6) else Param6 = ""
|
||||
If Assigned(Param7) else Param7 = ""
|
||||
If Assigned(Param8) else Param8 = ""
|
||||
If Assigned(Param9) else Param9 = ""
|
||||
If Assigned(Param10) else Param10 = ""
|
||||
return
|
||||
|
||||
ParseParam1:
|
||||
SelPos1 = Param1
|
||||
FieldPos1 = Field(SelPos1, ";", 1)
|
||||
RecordPos1 = Field(SelPos1, ";", 2)
|
||||
return
|
||||
|
||||
ParseParam2:
|
||||
SelPos2 = Param2
|
||||
FieldPos2 = Field(SelPos2, ";", 1)
|
||||
RecordPos2 = Field(SelPos2, ";", 2)
|
||||
return
|
||||
|
||||
Update_Databound_EditTable:
|
||||
// Transfer the Array property of the OLE EditTable to the DEFPROP property of the OI EditTable. Assumes that the
|
||||
// OLE EditTable begins with "OLE_EDT" and that the OI EditTable begins with "EDT" and it also assumes the rest of
|
||||
// the control names match.
|
||||
OIEditTable = CtrlEntId
|
||||
Swap "OLE_EDT" with "EDT" in OIEditTable
|
||||
Transfer_EditTable_Data(CtrlEntId, OIEditTable, No$, UpdateCellEdit)
|
||||
|
||||
// Force a redisplay of any symbolic columns in the window.
|
||||
Set_Record("", "SYM")
|
||||
return
|
||||
|
||||
Qualify_Events:
|
||||
// Enable OLE event processing for this control. Set the Synchronous event flag for better event control.
|
||||
Qualify = ""
|
||||
Qualify<1> = 1 ; // Enable OLE event
|
||||
Qualify<4> = 2 ; // Synchronous event processing
|
||||
|
||||
Send_Message(CtrlEntId, "QUALIFY_EVENT", "ALL_OLES", Qualify)
|
||||
return
|
||||
40
SYSPROG/STPROC/SRP_GIT_LISTENER.txt
Normal file
40
SYSPROG/STPROC/SRP_GIT_LISTENER.txt
Normal file
@ -0,0 +1,40 @@
|
||||
Compile function SRP_Git_Listener(Message,OrigEntid,Arg1,Arg2,Arg3,Arg4,Arg5,Arg6,Arg7,Arg8,Arg9,Arg10,Arg11,Arg12,Arg13,Arg14,Arg15,Arg16,Arg17,Arg18,Arg19,Arg20)
|
||||
#pragma precomp SRP_PreCompiler
|
||||
|
||||
Declare function SRP_Git_Services, SRP_Git_Redirect, Status
|
||||
Declare subroutine SRP_Git_Serializer, Set_Status
|
||||
|
||||
Common /SRP_Git_Listener/ SRPGitListener_Suppress@
|
||||
|
||||
If SRPGitListener_Suppress@ NE 1 then
|
||||
Name = OrigEntId[-1, "B*"]
|
||||
If Name[1, 16] _NEC "SRP_EDITOR_TEMP_" AND Name[-14, 14] _NEC "__SRP_GIT_TEMP" then
|
||||
Begin Case
|
||||
|
||||
Case Message _EQC 'UPDATE'
|
||||
|
||||
If SRP_Git_Services("IsEnabled") AND Assigned(Arg1) then
|
||||
SRP_Git_Serializer('Write', OrigEntId, Arg1, SRP_Git_Services("GetRepoPath"))
|
||||
end
|
||||
|
||||
Case Message _EQC 'WRITE' OR Message _EQC 'NEW'
|
||||
|
||||
If SRP_Git_Services("IsEnabled") AND Assigned(Arg10) then
|
||||
// Ignore APPROW entities whose contents are the same as it's key
|
||||
If Field(OrigEntId, "*", 2, 1) EQ "APPROW" AND Arg10 _EQC OrigEntId[-1, "B:"] else
|
||||
SRP_Git_Serializer('Write', OrigEntId, Arg10, SRP_Git_Services("GetRepoPath"))
|
||||
end
|
||||
end
|
||||
|
||||
Case Message _EQC 'DESTROY' OR Message _EQC 'TDESTROY'
|
||||
|
||||
If SRP_Git_Services("IsEnabled") then
|
||||
SRP_Git_Serializer('Delete', OrigEntId, SRP_Git_Services("GetRepoPath"))
|
||||
end
|
||||
|
||||
End Case
|
||||
end
|
||||
end
|
||||
Ans = SRP_Git_Redirect(Message,OrigEntid,Arg1,Arg2,Arg3,Arg4,Arg5,Arg6,Arg7,Arg8,Arg9,Arg10,Arg11,Arg12,Arg13,Arg14,Arg15,Arg16,Arg17,Arg18,Arg19,Arg20)
|
||||
|
||||
Return Ans
|
||||
163
SYSPROG/STPROC/SRP_GIT_SERIALIZER.txt
Normal file
163
SYSPROG/STPROC/SRP_GIT_SERIALIZER.txt
Normal file
@ -0,0 +1,163 @@
|
||||
Compile function SRP_Git_Serializer(@Service, @Params)
|
||||
/************************************************************************************************
|
||||
This program is proprietary and is not to be used by or disclosed to others, nor is it to
|
||||
be copied without written permission from SRP Computer Solutions, Inc.
|
||||
|
||||
Name : SRP_Git_Serializer
|
||||
|
||||
Description : Service module for the converting files to formats suitable for Git.
|
||||
|
||||
Parameters:
|
||||
Service [IN] - The service to execute
|
||||
Params [IN] - Service specific parameters
|
||||
|
||||
History (Date, Initials, Notes)
|
||||
02/20/19 KRF Original programmer
|
||||
07/30/19 KRF Renamed to SRP_Git_Serializer and updated to use new DLL stubs
|
||||
************************************************************************************************/
|
||||
#pragma precomp SRP_PreCompiler
|
||||
#pragma output SYSLISTS SRP_GIT_SERIALIZER
|
||||
$insert LOGICAL
|
||||
|
||||
Declare function ISRPGitSerializer_ReadFromGit, ISRPGitSerializer_ReadFileFromGit, ISRPGitSerializer_PathToEntityId, ISRPGitSerializer_Deserialize
|
||||
Declare function ISRPGitSerializer_EntityIdToPath, ISRPGitSerializer_GetSupportedTypes, ISRPGitSerializer_EntityIdToKeys, ISRPGitSerializer_EntityIdToRelativePath
|
||||
Declare function Str_Unicode, Unicode_Str, ISRPGitSerializer_GetMetaData
|
||||
Declare subroutine ISRPGitSerializer_WriteToGit, ISRPGitSerializer_WriteToGitSync, ISRPGitSerializer_DeleteFromGit, ISRPGitSerializer_CopyOutput, ISRPGitSerializer_SetMetaData
|
||||
|
||||
GoToService
|
||||
|
||||
Return Response or ""
|
||||
|
||||
///////////////////////////////////////////////////////////////////////////////////////////////////
|
||||
// SERVICES
|
||||
///////////////////////////////////////////////////////////////////////////////////////////////////
|
||||
|
||||
//-------------------------------------------------------------------------------------------------
|
||||
// Converts the given entity into a file suitable for GIT comparisons.
|
||||
//-------------------------------------------------------------------------------------------------
|
||||
Service Write(EntityId, Record, RepoPath, Metadata)
|
||||
|
||||
If Len(Metadata) then
|
||||
ISRPGitSerializer_SetMetaData(Metadata)
|
||||
end
|
||||
RecordW = Str_Unicode(Record)
|
||||
ISRPGitSerializer_WriteToGit(EntityId, RecordW, Len(Record), RepoPath)
|
||||
|
||||
end service
|
||||
|
||||
//-------------------------------------------------------------------------------------------------
|
||||
// Converts the given entity into a file suitable for GIT comparisons. Synchronous.
|
||||
//-------------------------------------------------------------------------------------------------
|
||||
Service WriteSync(EntityId, Record, RepoPath, Metadata)
|
||||
|
||||
If Len(Metadata) then
|
||||
ISRPGitSerializer_SetMetaData(Metadata)
|
||||
end
|
||||
RecordW = Str_Unicode(Record)
|
||||
ISRPGitSerializer_WriteToGitSync(EntityId, RecordW, Len(Record), RepoPath)
|
||||
|
||||
end service
|
||||
|
||||
//-------------------------------------------------------------------------------------------------
|
||||
// Deletes the file associated with this entity id
|
||||
//-------------------------------------------------------------------------------------------------
|
||||
Service Delete(EntityId, RepoPath)
|
||||
|
||||
ISRPGitSerializer_DeleteFromGit(EntityId, RepoPath)
|
||||
|
||||
end service
|
||||
|
||||
//-------------------------------------------------------------------------------------------------
|
||||
// Converts a file suitable for GIT comparisons back into an OI entity.
|
||||
//-------------------------------------------------------------------------------------------------
|
||||
Service Read(EntityId, RepoPath, Ref Metadata)
|
||||
|
||||
Len = ISRPGitSerializer_ReadFromGit(EntityId, RepoPath)
|
||||
GoSub GetOutput
|
||||
Metadata = ISRPGitSerializer_GetMetaData()
|
||||
|
||||
end service
|
||||
|
||||
//-------------------------------------------------------------------------------------------------
|
||||
// Reads the given file, returning the record and it's entity id
|
||||
//-------------------------------------------------------------------------------------------------
|
||||
Service ReadFile(RepoPath, FilePath, Ref EntityId, Ref Metadata)
|
||||
|
||||
EntityId = Str(\00\, 260)
|
||||
Len = ISRPGitSerializer_ReadFileFromGit(EntityId, RepoPath, FilePath)
|
||||
EntityId = EntityId[1, \00\]
|
||||
GoSub GetOutput
|
||||
Metadata = ISRPGitSerializer_GetMetaData()
|
||||
|
||||
end service
|
||||
|
||||
//-------------------------------------------------------------------------------------------------
|
||||
// Deserializes text
|
||||
//-------------------------------------------------------------------------------------------------
|
||||
Service Deserialize(EntityId, Text, Ref Metadata)
|
||||
|
||||
Len = ISRPGitSerializer_Deserialize(EntityId, Text)
|
||||
GoSub GetOutput
|
||||
Metadata = ISRPGitSerializer_GetMetaData()
|
||||
|
||||
end service
|
||||
|
||||
//-------------------------------------------------------------------------------------------------
|
||||
// Given an EntityId, this service constructs the target full file and path name
|
||||
//-------------------------------------------------------------------------------------------------
|
||||
Service EntityIdToPath(RepoPath, EntityId)
|
||||
|
||||
Response = ISRPGitSerializer_EntityIdToPath(RepoPath, EntityId)
|
||||
|
||||
end service
|
||||
|
||||
//-------------------------------------------------------------------------------------------------
|
||||
// Given an EntityId, this service constructs the target path name relative to the repo directory
|
||||
//-------------------------------------------------------------------------------------------------
|
||||
Service EntityIdToRelativePath(EntityId)
|
||||
|
||||
Response = ISRPGitSerializer_EntityIdToRelativePath(EntityId)
|
||||
|
||||
end service
|
||||
|
||||
//-------------------------------------------------------------------------------------------------
|
||||
// Given a full file and path name, this service constructs the target EntityId
|
||||
//-------------------------------------------------------------------------------------------------
|
||||
Service PathToEntityId(RepoPath, FilePath)
|
||||
|
||||
Response = ISRPGitSerializer_PathToEntityId(RepoPath, FilePath)
|
||||
|
||||
end service
|
||||
|
||||
//-------------------------------------------------------------------------------------------------
|
||||
// Given an EntityId, this service constructs all the tables and keys housing that entities data
|
||||
//-------------------------------------------------------------------------------------------------
|
||||
Service EntityIdToKeys(EntityId)
|
||||
|
||||
Response = ISRPGitSerializer_EntityIdToKeys(EntityId)
|
||||
|
||||
end service
|
||||
|
||||
//-------------------------------------------------------------------------------------------------
|
||||
// An @FM delimited list of supported entity types
|
||||
//-------------------------------------------------------------------------------------------------
|
||||
Service GetSupportedEntityTypes()
|
||||
|
||||
Response = ISRPGitSerializer_GetSupportedTypes()
|
||||
|
||||
end service
|
||||
|
||||
///////////////////////////////////////////////////////////////////////////////////////////////////
|
||||
// GOSUBS
|
||||
///////////////////////////////////////////////////////////////////////////////////////////////////
|
||||
|
||||
GetOutput:
|
||||
|
||||
If Len GT 0 then
|
||||
ResponseW = Str(\0000\, Len)
|
||||
ISRPGitSerializer_CopyOutput(ResponseW, Len)
|
||||
Response = Unicode_Str(ResponseW)
|
||||
end
|
||||
|
||||
return
|
||||
|
||||
756
SYSPROG/STPROC/SRP_GIT_SERVICES.txt
Normal file
756
SYSPROG/STPROC/SRP_GIT_SERVICES.txt
Normal file
@ -0,0 +1,756 @@
|
||||
Compile function SRP_Git_Services(@Service, @Params)
|
||||
/************************************************************************************************
|
||||
This program is proprietary and is not to be used by or disclosed to others, nor is it to
|
||||
be copied without written permission from SRP Computer Solutions, Inc.
|
||||
|
||||
Name : SRP_GIT_SERVICES
|
||||
Test
|
||||
Description : Service module for the SRP GIT system.
|
||||
|
||||
Parameters:
|
||||
Service [IN] - The service to execute
|
||||
Params [IN] - Service specific parameters
|
||||
|
||||
History (Date, Initials, Notes)
|
||||
02/25/19 DJS Original programmer
|
||||
07/29/19 KRF Ported from Git_Services
|
||||
03/04/24 KRF Fixed bug in PullEntities where For Loop iterator was getting reset
|
||||
by gosubs
|
||||
************************************************************************************************/
|
||||
#pragma precomp SRP_PreCompiler
|
||||
|
||||
Common /SRP_Git_Services/ SRPGitServices_UserSettings@
|
||||
Common /SRP_Git_Listener/ SRPGitListener_Suppress@
|
||||
|
||||
$insert LOGICAL
|
||||
$insert MESSAGE_BOX_EQUATES
|
||||
$insert RLIST_EQUATES
|
||||
|
||||
Equ CRLF$ to \0D0A\
|
||||
|
||||
Equ SrpGitEnabled$ To 1
|
||||
Equ SrpGitRepoLoc$ To 2
|
||||
Equ SrpGitExePath$ To 3
|
||||
Equ SrpGitGUICommand$ To 4
|
||||
Equ SrpGitCommitCommand$ To 5
|
||||
Equ SrpGitPullCommand$ To 6
|
||||
Equ SrpGitPushCommand$ To 7
|
||||
Equ SrpGitHistCommand$ To 8
|
||||
Equ SrpGitDiffCommand$ To 9
|
||||
Equ SrpGitWarning$ To 10
|
||||
|
||||
Declare function SRP_Git_Services, SRP_Git_Serializer, Get_Repos_Entities, Repository, SRP_Editor_Parse, SRP_RevErrorMsg, SRP_Array, Min, DateTime
|
||||
Declare subroutine SRP_Git_Serializer, Utility, Get_Status, Set_Status, Repository, Msg, Set_Property, Send_Message, Yield, SRP_Git_Services
|
||||
|
||||
// load the settings on the first call
|
||||
If Len(SRPGitServices_UserSettings@) else
|
||||
SRPGitServices_UserSettings@ = Xlate("SYSENV", "SRP_GIT_SETTINGS", "", "X")
|
||||
If Len(SRPGitServices_UserSettings@) else
|
||||
SRPGitServices_UserSettings@ = Xlate("SYSENV", "SRP_GIT_SETTINGS*":@APPID<1>:"*":@Username, "", "X")
|
||||
end
|
||||
end
|
||||
|
||||
GoToService
|
||||
|
||||
Return Response or ""
|
||||
|
||||
//-----------------------------------------------------------------------------
|
||||
// SERVICES
|
||||
//-----------------------------------------------------------------------------
|
||||
|
||||
Service HasSettings()
|
||||
Response = Len(SRPGitServices_UserSettings@<SrpGitRepoLoc$>) GT 0 AND Len(SRPGitServices_UserSettings@<SrpGitExePath$>) GT 0
|
||||
end service
|
||||
|
||||
Service IsEnabled()
|
||||
Response = If Len(SRPGitServices_UserSettings@<SrpGitEnabled$>) then SRPGitServices_UserSettings@<SrpGitEnabled$> else 0
|
||||
end service
|
||||
|
||||
Service GetRepoPath()
|
||||
Response = SRPGitServices_UserSettings@<SrpGitRepoLoc$>
|
||||
end service
|
||||
|
||||
Service GetGitPath()
|
||||
Response = SRPGitServices_UserSettings@<SrpGitExePath$>
|
||||
end service
|
||||
|
||||
Service GetGuiCommand()
|
||||
Response = SRPGitServices_UserSettings@<SrpGitGUICommand$>
|
||||
end service
|
||||
|
||||
Service GetCommitCommand()
|
||||
Response = SRPGitServices_UserSettings@<SrpGitCommitCommand$>
|
||||
end service
|
||||
|
||||
Service GetPullCommand()
|
||||
Response = SRPGitServices_UserSettings@<SrpGitPullCommand$>
|
||||
end service
|
||||
|
||||
Service GetPushCommand()
|
||||
Response = SRPGitServices_UserSettings@<SrpGitPushCommand$>
|
||||
end service
|
||||
|
||||
Service GetHistCommand()
|
||||
Response = SRPGitServices_UserSettings@<SrpGitHistCommand$>
|
||||
end service
|
||||
|
||||
Service GetDiffCommand()
|
||||
Response = SRPGitServices_UserSettings@<SrpGitDiffCommand$>
|
||||
end service
|
||||
|
||||
Service GetWarning()
|
||||
Response = SRPGitServices_UserSettings@<SrpGitWarning$>
|
||||
end service
|
||||
|
||||
Service GetCurrentCommit()
|
||||
|
||||
If Len(SRPGitServices_UserSettings@<SrpGitExePath$>) then
|
||||
Root = SRPGitServices_UserSettings@<SrpGitExePath$>:' -C "':SRPGitServices_UserSettings@<SrpGitRepoLoc$>:'"'
|
||||
Cmd = Root:" for-each-ref --count=1 --sort=-committerdate refs/heads --format=%(HEAD)":\0D\:"%(objectname:short=8)":\0D\:"%(refname:short)":\0D\:"%(committerdate:relative)":\0D\:"%(authorname)":\0D\:"%(subject)":\0D\:"[%(refname:short)]":\0B\:"%(subject)":\0B\:"(%(authorname))"
|
||||
Output = "VAR"
|
||||
Call SRP_Run_Command(Cmd, Output)
|
||||
Convert \0D0B\ to @FM:" " in Output
|
||||
Response = Field(Output, @FM, 1, 7)
|
||||
end
|
||||
|
||||
end service
|
||||
|
||||
Service GetBranchHeads()
|
||||
|
||||
If Len(SRPGitServices_UserSettings@<SrpGitExePath$>) then
|
||||
Root = SRPGitServices_UserSettings@<SrpGitExePath$>:' -C "':SRPGitServices_UserSettings@<SrpGitRepoLoc$>:'"'
|
||||
Cmd = Root:" for-each-ref --sort=-committerdate refs/heads --format=%(HEAD)":\0D\:"%(objectname:short=8)":\0D\:"%(refname:short)":\0D\:"%(committerdate:relative)":\0D\:"%(authorname)":\0D\:"%(subject)":\0D\:"[%(refname:short)]":\0B\:"%(subject)":\0B\:"(%(authorname))"
|
||||
Response = "VAR"
|
||||
Call SRP_Run_Command(Cmd, Response)
|
||||
Convert \0A0D0B\ to @FM:@VM:" " in Response
|
||||
If Response[-1, 1] EQ @FM then Response[-1, 1] = ""
|
||||
end
|
||||
|
||||
end service
|
||||
|
||||
Service GetCommits()
|
||||
|
||||
If Len(SRPGitServices_UserSettings@<SrpGitExePath$>) then
|
||||
Root = SRPGitServices_UserSettings@<SrpGitExePath$>:' -C "':SRPGitServices_UserSettings@<SrpGitRepoLoc$>:'"'
|
||||
Cmd = Root:" for-each-ref --sort=-committerdate refs --format=%(HEAD)":\0D\:"%(objectname:short=8)":\0D\:"%(refname:short)":\0D\:"%(committerdate:relative)":\0D\:"%(authorname)":\0D\:"%(subject)":\0D\:"[%(refname:short)]":\0B\:"%(subject)":\0B\:"(%(authorname))"
|
||||
Response = "VAR"
|
||||
Call SRP_Run_Command(Cmd, Response)
|
||||
Convert \0A0D0B\ to @FM:@VM:" " in Response
|
||||
If Response[-1, 1] EQ @FM then Response[-1, 1] = ""
|
||||
end
|
||||
|
||||
end service
|
||||
|
||||
Service LoadLastCommit()
|
||||
Response = Xlate("SYSENV", "SRP_GIT_LASTCOMMIT", "", "X")
|
||||
end service
|
||||
|
||||
Service SaveLastCommit(CommitId, CommitDesc, CommitBranch, CommitAuthor)
|
||||
Open "SYSENV" to hSYSENV then
|
||||
Rec = ""
|
||||
Rec<-1> = CommitId
|
||||
Rec<-1> = CommitDesc
|
||||
Rec<-1> = CommitBranch
|
||||
Rec<-1> = CommitAuthor
|
||||
Write Rec to hSYSENV, "SRP_GIT_LASTCOMMIT" then NULL
|
||||
end
|
||||
end service
|
||||
|
||||
Service GetFileChanges(StartCommit, EndCommit)
|
||||
|
||||
Equ StatusName$ to "Added,Deleted,Modified"
|
||||
Response = ""
|
||||
ExePath = SRPGitServices_UserSettings@<SrpGitExePath$>
|
||||
RepoPath = SRPGitServices_UserSettings@<SrpGitRepoLoc$>
|
||||
If Len(ExePath) then
|
||||
Cmd = ExePath:' -C "':RepoPath:'" diff --name-status --no-renames --diff-filter=crtuxb ':StartCommit:' ':EndCommit
|
||||
Output = "VAR"
|
||||
Call SRP_Run_Command(Cmd, Output)
|
||||
If RepoPath[-1, 1] NE '\' then RepoPath := '\'
|
||||
For Each Line in Output using \0A\
|
||||
Status = Line[1, \09\]
|
||||
File = Line[Col2() + 1, \09\]
|
||||
If IndexC(File, ".gitignore", 1) EQ 0 then
|
||||
Pos = Index("ADM", Status[1, 1], 1)
|
||||
If Pos GT 0 then Status = Field(StatusName$, ",", Pos, 1) else Status = "Unknown"
|
||||
EntId = SRP_Git_Serializer("PathToEntityId", RepoPath, RepoPath:File)
|
||||
Response<-1> = Status:@VM:EntId
|
||||
end
|
||||
Next Line
|
||||
end
|
||||
|
||||
end service
|
||||
|
||||
Service SaveUserSettings(GitEnabled, GitRepoLoc, GitExePath, GitGUICommand, GitWarning, GitCommitCommand, GitPullCommand, GitPushCommand, GitHistCommand, GitDiffCommand)
|
||||
|
||||
// Update the settings
|
||||
SRPGitServices_UserSettings@<SrpGitEnabled$> = GitEnabled
|
||||
SRPGitServices_UserSettings@<SrpGitRepoLoc$> = GitRepoLoc
|
||||
SRPGitServices_UserSettings@<SrpGitExePath$> = GitExePath
|
||||
SRPGitServices_UserSettings@<SrpGitGUICommand$> = GitGUICommand
|
||||
SRPGitServices_UserSettings@<SrpGitWarning$> = GitWarning
|
||||
SRPGitServices_UserSettings@<SrpGitCommitCommand$> = GitCommitCommand
|
||||
SRPGitServices_UserSettings@<SrpGitPullCommand$> = GitPullCommand
|
||||
SRPGitServices_UserSettings@<SrpGitPushCommand$> = GitPushCommand
|
||||
SRPGitServices_UserSettings@<SrpGitHistCommand$> = GitHistCommand
|
||||
SRPGitServices_UserSettings@<SrpGitDiffCommand$> = GitDiffCommand
|
||||
|
||||
// Write the settings to disk
|
||||
Open 'SYSENV' to hSYSENV then
|
||||
Write SRPGitServices_UserSettings@ on hSYSENV, "SRP_GIT_SETTINGS" else
|
||||
Response = "Failed to save user Git settings. OpenInsight error code: ":Status()
|
||||
end
|
||||
end
|
||||
|
||||
// Update the MD table base on whether or not things are enabled
|
||||
Open "MD" to hMD then
|
||||
If GitEnabled then
|
||||
Read Rec from hMD, "REPOSITORY" else
|
||||
Rec = 'P':@FM:@FM:@FM:@FM:'SYSOBJ':@FM:'SRP_GIT_LISTENER'
|
||||
Write Rec to hMD, "REPOSITORY" then null
|
||||
end
|
||||
end else
|
||||
Delete hMD, "REPOSITORY" then null
|
||||
end
|
||||
GarbageCollect
|
||||
Flush
|
||||
Call Set_Property("SYSTEM", "IDLEPROC", "RTP27":@FM:"REPOSITORY")
|
||||
end
|
||||
|
||||
end service
|
||||
|
||||
Options ENTITY_TYPES = "ALL", "OIWIN", "STPROC", "STPROCINS"
|
||||
|
||||
Service GetSupportedEntityTypes()
|
||||
|
||||
Response = SRP_Git_Serializer("GetSupportedEntityTypes")
|
||||
|
||||
end service
|
||||
|
||||
Service GetOIEntities(EntityTypes=ENTITY_TYPES, Apps)
|
||||
|
||||
Response = ""
|
||||
If EntityTypes EQ "" OR EntityTypes EQ "ALL" then EntityTypes = SRP_Git_Services("GetSupportedEntityTypes")
|
||||
If Apps EQ "" then Apps = @APPID
|
||||
For each EntityType in EntityTypes using @FM
|
||||
For each App in Apps
|
||||
EntList = Get_Repos_Entities(App, EntityType, '')
|
||||
If Len(EntList) then
|
||||
For each EntID in EntList using @FM
|
||||
Parts = EntID
|
||||
Convert '*' to @VM in Parts
|
||||
Response := EntID:@VM:Parts:@FM ; *:@VM:LastChanged:@FM
|
||||
Next EntID
|
||||
end
|
||||
Next App
|
||||
Next EntityType
|
||||
Response[-1, 1] = ""
|
||||
|
||||
end service
|
||||
|
||||
Service GetRepoEntities(EntityTypes=ENTITY_TYPES, Apps, CommitStart, CommitEnd)
|
||||
|
||||
// get the repo path
|
||||
RepoPath = SRPGitServices_UserSettings@<SrpGitRepoLoc$>
|
||||
If RepoPath[-1, 1] NE '\' then RepoPath := '\'
|
||||
|
||||
Response = ""
|
||||
If EntityTypes EQ "" OR EntityTypes EQ "ALL" then EntityTypes = SRP_Git_Services("GetSupportedEntityTypes")
|
||||
If Apps EQ "" then Apps = @APPID
|
||||
|
||||
If Len(CommitStart) AND Len(CommitEnd) then
|
||||
FileChanges = SRP_Git_Services("GetFileChanges", CommitStart, CommitEnd)
|
||||
For Each FileChange in FileChanges
|
||||
Status = FileChange<1, 1>
|
||||
EntId = FileChange<1, 2>
|
||||
Parts = EntId
|
||||
Convert '*' to @VM in Parts
|
||||
Locate Parts<1, 1> in Apps using @FM setting AppPos then
|
||||
Locate Parts<1, 2> in EntityTypes using @FM setting TypePos then
|
||||
Response := EntId:@VM:Parts:@VM:Status:@FM
|
||||
end
|
||||
end
|
||||
Next FileChange
|
||||
end else
|
||||
For each EntityType in EntityTypes using @FM
|
||||
For each App in Apps
|
||||
ErrCode = ''
|
||||
Type = EntityType[1, '*']
|
||||
Class = EntityType[Col2() + 1, '*']
|
||||
WinDir = If Len(Class) then RepoPath:App:'\':Type:'\':Class else RepoPath:App:'\':Type
|
||||
Call SetInitDirOptions("D")
|
||||
InitDir WinDir:'\*.*'
|
||||
DirList = DirList()
|
||||
NumDirs = DCount(DirList, @FM)
|
||||
For iDir = 1 to NumDirs
|
||||
Dir = DirList<iDir>
|
||||
If Dir NE ".." then
|
||||
CurrPath = If Dir EQ "." then WinDir else WinDir:"\":Dir
|
||||
InitDir CurrPath:'\*.*'
|
||||
FileList = DirList()
|
||||
If Len(FileList) then
|
||||
For each Filename in FileList using @FM setting fPos
|
||||
EntID = SRP_Git_Serializer("PathToEntityId", RepoPath, CurrPath:'\':Filename)
|
||||
Parts = EntID
|
||||
Convert '*' to @VM in Parts
|
||||
Response := EntID:@VM:Parts:@FM
|
||||
Next Filename
|
||||
end
|
||||
end
|
||||
Next iDir
|
||||
Next App
|
||||
Next EntityType
|
||||
end
|
||||
Response[-1, 1] = ""
|
||||
|
||||
return
|
||||
|
||||
Service PushEntities(EntityList, StatusCtrl)
|
||||
|
||||
OSWrite "" to "SRPGitLog.txt"
|
||||
LogPos = 0
|
||||
SRPGitListener_Suppress@ = 1
|
||||
RepoPath = SRPGitServices_UserSettings@<SrpGitRepoLoc$>
|
||||
|
||||
NumEntities = DCount(EntityList, @FM)
|
||||
SRP_Git_Services("SendStatus", StatusCtrl, "Pushing ":NumEntities:" entities.\n", "", LogPos)
|
||||
For i = 1 to NumEntities
|
||||
EntityId = EntityList<i>
|
||||
SRP_Git_Services("SendStatus", StatusCtrl, EntityId, "", LogPos)
|
||||
If Field(EntityId, "*", 2, 1) EQ "APPROW" then
|
||||
Name = EntityId[-1, "B*"]
|
||||
Table = Name[1, ":"]
|
||||
Open Table to hTable then
|
||||
Key = Xlate("SYSREPOS", EntityId, 4, "X")
|
||||
If Len(Key) else Key = Name[Col2() + 1, Len(Name)]
|
||||
Read Record from hTable, Key then
|
||||
SRP_Git_Services("SendStatus", StatusCtrl, " -- Pushed\n", "", LogPos)
|
||||
SRP_Git_Serializer("WriteSync", EntityId, Record, RepoPath, Key)
|
||||
end else
|
||||
SRP_Git_Services("SendStatus", StatusCtrl, " -- Push Failed\n Unable to read SYSREPOS, ":Key:".\n", "", LogPos)
|
||||
end
|
||||
end else
|
||||
SRP_Git_Services("SendStatus", StatusCtrl, " -- Push Failed\n Unable to open SYSREPOS.\n", "", LogPos)
|
||||
end
|
||||
end else
|
||||
Set_Status(0)
|
||||
Record = Repository("ACCESS", EntityId)
|
||||
If Get_Status(ErrCode) then
|
||||
SRP_Git_Services("SendStatus", StatusCtrl, " -- Push Failed\n", ErrCode, LogPos)
|
||||
end else
|
||||
SRP_Git_Services("SendStatus", StatusCtrl, " -- Pushed\n", "", LogPos)
|
||||
SRP_Git_Serializer("WriteSync", EntityId, Record, RepoPath)
|
||||
end
|
||||
end
|
||||
Next i
|
||||
|
||||
SRPGitListener_Suppress@ = ""
|
||||
|
||||
end service
|
||||
|
||||
Service PullEntities(EntityList, StatusList, StatusCtrl, CommitId)
|
||||
|
||||
OSWrite "" to "SRPGitLog.txt"
|
||||
LogPos = 0
|
||||
SRPGitListener_Suppress@ = 1
|
||||
ExePath = SRPGitServices_UserSettings@<SrpGitExePath$>
|
||||
RepoPath = SRPGitServices_UserSettings@<SrpGitRepoLoc$>
|
||||
|
||||
EntitiesToCompile = ''
|
||||
NumEntities = DCount(EntityList, @FM)
|
||||
SRP_Git_Services("SendStatus", StatusCtrl, "Pulling ":NumEntities:" entities.\n", "", LogPos)
|
||||
For iEntityToPull = 1 to NumEntities
|
||||
EntityId = EntityList<iEntityToPull>
|
||||
Status = StatusList<iEntityToPull>
|
||||
App = EntityId[1, "*"]
|
||||
Type = EntityId[Col2() + 1, "*"]
|
||||
Class = EntityId[Col2() + 1, "*"]
|
||||
Name = EntityId[Col2() + 1, "*"]
|
||||
SRP_Git_Services("SendStatus", StatusCtrl, EntityId, "", LogPos)
|
||||
If Status _EQC "Deleted" then
|
||||
If Type EQ "APPROW" then
|
||||
Table = Name[1, ":"]
|
||||
Key = Xlate("SYSREPOS", EntityId, 4, "X")
|
||||
If Len(Key) else Key = Name[Col2() + 1, Len(Name)]
|
||||
Open Table to hTable then
|
||||
Lock hTable, Key then
|
||||
Unlock hTable, Key
|
||||
Delete hTable, Key then
|
||||
Open "SYSREPOS" to hTable then
|
||||
Delete hTable, EntityID then null
|
||||
end else
|
||||
SRP_Git_Services("SendStatus", StatusCtrl, " -- Delete Failed\n", Status(), LogPos)
|
||||
end
|
||||
end else
|
||||
SRP_Git_Services("SendStatus", StatusCtrl, " -- Delete Failed\n", Status(), LogPos)
|
||||
end
|
||||
end else
|
||||
SRP_Git_Services("SendStatus", StatusCtrl, " -- Delete Failed\n Locked or Doesn't Exist!\n", "", LogPos)
|
||||
end
|
||||
end else
|
||||
SRP_Git_Services("SendStatus", StatusCtrl, " -- Delete Failed\n", Status(), LogPos)
|
||||
end
|
||||
end else
|
||||
If App EQ @APPID<1> then
|
||||
Set_Status(0)
|
||||
Repository("DESTROY", EntityId)
|
||||
end else
|
||||
GoSub DeleteInherited
|
||||
end
|
||||
SRP_Git_Services("SendStatus", StatusCtrl, " -- Deleted\n", "", LogPos)
|
||||
end
|
||||
end else
|
||||
|
||||
// Get the file from git
|
||||
Path = SRP_Git_Serializer("EntityIdToRelativePath", EntityId)
|
||||
Convert "\" to "/" in Path
|
||||
Cmd = ExePath:' -C "':RepoPath:'" show ':CommitId:':':Path
|
||||
FileData = "VAR"
|
||||
Call SRP_Run_Command(Cmd, FileData)
|
||||
|
||||
// If it didn't work, just read it if possible
|
||||
ErrCode = 0
|
||||
If FileData[1, 7] EQ "fatal: " then
|
||||
Convert "/" to "\" in Path
|
||||
OSRead FileData from RepoPath:"\":Path else
|
||||
ErrCode = Status()
|
||||
end
|
||||
end
|
||||
|
||||
If ErrCode EQ 0 then
|
||||
|
||||
Metadata = ""
|
||||
Record = SRP_Git_Serializer("Deserialize", EntityId, FileData, Metadata)
|
||||
|
||||
If Len(Record) else Record = " "
|
||||
If Type EQ "APPROW" then
|
||||
Table = Name[1, ":"]
|
||||
Key = If Len(Metadata) then Metadata else Key = Name[Col2() + 1, Len(Name)]
|
||||
Open Table to hTable then
|
||||
Write Record to hTable, Key then
|
||||
Open "SYSREPOS" to hSYSREPOS then
|
||||
Read RepoRec from hSYSREPOS, EntityId else
|
||||
RepoRec = App
|
||||
RepoRec<2> = "$PUBLIC"
|
||||
RepoRec<3> = "$PUBLIC"
|
||||
RepoRec<4> = Key
|
||||
RepoRec<18> = "0"
|
||||
RepoRec<20> = "0"
|
||||
RepoRec<21> = "1"
|
||||
RepoRec<22> = "0"
|
||||
RepoRec<23> = "0"
|
||||
RepoRec<26> = App
|
||||
RepoRec<27> = Key
|
||||
end
|
||||
RepoRec<25> = DateTime()
|
||||
Write RepoRec to hSYSREPOS, EntityId then
|
||||
SRP_Git_Services("SendStatus", StatusCtrl, " -- Saved\n", "", LogPos)
|
||||
end else
|
||||
SRP_Git_Services("SendStatus", StatusCtrl, " -- Save Failed\n", Status(), LogPos)
|
||||
end
|
||||
end else
|
||||
SRP_Git_Services("SendStatus", StatusCtrl, " -- Save Failed\n", Status(), LogPos)
|
||||
end
|
||||
end else
|
||||
SRP_Git_Services("SendStatus", StatusCtrl, " -- Save Failed\n", Status(), LogPos)
|
||||
end
|
||||
end else
|
||||
SRP_Git_Services("SendStatus", StatusCtrl, " -- Save Failed\n", Status(), LogPos)
|
||||
end
|
||||
end else
|
||||
If App EQ @APPID<1> then
|
||||
Set_Status(0)
|
||||
Repository("LOCK", EntityId)
|
||||
If Get_Status(ErrCode) then
|
||||
SRP_Git_Services("SendStatus", StatusCtrl, " -- Save Failed\n Locked!\n", "", LogPos)
|
||||
end else
|
||||
Set_Status(0)
|
||||
Repository("WRITE", EntityId, "", 1, 1, "", "", "", "", "", EntityId[-1, "B*"], Record)
|
||||
If Get_Status(ErrCode) then
|
||||
SRP_Git_Services("SendStatus", StatusCtrl, " -- Save Failed\n", ErrCode, LogPos)
|
||||
end else
|
||||
SRP_Git_Services("SendStatus", StatusCtrl, " -- Saved\n", "", LogPos)
|
||||
Get_Status(ErrCode)
|
||||
If Type EQ "STPROC" OR Type EQ "OIWIN" OR Type EQ "OIEVENT" then EntitiesToCompile := EntityId:@FM
|
||||
end
|
||||
Set_Status(0)
|
||||
Repository("UNLOCK", EntityId)
|
||||
end
|
||||
end else
|
||||
GoSub WriteInherited
|
||||
end
|
||||
end
|
||||
|
||||
end else
|
||||
SRP_Git_Services("SendStatus", StatusCtrl, " -- Save Failed\n", ErrCode, LogPos)
|
||||
end
|
||||
end
|
||||
Next iEntityToPull
|
||||
EntitiesToCompile[-1, 1] = ""
|
||||
|
||||
NumEntities = DCount(EntitiesToCompile, @FM)
|
||||
If NumEntities GT 0 then
|
||||
SRP_Git_Services("SendStatus", StatusCtrl, "\nCompiling ":NumEntities:" entities.\n", "", LogPos)
|
||||
For Each EntityId in EntitiesToCompile
|
||||
SRP_Git_Services("SendStatus", StatusCtrl, EntityId, "", LogPos)
|
||||
App = EntityId[1, "*"]
|
||||
If App EQ @APPID<1> then
|
||||
Set_Status(0)
|
||||
Repository("COMPILE", EntityId, 1)
|
||||
If Get_Status(ErrCode) then
|
||||
SRP_Git_Services("SendStatus", StatusCtrl, " -- Compile Errors\n", ErrCode, LogPos)
|
||||
end else
|
||||
SRP_Git_Services("SendStatus", StatusCtrl, " -- Compile Successful\n", "", LogPos)
|
||||
end
|
||||
end else
|
||||
GoSub CompileInherited
|
||||
end
|
||||
Next EntityId
|
||||
end else
|
||||
SRP_Git_Services("SendStatus", StatusCtrl, "\nNo entities to compile.\n", "", LogPos)
|
||||
end
|
||||
SRPGitListener_Suppress@ = ""
|
||||
|
||||
end service
|
||||
|
||||
Service OpenRepo()
|
||||
|
||||
Name = "GUI"
|
||||
CmdPos = SrpGitGUICommand$
|
||||
GoSub RunGitCommand
|
||||
If Assigned(ErrorMsg) then
|
||||
If Len(ErrorMsg) then Msg(@Window, ErrorMsg:@FM:@FM:@FM:"!")
|
||||
end
|
||||
|
||||
end service
|
||||
|
||||
Service Commit()
|
||||
|
||||
Name = "Commit"
|
||||
CmdPos = SrpGitCommitCommand$
|
||||
GoSub RunGitCommand
|
||||
|
||||
end service
|
||||
|
||||
Service Pull()
|
||||
|
||||
Name = "Pull"
|
||||
CmdPos = SrpGitPullCommand$
|
||||
GoSub RunGitCommand
|
||||
|
||||
end service
|
||||
|
||||
Service Push()
|
||||
|
||||
Name = "Push"
|
||||
CmdPos = SrpGitPushCommand$
|
||||
GoSub RunGitCommand
|
||||
|
||||
end service
|
||||
|
||||
Service ViewHist()
|
||||
|
||||
Name = "ViewHist"
|
||||
CmdPos = SrpGitHistCommand$
|
||||
GoSub RunGitCommand
|
||||
|
||||
end service
|
||||
|
||||
Service Diff()
|
||||
|
||||
Name = "Diff"
|
||||
CmdPos = SrpGitDiffCommand$
|
||||
GoSub RunGitCommand
|
||||
|
||||
end service
|
||||
|
||||
Service SendStatus(StatusCtrl, Text, ErrCode, Ref Pos)
|
||||
|
||||
Swap "\n" with CRLF$ in Text
|
||||
|
||||
OSOpen "SRPGitLog.txt" to hFile else hFile = ""
|
||||
|
||||
If Len(StatusCtrl) then
|
||||
Send_Message(StatusCtrl, "INSERT", -1, Text)
|
||||
If Len(hFile) then
|
||||
OSBWrite text on hFile at Pos
|
||||
Pos += Len(Text)
|
||||
end
|
||||
If Len(ErrCode) then
|
||||
For Each ErrorInfo in ErrCode using @FM
|
||||
Text = " ":SRP_RevErrorMsg(ErrorInfo[1, @VM], ErrorInfo[Col2() + 1, Len(ErrorInfo)]):CRLF$
|
||||
Swap "__SRP_GIT_TEMP" with "" in Text
|
||||
Send_Message(StatusCtrl, "INSERT", -1, Text)
|
||||
If Len(hFile) then
|
||||
OSBWrite text on hFile at Pos
|
||||
Pos += Len(Text)
|
||||
end
|
||||
Next ErrorCode
|
||||
end
|
||||
Yield()
|
||||
end
|
||||
|
||||
If Len(hFile) then OSClose hFile
|
||||
|
||||
end service
|
||||
|
||||
RunGitCommand:
|
||||
|
||||
ErrorList = ''
|
||||
If SRPGitServices_UserSettings@<SrpGitEnabled$> EQ True$ then
|
||||
Command = SRPGitServices_UserSettings@<CmdPos>
|
||||
RepoPath = SRPGitServices_UserSettings@<SrpGitRepoLoc$>
|
||||
If Command NE '' then
|
||||
If RepoPath NE '' then
|
||||
Utility("RUNWIN", Command, 1)
|
||||
end else
|
||||
// User has not set the Git repository location
|
||||
ErrorMsg = "Git repository location has not been defined within Git Settings"
|
||||
ErrorList<-1> = ErrorMsg
|
||||
end
|
||||
end else
|
||||
// User has not set the Git open repo command (Git GUI command)
|
||||
ErrorMsg = "Git ":Name:" command has not been configured within Git Settings"
|
||||
ErrorList<-1> = ErrorMsg
|
||||
end
|
||||
end else
|
||||
// User has Git disabled
|
||||
ErrorMsg = "Git must first be enabled within Git Settings"
|
||||
ErrorList<-1> = ErrorMsg
|
||||
end
|
||||
Response = ErrorList
|
||||
|
||||
return
|
||||
|
||||
CompileInherited:
|
||||
// IN: EntityId
|
||||
|
||||
// Read the original source record
|
||||
DestList = SRP_Git_Serializer("EntityIdToKeys", EntityId)
|
||||
Record = Xlate(DestList<1, 1>, DestList<1, 2>, "", "X")
|
||||
|
||||
// Build a temporary entity in the current app
|
||||
TempId = @APPID<1>:"*":Field(EntityID, "*", 2, 3):"__SRP_GIT_TEMP"
|
||||
Type = Field(EntityId, "*", 2, 1)
|
||||
|
||||
// If this is a stored procedure or insert, we need to rename it temporarily IN THE CODE
|
||||
FirstLine = Record<1>
|
||||
If Type[1, 6] _EQC "STPROC" AND Len(Xlate("SYSOBJ", "$SRP_EDITOR_PARSE", "", "X")) then
|
||||
ProcType = If Type _EQC "STPROCINS" then "Insert" else "Procedure"
|
||||
OrigProcName = ""
|
||||
If SRP_Editor_Parse(FirstLine, "", ProcType, OrigProcName, "") then
|
||||
TempName = Field(TempId, "*", 4)
|
||||
TempFirstLine = FirstLine[1, "("]
|
||||
Swap OrigProcName with TempName in TempFirstLine
|
||||
If ProcType EQ "Insert" then
|
||||
Record<1> = TempFirstLine
|
||||
end else
|
||||
Record<1> = TempFirstLine:"(":FirstLine[-1, "B("]
|
||||
end
|
||||
end
|
||||
end
|
||||
|
||||
// Update it and compile it
|
||||
SRPGitListener_Suppress@ = 1
|
||||
Set_Status(0)
|
||||
Repository("WRITE", TempID, "", 1, 1, "", "", "", "", "", TempID[-1, "F*"], Record)
|
||||
If Get_Status(ErrCode) then
|
||||
SRP_Git_Services("SendStatus", StatusCtrl, " -- Failed to create Temprorary Entity.\n", ErrCode, LogPos)
|
||||
end else
|
||||
Set_Status(0)
|
||||
Repository("COMPILE", TempId)
|
||||
If Get_Status(ErrCode) then
|
||||
SRP_Git_Services("SendStatus", StatusCtrl, " -- Compile Errors\n", ErrCode, LogPos)
|
||||
end else
|
||||
SRP_Git_Services("SendStatus", StatusCtrl, " -- Compile Successful\n", "", LogPos)
|
||||
// Copy the temporary records back to the entity records
|
||||
SourceList = SRP_Git_Serializer("EntityIdToKeys", TempId)
|
||||
NumItems = DCount(SourceList, @FM)
|
||||
For i = 1 to NumItems
|
||||
Table = SourceList<i, 1>
|
||||
SourceKey = SourceList<i, 2>
|
||||
DestKey = DestList<i, 2>
|
||||
If SourceKey NE DestKey then
|
||||
Open Table to hTable then
|
||||
Read Rec from hTable, SourceKey then
|
||||
If Table EQ "SYSPROCS" then Rec<1> = FirstLine
|
||||
Swap TempID with EntityID in Rec
|
||||
Write Rec to hTable, DestKey then null
|
||||
end
|
||||
end
|
||||
end
|
||||
Next i
|
||||
end
|
||||
end
|
||||
|
||||
// Delete the local copy
|
||||
Set_Status(0)
|
||||
Repository("DESTROY", TempId)
|
||||
SRPGitListener_Suppress@ = ""
|
||||
|
||||
return
|
||||
|
||||
WriteInherited:
|
||||
// IN: EntityId, Record
|
||||
|
||||
// Delete the actual records
|
||||
DestList = SRP_Git_Serializer("EntityIdToKeys", EntityId)
|
||||
Table = DestList<1, 1>
|
||||
DestKey = DestList<1, 2>
|
||||
Open Table to hTable then
|
||||
Lock hTable, DestKey then
|
||||
Write Record to hTable, DestKey then
|
||||
|
||||
// Update or create the SYSREPOS record at the correct app level
|
||||
Open "SYSREPOS" to hSYSREPOS then
|
||||
RepoKey = DestList[-1, "B":@VM]
|
||||
Read RepoRec from hSYSREPOS, RepoKey else
|
||||
RepoRec = App
|
||||
RepoRec<2> = "$PUBLIC"
|
||||
RepoRec<3> = "$PUBLIC"
|
||||
RepoRec<18> = "0"
|
||||
RepoRec<20> = "1"
|
||||
RepoRec<21> = "1"
|
||||
RepoRec<22> = "0"
|
||||
RepoRec<23> = "1"
|
||||
RepoRec<26> = App
|
||||
RepoRec<27> = "Y"
|
||||
end
|
||||
RepoRec<24> = EntityId:"*":DateTime()
|
||||
RepoRec<25> = DateTime()
|
||||
Write RepoRec to hSYSREPOS, RepoKey then null
|
||||
end
|
||||
|
||||
SRP_Git_Services("SendStatus", StatusCtrl, " -- Saved\n", "", LogPos)
|
||||
If Type EQ "STPROC" OR Type EQ "OIWIN" OR Type EQ "OIEVENT" then EntitiesToCompile := EntityId:@FM
|
||||
end
|
||||
Unlock hTable, DestKey
|
||||
end else
|
||||
SRP_Git_Services("SendStatus", StatusCtrl, " -- Save Failed\n Locked!\n", "", LogPos)
|
||||
end
|
||||
end
|
||||
|
||||
return
|
||||
|
||||
DeleteInherited:
|
||||
// IN: EntityId, Record
|
||||
|
||||
// Delete the actual records
|
||||
DestList = SRP_Git_Serializer("EntityIdToKeys", EntityId)
|
||||
NumItems = DCount(DestList, @FM)
|
||||
For i = 1 to NumItems
|
||||
Table = DestList<i, 1>
|
||||
DestKey = DestList<i, 2>
|
||||
Open Table to hTable then
|
||||
Lock hTable, DestKey then
|
||||
Delete hTable, DestKey then
|
||||
SRP_Git_Services("SendStatus", StatusCtrl, " -- Deleted\n", "", LogPos)
|
||||
end
|
||||
Unlock hTable, DestKey
|
||||
end else
|
||||
SRP_Git_Services("SendStatus", StatusCtrl, " -- Delete Failed\n Locked!\n", "", LogPos)
|
||||
end
|
||||
end
|
||||
Next i
|
||||
|
||||
return
|
||||
213
SYSPROG/STPROC/SRP_GIT_SETTINGS_EVENTS.txt
Normal file
213
SYSPROG/STPROC/SRP_GIT_SETTINGS_EVENTS.txt
Normal file
@ -0,0 +1,213 @@
|
||||
Compile function SRP_GIT_SETTINGS_EVENTS(Event, CtrlEntId, @PARAMS)
|
||||
/************************************************************************************************
|
||||
*
|
||||
* This program is proprietary and is not to be used by or disclosed to others, nor is it to
|
||||
* be copied without written permission from SRP Computer Solutions, Inc.
|
||||
*
|
||||
* Name : SRP_GIT_SETTINGS_Events
|
||||
*
|
||||
* Description: Event handling commuter module for the SRP_GIT_SETTINGS form.
|
||||
*
|
||||
* User Defined Properties:
|
||||
*
|
||||
* Parameters:
|
||||
* EventID [in] -- Event ID
|
||||
* CtrlEntId [in] -- Control whose event is being handled
|
||||
* Param1-13 [in] -- Event Parameters
|
||||
*
|
||||
* Returns:
|
||||
* Event handling result, usually 1
|
||||
*
|
||||
* History (Date, Initials, Notes)
|
||||
* 02/25/19 DJS Original programmer
|
||||
* 07/29/19 KRF Updated with different controls and cleaned up the code
|
||||
*
|
||||
************************************************************************************************/
|
||||
#pragma precomp SRP_PreCompiler
|
||||
#window SRP_GIT_SETTINGS
|
||||
|
||||
$Insert LOGICAL
|
||||
|
||||
Declare function SRP_Git_Services, Get_Property, Utility
|
||||
Declare subroutine SRP_Git_Services, Set_Property, Post_Event, Send_Message
|
||||
|
||||
GoToEvent Event for CtrlEntId else
|
||||
// Event not implemented
|
||||
end
|
||||
|
||||
Return 1
|
||||
|
||||
//-----------------------------------------------------------------------------
|
||||
// EVENT HANDLERS
|
||||
//-----------------------------------------------------------------------------
|
||||
|
||||
Event WINDOW.CREATE(CreateParam)
|
||||
|
||||
GoSub Setup_OLE_Controls
|
||||
GoSub FillUserSettings
|
||||
|
||||
End Event
|
||||
|
||||
|
||||
Event PUB_APPLY.CLICK()
|
||||
|
||||
GoSub SaveUserSettings
|
||||
Set_Property(CtrlEntID, 'ENABLED', False$)
|
||||
|
||||
end event
|
||||
|
||||
|
||||
Event PUB_OK.CLICK()
|
||||
|
||||
GoSub SaveUserSettings
|
||||
Post_Event(@Window, 'CLOSE')
|
||||
|
||||
end event
|
||||
|
||||
|
||||
Event CHB_ENABLED.CLICK()
|
||||
|
||||
GoSub CheckModified
|
||||
|
||||
end event
|
||||
|
||||
|
||||
Event EDL_REPO_LOC.LOSTFOCUS(Flag, FocusID)
|
||||
|
||||
GoSub CheckModified
|
||||
|
||||
end event
|
||||
|
||||
|
||||
Event EDL_GIT_LOC.LOSTFOCUS(Flag, FocusID)
|
||||
|
||||
GoSub CheckModified
|
||||
|
||||
end event
|
||||
|
||||
|
||||
Event EDL_GUI_LOC.LOSTFOCUS(Flag, FocusID)
|
||||
|
||||
GoSub CheckModified
|
||||
|
||||
end event
|
||||
|
||||
|
||||
Event EDL_WARNING.LOSTFOCUS(Flag, FocusID)
|
||||
|
||||
GoSub CheckModified
|
||||
|
||||
end event
|
||||
|
||||
|
||||
Event OLE_SUBCLASS.OnOptionClick(CtrlId)
|
||||
|
||||
OrigDirectory = Get_Property(CtrlId, 'TEXT')
|
||||
|
||||
If CtrlId[-1, "B."] EQ "EDL_REPO_LOC" then
|
||||
Directory = Utility("CHOOSEDIR", @Window, "Select directory":@FM:"%HOMEPATH%")
|
||||
end else
|
||||
Directory = Utility("CHOOSEFILE", @Window, "Select executable":@FM:"%HOMEPATH%")
|
||||
end
|
||||
|
||||
If Directory NE '' then
|
||||
Set_Property(CtrlId, 'TEXT', Directory)
|
||||
GoSub CheckModified
|
||||
end
|
||||
|
||||
end event
|
||||
|
||||
|
||||
* Event OLE_EDITTABLE_GIT.OnOptionClick(Cell, Point, Button, Shift, Ctrl)
|
||||
*
|
||||
* Col = Field(Cell, ';', 1)
|
||||
* Row = Field(Cell, ';', 2)
|
||||
* OrigDirectory = Get_Property(CtrlEntID, 'OLE.CellText[':Col:'; ':Row:']')
|
||||
* Directory = Utility("CHOOSEFILE", @Window, "Select executable":@FM:"%HOMEPATH%")
|
||||
* If Directory NE '' then
|
||||
* Set_Property(CtrlEntID, 'OLE.CellText[':Col:'; ':Row:']', Directory)
|
||||
* GoSub CheckModified
|
||||
* end
|
||||
*
|
||||
* end event
|
||||
|
||||
|
||||
Event OLE_EDITTABLE_GIT.AfterUpdate(Cell, Text, Pattern, OldText)
|
||||
GoSub CheckModified
|
||||
end event
|
||||
|
||||
|
||||
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
|
||||
// Internal GoSubs
|
||||
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
|
||||
|
||||
|
||||
Setup_OLE_Controls:
|
||||
|
||||
// Add browse buttons
|
||||
Ctrl = @Window:".OLE_SUBCLASS"
|
||||
CtrlIds = "EDL_REPO_LOC,EDL_GIT_LOC,EDL_GUI_LOC"
|
||||
For i = 1 to 3
|
||||
CtrlId = @Window:".":Field(CtrlIds, ",", i, 1)
|
||||
Handle = Get_Property(CtrlId, "HANDLE")
|
||||
Send_Message(Ctrl, "OLE.Subclass", Handle, CtrlId)
|
||||
Convert "." to ";" in CtrlId
|
||||
Set_Property(Ctrl, "OLE.OptionButton[":CtrlId:"]", 1)
|
||||
Set_Property(Ctrl, "OLE.OptionImage[":CtrlId:"]", "BMPS\SRPGit.zip#browse.png")
|
||||
Send_Message(Ctrl, "QUALIFY_EVENT", "OLE.OnOptionClick", Yes$)
|
||||
Next i
|
||||
|
||||
return
|
||||
|
||||
|
||||
CheckModified:
|
||||
|
||||
OrigGenCtrlList = Get_Property(@Window, '@OrigGitCtrlList')
|
||||
CurrGenCtrlList = Get_Property(@Window:".CHB_ENABLED", 'CHECK'):@RM:Get_Property(@Window:".EDL_REPO_LOC", 'TEXT'):@RM:Get_Property(@Window:".EDL_GIT_LOC", 'TEXT'):@RM:Get_Property(@Window:".EDL_GUI_LOC", 'TEXT'):@RM:Get_Property(@Window:".EDL_WARNING", 'TEXT')
|
||||
If CurrGenCtrlList NE OrigGenCtrlList then
|
||||
Set_Property(@Window:'.PUB_APPLY', 'ENABLED', True$)
|
||||
end else
|
||||
Set_Property(@Window:'.PUB_APPLY', 'ENABLED', False$)
|
||||
end
|
||||
|
||||
return
|
||||
|
||||
|
||||
FillUserSettings:
|
||||
|
||||
// Get the settings
|
||||
GitEnabled = SRP_Git_Services("IsEnabled")
|
||||
GitRepoLoc = SRP_Git_Services("GetRepoPath")
|
||||
GitExePath = SRP_Git_Services("GetGitPath")
|
||||
GitGUICommand = SRP_Git_Services("GetGuiCommand")
|
||||
GitWarning = SRP_Git_Services("GetWarning")
|
||||
|
||||
// Pass the data to the control
|
||||
Set_Property(@Window:".CHB_ENABLED", "CHECK", GitEnabled)
|
||||
Set_Property(@Window:".EDL_REPO_LOC", "TEXT", GitRepoLoc)
|
||||
Set_Property(@Window:".EDL_GIT_LOC", "TEXT", GitExePath)
|
||||
Set_Property(@Window:".EDL_GUI_LOC", "TEXT", GitGUICommand)
|
||||
Set_Property(@Window:".EDL_WARNING", "TEXT", GitWarning)
|
||||
|
||||
// Save the data so we know when we can apply
|
||||
Set_Property(@Window, "@OrigGitCtrlList", GitEnabled:@RM:GitRepoLoc:@RM:GitExePath:@RM:GitWarning)
|
||||
Set_Property(@Window:".PUB_APPLY", "ENABLED", False$)
|
||||
|
||||
return
|
||||
|
||||
|
||||
SaveUserSettings:
|
||||
|
||||
GitEnabled = Get_Property(@Window:".CHB_ENABLED", "CHECK")
|
||||
GitRepoLoc = Get_Property(@Window:".EDL_REPO_LOC", "TEXT")
|
||||
GitExePath = Get_Property(@Window:".EDL_GIT_LOC", "TEXT")
|
||||
GitGUICommand = Get_Property(@Window:".EDL_GUI_LOC", "TEXT")
|
||||
GitWarning = Get_Property(@Window:".EDL_WARNING", "TEXT")
|
||||
SRP_Git_Services("SaveUserSettings", GitEnabled, GitRepoLoc, GitExePath, GitGUICommand, GitWarning)
|
||||
|
||||
// Save the data so we know when we can apply
|
||||
Set_Property(@Window, "@OrigGitCtrlList", GitEnabled:@RM:GitRepoLoc:@RM:GitExePath:@RM:GitGUICommand:@RM:GitWarning)
|
||||
Set_Property(@Window:".PUB_APPLY", "ENABLED", False$)
|
||||
|
||||
return
|
||||
|
||||
599
SYSPROG/STPROC/SRP_GIT_UTILITY_EVENTS.txt
Normal file
599
SYSPROG/STPROC/SRP_GIT_UTILITY_EVENTS.txt
Normal file
@ -0,0 +1,599 @@
|
||||
Compile function SRP_GIT_UTILITY_EVENTS(Event, CtrlEntId, @PARAMS)
|
||||
/************************************************************************************************
|
||||
*
|
||||
* This program is proprietary and is not to be used by or disclosed to others, nor is it to
|
||||
* be copied without written permission from SRP Computer Solutions, Inc.
|
||||
*
|
||||
* Name : SRP_GIT_UTILITY_Events
|
||||
*
|
||||
* Description: Event handling commuter module for the SRP_GIT_UTILITY form.
|
||||
*
|
||||
* User Defined Properties:
|
||||
*
|
||||
* Parameters:
|
||||
* EventID [in] -- Event ID
|
||||
* CtrlEntId [in] -- Control whose event is being handled
|
||||
* Param1-13 [in] -- Event Parameters
|
||||
*
|
||||
* Returns:
|
||||
* Event handling result, usually 1
|
||||
*
|
||||
* History (Date, Initials, Notes)
|
||||
* 04/05/19 DJS Original programmer
|
||||
* 07/29/19 KRF Updated with different controls and cleaned up the code
|
||||
*
|
||||
************************************************************************************************/
|
||||
#pragma precomp SRP_PreCompiler
|
||||
#window SRP_GIT_UTILITY
|
||||
|
||||
$Insert LOGICAL
|
||||
|
||||
Equ IMAGE_LOC$ to 'BMPS\SRPGit.zip#'
|
||||
|
||||
Declare function RGB, SRP_Git_Services, Git_Services, SRP_Array, Set_Property, Get_Property
|
||||
Declare subroutine SRP_Git_Services, SRP_Set_Minmaxinfo, Set_Property, Send_Event, Post_Event, Send_Message
|
||||
|
||||
GoToEvent Event for CtrlEntId else
|
||||
// Event not implemented
|
||||
end
|
||||
|
||||
Return 1
|
||||
|
||||
//-----------------------------------------------------------------------------
|
||||
// EVENT HANDLERS
|
||||
//-----------------------------------------------------------------------------
|
||||
|
||||
|
||||
Event WINDOW.CREATE(CreateParam)
|
||||
|
||||
If SRP_Git_Services("HasSettings") then
|
||||
|
||||
// Setup combo boxes
|
||||
Set_Property(@Window:'.CMB_FILTER_APP', 'LIST', @FM:@APPID)
|
||||
Set_Property(@Window:'.CMB_FILTER_WORK', 'LIST', @FM:SRP_Git_Services("GetSupportedEntityTypes"))
|
||||
|
||||
GoSub Setup_OLE_Controls
|
||||
GoSub Load_Auto
|
||||
|
||||
// Default to pull
|
||||
Send_Event(@Window:".PUB_PULL", "OLE", "OnClick", "0,0", "Left", 0, 0)
|
||||
|
||||
end else
|
||||
|
||||
Call Start_Window("SRP_GIT_SETTINGS")
|
||||
Call Post_Event(@Window, "CLOSE")
|
||||
|
||||
end
|
||||
|
||||
End Event
|
||||
|
||||
|
||||
Event PUB_PULL.OnClick(Point, Button, Shift, Ctrl)
|
||||
|
||||
Set_Property(@Window:".PUB_PULL", "OLE.State", 1)
|
||||
Set_Property(@Window:".PUB_PULL", "OLE.FontBold", 1)
|
||||
Set_Property(@Window:".PUB_PUSH", "OLE.State", 0)
|
||||
Set_Property(@Window:".PUB_PUSH", "OLE.FontBold", 0)
|
||||
Set_Property(@Window, "@OPERATION", "PULL")
|
||||
|
||||
Set_Property(@Window:".STA_WORKING", "TEXT", "Git Repo Entities")
|
||||
Set_Property(@Window:".STA_STAGE", "TEXT", "Entities to Pull into OpenInsight")
|
||||
Set_Property(@Window:".EDL_FROM_COMMIT", "VISIBLE", Yes$)
|
||||
Set_Property(@Window:".STA_FROM_COMMIT", "VISIBLE", Yes$)
|
||||
Set_Property(@Window:".EDL_TO_COMMIT", "VISIBLE", Yes$)
|
||||
Set_Property(@Window:".STA_TO_COMMIT", "VISIBLE", Yes$)
|
||||
Set_Property(@Window:".OLE_REFRESH", "VISIBLE", Get_Property(@Window:".OLE_MANUAL", "OLE.Caption") _EQC "Auto")
|
||||
Set_Property(@Window:".OLE_MANUAL", "VISIBLE", Yes$)
|
||||
Set_Property(@Window:".OLE_HEADS", "VISIBLE", Get_Property(@Window:".OLE_MANUAL", "OLE.Caption") _EQC "Auto")
|
||||
Set_Property(@Window:".PUB_APPLY", "TEXT", "Pull")
|
||||
Set_Property(@Window:".OLE_RPT_STAGE", "OLE.EmptyTablePrompt", "Move items here you want to pull from Git into OpenInsight.")
|
||||
|
||||
GoSub Populate
|
||||
|
||||
end event
|
||||
|
||||
|
||||
Event PUB_PUSH.OnClick(Point, Button, Shift, Ctrl)
|
||||
|
||||
Set_Property(@Window:".PUB_PULL", "OLE.State", 0)
|
||||
Set_Property(@Window:".PUB_PULL", "OLE.FontBold", 0)
|
||||
Set_Property(@Window:".PUB_PUSH", "OLE.State", 1)
|
||||
Set_Property(@Window:".PUB_PUSH", "OLE.FontBold", 1)
|
||||
Set_Property(@Window, "@OPERATION", "PUSH")
|
||||
|
||||
Set_Property(@Window:".STA_WORKING", "TEXT", "OpenInsight Entities")
|
||||
Set_Property(@Window:".STA_STAGE", "TEXT", "Entities to Push into Git")
|
||||
Set_Property(@Window:".EDL_FROM_COMMIT", "VISIBLE", No$)
|
||||
Set_Property(@Window:".STA_FROM_COMMIT", "VISIBLE", No$)
|
||||
Set_Property(@Window:".EDL_TO_COMMIT", "VISIBLE", No$)
|
||||
Set_Property(@Window:".STA_TO_COMMIT", "VISIBLE", No$)
|
||||
Set_Property(@Window:".OLE_REFRESH", "VISIBLE", No$)
|
||||
Set_Property(@Window:".OLE_MANUAL", "VISIBLE", No$)
|
||||
Set_Property(@Window:".OLE_HEADS", "VISIBLE", No$)
|
||||
Set_Property(@Window:".EDL_SEARCH", "FOCUS", Yes$)
|
||||
Set_Property(@Window:".PUB_APPLY", "TEXT", "Push")
|
||||
Set_Property(@Window:".OLE_RPT_STAGE", "OLE.EmptyTablePrompt", "Move items here you want to push from OpenInsight into Git.")
|
||||
|
||||
GoSub Populate
|
||||
|
||||
end event
|
||||
|
||||
|
||||
Event CMB_FILTER_APP.CHANGED(NewData)
|
||||
GoSub Populate
|
||||
end event
|
||||
|
||||
|
||||
Event CMB_FILTER_WORK.CHANGED(NewData)
|
||||
GoSub Populate
|
||||
end event
|
||||
|
||||
|
||||
* Event CMB_FROM_COMMIT.CHANGED(NewData)
|
||||
* GoSub Populate
|
||||
* end event
|
||||
*
|
||||
*
|
||||
* Event CMB_TO_COMMIT.CHANGED(NewData)
|
||||
* GoSub Populate
|
||||
* end event
|
||||
|
||||
|
||||
Event OLE_REFRESH.OnClick(Point, Button, Shift, Ctrl)
|
||||
|
||||
Text = Get_Property(@Window:".OLE_MANUAL", "OLE.Caption")
|
||||
If Text _EQC "Manual" then
|
||||
GoSub Populate
|
||||
end else
|
||||
Set_Property(@Window, "REDRAW", No$)
|
||||
Set_Property("SYSTEM", "CURSOR", "H")
|
||||
GoSub Load_Commits
|
||||
Set_Property("SYSTEM", "CURSOR", "A")
|
||||
Set_Property(@Window, "REDRAW", Yes$)
|
||||
end
|
||||
|
||||
end event
|
||||
|
||||
|
||||
Event OLE_MANUAL.OnClick(Point, Button, Shift, Ctrl)
|
||||
|
||||
Set_Property(@Window, "REDRAW", No$)
|
||||
Text = Get_Property(@Window:".OLE_MANUAL", "OLE.Caption")
|
||||
If Text _EQC "Manual" then
|
||||
Set_Property(@Window:".STA_FROM_COMMIT", "TEXT", "Start:")
|
||||
Set_Property(@Window:".STA_TO_COMMIT", "TEXT", "End:")
|
||||
Set_Property(@Window:".OLE_MANUAL", "OLE.Caption", "Auto")
|
||||
Set_Property(@Window:".OLE_HEADS", "VISIBLE", Yes$)
|
||||
Set_Property(@Window:".OLE_REFRESH", "VISIBLE", Yes$)
|
||||
GoSub Enable_Combos
|
||||
GoSub Load_Commits
|
||||
end else
|
||||
Set_Property(@Window:".OLE_SUBCLASS", "OLE.Combo[EDL_FROM_COMMIT]", 0)
|
||||
Set_Property(@Window:".OLE_SUBCLASS", "OLE.Combo[EDL_TO_COMMIT]", 0)
|
||||
Set_Property(@Window:".STA_FROM_COMMIT", "TEXT", "Last Pull:")
|
||||
Set_Property(@Window:".STA_TO_COMMIT", "TEXT", "Current:")
|
||||
Set_Property(@Window:".OLE_MANUAL", "OLE.Caption", "Manual")
|
||||
Set_Property(@Window:".OLE_HEADS", "VISIBLE", No$)
|
||||
Set_Property(@Window:".OLE_REFRESH", "VISIBLE", No$)
|
||||
GoSub Load_Auto
|
||||
GoSub Populate
|
||||
end
|
||||
Set_Property(@Window, "REDRAW", Yes$)
|
||||
|
||||
end event
|
||||
|
||||
Event OLE_HEADS.OnClick(Point, Button, Shift, Ctrl)
|
||||
Text = Get_Property(@Window:".OLE_HEADS", "OLE.Caption")
|
||||
If Text _EQC "All Refs" then
|
||||
Set_Property(@Window:".OLE_HEADS", "OLE.Caption", "Heads")
|
||||
end else
|
||||
Set_Property(@Window:".OLE_HEADS", "OLE.Caption", "All Refs")
|
||||
end
|
||||
GoSub Load_Commits
|
||||
end event
|
||||
|
||||
|
||||
Event EDL_SEARCH.CHANGED(NewData)
|
||||
Set_Property(@Window, "TIMER", 0:@FM:500)
|
||||
end event
|
||||
|
||||
|
||||
Event EDL_CONFIRM.CHAR(VirtCode, ScanCode, CtrlKey, ShiftKey, AltKey)
|
||||
|
||||
If Get_Property(CtrlEntId, "TEXT") EQ "PULL" then
|
||||
GoSub Execute
|
||||
end
|
||||
|
||||
end event
|
||||
|
||||
|
||||
Event WINDOW.TIMER()
|
||||
|
||||
Text = Get_Property(@Window:".EDL_SEARCH", "TEXT")
|
||||
List = Get_Property(@Window:".OLE_RPT_WORK", "@ORIGLIST")
|
||||
NewList = ""
|
||||
If Len(Text) then
|
||||
For Each Row in List
|
||||
If IndexC(Row, Text, 1) GT 0 then
|
||||
NewList := Row:@FM
|
||||
end
|
||||
Next Row
|
||||
NewList[-1, 1] = ""
|
||||
end else
|
||||
Transfer List to NewList
|
||||
end
|
||||
Set_Property(@Window:".OLE_RPT_WORK", "OLE.List", NewList)
|
||||
|
||||
end event
|
||||
|
||||
|
||||
Event PUB_APPLY.CLICK()
|
||||
|
||||
GitWarning = SRP_Git_Services("GetWarning")
|
||||
If Len(GitWarning) AND Get_Property(@Window, '@OPERATION') EQ "PULL" then
|
||||
Set_Property(@Window:".EDL_CONFIRM", "TEXT", "")
|
||||
Set_Property(@Window, "VPOSITION", 3)
|
||||
Set_Property(@Window:".EDL_CONFIRM", "FOCUS", Yes$)
|
||||
end else
|
||||
GoSub Execute
|
||||
end
|
||||
|
||||
end event
|
||||
|
||||
|
||||
Event PUB_CLOSE.CLICK()
|
||||
Post_Event(@Window, 'CLOSE')
|
||||
end event
|
||||
|
||||
|
||||
Event PUB_BACK.CLICK()
|
||||
Set_Property(@Window, "VPOSITION", 1)
|
||||
end event
|
||||
|
||||
|
||||
Event OLE_ADD_ALL.OnClick(Point, Button, Shift, Ctrl)
|
||||
|
||||
Send_Message(@Window:'.OLE_RPT_WORK', 'OLE.ExpandAll')
|
||||
EntityList = Get_Property(@Window:'.OLE_RPT_WORK', 'OLE.List')
|
||||
Set_Property(@Window:'.OLE_RPT_STAGE', 'OLE.List', EntityList)
|
||||
GoSub EnableArrowButtons
|
||||
GoSub EnableStagingCtrls
|
||||
|
||||
end event
|
||||
|
||||
|
||||
Event OLE_ADD_SELECTED.OnClick(Point, Button, Shift, Ctrl)
|
||||
|
||||
EntitiesToAdd = Get_Property(@Window:'.OLE_RPT_WORK', 'OLE.SelList')
|
||||
StageList = Get_Property(@Window:'.OLE_RPT_STAGE', 'OLE.List')
|
||||
ResultList = SRP_Array('Join', StageList, EntitiesToAdd, 'OR', @FM)
|
||||
Set_Property(@Window:'.OLE_RPT_STAGE', 'OLE.List', ResultList)
|
||||
GoSub EnableArrowButtons
|
||||
GoSub EnableStagingCtrls
|
||||
|
||||
end event
|
||||
|
||||
|
||||
Event OLE_REMOVE_ALL.OnClick(Point, Button, Shift, Ctrl)
|
||||
|
||||
Send_Message(@Window:'.OLE_RPT_STAGE', 'OLE.ExpandAll')
|
||||
Set_Property(@Window:'.OLE_RPT_STAGE', 'OLE.List', '')
|
||||
GoSub EnableArrowButtons
|
||||
GoSub EnableStagingCtrls
|
||||
|
||||
end event
|
||||
|
||||
|
||||
Event OLE_REMOVE_SELECTED.OnClick(Point, Button, Shift, Ctrl)
|
||||
|
||||
StageRptCtrl = @Window : '.OLE_RPT_STAGE'
|
||||
SelList = Get_Property(StageRptCtrl, 'OLE.SelList')
|
||||
EntityList = Get_Property(StageRptCtrl, 'OLE.List')
|
||||
For each Row in SelList using @FM setting sPos
|
||||
Locate Row in EntityList using @FM setting ePos then EntityList = Delete(EntityList, ePos, 0, 0)
|
||||
Next Row
|
||||
Set_Property(StageRptCtrl, 'OLE.List', EntityList)
|
||||
GoSub EnableArrowButtons
|
||||
GoSub EnableStagingCtrls
|
||||
|
||||
end event
|
||||
|
||||
|
||||
Event OLE_RPT_WORK.OnSelChange()
|
||||
GoSub EnableArrowButtons
|
||||
end event
|
||||
|
||||
|
||||
Event OLE_RPT_WORK.OnItemDblClick(Row, Button, Col, Point)
|
||||
Send_Event(@Window:".OLE_ADD_SELECTED", "OLE", "OnClick", "", "", "", "")
|
||||
end event
|
||||
|
||||
|
||||
Event OLE_RPT_STAGE.OnSelChange()
|
||||
GoSub EnableArrowButtons
|
||||
end event
|
||||
|
||||
|
||||
Event OLE_RPT_STAGE.OnItemDblClick(Row, Button, Col, Point)
|
||||
Send_Event(@Window:".OLE_REMOVE_SELECTED", "OLE", "OnClick", "", "", "", "")
|
||||
end event
|
||||
|
||||
|
||||
Event OLE_SUBCLASS.OnComboClick(CtrlId, Sel, Value)
|
||||
Set_Property(@Window:".EDL_FROM_COMMIT", "@HASH", Get_Property(@Window:".OLE_SUBCLASS", "OLE.ComboRowData[EDL_FROM_COMMIT]")<2>)
|
||||
Set_Property(@Window:".EDL_TO_COMMIT", "@HASH", Get_Property(@Window:".OLE_SUBCLASS", "OLE.ComboRowData[EDL_TO_COMMIT]")<2>)
|
||||
GoSub Populate
|
||||
end event
|
||||
|
||||
|
||||
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
|
||||
// Internal GoSubs
|
||||
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
|
||||
|
||||
Setup_OLE_Controls:
|
||||
|
||||
// Subclassing
|
||||
Ctrl = @Window:".OLE_SUBCLASS"
|
||||
Send_Message(Ctrl, "OLE.Subclass", Get_Property(@Window:".EDL_FROM_COMMIT", "HANDLE"), @Window:".EDL_FROM_COMMIT")
|
||||
Send_Message(Ctrl, "OLE.Subclass", Get_Property(@Window:".EDL_TO_COMMIT", "HANDLE"), @Window:".EDL_TO_COMMIT")
|
||||
Set_Property(Ctrl, "OLE.CurrentWindow", @Window)
|
||||
Send_Message(Ctrl, 'QUALIFY_EVENT', 'OLE.OnComboClick', Yes$)
|
||||
|
||||
// Setup buttons
|
||||
Background = ""
|
||||
Background<1> = "Vertical(Gradient(White, White), Border(White))"
|
||||
Background<2> = "Vertical(Gradient(White, White), Gradient(Blue L=50, Blue L=50, 4), Border(White))"
|
||||
Background<3> = "Vertical(Gradient(White, White), Gradient(Blue L=50, Blue L=50, 4), Border(White))"
|
||||
Foreground = ""
|
||||
Foreground<1> = "Blue L=50"
|
||||
Foreground<2> = "Blue L=50"
|
||||
Foreground<3> = "Blue L=50"
|
||||
* CtrlIds = "PUB_PULL,PUB_PUSH"
|
||||
Set_Property(@Window:".PUB_PULL", "OLE.Background", Background)
|
||||
Set_Property(@Window:".PUB_PULL", "OLE.Forecolor", Foreground)
|
||||
Send_Message(@Window:".PUB_PULL", 'QUALIFY_EVENT', 'OLE.OnClick', Yes$)
|
||||
Swap "Blue" with "Red" in Background
|
||||
Swap "Blue" with "Red" in Foreground
|
||||
Set_Property(@Window:".PUB_PUSH", "OLE.Background", Background)
|
||||
Set_Property(@Window:".PUB_PUSH", "OLE.Forecolor", Foreground)
|
||||
Send_Message(@Window:".PUB_PUSH", 'QUALIFY_EVENT', 'OLE.OnClick', Yes$)
|
||||
* For i = 1 to 2
|
||||
* Ctrl = @Window:".":Field(CtrlIds, ",", i, 1)
|
||||
* Set_Property(Ctrl, "OLE.Background", Background)
|
||||
* Set_Property(Ctrl, "OLE.Forecolor", Foreground)
|
||||
* Send_Message(Ctrl, 'QUALIFY_EVENT', 'OLE.OnClick', Yes$)
|
||||
* Next i
|
||||
|
||||
// Qualify OLE events that we want to intercept
|
||||
Send_Message(@Window:'.OLE_ADD_ALL', 'QUALIFY_EVENT', 'OLE.OnClick', Yes$)
|
||||
Send_Message(@Window:'.OLE_ADD_SELECTED', 'QUALIFY_EVENT', 'OLE.OnClick', Yes$)
|
||||
Send_Message(@Window:'.OLE_REMOVE_ALL', 'QUALIFY_EVENT', 'OLE.OnClick', Yes$)
|
||||
Send_Message(@Window:'.OLE_REMOVE_SELECTED', 'QUALIFY_EVENT', 'OLE.OnClick', Yes$)
|
||||
Send_Message(@Window:'.OLE_REFRESH', 'QUALIFY_EVENT', 'OLE.OnClick', Yes$)
|
||||
Send_Message(@Window:'.OLE_MANUAL', 'QUALIFY_EVENT', 'OLE.OnClick', Yes$)
|
||||
Send_Message(@Window:'.OLE_HEADS', 'QUALIFY_EVENT', 'OLE.OnClick', Yes$)
|
||||
|
||||
// Setup selection buttons
|
||||
Style = 'TBNG'
|
||||
Background = ''
|
||||
Background<1> = 'None'
|
||||
Background<2> = 'Vertical(Gradient(S L=90, S L=90), Border(S L=70))'
|
||||
Background<3> = 'Vertical(Gradient(S L=80, S L=80), Border(S L=60))'
|
||||
Background<4> = 'None'
|
||||
Background<5> = 'Vertical(Gradient(S L=80, S L=80), Border(S L=60))'
|
||||
Set_Property(@Window:'.OLE_ADD_ALL', 'OLE.Style', Style)
|
||||
Set_Property(@Window:'.OLE_ADD_SELECTED', 'OLE.Style', Style)
|
||||
Set_Property(@Window:'.OLE_REMOVE_SELECTED', 'OLE.Style', Style)
|
||||
Set_Property(@Window:'.OLE_REMOVE_ALL', 'OLE.Style', Style)
|
||||
Set_Property(@Window:'.OLE_ADD_ALL', 'OLE.Background', Background)
|
||||
Set_Property(@Window:'.OLE_ADD_SELECTED', 'OLE.Background', Background)
|
||||
Set_Property(@Window:'.OLE_REMOVE_SELECTED', 'OLE.Background', Background)
|
||||
Set_Property(@Window:'.OLE_REMOVE_ALL', 'OLE.Background', Background)
|
||||
Set_Property(@Window:'.OLE_ADD_ALL', 'OLE.Icon', IMAGE_LOC$:'ArrowDblRight.png')
|
||||
Set_Property(@Window:'.OLE_ADD_SELECTED', 'OLE.Icon', IMAGE_LOC$:'ArrowRight.png')
|
||||
Set_Property(@Window:'.OLE_REMOVE_SELECTED', 'OLE.Icon', IMAGE_LOC$:'ArrowLeft.png')
|
||||
Set_Property(@Window:'.OLE_REMOVE_ALL', 'OLE.Icon', IMAGE_LOC$:'ArrowDblLeft.png')
|
||||
|
||||
// Setup Working OLE Report Table
|
||||
Ctrl = @Window:'.OLE_RPT_WORK' ; GoSub Setup_ReportTable
|
||||
Ctrl = @Window:'.OLE_RPT_STAGE' ; GoSub Setup_ReportTable
|
||||
|
||||
return
|
||||
|
||||
Setup_ReportTable:
|
||||
|
||||
ColumnList = ''
|
||||
ColumnList<-1> = 'Id' :@VM:'Text':@VM:100:@VM:0:@VM:@VM:@VM:1:@VM:0:@VM:50:@VM:'Left':@VM:@VM:@VM:@VM:'Segeo UI Semilight':@SVM:'10'
|
||||
ColumnList<-1> = 'App' :@VM:'Text':@VM:120:@VM:0:@VM:@VM:@VM:1:@VM:1:@VM:50:@VM:'Left':@VM:@VM:@VM:@VM:'Segoe UI Semilight':@SVM:'10'
|
||||
ColumnList<-1> = 'Type' :@VM:'Text':@VM:100:@VM:0:@VM:@VM:@VM:1:@VM:0:@VM:50:@VM:'Left':@VM:@VM:@VM:@VM:'Segoe UI Semilight':@SVM:'10'
|
||||
ColumnList<-1> = 'Class' :@VM:'Text':@VM:100:@VM:0:@VM:@VM:@VM:1:@VM:0:@VM:50:@VM:'Left':@VM:@VM:@VM:@VM:'Segoe UI Semilight':@SVM:'10'
|
||||
ColumnList<-1> = 'Name' :@VM:'Text':@VM:300:@VM:1:@VM:@VM:@VM:1:@VM:1:@VM:50:@VM:'Left':@VM:@VM:@VM:@VM:'Segoe UI Semilight':@SVM:'10'
|
||||
ColumnList<-1> = 'Status' :@VM:'Text':@VM:80 :@VM:0:@VM:@VM:@VM:0:@VM:1:@VM:50:@VM:'Left':@VM:@VM:@VM:@VM:'Segoe UI Semilight':@SVM:'10'
|
||||
|
||||
Set_Property(Ctrl, 'OLE.ColumnList', ColumnList)
|
||||
Set_Property(Ctrl, 'OLE.GroupOrder', 3)
|
||||
Set_Property(Ctrl, 'OLE.SortOrder', 3:@FM:5)
|
||||
Set_Property(Ctrl, 'OLE.MultiSelect', 1)
|
||||
Set_Property(Ctrl, 'OLE.HorizontalGridStyle', 'None')
|
||||
Set_Property(Ctrl, "OLE.AlwaysShowSelection", Yes$)
|
||||
Send_Message(Ctrl, 'QUALIFY_EVENT', 'OLE.OnSelChange', Yes$)
|
||||
Send_Message(Ctrl, 'QUALIFY_EVENT', 'OLE.OnItemDblClick', Yes$)
|
||||
|
||||
return
|
||||
|
||||
|
||||
EnableArrowButtons:
|
||||
|
||||
Set_Property(@Window:'.OLE_ADD_ALL', 'ENABLED', Get_Property(@Window:'.OLE_RPT_WORK', 'OLE.RowCount') GT 0)
|
||||
Set_Property(@Window:'.OLE_ADD_SELECTED', 'ENABLED', Get_Property(@Window:'.OLE_RPT_WORK', 'OLE.SelList') NE "")
|
||||
Set_Property(@Window:'.OLE_REMOVE_SELECTED', 'ENABLED', Get_Property(@Window:'.OLE_RPT_STAGE', 'OLE.SelList') NE "")
|
||||
Set_Property(@Window:'.OLE_REMOVE_ALL', 'ENABLED', Get_Property(@Window:'.OLE_RPT_STAGE', 'OLE.RowCount') GT 0)
|
||||
|
||||
return
|
||||
|
||||
|
||||
EnableStagingCtrls:
|
||||
|
||||
StagingList = Get_Property(@Window:'.OLE_RPT_STAGE', 'OLE.List')
|
||||
If StagingList NE '' then
|
||||
Set_Property(@Window:'.PUB_APPLY', 'ENABLED', Yes$)
|
||||
end else
|
||||
Set_Property(@Window:'.PUB_APPLY', 'ENABLED', No$)
|
||||
end
|
||||
|
||||
return
|
||||
|
||||
|
||||
Populate:
|
||||
|
||||
Set_Property('SYSTEM', 'CURSOR', 'H')
|
||||
Set_Property(@Window:".OLE_RPT_WORK", "OLE.EmptyTablePrompt", "Loading...")
|
||||
Set_Property(@Window:'.OLE_RPT_WORK', 'OLE.List', "")
|
||||
Set_Property(@Window:'.OLE_RPT_STAGE', 'OLE.List', "")
|
||||
|
||||
Types = Get_Property(@Window:".CMB_FILTER_WORK", "TEXT")
|
||||
Apps = Get_Property(@Window:".CMB_FILTER_APP", "TEXT")
|
||||
Operation = Get_Property(@Window, '@OPERATION')
|
||||
|
||||
Begin Case
|
||||
|
||||
Case Operation EQ "PULL"
|
||||
FromCommit = Get_Property(@Window:".EDL_FROM_COMMIT", "@HASH")
|
||||
ToCommit = Get_Property(@Window:".EDL_TO_COMMIT", "@HASH")
|
||||
EntityList = SRP_Git_Services("GetRepoEntities", Types, Apps, FromCommit, ToCommit)
|
||||
|
||||
Case Operation EQ "PUSH"
|
||||
EntityList = SRP_Git_Services("GetOIEntities", Types, Apps)
|
||||
|
||||
End Case
|
||||
|
||||
Set_Property(@Window:".EDL_SEARCH", "TEXT", "")
|
||||
Set_Property(@Window:'.OLE_RPT_WORK', 'OLE.List', EntityList)
|
||||
Set_Property(@Window:'.OLE_RPT_WORK', '@ORIGLIST', EntityList)
|
||||
Apps = @APPID
|
||||
NumApps = DCount(Apps, @FM)
|
||||
If NumApps GE 2 then
|
||||
FirstApps = Field(Apps, @FM, 1, NumApps - 1)
|
||||
Swap @FM with ", " in FirstApps
|
||||
Apps = FirstApps:", or ":Apps<NumApps>
|
||||
end
|
||||
Set_Property(@Window:".OLE_RPT_WORK", "OLE.EmptyTablePrompt", "No entities found in ":Apps:" matching criteria.")
|
||||
|
||||
GoSub EnableArrowButtons
|
||||
|
||||
Set_Property('SYSTEM', 'CURSOR', 'A')
|
||||
|
||||
return
|
||||
|
||||
|
||||
Load_Commits:
|
||||
|
||||
// Clear lists
|
||||
Set_Property(@Window:".EDL_FROM_COMMIT", "TEXT", "")
|
||||
Set_Property(@Window:".EDL_TO_COMMIT", "TEXT", "")
|
||||
|
||||
// Load the commit options
|
||||
If Get_Property(@Window:".OLE_HEADS", "OLE.Caption") _EQC "Heads" then
|
||||
CommitData = @FM:SRP_Git_Services("GetCommits")
|
||||
end else
|
||||
CommitData = @FM:SRP_Git_Services("GetBranchHeads")
|
||||
end
|
||||
|
||||
// Get the SHA for the last saved commit
|
||||
LastCommit = SRP_Git_Services("LoadLastCommit")<1>
|
||||
|
||||
// Find the curr head and the last saved commit
|
||||
LastCommitPos = 1
|
||||
CurrPos = 1
|
||||
For Each Commit in CommitData setting Pos
|
||||
If Commit<1, 2> EQ LastCommit then LastCommitPos = Pos
|
||||
If Commit<1, 1> EQ "*" then CurrPos = Pos
|
||||
Next Commit
|
||||
|
||||
// Populate the controls
|
||||
Convert @FM:@VM to @TM:@STM in CommitData
|
||||
Set_Property(@Window:".OLE_SUBCLASS", "OLE.ComboData[EDL_FROM_COMMIT]", CommitData)
|
||||
Set_Property(@Window:".OLE_SUBCLASS", "OLE.ComboData[EDL_TO_COMMIT]", CommitData)
|
||||
Set_Property(@Window:".OLE_SUBCLASS", "OLE.ComboSelPos[EDL_FROM_COMMIT]", LastCommitPos)
|
||||
Set_Property(@Window:".OLE_SUBCLASS", "OLE.ComboSelPos[EDL_TO_COMMIT]", CurrPos)
|
||||
|
||||
return
|
||||
|
||||
|
||||
Enable_Combos:
|
||||
|
||||
// Subclassing
|
||||
Ctrl = @Window:".OLE_SUBCLASS"
|
||||
ComboDropDown = ""
|
||||
ComboDropDown<1> = 1 ;// by default, we won't show the combo box itself
|
||||
ComboDropDown<2, 1> = "*":@TM:"SHA":@TM:"Branch":@TM:"When":@TM:"Author":@TM:"Commit" :@TM:""
|
||||
ComboDropDown<2, 2> = "L":@TM:"L" :@TM:"L" :@TM:"L" :@TM:"L" :@TM:"L":@STM:300:@TM:"L":@STM:0
|
||||
ComboDropDown<2, 4> = 7 ;// master column
|
||||
ComboDropDown<2, 5> = 0 ;// auto fill off
|
||||
ComboDropDown<2, 10> = 0 ;// Only show the drop down when the user types
|
||||
ComboDropDown<2, 11> = 1 ;// Use LIST Format
|
||||
ComboDropDown<2, 18> = 1 ;// Show Popup while in read only mode
|
||||
ComboDropDown<2, 22> = 'Segeo UI Semilight':@SVM:'9' ;// Font
|
||||
Set_Property(Ctrl, "OLE.Combo[EDL_FROM_COMMIT]", ComboDropDown)
|
||||
Set_Property(Ctrl, "OLE.Combo[EDL_TO_COMMIT]", ComboDropDown)
|
||||
|
||||
return
|
||||
|
||||
Load_Auto:
|
||||
|
||||
LastCommit = SRP_Git_Services("LoadLastCommit")
|
||||
If Len(LastCommit) then
|
||||
Text = '[':LastCommit<3>:'] ':LastCommit<2>:' (':LastCommit<4>:')'
|
||||
Set_Property(@Window:".EDL_FROM_COMMIT", "TEXT", Text)
|
||||
Set_Property(@Window:".EDL_FROM_COMMIT", "@HASH", LastCommit<1>)
|
||||
end else
|
||||
Set_Property(@Window:".EDL_FROM_COMMIT", "TEXT", "")
|
||||
Set_Property(@Window:".EDL_FROM_COMMIT", "@HASH", "")
|
||||
end
|
||||
|
||||
CurrCommit = SRP_Git_Services("GetCurrentCommit")
|
||||
If Len(CurrCommit) then
|
||||
Text = '[':CurrCommit<3>:'] ':CurrCommit<6>:' (':CurrCommit<5>:')'
|
||||
Set_Property(@Window:".EDL_TO_COMMIT", "TEXT", Text)
|
||||
Set_Property(@Window:".EDL_TO_COMMIT", "@HASH", "*")
|
||||
end else
|
||||
Set_Property(@Window:".EDL_TO_COMMIT", "TEXT", "")
|
||||
Set_Property(@Window:".EDL_TO_COMMIT", "@HASH", "")
|
||||
end
|
||||
|
||||
return
|
||||
|
||||
Execute:
|
||||
|
||||
Set_Property('SYSTEM', 'CURSOR', 'H')
|
||||
ErrorList = ''
|
||||
Operation = Get_Property(@Window, '@OPERATION')
|
||||
StageList = Get_Property(@Window:'.OLE_RPT_STAGE', 'OLE.List')
|
||||
RotatedList = SRP_Array('Rotate', StageList)
|
||||
EntityList = RotatedList<1>
|
||||
StatusList = RotatedList<6>
|
||||
Convert @VM to @FM in EntityList
|
||||
Convert @VM to @FM in StatusList
|
||||
Set_Property(@Window, "VPOSITION", 2)
|
||||
Set_Property(@Window:".PUB_BACK", "ENABLED", No$)
|
||||
Set_Property(@Window:".EDB_STATUS", "TEXT", "")
|
||||
Begin Case
|
||||
Case Operation EQ "PULL"
|
||||
ToCommit = Get_Property(@Window:".CMB_TO_COMMIT", "TEXT")
|
||||
If Len(ToCommit) then
|
||||
CommitLabels = Get_Property(@Window:".CMB_TO_COMMIT", "LIST")
|
||||
Locate ToCommit in CommitLabels using @FM setting Pos then
|
||||
ToCommit = Get_Property(@Window:".CMB_TO_COMMIT", "@IDS")<Pos>
|
||||
end
|
||||
end
|
||||
ErrorList = SRP_Git_Services('PullEntities', EntityList, StatusList, @Window:".EDB_STATUS", ToCommit)
|
||||
Case Operation EQ "PUSH"
|
||||
ErrorList = SRP_Git_Services('PushEntities', EntityList, @Window:".EDB_STATUS")
|
||||
End Case
|
||||
Set_Property(@Window:".PUB_BACK", "ENABLED", Yes$)
|
||||
CurrCommit = SRP_Git_Services("GetCurrentCommit")
|
||||
SRP_Git_Services("SaveLastCommit", CurrCommit<2>, CurrCommit<6>, CurrCommit<3>, CurrCommit<5>)
|
||||
Set_Property('SYSTEM', 'CURSOR', 'A')
|
||||
|
||||
return
|
||||
|
||||
40
SYSPROG/STPROC/SRP_LOGON.txt
Normal file
40
SYSPROG/STPROC/SRP_LOGON.txt
Normal file
@ -0,0 +1,40 @@
|
||||
Compile function SRP_Logon(@Service, @Params)
|
||||
/************************************************************************************************
|
||||
This program is proprietary and is not to be used by or disclosed to others, nor is it to
|
||||
be copied without written permission from SRP Computer Solutions, Inc.
|
||||
|
||||
Name : SRP_Logon
|
||||
|
||||
Description : Service module for the SRP_Logon system.
|
||||
|
||||
Parameters:
|
||||
Service [IN] - The service to execute
|
||||
Params [IN] - Service specific parameters
|
||||
|
||||
History (Date, Initials, Notes)
|
||||
06/18/20 KRF Original programmer
|
||||
************************************************************************************************/
|
||||
#pragma precomp SRP_PreCompiler
|
||||
$insert LOGICAL
|
||||
|
||||
Declare function SRPLogonAPI_ValidateUser, SRPLogonAPI_GetADGroups, SRPLogonAPI_GetError
|
||||
|
||||
GoToService
|
||||
|
||||
Return Response or ""
|
||||
|
||||
//-----------------------------------------------------------------------------
|
||||
// SERVICES
|
||||
//-----------------------------------------------------------------------------
|
||||
|
||||
Service ValidateUser(Username, Password, Domain)
|
||||
Response = SRPLogonAPI_ValidateUser(Username, Password, Domain)
|
||||
End Service
|
||||
|
||||
Service GetADGroups(AdName, DcName)
|
||||
Response = SRPLogonAPI_GetADGroups(AdName, DcName)
|
||||
End Service
|
||||
|
||||
Service GetError()
|
||||
Response = SRPLogonAPI_GetError()
|
||||
End Service
|
||||
310
SYSPROG/STPROC/SRP_MAIL_DEMO_EVENTS.txt
Normal file
310
SYSPROG/STPROC/SRP_MAIL_DEMO_EVENTS.txt
Normal file
@ -0,0 +1,310 @@
|
||||
Function SRP_MAIL_DEMO_EVENTS(CtrlEntID, Event, Param1, Param2, Param3, Param4, Param5, Param6, Param7, Param8)
|
||||
/*
|
||||
* Subroutine Name :SRP_MAIL_DEMO_EVENTS
|
||||
*
|
||||
* Description : Commuter Module for SRP_MAIL_DEMO
|
||||
*
|
||||
* Date : 01/07/2016
|
||||
*
|
||||
* Author : SYSPROG
|
||||
*
|
||||
* OI Version : 9.4.0
|
||||
*
|
||||
********************************************************/
|
||||
|
||||
Declare Subroutine Msg, FsMsg, Set_Status, Center_Window, Set_Property, Send_Message, Yield
|
||||
|
||||
Declare Function Msg, Get_Property, Get_Status, Set_Property, Popup
|
||||
Declare Function Repository, Send_Message, Send_Event, Unassigned, Utility
|
||||
Declare Function ContextMenu, SRP_Send_Mail
|
||||
|
||||
$Insert MSG_Equates
|
||||
$Insert Popup_Equates
|
||||
$INSERT LOGICAL
|
||||
$Insert RTI_STYLE_EQUATES
|
||||
|
||||
If Unassigned(CtrlEntID) Then CtrlEntID = ''
|
||||
If Unassigned(Event) Then Event = ''
|
||||
If Unassigned(Param1) Then Param1 = ''
|
||||
If Unassigned(Param2) Then Param2 = ''
|
||||
If Unassigned(Param3) Then Param3 = ''
|
||||
If Unassigned(Param4) Then Param4 = ''
|
||||
If Unassigned(Param5) Then Param5 = ''
|
||||
If Unassigned(Param6) Then Param6 = ''
|
||||
If Unassigned(Param7) Then Param7 = ''
|
||||
If Unassigned(Param8) Then Param8 = ''
|
||||
|
||||
|
||||
If index(CtrlEntID,".",1) then
|
||||
WinName = Field(CtrlEntID,'.',1)
|
||||
Control = Field(CtrlEntID,'.',2)
|
||||
End else
|
||||
WinName = CtrlEntID
|
||||
Control = WinName
|
||||
End
|
||||
|
||||
Parent = @window
|
||||
Frame = Get_Property(Parent,'MDIFRAME')
|
||||
If len(Frame) then Parent = Frame
|
||||
|
||||
Retval = 1
|
||||
|
||||
Begin Case
|
||||
Case Event _EQC 'CREATE' ; Gosub CREATE
|
||||
|
||||
Case Event _EQC 'CHANGED'
|
||||
Begin Case
|
||||
Case Control _EQC 'COB_BODY_TYPE' ; GoSub CHANGED.COB_BODY_TYPE
|
||||
Case Control _EQC 'COB_SERVER_PORT' ; GoSub CHANGED.COB_SERVER_PORT
|
||||
Case Control _EQC 'COB_ENCRYPTION' ; GoSub CHANGED.COB_ENCRYPTION
|
||||
End Case
|
||||
|
||||
Case Event _EQC 'OPTIONS'
|
||||
Begin Case
|
||||
Case Control _EQC 'EDT_ATTACHMENTS' ; GoSub OPTIONS.EDT_ATTACHMENTS
|
||||
End Case
|
||||
|
||||
Case Event _EQC 'CLICK'
|
||||
Begin Case
|
||||
Case Control _EQC 'PUB_SEND_EMAIL' ; GoSub CLICK.PUB_SEND_EMAIL
|
||||
End Case
|
||||
End Case
|
||||
|
||||
return retval
|
||||
|
||||
|
||||
CREATE:
|
||||
HTMLCtrl = @Window : '.OLE_BODY'
|
||||
Send_Message(HTMLCtrl, 'OLE.Navigate2', 'about:blank')
|
||||
Loop
|
||||
Status = Get_Property(HTMLCtrl, 'OLE.ReadyState')
|
||||
While (Status NE 4)
|
||||
Yield()
|
||||
Repeat
|
||||
|
||||
OSRead Body from Drive() : '\Sample HTML Email.htm' then
|
||||
Send_Message(HTMLCtrl, 'OLE.document.open')
|
||||
Send_Message(HTMLCtrl, 'OLE.document.write', Body)
|
||||
Send_Message(HTMLCtrl, 'OLE.document.close')
|
||||
end
|
||||
|
||||
Send_Message(@Window : '.EDT_ATTACHMENTS', 'STYLE_BY_POS', 1, 0, DTCS_OPTIONSBUTTON$)
|
||||
|
||||
Open "SYSLISTS" to hSYSLISTS then
|
||||
Read Cache from hSYSLISTS, "SRP_MAIL_DEMO_CACHE" then
|
||||
Set_Property(@Window : '.EDL_SUBJECT', 'TEXT', Cache<1>)
|
||||
Set_Property(@Window : '.EDL_FROM', 'TEXT', Cache<2>)
|
||||
Set_Property(@Window : '.EDL_TO', 'TEXT', Cache<3>)
|
||||
Set_Property(@Window : '.EDL_CC', 'TEXT', Cache<4>)
|
||||
Set_Property(@Window : '.EDL_BCC', 'TEXT', Cache<5>)
|
||||
Set_Property(@Window : '.EDL_REPLY_TO', 'TEXT', Cache<6>)
|
||||
Set_Property(@Window : '.COB_BODY_TYPE', 'TEXT', Cache<7>)
|
||||
Set_Property(@Window : '.COB_SERVER_PORT', 'TEXT', Cache<8>)
|
||||
Set_Property(@Window : '.COB_ENCRYPTION', 'TEXT', Cache<9>)
|
||||
Set_Property(@Window : '.EDL_SMTP_SERVER', 'TEXT', Cache<10>)
|
||||
Set_Property(@Window : '.EDL_ACCOUNT_USERNAME', 'TEXT', Cache<11>)
|
||||
Set_Property(@Window : '.CHB_AUTHENTICATE', 'CHECK', Cache<12>)
|
||||
Set_Property(@Window : '.EDT_ATTACHMENTS', 'ARRAY', Cache<13>:@FM:Cache<14>)
|
||||
* Set_Property(@Window : '.EDL_ACCOUNT_PASSWORD', 'TEXT', Cache<15>)
|
||||
GoSub CHANGED.COB_BODY_TYPE
|
||||
end
|
||||
end
|
||||
|
||||
Size = Get_Property(@Window, 'SIZE')
|
||||
TrackingSize = Size<3> : @FM : Size<4> : @FM : Size<3> : @FM : Size<4>
|
||||
Set_Property(@Window, 'TRACKINGSIZE', TrackingSize)
|
||||
|
||||
Center_Window(@Window)
|
||||
Return
|
||||
|
||||
|
||||
CHANGED.COB_BODY_TYPE:
|
||||
BodyType = Get_Property(@Window : '.COB_BODY_TYPE', 'TEXT')
|
||||
If BodyType _EQC 'HTML' Then
|
||||
Set_Property(@Window : '.OLE_BODY', 'VISIBLE', True$)
|
||||
Set_Property(@Window : '.EDB_BODY', 'VISIBLE', False$)
|
||||
End Else
|
||||
Set_Property(@Window : '.EDB_BODY', 'VISIBLE', True$)
|
||||
Set_Property(@Window : '.OLE_BODY', 'VISIBLE', False$)
|
||||
end
|
||||
Return
|
||||
|
||||
|
||||
OPTIONS.EDT_ATTACHMENTS:
|
||||
SelPos = Get_Property(CtrlEntId, 'SELPOS')
|
||||
RowPos = SelPos<2>
|
||||
CurPath = Send_Message(CtrlEntId, 'TEXT_BY_POS', 2, RowPos)
|
||||
If Len(CurPath) Then
|
||||
FileName = CurPath[-1, 'B\']
|
||||
NumDelims = Count(CurPath, '\')
|
||||
InitDir = Field(CurPath, '\', 1, NumDelims)
|
||||
End Else
|
||||
FileName = ''
|
||||
InitDir = Drive()
|
||||
end
|
||||
ConfigOptions = ''
|
||||
ConfigOptions<1> = 0
|
||||
ConfigOptions<4> = FileName
|
||||
ConfigOptions<6> = InitDir
|
||||
Path = Utility('CHOOSEFILE', @Window, ConfigOptions)
|
||||
If Len(Path) And (Path NE CurPath) Then
|
||||
Set_Property(CtrlEntId, 'ROWDATA', '' : @FM : Path)
|
||||
end
|
||||
Return
|
||||
|
||||
|
||||
CHANGED.COB_SERVER_PORT:
|
||||
ServerPort = Param1
|
||||
Begin Case
|
||||
Case ServerPort[1, 2] EQ 25 ; Set_Property(@Window : '.COB_ENCRYPTION', 'TEXT', '<none>')
|
||||
Case ServerPort[1, 3] EQ 465 ; Set_Property(@Window : '.COB_ENCRYPTION', 'TEXT', 'SSL')
|
||||
Case ServerPort[1, 3] EQ 587 ; Set_Property(@Window : '.COB_ENCRYPTION', 'TEXT', 'TLS')
|
||||
End Case
|
||||
Return
|
||||
|
||||
|
||||
CHANGED.COB_ENCRYPTION:
|
||||
Encryption = Param1
|
||||
Begin Case
|
||||
Case Encryption EQ '<none>' ; Set_Property(@Window : '.COB_SERVER_PORT', 'TEXT', '25 (Non-Secure SMTP)')
|
||||
Case Encryption EQ 'SSL' ; Set_Property(@Window : '.COB_SERVER_PORT', 'TEXT', '465 (SSL)')
|
||||
Case Encryption EQ 'TLS' ; Set_Property(@Window : '.COB_SERVER_PORT', 'TEXT', '587 (TLS)')
|
||||
End Case
|
||||
Return
|
||||
|
||||
|
||||
CLICK.PUB_SEND_EMAIL:
|
||||
TestResults = @Window : '.EDB_TEST_RESULTS'
|
||||
Set_Property(TestResults, 'TEXTVAL', '')
|
||||
Send_Message(TestResults, 'INSERT', -1, 'Attempting to send email...')
|
||||
|
||||
Continue = True$
|
||||
Gosub Get_Message_Parameters
|
||||
If Continue Then Gosub Get_Configuration_Parameters
|
||||
If Continue Then Gosub Send_Email
|
||||
|
||||
If Not(Continue) Then Send_Message(TestResults, 'INSERT', -1, \0D0A\ : 'Sending email failed.')
|
||||
|
||||
Cache = ''
|
||||
Cache<-1> = Get_Property(@Window : '.EDL_SUBJECT', 'TEXT')
|
||||
Cache<-1> = Get_Property(@Window : '.EDL_FROM', 'TEXT')
|
||||
Cache<-1> = Get_Property(@Window : '.EDL_TO', 'TEXT')
|
||||
Cache<-1> = Get_Property(@Window : '.EDL_CC', 'TEXT')
|
||||
Cache<-1> = Get_Property(@Window : '.EDL_BCC', 'TEXT')
|
||||
Cache<-1> = Get_Property(@Window : '.EDL_REPLY_TO', 'TEXT')
|
||||
Cache<-1> = Get_Property(@Window : '.COB_BODY_TYPE', 'TEXT')
|
||||
Cache<-1> = Get_Property(@Window : '.COB_SERVER_PORT', 'TEXT')
|
||||
Cache<-1> = Get_Property(@Window : '.COB_ENCRYPTION', 'TEXT')
|
||||
Cache<-1> = Get_Property(@Window : '.EDL_SMTP_SERVER', 'TEXT')
|
||||
Cache<-1> = Get_Property(@Window : '.EDL_ACCOUNT_USERNAME', 'TEXT')
|
||||
Cache<-1> = Get_Property(@Window : '.CHB_AUTHENTICATE', 'CHECK')
|
||||
Cache<-1> = Get_Property(@Window : '.EDT_ATTACHMENTS', 'ARRAY')
|
||||
* Cache<-1> = Get_Property(@Window : '.EDL_ACCOUNT_PASSWORD', 'TEXT')
|
||||
Open "SYSLISTS" to hSYSLISTS then
|
||||
Write Cache to hSYSLISTS, "SRP_MAIL_DEMO_CACHE" then NULL
|
||||
end
|
||||
|
||||
Return
|
||||
|
||||
|
||||
Get_Message_Parameters:
|
||||
Subject = Get_Property(@Window : '.EDL_SUBJECT', 'TEXT')
|
||||
From = Get_Property(@Window : '.EDL_FROM', 'TEXT')
|
||||
To = Get_Property(@Window : '.EDL_TO', 'TEXT')
|
||||
CC = Get_Property(@Window : '.EDL_CC', 'TEXT')
|
||||
BCC = Get_Property(@Window : '.EDL_BCC', 'TEXT')
|
||||
ReplyTo = Get_Property(@Window : '.EDL_REPLY_TO', 'TEXT')
|
||||
BodyType = Get_Property(@Window : '.COB_BODY_TYPE', 'TEXT')
|
||||
If BodyType _EQC 'HTML' Then
|
||||
OSRead Body from Drive() : '\Sample HTML Email.htm' else Body = ''
|
||||
End Else
|
||||
Body = Get_Property(@Window : '.EDB_BODY', 'TEXT')
|
||||
End
|
||||
Attachments = Send_Message(@Window : '.EDT_ATTACHMENTS', 'TEXT_BY_POS', 2, 0)
|
||||
NumAttachments = DCount(Attachments, @FM)
|
||||
Loop
|
||||
Attachment = Attachments<NumAttachments>
|
||||
Until Len(Attachment) Or NumAttachments LT 1
|
||||
Attachments = Delete(Attachments, NumAttachments, 0, 0)
|
||||
NumAttachments -= 1
|
||||
Repeat
|
||||
Convert @FM To @VM In Attachments
|
||||
|
||||
If Len(From) Else
|
||||
Continue = False$
|
||||
Send_Message(TestResults, 'INSERT', -1, \0D0A\ : 'Missing the From email address.')
|
||||
end
|
||||
|
||||
If Len(To) Else
|
||||
Continue = False$
|
||||
Send_Message(TestResults, 'INSERT', -1, \0D0A\ : 'Missing the To email address.')
|
||||
end
|
||||
Return
|
||||
|
||||
|
||||
Get_Configuration_Parameters:
|
||||
ServerPort = Get_Property(@Window : '.COB_SERVER_PORT', 'TEXT')
|
||||
ServerPort = ServerPort[1, ' ']
|
||||
Encryption = Get_Property(@Window : '.COB_ENCRYPTION', 'TEXT')
|
||||
If Encryption _EQC '<none>' Then Encryption = ''
|
||||
Authenticate = Get_Property(@Window : '.CHB_AUTHENTICATE', 'CHECK')
|
||||
SMTPServer = Get_Property(@Window : '.EDL_SMTP_SERVER', 'TEXT')
|
||||
AccountUsername = Get_Property(@Window : '.EDL_ACCOUNT_USERNAME', 'TEXT')
|
||||
AccountPassword = Get_Property(@Window : '.EDL_ACCOUNT_PASSWORD', 'TEXT')
|
||||
|
||||
If Len(ServerPort) else
|
||||
Continue = False$
|
||||
Send_Message(TestResults, 'INSERT', -1, \0D0A\ : 'Missing the Server Port.')
|
||||
End
|
||||
|
||||
If Len(SMTPServer) else
|
||||
Continue = False$
|
||||
Send_Message(TestResults, 'INSERT', -1, \0D0A\ : 'Missing the SMTP Server URL.')
|
||||
end
|
||||
|
||||
If Len(AccountUsername) else
|
||||
Continue = False$
|
||||
Send_Message(TestResults, 'INSERT', -1, \0D0A\ : 'Missing the Account Username.')
|
||||
End
|
||||
|
||||
If Len(AccountPassword) else
|
||||
Continue = False$
|
||||
Send_Message(TestResults, 'INSERT', -1, \0D0A\ : 'Missing the Account Password.')
|
||||
end
|
||||
Return
|
||||
|
||||
|
||||
Send_Email:
|
||||
Message = ''
|
||||
Message<1> = Subject
|
||||
Message<2> = From
|
||||
Message<3> = To
|
||||
Message<4> = CC
|
||||
Message<5> = BCC
|
||||
Message<6> = ReplyTo
|
||||
Message<7> = BodyType
|
||||
Message<8> = Body
|
||||
Message<9> = Attachments
|
||||
Message<10> = ''
|
||||
Message<11> = ''
|
||||
Message<12> = ''
|
||||
|
||||
Config = ''
|
||||
Config<1> = '' ; // Send Using is deprecated
|
||||
Config<2> = '' ; // Server Directory is deprecated
|
||||
Config<3> = ServerPort
|
||||
Config<4> = SMTPServer
|
||||
Config<5> = Authenticate
|
||||
Config<6> = AccountUsername
|
||||
Config<7> = AccountPassword
|
||||
Config<8> = Encryption
|
||||
|
||||
Response = SRP_Send_Mail(Message, Config)
|
||||
If Response EQ 1 Then
|
||||
Send_Message(TestResults, 'INSERT', -1, \0D0A\ : 'Sending email was successful.')
|
||||
End Else
|
||||
Continue = False$
|
||||
Send_Message(TestResults, 'INSERT', -1, \0D0A\ : 'SMTP Server Response: ' : Response)
|
||||
end
|
||||
Return
|
||||
|
||||
883
SYSPROG/STPROC/SRP_PRECOMPILER.txt
Normal file
883
SYSPROG/STPROC/SRP_PRECOMPILER.txt
Normal file
@ -0,0 +1,883 @@
|
||||
Compile Subroutine SRP_Precompiler(Routine, ProgName)
|
||||
|
||||
/************************************************************************************************
|
||||
|
||||
This program is proprietary and is not to be used by or disclosed to others, nor is it to
|
||||
be copied without written permission from SRP Computer Solutions, Inc.
|
||||
|
||||
Name : SRP_Precompiler
|
||||
|
||||
Description : Enhances BASIC+ with new features.
|
||||
|
||||
Parameters:
|
||||
Routine [IN] - The orginal source code when we will alter
|
||||
ProgName [IN] - The stored procedure name
|
||||
|
||||
History (Date, Initials, Notes)
|
||||
08/25/16 KRF Original programmer
|
||||
10/20/17 KRF Added support for unit test modules
|
||||
11/16/18 dmb Added support for web APIs
|
||||
|
||||
************************************************************************************************/
|
||||
$insert LOGICAL
|
||||
$insert SRPARRAY
|
||||
|
||||
Declare function Max, Get_Property, RetStack, SRP_String
|
||||
|
||||
// Don't precompile THIS!!!!
|
||||
If ProgName _EQC "SRP_PRECOMPILER" then return
|
||||
|
||||
#region Declarations
|
||||
|
||||
UsesGoSubList = 0
|
||||
UsesEventNames = 0
|
||||
UsesTestResult = 0
|
||||
UsesEncoding = 0
|
||||
UsesUnpackTarget = 0
|
||||
UsesUnpackSkip = 0
|
||||
HasLoops = 0
|
||||
|
||||
EventNames = "" ; // List of all events
|
||||
ServiceNames = "" ; // List of all services
|
||||
APINames = "" ; // List of all Web APIs
|
||||
ServicePos = 0 ; // The current position of the current service in ServiceNames (counts services essentially)
|
||||
APIPos = 0 ; // The current position of the current API in APINames (counts APIs essentially)
|
||||
ReturnVar = "" ; // The return variable for the store procedure
|
||||
CommonsAdded = No$ ; // Keeps track as to whether or not the commons have been added yet
|
||||
MaxNumParams = 0 ; // Keeps track of the number of generic parameters needed to cover all events or services
|
||||
AutoParamsNeeded = No$ ; // Keeps track as to whether or not there is an auto parameter keyword
|
||||
ReferenceParams = "" ; // Keeps track of servce parameters using pass-by-reference
|
||||
InCommentBlock = No$ ; // Keeps track as to whether or not the current line is within a comment block
|
||||
TestLineNumbers = "" ; // Keeps track of line numbers of test modules
|
||||
|
||||
// The metadata types: SERVICE or TEST
|
||||
Type = ""
|
||||
|
||||
// The SERVICE metadata
|
||||
DefaultParams = 0 ; // The service's default parameters
|
||||
ServiceParamPos = 0 ; // Indicates position of the parameter to receive the service name
|
||||
Param1Pos = 0 ; // Indicates the position of the first generic parameter
|
||||
ServiceNamesQuoted = 1 ; // Service parameters are always quoted when using precompiler
|
||||
ParamOptions = "" ; // Reserved. (Unused at the moment.)
|
||||
ServiceParams = "" ; // The parameter lists for each service
|
||||
ServiceParamOptions = "" ; // The parameter options for each service parameter
|
||||
APIParams = "" ; // The parameter lists for each API
|
||||
APIParamOptions = "" ; // The parameter options for each API parameter
|
||||
OptionNames = "" ; // The list of all options, by name
|
||||
OptionLists = "" ; // The option lists associated to the above option names
|
||||
OptionQuoteFlags = "" ; // The option lists' quoted flag associated to the above option names
|
||||
|
||||
// We need a stack to handle nest for-each and for loops. When a for-each loop is encountered,
|
||||
// we push "FOREACH" to the stack. When a regular for loop is encountered, we push "FOR" to the
|
||||
// stack. So, when we encounter "NEXT" statments, we know whether to handle them or ignore them
|
||||
NextStack = ""
|
||||
NextStackCount = 0
|
||||
|
||||
#endregion
|
||||
|
||||
// Determine if this version of OI supports UTF8 op codes
|
||||
SupportsUTF8Ops = Field(Get_Property("SYSTEM", "VERSION")<2>, ".", 1, 2) GE "9.2"
|
||||
If SupportsUTF8Ops then
|
||||
SupportsUTF8Ops = Xlate("SYSENV", "SRP_EDITOR_NO_UTF8_OPS", "", "X") NE 1
|
||||
end
|
||||
|
||||
// Break the code into an array of lines and create a blank array of lines for the new code
|
||||
Lines = Routine
|
||||
NewLines = ""
|
||||
NumLines = DCount(Lines, @FM)
|
||||
ParseState = ""
|
||||
|
||||
// Loop through each line
|
||||
For iLine = 1 to NumLines
|
||||
|
||||
Line = Lines<iLine>
|
||||
GoSub ParseLine
|
||||
Begin Case
|
||||
|
||||
// First line of code
|
||||
Case iLine EQ 1
|
||||
|
||||
// Required @SERVICE parameter (if service)
|
||||
Pos = IndexC(Line, "@SERVICE", 1)
|
||||
If Pos GT 0 then
|
||||
If Trim(Line[Pos, ")"][1, ","]) _EQC "@SERVICE" then
|
||||
Line[Pos, 8] = "Service"
|
||||
ServiceParamPos = DCount(Line[1, Pos], ",")
|
||||
IsServiceModule = 1
|
||||
end
|
||||
end
|
||||
|
||||
// Required @TEST parameter (if unit test module)
|
||||
Pos = IndexC(Line, "@TEST", 1)
|
||||
If Pos GT 0 then
|
||||
If Trim(Line[Pos, ")"][1, ","]) _EQC "@TEST" then
|
||||
Line[Pos, 5] = "TestName"
|
||||
ServiceParamPos = DCount(Line[1, Pos], ",")
|
||||
UsesTestResult = 1
|
||||
end
|
||||
end
|
||||
|
||||
// Required @API parameter (if API module)
|
||||
Pos = IndexC(Line, "@API", 1)
|
||||
If Pos GT 0 then
|
||||
If Trim(Line[Pos, ")"][1, ","]) _EQC "@API" then
|
||||
Line[Pos, 4] = "Api"
|
||||
ServiceParamPos = DCount(Line[1, Pos], ",")
|
||||
IsServiceModule = 1
|
||||
end
|
||||
end
|
||||
|
||||
// Optional @PARAMS parameter
|
||||
Pos = IndexC(Line, "@PARAMS", 1)
|
||||
If Pos GT 0 then
|
||||
If Trim(Line[Pos, ")"][1, ","]) _EQC "@PARAMS" then
|
||||
Line[Pos, 7] = "%%AUTOPARAMLIST%%"
|
||||
AutoParamsNeeded = Yes$
|
||||
end
|
||||
end
|
||||
Locate "(" in Tokens using @FM setting ParenPos then
|
||||
ParamList = SRP_String("DetokenizeCode", Field(Tokens, @FM, ParenPos, NumTokens))
|
||||
GoSub CleanParamList
|
||||
end else
|
||||
ParamList = ""
|
||||
end
|
||||
DefaultParams = ParamList
|
||||
Convert @FM to @SVM in DefaultParams
|
||||
Convert @Lower.Case to @Upper.Case in ParamList
|
||||
Locate "PARAM1" in ParamList using @FM setting Param1Pos else
|
||||
Locate "@PARAMS" in ParamList using @FM setting Param1Pos else null
|
||||
end
|
||||
|
||||
// Get the proc name as it is written
|
||||
CasedProcName = Line[1, "("][-1, "B "]
|
||||
|
||||
NewLines<-1> = Line
|
||||
|
||||
// Replace pragma with common statement. This is a much better place for it, assuming the pragma is at the top
|
||||
Case Trim(Line[1, 15]) _EQC "*pragma precomp"
|
||||
NewLines<-1> = "%%SRPAUTO_COMMON%%"
|
||||
|
||||
// Ignore all assignment statements
|
||||
Case IsAssignmentOrMethod
|
||||
NewLines<-1> = Line
|
||||
|
||||
// Check for For-Each loop
|
||||
Case Tokens<1> _EQC "FOR"
|
||||
LineFormat = "FOR,EACH,*,IN,*,USING|SETTING,*,SETTING"
|
||||
GoSub FormatTokens
|
||||
If Tokens<2> _EQC "EACH" AND Tokens<4> _EQC "IN" then
|
||||
HasLoops = 1
|
||||
ElementVar = Tokens<3>
|
||||
ListVar = Tokens<5>
|
||||
CounterVar = ""
|
||||
NextToken = 6
|
||||
If Tokens<NextToken> _EQC "USING" then
|
||||
Delimiter = Tokens<NextToken + 1>
|
||||
NextToken += 2
|
||||
end else
|
||||
Delimiter = '@FM'
|
||||
end
|
||||
If Tokens<NextToken> _EQC "SETTING" then
|
||||
CounterVar = Tokens<NextToken + 1>
|
||||
NextToken += 2
|
||||
end
|
||||
NewLine = ''
|
||||
// Make UTF-8 compatible (thanks Matt Crozier)
|
||||
NewLine<-1> = 'SRP_Precompiler_LoopStack@<-1> = SRP_Precompiler_LoopPos@:@VM:SRP_Precompiler_LoopLen@;'
|
||||
NewLine<-1> = 'SRP_Precompiler_LoopPos@ = 1;'
|
||||
If Len(CounterVar) then
|
||||
NewLine<-1> = CounterVar:' = 0;'
|
||||
end
|
||||
If SupportsUTF8Ops then
|
||||
NewLine<-1> = 'SRP_Precompiler_LoopLen@ = getByteSize(':ListVar:');'
|
||||
NewLine<-1> = 'Loop;'
|
||||
NewLine<-1> = ElementVar:' = ':ListVar:'[SRP_Precompiler_LoopPos@, "F":':Delimiter:', 1];'
|
||||
NewLine<-1> = 'SRP_Precompiler_LoopPos@ = bCol2() + 1'
|
||||
If Len(CounterVar) then
|
||||
NewLine<-1> = ';':CounterVar:' += 1'
|
||||
end
|
||||
end else
|
||||
NewLine<-1> = 'SRP_Precompiler_LoopLen@ = Len(':ListVar:');'
|
||||
NewLine<-1> = 'Loop;'
|
||||
NewLine<-1> = ElementVar:' = ':ListVar:'[SRP_Precompiler_LoopPos@, "F":':Delimiter:'];'
|
||||
NewLine<-1> = 'SRP_Precompiler_LoopPos@ = Col2() + 1'
|
||||
If Len(CounterVar) then
|
||||
NewLine<-1> = ';':CounterVar:' += 1'
|
||||
end
|
||||
end
|
||||
If Tokens<NextToken> _EQC "UNTIL" OR Tokens<NextToken> _EQC "WHILE" then
|
||||
Pos = IndexC(Line, Tokens<NextToken>, 1)
|
||||
If Pos GT 0 then
|
||||
NewLine := ';':Line[Pos, LenLine]
|
||||
end else
|
||||
NewLine := ';':Field(Tokens, @FM, NextToken, NumTokens)
|
||||
end
|
||||
end
|
||||
GoSub CommitNewLine
|
||||
NextStack<-1> = "FOREACH"
|
||||
NextStackCount += 1
|
||||
end else
|
||||
NewLines<-1> = Line
|
||||
NextStack<-1> = "FOR"
|
||||
NextStackCount += 1
|
||||
end
|
||||
|
||||
// Check for Next statement to match with For-Each loop
|
||||
Case Tokens<1> _EQC "NEXT" AND NextStackCount GT 0
|
||||
NextData = NextStack[-1, "B":@FM]
|
||||
NextType = NextData<1, 1>
|
||||
NextStack = If Col1() GT 1 then NextStack[1, Col1() - 1] else ""
|
||||
NextStackCount -= 1
|
||||
Begin Case
|
||||
Case NextType EQ "FOREACH"
|
||||
HasLoops = 1
|
||||
NewLine = ''
|
||||
NewLine<-1> = 'Until SRP_Precompiler_LoopPos@ GT SRP_Precompiler_LoopLen@;'
|
||||
NewLine<-1> = 'Repeat;'
|
||||
If SupportsUTF8Ops then
|
||||
NewLine<-1> = 'SRP_Precompiler_LoopLen@ = SRP_Precompiler_LoopStack@[-1, "B":@VM, 1];'
|
||||
NewLine<-1> = 'SRP_Precompiler_LoopPos@ = SRP_Precompiler_LoopStack@[bCol1() - 1, "B":@FM, 1];'
|
||||
NewLine<-1> = 'SRP_Precompiler_LoopStack@ = If bCol1() GT 1 then SRP_Precompiler_LoopStack@[1, bCol1() - 1, 1] else ""'
|
||||
end else
|
||||
NewLine<-1> = 'SRP_Precompiler_LoopLen@ = SRP_Precompiler_LoopStack@[-1, "B":@VM];'
|
||||
NewLine<-1> = 'SRP_Precompiler_LoopPos@ = SRP_Precompiler_LoopStack@[Col1() - 1, "B":@FM];'
|
||||
NewLine<-1> = 'SRP_Precompiler_LoopStack@ = If Col1() GT 1 then SRP_Precompiler_LoopStack@[1, Col1() - 1] else ""'
|
||||
end
|
||||
GoSub CommitNewLine
|
||||
Case 1
|
||||
NewLines<-1> = Line
|
||||
End Case
|
||||
|
||||
// Check for final return value, we'll use it to make sure it's always assigned
|
||||
Case Tokens<1> _EQC "RETURN" AND Len(ReturnVar) EQ 0
|
||||
ReturnVar = Tokens<2>
|
||||
If Tokens<3> _EQC "OR" OR Tokens<3> _EQC "ELSE" then
|
||||
NewLines<-1> = 'If Assigned(':ReturnVar:') then Return ':ReturnVar:' else Return ':Tokens<4>:''
|
||||
end else
|
||||
NewLines<-1> = Line
|
||||
end
|
||||
|
||||
// Check for GoToEvent
|
||||
Case Tokens<1> _EQC "GOTOEVENT"
|
||||
UsesGoSubList = 1
|
||||
UsesEventNames = 1
|
||||
LineFormat = "GOTOEVENT,*,FOR,*,ELSE"
|
||||
GoSub FormatTokens
|
||||
If Tokens<3> _EQC "FOR" then
|
||||
NewLine = ''
|
||||
NewLine<-1> = '%%SRPAUTO_EVENTLIST%%;'
|
||||
NewLine<-1> = 'SRP_Precompiler_EventEvent@ = ':Tokens<2>:';'
|
||||
NewLine<-1> = 'SRP_Precompiler_EventCtrl@ = Field(':Tokens<4>:', ".", 2, 9);'
|
||||
NewLine<-1> = 'SRP_Precompiler_GoSubTarget@ = (If Len(SRP_Precompiler_EventCtrl@) then SRP_Precompiler_EventCtrl@ else "WINDOW"):".":SRP_Precompiler_EventEvent@;'
|
||||
NewLine<-1> = 'Convert @Lower.Case to @Upper.Case in SRP_Precompiler_GoSubTarget@;'
|
||||
NewLine<-1> = 'Locate SRP_Precompiler_GoSubTarget@ in SRP_Precompiler_GoSubList@ using "," setting SRP_Precompiler_GoSubPos@ then'
|
||||
NewLine<-1> = '%%SRPAUTO_EVENTGOSUBLIST%%'
|
||||
If Tokens<5> _EQC "ELSE" then NewLine<-1> = 'else' else NewLine<-1> = 'else NULL'
|
||||
GoSub CommitNewLine
|
||||
end
|
||||
|
||||
// Check for event
|
||||
Case Tokens<1> _EQC "EVENT"
|
||||
EventName = Tokens<2>
|
||||
EventNames<-1> = EventName
|
||||
If Tokens<3> EQ "(" then
|
||||
ParamList = SRP_String("DetokenizeCode", Field(Tokens, @FM, 3, NumTokens))
|
||||
GoSub CleanParamList
|
||||
MaxNumParams = Max(MaxNumParams, NumParams)
|
||||
If NumParams GT 0 then
|
||||
InitEventParams = ""
|
||||
For iParam = 1 to NumParams
|
||||
InitEventParams<-1> = Trim(ParamList<iParam>):' = (If Assigned(Param':iParam:') then Param':iParam:' else "")'
|
||||
Next iParam
|
||||
Convert @FM to ";" in InitEventParams
|
||||
NewLines<-1> = EventName:': | ':InitEventParams
|
||||
end else
|
||||
NewLines<-1> = EventName:':'
|
||||
end
|
||||
end else
|
||||
NewLines<-1> = EventName:':'
|
||||
end
|
||||
|
||||
// Check for end of event
|
||||
Case Tokens<1> _EQC "END" AND Tokens<2> _EQC "EVENT"
|
||||
NewLines<-1> = 'return'
|
||||
|
||||
// Check for GoToService
|
||||
Case Tokens<1> _EQC "GOTOSERVICE"
|
||||
UsesGoSubList = 1
|
||||
Type = "SERVICE"
|
||||
NewLine = ''
|
||||
NewLine<-1> = '%%SRPAUTO_SERVICELIST%%;'
|
||||
NewLine<-1> = 'SRP_Precompiler_GoSubTarget@ = (If Assigned(Service) then Service else "");'
|
||||
NewLine<-1> = 'Convert @Lower.Case to @Upper.Case in SRP_Precompiler_GoSubTarget@;'
|
||||
NewLine<-1> = 'Locate SRP_Precompiler_GoSubTarget@ in SRP_Precompiler_GoSubList@ using "," setting SRP_Precompiler_GoSubPos@ then'
|
||||
NewLine<-1> = '%%SRPAUTO_SERVICEGOSUBLIST%%'
|
||||
If Tokens<2> _EQC "ELSE" then NewLine<-1> = 'else' else NewLine<-1> = 'else NULL'
|
||||
GoSub CommitNewLine
|
||||
|
||||
// Check for service
|
||||
Case Tokens<1> _EQC "SERVICE"
|
||||
ServicePos += 1
|
||||
ServiceName = Tokens<2>
|
||||
ServiceNames<-1> = ServiceName
|
||||
If Tokens<3> EQ "(" then
|
||||
ParamList = SRP_String("DetokenizeCode", Field(Tokens, @FM, 3, NumTokens))
|
||||
GoSub CleanParamList
|
||||
MaxNumParams = Max(MaxNumParams, NumParams)
|
||||
InitServiceParams = ""
|
||||
ReferenceParams = ""
|
||||
For iParam = 1 to NumParams
|
||||
DefaultParamValue = '""'
|
||||
ParamSuffix = ""
|
||||
Param = Trim(ParamList<iParam>)
|
||||
If Param[1, 4] _EQC "REF " then
|
||||
Param = Trim(Param[5, Len(Param)][1, "="])
|
||||
ReferenceParams<-1> = Param:@VM:iParam
|
||||
IsRef = Yes$
|
||||
end else
|
||||
IsRef = No$
|
||||
end
|
||||
If Index(Param, "=", 1) GT 0 then
|
||||
ParamValue = Trim(Field(Param, "=", 2))
|
||||
Param = Trim(Field(Param, "=", 1))
|
||||
If Num(ParamValue) OR ParamValue[1, 1] EQ "'" OR ParamValue[1, 1] EQ '"' OR ParamValue[1, 1] EQ '@' then
|
||||
DefaultParamValue = ParamValue
|
||||
ParamSuffix = " = ":ParamValue
|
||||
end else
|
||||
If Index(ParamValue, "[", 1) then
|
||||
ServiceParamOptions<1, ServicePos, iParam> = ParamValue[1, "["]
|
||||
DefaultParamValue = Trim(ParamValue[Col2() + 1, "]"])
|
||||
ParamSuffix = " = ":DefaultParamValue
|
||||
end else
|
||||
ServiceParamOptions<1, ServicePos, iParam> = ParamValue
|
||||
end
|
||||
end
|
||||
end else
|
||||
ServiceParamOptions<1, ServicePos, iParam> = ""
|
||||
end
|
||||
If IsRef then
|
||||
ServiceParams<1, ServicePos, iParam> = "Ref ":Param:ParamSuffix
|
||||
end else
|
||||
ServiceParams<1, ServicePos, iParam> = Param:ParamSuffix
|
||||
end
|
||||
InitServiceParams<-1> = Param:' = If Assigned(Param':iParam:') then Param':iParam:' else ':DefaultParamValue
|
||||
Next iParam
|
||||
Convert @FM to ";" in InitServiceParams
|
||||
If Len(Trim(InitServiceParams)) then
|
||||
NewLines<-1> = ServiceName:': | ':InitServiceParams
|
||||
end else
|
||||
NewLines<-1> = ServiceName:':'
|
||||
end
|
||||
Convert @FM to @SVM in ParamList
|
||||
end else
|
||||
NewLines<-1> = ServiceName:':'
|
||||
end
|
||||
|
||||
// Check for end of service
|
||||
Case Tokens<1> _EQC "END" AND Tokens<2> _EQC "SERVICE"
|
||||
ReturnLine = ""
|
||||
NumParams = DCount(ReferenceParams, @FM)
|
||||
For iParam = 1 to NumParams
|
||||
Param = ReferenceParams<iParam, 1>
|
||||
ParamNum = ReferenceParams<iParam, 2>
|
||||
ReturnLine<-1> = 'Param':ParamNum:' = ':Param
|
||||
Next iParam
|
||||
ReturnLine<-1> = 'return'
|
||||
Convert @FM to ";" in ReturnLine
|
||||
NewLines<-1> = ReturnLine
|
||||
|
||||
// Check for GoToAPI
|
||||
Case Tokens<1> _EQC "GOTOAPI"
|
||||
UsesGoSubList = 1
|
||||
Type = "API"
|
||||
NewLine = ''
|
||||
NewLine<-1> = '%%SRPAUTO_SERVICELIST%%;'
|
||||
NewLine<-1> = 'SRP_Precompiler_GoSubTarget@ = (If Assigned(API) then API else "");'
|
||||
NewLine<-1> = 'Convert @Lower.Case to @Upper.Case in SRP_Precompiler_GoSubTarget@;'
|
||||
NewLine<-1> = 'Locate SRP_Precompiler_GoSubTarget@ in SRP_Precompiler_GoSubList@ using "," setting SRP_Precompiler_GoSubPos@ then'
|
||||
NewLine<-1> = '%%SRPAUTO_SERVICEGOSUBLIST%%'
|
||||
If Tokens<2> _EQC "ELSE" then NewLine<-1> = 'else' else NewLine<-1> = 'else NULL'
|
||||
GoSub CommitNewLine
|
||||
|
||||
// Check for service
|
||||
Case Tokens<1> _EQC "API"
|
||||
ServicePos += 1
|
||||
ServiceName = Tokens<2>
|
||||
ServiceNames<-1> = ServiceName
|
||||
If Tokens<3> EQ "(" then
|
||||
ParamList = SRP_String("DetokenizeCode", Field(Tokens, @FM, 3, NumTokens))
|
||||
GoSub CleanParamList
|
||||
MaxNumParams = Max(MaxNumParams, NumParams)
|
||||
InitServiceParams = ""
|
||||
ReferenceParams = ""
|
||||
For iParam = 1 to NumParams
|
||||
DefaultParamValue = '""'
|
||||
ParamSuffix = ""
|
||||
Param = Trim(ParamList<iParam>)
|
||||
If Param[1, 4] _EQC "REF " then
|
||||
Param = Trim(Param[5, Len(Param)][1, "="])
|
||||
ReferenceParams<-1> = Param:@VM:iParam
|
||||
IsRef = Yes$
|
||||
end else
|
||||
IsRef = No$
|
||||
end
|
||||
If Index(Param, "=", 1) GT 0 then
|
||||
ParamValue = Trim(Field(Param, "=", 2))
|
||||
Param = Trim(Field(Param, "=", 1))
|
||||
If Num(ParamValue) OR ParamValue[1, 1] EQ "'" OR ParamValue[1, 1] EQ '"' OR ParamValue[1, 1] EQ '@' then
|
||||
DefaultParamValue = ParamValue
|
||||
ParamSuffix = " = ":ParamValue
|
||||
end else
|
||||
If Index(ParamValue, "[", 1) then
|
||||
ServiceParamOptions<1, ServicePos, iParam> = ParamValue[1, "["]
|
||||
DefaultParamValue = Trim(ParamValue[Col2() + 1, "]"])
|
||||
ParamSuffix = " = ":DefaultParamValue
|
||||
end else
|
||||
ServiceParamOptions<1, ServicePos, iParam> = ParamValue
|
||||
end
|
||||
end
|
||||
end else
|
||||
ServiceParamOptions<1, ServicePos, iParam> = ""
|
||||
end
|
||||
If IsRef then
|
||||
ServiceParams<1, ServicePos, iParam> = "Ref ":Param:ParamSuffix
|
||||
end else
|
||||
ServiceParams<1, ServicePos, iParam> = Param:ParamSuffix
|
||||
end
|
||||
InitServiceParams<-1> = Param:' = If Assigned(Param':iParam:') then Param':iParam:' else ':DefaultParamValue
|
||||
Next iParam
|
||||
Convert @FM to ";" in InitServiceParams
|
||||
If Len(Trim(InitServiceParams)) then
|
||||
NewLines<-1> = ServiceName:': | ':InitServiceParams
|
||||
end else
|
||||
NewLines<-1> = ServiceName:':'
|
||||
end
|
||||
Convert @FM to @SVM in ParamList
|
||||
end else
|
||||
NewLines<-1> = ServiceName:':'
|
||||
end
|
||||
|
||||
// Check for end of API
|
||||
Case Tokens<1> _EQC "END" AND Tokens<2> _EQC "API"
|
||||
ReturnLine = ""
|
||||
NumParams = DCount(ReferenceParams, @FM)
|
||||
For iParam = 1 to NumParams
|
||||
Param = ReferenceParams<iParam, 1>
|
||||
ParamNum = ReferenceParams<iParam, 2>
|
||||
ReturnLine<-1> = 'Param':ParamNum:' = ':Param
|
||||
Next iParam
|
||||
ReturnLine<-1> = 'return'
|
||||
Convert @FM to ";" in ReturnLine
|
||||
NewLines<-1> = ReturnLine
|
||||
|
||||
// Parameter Options
|
||||
Case Tokens<1> _EQC "OPTIONS" AND Alpha(Tokens<2>[1, 1]) AND Tokens<3> EQ "="
|
||||
CurrOptionList = ""
|
||||
IsQuoted = No$
|
||||
FirstItem = Tokens<4>
|
||||
IsQuoted = (FirstItem[1, 1] EQ FirstItem[-1, 1] AND (FirstItem[1, 1] EQ '"' OR FirstItem[1, 1] EQ "'"))
|
||||
For iToken = 4 to NumTokens
|
||||
Token = Trim(Tokens<iToken>)
|
||||
If Token NE "," then
|
||||
If IsQuoted then
|
||||
CurrOptionList<1, 1, -1> = Token[2, Len(Token) - 2]
|
||||
end else
|
||||
CurrOptionList<1, 1, -1> = Token
|
||||
end
|
||||
end
|
||||
Next iToken
|
||||
OptionNames<1, -1> = Tokens<2>
|
||||
OptionLists<1, -1> = CurrOptionList
|
||||
OptionQuoteFlags<1, -1> = IsQuoted
|
||||
NewLines<-1> = ""
|
||||
|
||||
// Check for GoToTest
|
||||
Case Tokens<1> _EQC "GOTOTEST"
|
||||
UsesGoSubList = 1
|
||||
Type = "TEST"
|
||||
NewLine = ''
|
||||
NewLine<-1> = '%%SRPAUTO_SERVICELIST%%;'
|
||||
NewLine<-1> = 'SRP_Precompiler_GoSubTarget@ = (If Assigned(TestName) then TestName else "");'
|
||||
NewLine<-1> = 'Convert @Lower.Case to @Upper.Case in SRP_Precompiler_GoSubTarget@;'
|
||||
NewLine<-1> = 'Locate SRP_Precompiler_GoSubTarget@ in SRP_Precompiler_GoSubList@ using "," setting SRP_Precompiler_GoSubPos@ then'
|
||||
NewLine<-1> = '%%SRPAUTO_SERVICEGOSUBLIST%%'
|
||||
GoSub CommitNewLine
|
||||
|
||||
// Check for test
|
||||
Case Tokens<1> _EQC "TEST"
|
||||
ServicePos += 1
|
||||
ServiceName = Tokens<2>
|
||||
ServiceNames<-1> = ServiceName
|
||||
TestLineNumbers<-1> = iLine
|
||||
NewLines<-1> = ServiceName:':'
|
||||
|
||||
// Check for end of test
|
||||
Case Tokens<1> _EQC "END" AND Tokens<2> _EQC "TEST"
|
||||
NewLines<-1> = 'return'
|
||||
|
||||
// Check for Assert statement
|
||||
Case Tokens<1> _EQC "ASSERT"
|
||||
LineFormat = "ASSERT,*,EQUALS,*,USING,*"
|
||||
GoSub FormatTokens
|
||||
AssertExpression = Tokens<2>
|
||||
If Tokens<3> _EQC "EQUALS" then
|
||||
UsesTestResult = 1
|
||||
UsesEncoding = 1
|
||||
Expected = Tokens<4>
|
||||
If Expected[1, 1] EQ '\' AND Expected[-1, 1] EQ '\' then
|
||||
ExpectedFormatted = '"':Expected[2, Len(Expected) - 2]:'"'
|
||||
WasHex = 1
|
||||
end else
|
||||
ExpectedFormatted = Expected
|
||||
WasHex = 0
|
||||
end
|
||||
NewLine = 'SRP_Precompiler_TestResult@ = (':AssertExpression:');'
|
||||
If Tokens<5> _EQC "USING" then
|
||||
Format = Tokens<6>
|
||||
If WasHex then
|
||||
NewLine<-1> = 'If SRP_Precompiler_TestResult@ NE ':Expected:' then'
|
||||
end else
|
||||
NewLine<-1> = 'If SRP_Precompiler_TestResult@ NE IConv(':Expected:', ':Format:') then'
|
||||
end
|
||||
NewLine<-1> = ReturnVar:' = BASE64ENCODE(SRP_Precompiler_TestResult@):@FM:':iLine:':@FM:BASE64ENCODE(':ExpectedFormatted:'):@FM:':Format:';'
|
||||
end else
|
||||
NewLine<-1> = 'If SRP_Precompiler_TestResult@ NE (':Expected:') then'
|
||||
NewLine<-1> = ReturnVar:' = BASE64ENCODE(SRP_Precompiler_TestResult@):@FM:':iLine:':@FM:BASE64ENCODE(':ExpectedFormatted:');'
|
||||
end
|
||||
NewLine<-1> = 'return'
|
||||
end else
|
||||
AssertCapture = AssertExpression
|
||||
Swap '"' with '":':"'":'"':"'":':"' in AssertCapture
|
||||
NewLine = 'If Not(':AssertExpression:') then'
|
||||
NewLine<-1> = ReturnVar:' = "':AssertCapture:'":@FM:':iLine:';'
|
||||
NewLine<-1> = 'return'
|
||||
end
|
||||
GoSub CommitNewLine
|
||||
|
||||
// Check for unpacking syntax
|
||||
Case Tokens<1> _EQC "("
|
||||
NewLine = ""
|
||||
Success = 0
|
||||
Done = 0
|
||||
Delim = '@FM'
|
||||
NextPos = If SupportsUTF8Ops then 'bCol2() + 1' else 'Col2() + 1'
|
||||
For iToken = 2 to NumTokens Until Done
|
||||
VarName = Tokens<iToken>
|
||||
Pos = If iToken EQ 2 then 1 else NextPos
|
||||
If VarName _EQC 'Null' OR VarName EQ '_' OR VarName EQ ',' then
|
||||
UsesUnpackSkip = 1
|
||||
NewLine<-1> = 'SRP_Precompiler_UnpackSkip@ = %UNPACKTARGET%[':Pos:',%UNPACKDELIM%];'
|
||||
If Varname EQ ',' then iToken -= 1
|
||||
end else
|
||||
NewLine<-1> = VarName:' = %UNPACKTARGET%[':Pos:',%UNPACKDELIM%];'
|
||||
end
|
||||
NextToken = Tokens<iToken + 1>
|
||||
If NextToken EQ ',' then
|
||||
iToken += 1
|
||||
end else if NextToken EQ ')' then
|
||||
iToken += 1
|
||||
Done = 1
|
||||
end else
|
||||
Done = 1
|
||||
end
|
||||
Next iToken
|
||||
If Tokens<iToken> EQ "using" then
|
||||
Delim = Tokens<iToken + 1>
|
||||
iToken += 2
|
||||
end
|
||||
If Tokens<iToken> EQ '=' then
|
||||
iToken += 1
|
||||
If iToken = NumTokens then
|
||||
Swap "%UNPACKTARGET%" with Tokens<iToken> in NewLine
|
||||
end else
|
||||
UnpackExpression = SRP_String("DetokenizeCode", Field(Tokens, @FM, iToken, NumTokens))
|
||||
NewLine = 'SRP_Precompiler_UnpackTarget@ = ':UnpackExpression:';':@FM:NewLine
|
||||
Swap "%UNPACKTARGET%" with 'SRP_Precompiler_UnpackTarget@' in NewLine
|
||||
UsesUnpackTarget = 1
|
||||
end
|
||||
Success = 1
|
||||
end
|
||||
If Success then
|
||||
If SupportsUTF8Ops then
|
||||
Swap "%UNPACKDELIM%" with Delim:', 1' in NewLine
|
||||
end else
|
||||
Swap "%UNPACKDELIM%" with Delim in NewLine
|
||||
end
|
||||
end else
|
||||
NewLine = Line
|
||||
end
|
||||
GoSub CommitNewLine
|
||||
|
||||
// This directive is used by SRP Editor. The Precompiler just strips it away
|
||||
Case Tokens<1> _EQC "#" AND Tokens<2> _EQC "WINDOW" AND NumTokens EQ 3
|
||||
NewLines<-1> = ""
|
||||
|
||||
// Otherwise, keep the line as is
|
||||
Case 1
|
||||
NewLines<-1> = Line
|
||||
|
||||
End Case
|
||||
|
||||
Next iLine
|
||||
|
||||
// New code
|
||||
Routine = NewLines
|
||||
|
||||
// Insert the event names
|
||||
GoSubListVar = 'SRP_Precompiler_GoSubList@'
|
||||
GoSubNames = EventNames
|
||||
GoSubPlaceholders = "%%SRPAUTO_EVENTLIST%%":@FM:"%%SRPAUTO_EVENTGOSUBLIST%%"
|
||||
If Len(EventNames) then
|
||||
GoSub CreateGoSubList
|
||||
end else
|
||||
GoSub RemoveGoSubList
|
||||
end
|
||||
|
||||
// Insert the service names
|
||||
GoSubListVar = 'SRP_Precompiler_GoSubList@'
|
||||
GoSubNames = ServiceNames
|
||||
GoSubPlaceholders = "%%SRPAUTO_SERVICELIST%%":@FM:"%%SRPAUTO_SERVICEGOSUBLIST%%"
|
||||
If Len(ServiceNames) then
|
||||
GoSub CreateGoSubList
|
||||
end else
|
||||
GoSub RemoveGoSubList
|
||||
end
|
||||
|
||||
// Insert the API names
|
||||
* GoSubListVar = 'SRP_Precompiler_GoSubList@'
|
||||
* GoSubNames = APINames
|
||||
* GoSubPlaceholders = "%%SRPAUTO_APILIST%%":@FM:"%%SRPAUTO_APIGOSUBLIST%%"
|
||||
* If Len(APINames) then
|
||||
* GoSub CreateGoSubList
|
||||
* end else
|
||||
* GoSub RemoveGoSubList
|
||||
* end
|
||||
|
||||
// Insert Auto params
|
||||
If AutoParamsNeeded then
|
||||
NumParams = Max(1, MaxNumParams)
|
||||
ParamList = ""
|
||||
For iParam = 1 to NumParams
|
||||
ParamList<-1> = "Param":iParam
|
||||
Next iParam
|
||||
Convert @FM to "," in ParamList
|
||||
Swap "%%AUTOPARAMLIST%%" with ParamList in Routine
|
||||
end
|
||||
|
||||
// Insert commons
|
||||
Vars = ''
|
||||
If HasLoops then
|
||||
Vars<-1> = 'SRP_Precompiler_LoopPos@':@FM:'SRP_Precompiler_LoopLen@':@FM:'SRP_Precompiler_LoopStack@'
|
||||
end
|
||||
If UsesGoSubList then
|
||||
Vars<-1> = 'SRP_Precompiler_GoSubTarget@':@FM:'SRP_Precompiler_GoSubList@':@FM:'SRP_Precompiler_GoSubPos@'
|
||||
end
|
||||
If UsesEventNames then
|
||||
Vars<-1> = 'SRP_Precompiler_EventEvent@':@FM:'SRP_Precompiler_EventCtrl@'
|
||||
end
|
||||
If UsesTestResult then
|
||||
Vars<-1> = 'SRP_Precompiler_TestResult@'
|
||||
end
|
||||
If UsesUnpackTarget then
|
||||
Vars<-1> = 'SRP_Precompiler_UnpackTarget@'
|
||||
end
|
||||
If UsesUnpackSkip then
|
||||
Vars<-1> = 'SRP_Precompiler_UnpackSkip@'
|
||||
end
|
||||
If Len(Vars) then
|
||||
CommonLine = ""
|
||||
If UsesEncoding then CommonLine := "Declare function BASE64ENCODE;"
|
||||
Swap @FM with ', ' in Vars
|
||||
CommonLine := 'Common /SRP_Precompiler_':CasedProcName:'/ ':Vars
|
||||
Swap "%%SRPAUTO_COMMON%%" with CommonLine in Routine
|
||||
end else
|
||||
Swap "%%SRPAUTO_COMMON%%" with "" in Routine
|
||||
end
|
||||
// Only save the metadata if we had at least one occurence of "SERVICES_SIGNATURE"
|
||||
// AND if we not currently inside of BLINT
|
||||
Locate "BLINT" in RetStack() using @FM setting DummyPos else
|
||||
Open "SYSENV" to hTable then
|
||||
|
||||
// Store the service metadata
|
||||
Common /SRP_EDITOR_PRECOMPILER_HELPERS/ Frame@, ID@
|
||||
If Len(ID@) then
|
||||
AppName = ID@[1, "*"]
|
||||
ProcName = ID@[-1, "B*"]
|
||||
end else
|
||||
AppName = @AppID<1>
|
||||
ProcName = ProgName
|
||||
end
|
||||
|
||||
// If it's a TEST, then register it
|
||||
If Type EQ "TEST" then
|
||||
Call SRP_Editor_UnitTest_Services("Register", "SRP_EDITOR", CasedProcName, ServiceNames, TestLineNumbers, AppName)
|
||||
end else
|
||||
|
||||
Convert @FM to @VM in ServiceNames
|
||||
Record = Type:@FM:DefaultParams:@FM:ServiceParamPos:@FM:Param1Pos:@FM:ServiceNamesQuoted:@FM:ParamOptions:@FM:ServiceNames:@FM:ServiceParams:@FM:ServiceParamOptions:@FM:OptionNames:@FM:OptionLists:@FM:OptionQuoteFlags
|
||||
If AppName EQ "SYSPROG" then
|
||||
Key = "SRP_EDITOR_METADATA*":ProcName
|
||||
end else
|
||||
Key = "SRP_EDITOR_METADATA*":ProcName:"*":AppName
|
||||
end
|
||||
If Len(Type) then
|
||||
Write Record to hTable, Key else NULL
|
||||
If Len(Frame@) then
|
||||
Call Send_Message(Frame@:".OLE_EDITOR", "OLE.MetaDataRequestedResponse", ProcName, Record)
|
||||
end
|
||||
end else
|
||||
Delete hTable, Key else NULL
|
||||
If Len(Frame@) then
|
||||
Call Send_Message(Frame@:".OLE_EDITOR", "OLE.RemoveMetaData", ProcName)
|
||||
end
|
||||
end
|
||||
|
||||
end
|
||||
|
||||
end
|
||||
end
|
||||
|
||||
return
|
||||
|
||||
ParseLine:
|
||||
// Uses: [in]Line, [out]Tokens, [out]NumTokens
|
||||
|
||||
LenLine = Len(Line)
|
||||
Tokens = SRP_String("TokenizeCode", Line, "None", No$, ParseState)
|
||||
NumTokens = DCount(Tokens, @FM)
|
||||
GoSub IsAssignmentOrMethod
|
||||
|
||||
return
|
||||
|
||||
CommitNewLine:
|
||||
// Uses: [in]NewLine, [in]NewLines
|
||||
|
||||
If ProgName = "__TEST" then
|
||||
Swap @FM with \0D0A\ in NewLine
|
||||
end else
|
||||
Convert @FM to " " in NewLine
|
||||
end
|
||||
NewLines<-1> = NewLine
|
||||
|
||||
return
|
||||
|
||||
CleanParamList:
|
||||
// Uses: [in]ParamList, [out]NumParams
|
||||
|
||||
Swap ", " with @FM in ParamList
|
||||
Convert ",()" to @FM in ParamList
|
||||
* ParamList = SRP_Array("Clean", Trim(ParamList))
|
||||
ParamList = SRP_Clean_Array(Trim(ParamList), @FM)
|
||||
NumParams = DCount(ParamList, @FM)
|
||||
|
||||
return
|
||||
|
||||
CreateGoSubList:
|
||||
// Uses: [in] GoSubListVar, [in] GoSubNames, [in] GoSubPlaceholders
|
||||
|
||||
GoSubNamesLines = ''
|
||||
GoSubNamesLine = GoSubListVar:' = "'
|
||||
NumGoSubNames = DCount(GoSubNames, @FM)
|
||||
If NumGoSubNames GT 0 then
|
||||
For iGoSubName = 1 to NumGoSubNames
|
||||
GoSubName = GoSubNames<iGoSubName>
|
||||
Convert @Lower.Case to @Upper.Case in GoSubName
|
||||
If Len(GoSubNamesLine) + Len(GoSubName) > 200 then
|
||||
GoSubNamesLine[-1, 1] = ',"'
|
||||
If ProgName = "__TEST" then
|
||||
GoSubNamesLines<-1> = GoSubNamesLine:';':\0D0A\
|
||||
end else
|
||||
GoSubNamesLines<-1> = GoSubNamesLine:';'
|
||||
end
|
||||
GoSubNamesLine = GoSubListVar:' := "'
|
||||
end
|
||||
GoSubNamesLine := GoSubName:','
|
||||
Next iGoSubName
|
||||
GoSubNamesLine[-1, 1] = '"'
|
||||
end else
|
||||
GoSubNamesLine := '"'
|
||||
end
|
||||
GoSubNamesLines<-1> = GoSubNamesLine
|
||||
Convert @FM to " " in GoSubNamesLines
|
||||
Swap GoSubPlaceholders<1> with GoSubNamesLines in Routine
|
||||
|
||||
NumGoSubNames = DCount(GoSubNames, @FM)
|
||||
NumChunks = Int(NumGoSubNames / 255) + 1
|
||||
If NumChunks EQ 1 then
|
||||
Swap @FM with ", " in GoSubNames
|
||||
Swap GoSubPlaceholders<2> with GoSubNames in Routine
|
||||
end else
|
||||
Stmt = "Begin Case; "
|
||||
For i = 1 to NumChunks
|
||||
Temp = Field(GoSubNames, @FM, ((i - 1) * 255) + 1, 255)
|
||||
Swap @FM with ", " in Temp
|
||||
If i EQ NumChunks then
|
||||
Stmt := "Case 1; On SRP_Precompiler_GoSubPos@ GoSub ":Temp:"; "
|
||||
end else
|
||||
Stmt := "Case SRP_Precompiler_GoSubPos@ LE ":(i * 255):"; On SRP_Precompiler_GoSubPos@ GoSub ":Temp:"; "
|
||||
end
|
||||
Next i
|
||||
Stmt := "End Case"
|
||||
Swap GoSubPlaceholders<2> with Stmt in Routine
|
||||
end
|
||||
Return
|
||||
|
||||
RemoveGoSubList:
|
||||
// Uses: [in] GoSubListVar, [in] GoSubNames, [in] GoSubPlaceholders
|
||||
|
||||
PlaceholderPos = Index(Routine, GoSubPlaceholders<1>, 1)
|
||||
If PlaceholderPos GT 0 then
|
||||
LenToDelete = Len(Routine[PlaceholderPos, @FM])
|
||||
Routine[PlaceholderPos, LenToDelete] = "If 1 then"
|
||||
end
|
||||
|
||||
Return
|
||||
|
||||
IsAssignmentOrMethod:
|
||||
// Uses: [in]Tokens, [in]NumTokens, [out]IsAssignmentOrMethod
|
||||
|
||||
Locate Tokens<2> in "= := += -=" using " " setting Pos then
|
||||
IsAssignmentOrMethod = Yes$
|
||||
end else
|
||||
If Trim(Tokens<2>)[1, 1] EQ "(" then
|
||||
IsAssignmentOrMethod = Yes$
|
||||
end else
|
||||
IsAssignmentOrMethod = No$
|
||||
end
|
||||
end
|
||||
|
||||
return
|
||||
|
||||
FormatTokens:
|
||||
// Uses: [in] LineFormat, [in\out] Tokens, [in\out] NumTokens
|
||||
|
||||
// We are going to merge some tokens so more complication expressions can be supported.
|
||||
// We do this by merging everything between required keywords, as defined in LineFormat
|
||||
FormatValid = Yes$
|
||||
NumFormatItems = DCount(LineFormat, ",")
|
||||
|
||||
For iItem = 1 to NumFormatItems while FormatValid
|
||||
CurrKeyword = Field(LineFormat, ",", iItem, 1)
|
||||
If CurrKeyword NE "*" AND iItem GT 1 then
|
||||
Done = No$
|
||||
Loop While iItem LE NumTokens
|
||||
CurrToken = Field(Tokens, @FM, iItem, 1)
|
||||
Convert @Lower.Case to @Upper.Case in CurrToken
|
||||
Locate CurrToken in CurrKeyword using "|" setting FormatPos then
|
||||
Done = Yes$
|
||||
end else
|
||||
Tokens[Col1(), 1] = @VM
|
||||
NumTokens -= 1
|
||||
end
|
||||
Until Done
|
||||
Repeat
|
||||
end
|
||||
Next iItem
|
||||
|
||||
// Now de-tokenize each field
|
||||
NumTokens = DCount(Tokens, @FM)
|
||||
For iToken = 1 to NumTokens
|
||||
Tokens<iToken> = SRP_String("DetokenizeCode", Tokens<iToken>, @VM)
|
||||
Next iToken
|
||||
|
||||
return
|
||||
82
SYSPROG/STPROC/SRP_SET_PROPERTY.txt
Normal file
82
SYSPROG/STPROC/SRP_SET_PROPERTY.txt
Normal file
@ -0,0 +1,82 @@
|
||||
Compile Function SRP_Set_Property(CtrlList, PropList, ValueList, AuxList, Window, AllPropsPerCtrl, Delim)
|
||||
|
||||
************************************************************************************************
|
||||
*
|
||||
* This program is proprietary and is not to be used by or disclosed to others, nor is it to
|
||||
* be copied without written permission from SRP Computer Solutions, Inc.
|
||||
*
|
||||
* Name : SRP_Set_Property
|
||||
*
|
||||
* Description: Sets controls properties if one of three ways:
|
||||
* - 1 to 1: Sets one property to a single control
|
||||
* - 1 to Many: Sets multiple properties for each control
|
||||
* - Many to 1: Sets the same property for multiple controls
|
||||
*
|
||||
* Parameters:
|
||||
* CtrlList [in] -- The list of controls whose property(s) are to be set
|
||||
* PropList [in] -- The list of properties
|
||||
* ValueList [in] -- The list of property values
|
||||
* AuxList [in] -- The list of auxiliary values
|
||||
* Window [in] -- If not empty, then this is prepended to each control is the ctrl list: default = ""
|
||||
* AllPropsPerCtrl [in] -- If TRUE, the property list is applied to each control: default = 0
|
||||
* Delim [in] -- The lists delimiter: default = "~"
|
||||
*
|
||||
* Returns:
|
||||
* The previous property value(s)
|
||||
*
|
||||
* History (Date, Initials, Notes)
|
||||
* 04/06/2004 KRF Initial Programmer
|
||||
*
|
||||
************************************************************************************************
|
||||
|
||||
Declare function Set_Property, FieldStore
|
||||
|
||||
* Prepare input
|
||||
If Assigned(CtrlList) else CtrlList = ""
|
||||
If Assigned(PropList) else PropList = ""
|
||||
If Assigned(ValueList) else ValueList = ""
|
||||
If Assigned(AuxList) else AuxList = ""
|
||||
If Assigned(Window) else Window = ""
|
||||
If Assigned(AllPropsPerCtrl) else AllPropsPerCtrl = 0
|
||||
If Assigned(Delim) else Delim = "~"
|
||||
|
||||
* Prepare lists
|
||||
Convert Delim to @RM in CtrlList
|
||||
Convert Delim to @RM in PropList
|
||||
Convert Delim to @RM in ValueList
|
||||
Convert Delim to @RM in AuxList
|
||||
|
||||
* If "1 to Many" then alter the ctrl list to meet OI's Set_Property specs
|
||||
If AllPropsPerCtrl then
|
||||
NumCtrls = Count(CtrlList, @RM) + (CtrlList NE "")
|
||||
NumProps = Count(PropList, @RM) + (PropList NE "")
|
||||
|
||||
* Expand the control list be repeating each control by the number of properties
|
||||
OldCtrlList = CtrlList
|
||||
CtrlList = ""
|
||||
For i = 1 to NumCtrls
|
||||
CtrlList := Str(Field(OldCtrlList, @RM, i):@RM, NumProps)
|
||||
If i LT NumCtrls then CtrlList := @RM
|
||||
next i
|
||||
|
||||
* Expand the property list to repeat the list for each control
|
||||
If NumCtrls GT 1 then
|
||||
PropList = Str(PropList:@RM, NumCtrls)
|
||||
PropList[-1, 1] = ""
|
||||
end
|
||||
end
|
||||
|
||||
* Prepend Window Name
|
||||
If Window then
|
||||
Window := "."
|
||||
NumCtrls = Count(CtrlList, @RM) + (CtrlList NE "")
|
||||
For i = 1 to NumCtrls
|
||||
CurrCtrl = Field(CtrlList, @RM, i)
|
||||
CtrlList = FieldStore(CtrlList, @RM, i, 1, Window:CurrCtrl)
|
||||
next i
|
||||
end
|
||||
|
||||
* Call the Set_Property
|
||||
Ans = Set_Property(CtrlList, PropList, ValueList, AuxList)
|
||||
|
||||
Return Ans
|
||||
356
SYSPROG/STPROC/SRP_SET_PROP_ARRAY.txt
Normal file
356
SYSPROG/STPROC/SRP_SET_PROP_ARRAY.txt
Normal file
@ -0,0 +1,356 @@
|
||||
Compile Subroutine SRP_Set_Prop_Array(PropArray)
|
||||
|
||||
************************************************************************************************
|
||||
*
|
||||
* This program is proprietary and is not to be used by or disclosed to others, nor is it to
|
||||
* be copied without written permission from SRP Computer Solutions, Inc.
|
||||
*
|
||||
* Name : SRP_Set_Prop_Array
|
||||
*
|
||||
* Description:
|
||||
*
|
||||
* Sets multiple properties over multiple controls in one data structure. The
|
||||
* structure is in a column/row format where rows are @FM delimited and columns
|
||||
* are @VM delimited. The first row always specifies the properties. Each property
|
||||
* may optionally include the angle-bracket syntax denoting that a particular
|
||||
* column of values belongs in a Field, Value, etc. of a given procedure. For
|
||||
* example, "SIZE<1>" indicates that all values represent the controls X position.
|
||||
* This, "SIZE<2>":@VM:"SIZE<3>":@VM:"SIZE<4>" could be added with "SIZE<1>" to
|
||||
* produce all fields of the property.
|
||||
*
|
||||
* The first column is always the control name with the left most 'cell' being the
|
||||
* window name to which the controls belong. If you place a value in the left cell,
|
||||
* then that value is prefixed to all of the following control names. If not, then
|
||||
* the control names are used as is. (NOTE: you don't need to append a "." to the window
|
||||
* name. If the top cell is not null, then this function will add the "." for you. So,
|
||||
* you can set the top cell to @Window -- not @Window:".") Below is an example array for a
|
||||
* series of buttons:
|
||||
*
|
||||
* PropArray = @Window :@VM: "ENABLED" :@VM: "SIZE<1>" :@VM: "SIZE<2>" :@VM: "SIZE<3>" :@VM: "SIZE<4>"
|
||||
* PropArray<-1> = "BUTTON_1" :@VM: 0 :@VM: 10 :@VM: 10 :@VM: 100 :@VM: 100
|
||||
* PropArray<-1> = "BUTTON_2" :@VM: 0 :@VM: 20 :@VM: 20 :@VM: 100 :@VM: 100
|
||||
* PropArray<-1> = "BUTTON_3" :@VM: 0 :@VM: 30 :@VM: 30 :@VM: 100 :@VM: 100
|
||||
* PropArray<-1> = "BUTTON_4" :@VM: 0 :@VM: 40 :@VM: 40 :@VM: 100 :@VM: 100
|
||||
*
|
||||
* You can optionally use this method to set many properties of one control. To
|
||||
* do this, set the first value in the first field to the control name ensuring that there
|
||||
* are absolutely no other value marks in the first row. When you have done this, then each
|
||||
* following row represents a property/value pair delimited by @VM. Just like before
|
||||
* you can use the angle-bracket syntax to denote property fields, values, etc. For
|
||||
* example:
|
||||
*
|
||||
* PropArray = @Window:".BUTTON_1"
|
||||
* PropArray<-1> = "ENABLED" :@VM: 0
|
||||
* PropArray<-1> = "SIZE<1>" :@VM: 0
|
||||
* PropArray<-1> = "SIZE<2>" :@VM: 0
|
||||
* PropArray<-1> = "SIZE<3>" :@VM: 0
|
||||
* PropArray<-1> = "SIZE<4>" :@VM: 0
|
||||
*
|
||||
* This function also allows you to combine both formats for a powerful and flexible
|
||||
* way to initialize a set of similar controls. In the first example above, notice that
|
||||
* all values are the same for the ENABLED, SIZE<3>, and SIZE<4> properties. To save time
|
||||
* and space, your array can also have a "Shared Properties" section. The section follows
|
||||
* main array and separated by a field containing a single @RM. The section is formatted
|
||||
* like the second example above. Each row in the section contains a property name and
|
||||
* a value. The function will use these property/value pairs to set the same value for all
|
||||
* controls in the preceding section. Here is first example rewritten to take advantage
|
||||
* of this functionality:
|
||||
*
|
||||
* PropArray = @Window :@VM: "SIZE<1>" :@VM: "SIZE<2>"
|
||||
* PropArray<-1> = "BUTTON_1" :@VM: 10 :@VM: 10
|
||||
* PropArray<-1> = "BUTTON_2" :@VM: 20 :@VM: 20
|
||||
* PropArray<-1> = "BUTTON_3" :@VM: 30 :@VM: 30
|
||||
* PropArray<-1> = "BUTTON_4" :@VM: 40 :@VM: 40
|
||||
* PropArray<-1> = @RM ;*<-- Notice that one row contains an @RM only
|
||||
* PropArray<-1> = "ENABLED" :@VM: 0
|
||||
* PropArray<-1> = "SIZE<3>" :@VM: 100
|
||||
* PropArray<-1> = "SIZE<4>" :@VM: 100
|
||||
*
|
||||
* For any value you want to "Leave Alone", pass "<NA>" (case insensative). Also, note
|
||||
* that ommitting a field of a multivalue property will also "leave it alone". "Leaving it alone" is
|
||||
* the equivalent of reading the property, changing those values you wish to change, and setting
|
||||
* the property again. The following example leave's the control width alone and also leaves
|
||||
* a couple other values alone as well:
|
||||
*
|
||||
* * Set all but SIZE<3>
|
||||
* PropArray = @Window :@VM: "SIZE<1>" :@VM: "SIZE<2>" :@VM: "SIZE<4>"
|
||||
* PropArray<-1> = "BUTTON_1" :@VM: 10 :@VM: 10 :@VM: 100
|
||||
* PropArray<-1> = "BUTTON_2" :@VM: "<NA>" :@VM: 20 :@VM: 100
|
||||
* PropArray<-1> = "BUTTON_3" :@VM: 30 :@VM: "<NA>" :@VM: 100
|
||||
* PropArray<-1> = "BUTTON_4" :@VM: 40 :@VM: 40 :@VM: "<NA>"
|
||||
*
|
||||
* Finally, you can also use this function to qualify events. To do so, simply specify "QUALIFY_EVENT"
|
||||
* as a property. The value to this property will be a comma delimited list of events to be
|
||||
* qualified. It only qualifies events, there is no rerouting of events involved. The following
|
||||
* example qualifies events for OLE controls
|
||||
*
|
||||
* * Init OLE Buttons
|
||||
* PropArray = @Window :@VM: "OLE.Style" :@VM: "QUALIFY_EVENT"
|
||||
* PropArray<-1> = "OLE_BUTTON1" :@VM: "Standard" :@VM: "OnClick"
|
||||
* PropArray<-1> = "OLE_BUTTON2" :@VM: "XP" :@VM: "OnClick,OnDblClick"
|
||||
* PropArray<-1> = "OLE_BUTTON3" :@VM: "XP Toolbar" :@VM: "<NA>"
|
||||
* PropArray<-1> = "OLE_BUTTON4" :@VM: "Office XP Toolbar" :@VM: "ALL_OLES"
|
||||
*
|
||||
* * Init a single OLE Edit Table
|
||||
* PropArray = @Window:".OLE_EDITTABLE"
|
||||
* PropArray<-1> = "Dimension<1>" :@VM: 10
|
||||
* PropArray<-1> = "Dimension<2>" :@VM: 10
|
||||
* PropArray<-1> = "QUALIFY_EVENT" :@VM: "PosChanging,PosChanged,BeforeUpdate,AfterUpdate"
|
||||
*
|
||||
* Parameters:
|
||||
* PropArray [in] -- The controls, properties, and values in one array
|
||||
*
|
||||
* History (Date, Initials, Notes)
|
||||
* 04/06/2004 KRF Initial Programmer
|
||||
*
|
||||
************************************************************************************************
|
||||
|
||||
Declare subroutine Set_Property, Send_Message
|
||||
Declare function Get_Property, Extract, Replace, Delete
|
||||
|
||||
* debug
|
||||
|
||||
* Prepare input
|
||||
If Assigned(PropArray) else PropArray = ""
|
||||
If PropArray then
|
||||
|
||||
CtrlList = ""
|
||||
PropList = ""
|
||||
ValueList = ""
|
||||
UsedProps = ""
|
||||
MV_Val = ""
|
||||
Shared_MV_Val = ""
|
||||
PrevProp = ""
|
||||
PrevCtrl = ""
|
||||
SharedPrevProp = ""
|
||||
|
||||
If Count(PropArray<1>, @VM) EQ 0 then
|
||||
|
||||
* One control ------------------------------------------------
|
||||
Ctrl = Extract(PropArray, 1, 0, 0)
|
||||
PropArray = Delete(PropArray, 1, 0, 0)
|
||||
|
||||
* Set each property
|
||||
NumProps = Count(PropArray, @FM) + 1
|
||||
For i = 1 to NumProps
|
||||
Prop = PropArray<i, 1>
|
||||
Val = PropArray<i, 2>
|
||||
GoSub Process_Property
|
||||
next i
|
||||
|
||||
* Just in case last property was MV
|
||||
If MV_Val then
|
||||
GoSub Add_MV_Property
|
||||
end
|
||||
|
||||
end else
|
||||
|
||||
* Many controls ----------------------------------------------
|
||||
If Index(PropArray, @RM, 1) then
|
||||
SharedProps = PropArray[-1, "B":@RM]
|
||||
PropArray = PropArray[1, "F":@RM]
|
||||
If SharedProps[1, 1] EQ @FM then SharedProps[1, 1] = ""
|
||||
If PropArray[-1, 1] EQ @FM then PropArray[-1, 1] = ""
|
||||
end else
|
||||
SharedProps = ""
|
||||
end
|
||||
|
||||
SharedCtrlList = ""
|
||||
|
||||
* First set individual properties
|
||||
TopRow = Extract(PropArray, 1, 0, 0)
|
||||
NumProps = Count(TopRow, @VM) + 1
|
||||
PropArray = Delete(PropArray, 1, 0, 0)
|
||||
Window = TopRow<1, 1>
|
||||
if Window then Window := "."
|
||||
|
||||
* Set each property
|
||||
NumCtrls = Count(PropArray, @FM) + 1
|
||||
For iCtrl = 1 to NumCtrls
|
||||
Ctrl = Window:PropArray<iCtrl, 1>
|
||||
If SharedProps NE "" then SharedCtrlList<-1> = Ctrl
|
||||
For i = 2 to NumProps
|
||||
Prop = TopRow<1, i>
|
||||
Val = PropArray<iCtrl, i>
|
||||
GoSub Process_Property
|
||||
If iCtrl EQ 1 then
|
||||
Locate Prop in UsedProps using @FM setting Pos else
|
||||
UsedProps<-1> = Prop
|
||||
end
|
||||
end
|
||||
next i
|
||||
next iCtrl
|
||||
|
||||
* How many properties are there?
|
||||
NumProps = Count(UsedProps, @FM) + 1
|
||||
|
||||
* Just in case last property was MV
|
||||
If MV_Val then
|
||||
GoSub Add_MV_Property
|
||||
end
|
||||
|
||||
* now set shared properties
|
||||
If SharedProps NE "" AND PropArray NE "" then
|
||||
Convert @FM to @RM in SharedCtrlList
|
||||
NumSharedProps = Count(SharedProps, @FM) + 1
|
||||
For iSharedProp = 1 to NumSharedProps
|
||||
SharedProp = SharedProps<iSharedProp, 1>
|
||||
SharedVal = SharedProps<iSharedProp, 2>
|
||||
GoSub Process_Shared_Property
|
||||
next iSharedProp
|
||||
|
||||
* Just in case last shared property was MV
|
||||
If MV_Val then
|
||||
GoSub Add_Shared_MV_Property
|
||||
end
|
||||
end
|
||||
end
|
||||
|
||||
* Set the properties
|
||||
CtrlList[-1, 1] = ""
|
||||
PropList[-1, 1] = ""
|
||||
ValueList[-1, 1] = ""
|
||||
Set_Property(CtrlList, PropList, ValueList)
|
||||
|
||||
end
|
||||
|
||||
Return
|
||||
|
||||
|
||||
Process_Property:
|
||||
* Params: [IN]Ctrl, [IN]Prop, [IN]Val, [IN]MV_Val, [IN|OUT]CtrlList, [IN|OUT]PropList, [IN|OUT]ValueList
|
||||
GoSub Get_MV_Structure
|
||||
If Prop NE PrevProp AND MV_Val NE "" then
|
||||
GoSub Add_MV_Property
|
||||
MV_Val = ""
|
||||
end
|
||||
|
||||
If Prop EQ "QUALIFY_EVENT" then
|
||||
If VAL NE "" AND Val _NEC "<NA>" then
|
||||
NumEvents = Count(Val, ",") + 1
|
||||
For iEvent = 1 to NumEvents
|
||||
Send_Message(Ctrl, "QUALIFY_EVENT", Field(Val, ",", iEvent), 1)
|
||||
next iEvent
|
||||
end
|
||||
end else
|
||||
If Field then
|
||||
If MV_Val EQ "" then
|
||||
MV_Val = Get_Property(Ctrl, Prop)
|
||||
end
|
||||
If Val _NEC "<NA>" then MV_Val = Replace(MV_Val, Field, Value, SubValue, Val)
|
||||
end else
|
||||
If Val _NEC "<NA>" then GoSub Add_Property
|
||||
end
|
||||
end
|
||||
PrevProp = Prop
|
||||
PrevCtrl = Ctrl
|
||||
return
|
||||
|
||||
|
||||
Get_MV_Structure:
|
||||
* Params: [IN]AnglePos, [IN|OUT]Prop, [OUT]Field, [OUT]Value, [OUT]SubValue
|
||||
Field = 0; Value = 0; SubValue = 0;
|
||||
AnglePos = Index(Prop, "<", 1)
|
||||
If AnglePos then
|
||||
Suffix = Prop[AnglePos + 1, "F>"]
|
||||
Prop = Prop[1, "F<"]
|
||||
Convert Char(9):" " to "" in Suffix
|
||||
Field = Field(Suffix, ",", 1)
|
||||
Value = Field(Suffix, ",", 2)
|
||||
SubValue = Field(Suffix, ",", 3)
|
||||
end
|
||||
return
|
||||
|
||||
|
||||
Add_Property:
|
||||
* Params: [IN]Ctrl, [IN]Prop, [IN]Val, [IN|OUT]CtrlList, [IN|OUT]PropList, [IN|OUT]ValueList
|
||||
CtrlList := Ctrl:@RM
|
||||
PropList := Prop:@RM
|
||||
ValueList := Val:@RM
|
||||
return
|
||||
|
||||
|
||||
Add_MV_Property:
|
||||
* Params: [IN]PrevCtrl, [IN]PrevProp, [IN]MV_Val, [IN|OUT]CtrlList, [IN|OUT]PropList, [IN|OUT]ValueList
|
||||
CtrlList := PrevCtrl:@RM
|
||||
PropList := PrevProp:@RM
|
||||
ValueList := MV_Val:@RM
|
||||
return
|
||||
|
||||
|
||||
Process_Shared_Property:
|
||||
* Params: [IN]NumCtrls, [IN]SharedCtrlList, [IN]SharedProp, [IN]SharedVal, [IN]Shared_MV_Val, [IN|OUT]CtrlList, [IN|OUT]PropList, [IN|OUT]ValueList
|
||||
GoSub Get_Shared_MV_Structure
|
||||
If SharedProp NE SharedPrevProp AND Shared_MV_Val NE "" then
|
||||
GoSub Add_Shared_MV_Property
|
||||
Shared_MV_Val = ""
|
||||
end
|
||||
|
||||
If SharedProp EQ "QUALIFY_EVENT" then
|
||||
If SharedVal NE "" AND SharedVal _NEC "<NA>" then
|
||||
NumEvents = Count(SharedVal, ",") + 1
|
||||
For iCtrl = 1 to NumCtrls
|
||||
CurrSharedCtrl = Field(SharedCtrlList, @RM, iCtrl)
|
||||
For iEvent = 1 to NumEvents
|
||||
Send_Message(CurrSharedCtrl, "QUALIFY_EVENT", Field(SharedVal, ",", iEvent), 1)
|
||||
next iEvent
|
||||
next iCtrl
|
||||
end
|
||||
end else
|
||||
If Field then
|
||||
If Shared_MV_Val EQ "" then
|
||||
Locate SharedProp in UsedProps using @FM setting Pos then
|
||||
For iCtrl = 1 to NumCtrls
|
||||
Data = Field(ValueList, @RM, Pos)
|
||||
Data = Replace(Data, Field, Value, SubValue, SharedVal)
|
||||
ValueList = FieldStore(ValueList, @RM, Pos, 1, Data)
|
||||
Pos += NumProps
|
||||
next iCtrl
|
||||
end else
|
||||
Shared_MV_Val = Get_Property(SharedCtrlList, SharedProp)
|
||||
end
|
||||
end
|
||||
If Shared_MV_Val NE "" AND SharedVal _NEC "<NA>" then
|
||||
For iCtrl = 1 to NumCtrls
|
||||
Data = Field(Shared_MV_Val, @RM, iCtrl)
|
||||
Data = Replace(Data, Field, Value, SubValue, SharedVal)
|
||||
Shared_MV_Val = FieldStore(Shared_MV_Val, @RM, iCtrl, 1, Data)
|
||||
next i
|
||||
end
|
||||
end else
|
||||
If SharedVal _NEC "<NA>" then GoSub Add_Shared_Property
|
||||
end
|
||||
end
|
||||
SharedPrevProp = SharedProp
|
||||
return
|
||||
|
||||
|
||||
Get_Shared_MV_Structure:
|
||||
* Params: [IN]AnglePos, [IN|OUT]SharedProp, [OUT]Field, [OUT]Value, [OUT]SubValue
|
||||
Field = 0; Value = 0; SubValue = 0;
|
||||
AnglePos = Index(SharedProp, "<", 1)
|
||||
If AnglePos then
|
||||
Suffix = SharedProp[AnglePos + 1, "F>"]
|
||||
SharedProp = SharedProp[1, "F<"]
|
||||
Suffix = Trim(Suffix)
|
||||
Field = Field(Suffix, ",", 1)
|
||||
Value = Field(Suffix, ",", 2)
|
||||
SubValue = Field(Suffix, ",", 3)
|
||||
end
|
||||
return
|
||||
|
||||
|
||||
Add_Shared_Property:
|
||||
* Params: [IN]SharedCtrlList, [IN]SharedProp, [IN]SharedVal, [IN|OUT]CtrlList, [IN|OUT]PropList, [IN|OUT]ValueList
|
||||
CtrlList := SharedCtrlList:@RM
|
||||
PropList := Str(SharedProp:@RM, NumCtrls)
|
||||
ValueList := Str(SharedVal:@RM, NumCtrls)
|
||||
return
|
||||
|
||||
|
||||
Add_Shared_MV_Property:
|
||||
* Params: [IN]SharedCtrlList, [IN]SharedPrevProp, [IN]Shared_MV_Val, [IN|OUT]CtrlList, [IN|OUT]PropList, [IN|OUT]ValueList
|
||||
CtrlList := SharedCtrlList:@RM
|
||||
PropList := Str(SharedPrevProp:@RM, NumCtrls)
|
||||
ValueList := Shared_MV_Val:@RM
|
||||
return
|
||||
134
SYSPROG/STPROC/SRP_UTILITIES_SAMPLE.txt
Normal file
134
SYSPROG/STPROC/SRP_UTILITIES_SAMPLE.txt
Normal file
@ -0,0 +1,134 @@
|
||||
Compile subroutine SRP_Utilities_Sample(VOID)
|
||||
/**********************************************************************************************************************\
|
||||
|
||||
Name : SRP_Utilities_Sample
|
||||
|
||||
Description : The SRP_Utilities_Sample includes sample code, with debugs, demonstrating the various functions
|
||||
included in the SRP Utilities library.
|
||||
|
||||
For best results, use the debugs provided. Some of them are placed after a call so you can see how fast, in
|
||||
milliseconds, the routine executed. The result is always in the ElapsedTime variable.
|
||||
|
||||
\**********************************************************************************************************************/
|
||||
|
||||
Declare function Rnd, GetTickCount
|
||||
|
||||
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
|
||||
// ARRAY FUNCTIONS
|
||||
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
|
||||
|
||||
Declare function SRP_Clean_Array, SRP_Join_Arrays, SRP_Reorder_Array, SRP_Rotate_Array, SRP_Sort_Array
|
||||
|
||||
// make a big array with blanks and duplicates
|
||||
Array = ""
|
||||
NumRows = 10000
|
||||
For iRow = 1 to NumRows
|
||||
If Rnd(3) then
|
||||
Array := Int(iRow / 2):@FM
|
||||
end else
|
||||
Array := @FM
|
||||
end
|
||||
Next iRow
|
||||
Array[-1, 1] = ""
|
||||
|
||||
// clean it
|
||||
StartTime = GetTickCount()
|
||||
Array = SRP_Clean_Array(Array, @FM, "UNIQUE")
|
||||
ElapsedTime = GetTickCount() - StartTime:" ms"
|
||||
debug
|
||||
|
||||
// make two big arrays, the first is every two numbers, the second is every three numbers
|
||||
LeftArray = ""
|
||||
RightArray = ""
|
||||
NumRows = 10000
|
||||
For iRow = 1 to NumRows
|
||||
LeftArray := iRow * 2:@FM
|
||||
RightArray := iRow * 3:@FM
|
||||
Next iRow
|
||||
LeftArray[-1, 1] = ""
|
||||
RightArray[-1, 1] = ""
|
||||
|
||||
// join them two different ways
|
||||
ArrayIntersect = SRP_Join_Arrays(LeftArray, RightArray, @FM, 1)
|
||||
ArrayUnion = SRP_Join_Arrays(LeftArray, RightArray)
|
||||
debug
|
||||
|
||||
// make a big array with random numbers
|
||||
Array = ""
|
||||
NumCols = 10
|
||||
NumRows = 10000
|
||||
StartTime = GetTickCount()
|
||||
For iCol = 1 to NumCols
|
||||
If iCol GT 1 then Array := @FM
|
||||
For iRow = 1 to NumRows
|
||||
If iRow GT 1 then Array := @VM
|
||||
Array := Rnd(10000) + 1
|
||||
Next iRow
|
||||
Next iCol
|
||||
|
||||
// reorder the columns (move col 5 to col 1, col 7 to col 2, and col 9 to col 3)
|
||||
StartTime = GetTickCount()
|
||||
Array = SRP_Reorder_Array(Array, 5:@FM:7:@FM:9)
|
||||
ElapsedTime = GetTickCount() - StartTime:" ms"
|
||||
debug
|
||||
|
||||
// rotate the array, making it suitable for the LIST property
|
||||
StartTime = GetTickCount()
|
||||
Array = SRP_Rotate_Array(Array)
|
||||
ElapsedTime = GetTickCount() - StartTime:" ms"
|
||||
debug
|
||||
|
||||
// sort the array. Unlike V119, we can leave the delimiters alone and sort in LIST format
|
||||
StartTime = GetTickCount()
|
||||
Array = SRP_Sort_Array(Array, "AR1", 1)
|
||||
ElapsedTime = GetTickCount() - StartTime:" ms"
|
||||
debug
|
||||
|
||||
|
||||
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
|
||||
// CRYPTOGRAPHY FUNCTIONS
|
||||
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
|
||||
|
||||
Declare function SRP_Hash, SRP_Encode, SRP_Decode
|
||||
|
||||
HashString = "My Hash"
|
||||
Encode = "HEX"
|
||||
|
||||
debug
|
||||
Hash = SRP_Hash(HashString, "ADLER32", Encode)
|
||||
Hash = SRP_Hash(HashString, "CRC32", Encode)
|
||||
Hash = SRP_Hash(HashString, "MD2", Encode)
|
||||
Hash = SRP_Hash(HashString, "MD4", Encode)
|
||||
Hash = SRP_Hash(HashString, "MD5", Encode)
|
||||
Hash = SRP_Hash(HashString, "SHA", Encode)
|
||||
Hash = SRP_Hash(HashString, "SHA-1", Encode)
|
||||
Hash = SRP_Hash(HashString, "SHA-2", Encode)
|
||||
Hash = SRP_Hash(HashString, "SHA-224", Encode)
|
||||
Hash = SRP_Hash(HashString, "SHA-256", Encode)
|
||||
Hash = SRP_Hash(HashString, "SHA-384", Encode)
|
||||
Hash = SRP_Hash(HashString, "SHA-512", Encode)
|
||||
Hash = SRP_Hash(HashString, "RIPEMD", Encode)
|
||||
Hash = SRP_Hash(HashString, "RIPEMD-128", Encode)
|
||||
Hash = SRP_Hash(HashString, "RIPEMD-160", Encode)
|
||||
Hash = SRP_Hash(HashString, "RIPEMD-256", Encode)
|
||||
Hash = SRP_Hash(HashString, "RIPEMD-320", Encode)
|
||||
Hash = SRP_Hash(HashString, "TIGER", Encode)
|
||||
Hash = SRP_Hash(HashString, "WHIRLPOOL", Encode)
|
||||
Hash = SRP_Hash(HashString, "SHA-1", Encode)
|
||||
Hash = SRP_Hash(HashString, "", Encode) ; // default = SHA-1
|
||||
Hash = SRP_Hash(HashString, "asdf", Encode) ; // unrecognized = SHA-1
|
||||
|
||||
debug
|
||||
EncodeString = "My String to Encode"
|
||||
EncodeString = SRP_Encode(EncodeString, "HEX")
|
||||
EncodeString = SRP_Decode(EncodeString, "HEX")
|
||||
EncodeString = SRP_Encode(EncodeString, "BASE32")
|
||||
EncodeString = SRP_Decode(EncodeString, "BASE32")
|
||||
EncodeString = SRP_Encode(EncodeString, "BASE64")
|
||||
EncodeString = SRP_Decode(EncodeString, "BASE64")
|
||||
EncodeString = SRP_Encode(EncodeString, "") ; // default = BASE64
|
||||
EncodeString = SRP_Decode(EncodeString, "") ; // default = BASE64
|
||||
EncodeString = SRP_Encode(EncodeString, "asdf") ; // unrecognized = BASE64
|
||||
EncodeString = SRP_Decode(EncodeString, "asdf") ; // unrecognized = BASE64
|
||||
|
||||
Return
|
||||
11
SYSPROG/STPROC/SRP_VALIDATE_USER.txt
Normal file
11
SYSPROG/STPROC/SRP_VALIDATE_USER.txt
Normal file
@ -0,0 +1,11 @@
|
||||
Compile function SRP_Validate_User(Username, Password, Domain)
|
||||
|
||||
If Assigned(Username) else Username = ""
|
||||
If Assigned(Password) else Password = ""
|
||||
If Assigned(Domain) else Domain = ""
|
||||
Debug
|
||||
Declare function SRPLogonAPI_ValidateUser
|
||||
Result = SRPLogonAPI_ValidateUser(Username, Password, Domain)
|
||||
|
||||
Return Result
|
||||
|
||||
84
SYSPROG/STPROC/SSN_FORMAT.txt
Normal file
84
SYSPROG/STPROC/SSN_FORMAT.txt
Normal file
@ -0,0 +1,84 @@
|
||||
compile Subroutine SSN_FORMAT( charstr CONV, charstr ANS, charstr BRANCH, charstr RETURN_DATA)
|
||||
*
|
||||
* SSN_FORMAT is an example of a developer's custom prompt formatting
|
||||
* routine using the square brackets call.
|
||||
*
|
||||
* It should be placed in square brackets, like this:
|
||||
*
|
||||
* [SSN_FORMAT]
|
||||
*
|
||||
* This subroutine should be used as the first and only "Input Validation" in
|
||||
* a window prompt. Placed in "Output Format", it properly formats any
|
||||
* reasonable string of numbers into a consistent US Social Security number format.
|
||||
*
|
||||
!
|
||||
begin condition
|
||||
pre:
|
||||
post:
|
||||
end condition
|
||||
|
||||
* Subroutine declarations
|
||||
|
||||
$insert msg_equates
|
||||
|
||||
declare function msg
|
||||
|
||||
* Local Equates
|
||||
* The STATUS() variable is used to indicated the error condition of the
|
||||
* pattern. They are:
|
||||
EQU VALID$ TO 0 ;* Successful
|
||||
EQU INVALID_MSG$ TO 1 ;* Bad Data - Print error message window
|
||||
EQU INVALID_CONV$ TO 2 ;* Bad Conversion - " "
|
||||
EQU INVALID_NOMSG$ TO 3 ;* Bad but do not print the error message window
|
||||
|
||||
EQU THREEDGRAY$ TO 192
|
||||
|
||||
* Begin Conversion
|
||||
*
|
||||
RETURN_DATA = ""
|
||||
IF ANS NE "" THEN
|
||||
SSN = ANS
|
||||
ANS = ""
|
||||
STATUS() = VALID$
|
||||
|
||||
Convert " -()." TO "" IN SSN
|
||||
|
||||
IF NUM( SSN ) THEN
|
||||
LENGTH = LEN( SSN )
|
||||
* Case statement to validate all possible types of Social Security numbers. If
|
||||
* a new format is required simply add another case.
|
||||
* The fall-through (CASE 1) traps invalid conversions.
|
||||
BEGIN CASE
|
||||
CASE LENGTH = 9
|
||||
IF CONV EQ "OCONV" THEN
|
||||
RETURN_DATA = FMT( SSN, "L###-##-####")
|
||||
END ELSE
|
||||
RETURN_DATA = SSN
|
||||
END
|
||||
CASE 1
|
||||
IF CONV = "ICONV" THEN
|
||||
gosub DisplayError
|
||||
END
|
||||
STATUS() = INVALID_NOMSG$
|
||||
END CASE
|
||||
END ELSE
|
||||
IF CONV = "ICONV" THEN
|
||||
gosub DisplayError
|
||||
END
|
||||
STATUS() = INVALID_NOMSG$
|
||||
END
|
||||
END
|
||||
RETURN
|
||||
*}
|
||||
|
||||
DisplayError:
|
||||
msgrec = ""
|
||||
msgrec<MCAPTION$> = "Data Validation Error"
|
||||
msgrec<MTEXT$> = SSN : " is not a valid Social Security number. Please enter a nine digit number in any format."
|
||||
msgrec<MBKCOLOR$> = THREEDGRAY$:@VM:THREEDGRAY$:@VM:THREEDGRAY$
|
||||
msgrec<MJUST$> = 'L'
|
||||
result = msg( "", msgrec)
|
||||
Return
|
||||
|
||||
* Source Date: 11:16:17 21 OCT 1991 Build ID: AREV*2.12.5 Level: 2.12
|
||||
|
||||
14
SYSPROG/STPROC/STATUSLINE.txt
Normal file
14
SYSPROG/STPROC/STATUSLINE.txt
Normal file
@ -0,0 +1,14 @@
|
||||
COMPILE FUNCTION StatusLine(Window,StatusLine,StatusOutline)
|
||||
|
||||
DECLARE Subroutine Set_Property
|
||||
|
||||
Window = IF ASSIGNED(Window) THEN Window ELSE @WINDOW
|
||||
StatusLine = IF ASSIGNED(StatusLine) THEN StatusLine ELSE 'STATUSLINE_FIX'
|
||||
StatusOutLine = IF ASSIGNED(StatusOutLine) THEN StatusOutLine ELSE 'STATUS_OUTLINE_FIX'
|
||||
|
||||
Ctrls = Window:'.":StatusOutLine':@RM ; Props = 'STYLE':@RM ; Vals = '0X0000008':@RM
|
||||
Ctrls := Window ; Props := 'STATUSLINE' ; Vals := Window:'.':Statusline
|
||||
|
||||
Set_Property(Ctrls,Props,Vals)
|
||||
|
||||
RETURN ''
|
||||
646
SYSPROG/STPROC/SYSLISTS_PUSH.SELECT.txt
Normal file
646
SYSPROG/STPROC/SYSLISTS_PUSH.SELECT.txt
Normal file
@ -0,0 +1,646 @@
|
||||
SUBROUTINE SYSLISTS_PUSH.SELECT(CURSOR, SAVE1, SAVE2, SAVE3)
|
||||
*#ADDED 1,2,3,4
|
||||
*#SOURCE AREV32_BP
|
||||
*#CTO
|
||||
*#Precompile
|
||||
*#FLAVOR AREV32
|
||||
*
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
!
|
||||
*
|
||||
!
|
||||
*
|
||||
* This program is proprietary and is not to be used by or disclosed to others, nor is it to be copied
|
||||
* without written permission from COSMOS, INC.
|
||||
*
|
||||
!
|
||||
*
|
||||
*÷ VERSION : AdvRev 1.0
|
||||
*
|
||||
*÷ PURPOSE : Push an active select list within an EXECUTE level to
|
||||
* prevent it from being destroyed by another select process
|
||||
*
|
||||
*÷ AUTHOR : BDA
|
||||
*
|
||||
*÷ CREATED : April 19, 88
|
||||
*
|
||||
*÷ PROCEDURES :
|
||||
*
|
||||
*÷ WARNINGS :
|
||||
*
|
||||
|
||||
!
|
||||
*÷ REVISION HISTORY (Most CURRENT first) :
|
||||
|
||||
* DATE IMPLEMENTOR FUNCTION
|
||||
* -------- ----------- --------
|
||||
* DD-MM-YY initials Modification
|
||||
* Aug 15-91 Pat Share code with RPM
|
||||
|
||||
!
|
||||
|
||||
*÷ THEORY OF OPERATION :
|
||||
* NOTE THAT CURSOR IS NOT CURRENTLY USED - FOR FORWARD COMPATIBILITY
|
||||
|
||||
!
|
||||
|
||||
*÷ $INSERT Blocks :
|
||||
*$insert syscommon
|
||||
** INCLUDED SOURCE: SYSPROCS,SYSCOMMON **
|
||||
*compile insert SysCommon
|
||||
|
||||
******************************************************************************
|
||||
*
|
||||
* This program is proprietary and is not to be used by or disclosed
|
||||
* to others, nor is it to be copied without written permission from
|
||||
* Revelation Technologies, Inc.
|
||||
*
|
||||
* Name : SysCommon
|
||||
* Description: OpenEngine System Common variable declarations
|
||||
*
|
||||
* History : (date, initials, notes)
|
||||
* 08-13-91 ba original programmer
|
||||
* 10-31-91 rkh removed SC_TIMEDATE_FMT (#215), per fix 4831 and 4813
|
||||
* 01-18-94 gg changed SC_UNUSED73 to SC_CONCURRENCY
|
||||
* 04-05-94 Pat changed SC_UNUSED_107 to SC_ENGINE_LOGGING_REQ;the
|
||||
* semaphore between oengine.exe and revexec.dll
|
||||
* 04-25-94 Slj changed SC_UNUSED_78 to SC_ATWINDOW for event handlers
|
||||
* 05-16-94 Pat change SC_UNUSED_165 to SC_CTRL_TYPES
|
||||
* 06-13-94 tmc 10695 changed SC_ARRAY_VOLUMES to dim of 6 (was 5)
|
||||
* 06-24-95 gg 11322 changed SC_UNUSED_155 to SC_DATASOURCETYPE
|
||||
* 07-17-95 cp 11322 changed SC_UNUSED_154 to SC_XO_DEFAULTS
|
||||
* 03-05-96 cp 11777 added SC_LHLICENSING SC_LHENABLED SC_LHFILESUSED
|
||||
* (160-162)
|
||||
* 08-05-96 gg 11853 changed PROGRAMS_DIM$ from '0299' to '0499'
|
||||
* 06-23/97 cp added support for SYSLOGINS table (201-203)
|
||||
*
|
||||
******************************************************************************
|
||||
|
||||
equ FRAMES_DIM$ to 49
|
||||
equ PROGRAMS_DIM$ to '0499' ;* appears in obj code's literal pool
|
||||
equ SC_ARRAY_VOLUMES_OFFSET$ to 17
|
||||
equ SC_ARRAY_TABLES_OFFSET$ to 19
|
||||
|
||||
*
|
||||
SYSCOM SC_ATRM ;* Set by RTP1 to the value of char(255)
|
||||
SYSCOM SC_ATFM ;* Set by RTP1 to the value of char(254)
|
||||
SYSCOM SC_ATVM ;* Set by RTP1 to the value of char(253)
|
||||
SYSCOM SC_ATSVM ;* Set by RTP1 to the value of char(252)
|
||||
SYSCOM SC_TM ;* Set by RTP1 to the value of char(251)
|
||||
SYSCOM SC_STM ;* Set by RTP1 to the value of char(13)
|
||||
SYSCOM SC_CRLF ;* Set by RTP1 to the value of char(10)
|
||||
SYSCOM SC_FILE_SYSENV ;* 8 The file handle for the SYSENV file
|
||||
SYSCOM SC_TIMEDATA
|
||||
SYSCOM SC_FILE_SYSPTRS ;* 10 The file handle for the SYSPTRS file
|
||||
SYSCOM SC_PROGLIST ;* Array of program names, format of name is
|
||||
SYSCOM SC_PROGRAMS(PROGRAMS_DIM$) ;* Object code for the program name in PROGLIST
|
||||
SYSCOM SC_FSTACK(1)
|
||||
SYSCOM SC_FRAMELIST
|
||||
SYSCOM SC_FRAMES(FRAMES_DIM$) ;* Originally ROS frames, now also other ones
|
||||
SYSCOM SC_FILE_VOLUMES ;* 16 The file handle for the VOLUMES file
|
||||
SYSCOM SC_ARRAY_VOLUMES(6) ;* 17 anchor The physical location of the SYSVOLUMES file
|
||||
SYSCOM SC_FILE_TABLES ;* 18 The file handle for the SYSTABLES file
|
||||
SYSCOM SC_ARRAY_TABLES(5) ;* 19 anchor The physical location of the SYSTABLES file
|
||||
SYSCOM SC_FILES_NO_DETACH ;* A list of system files that CAN NOT be detached
|
||||
SYSCOM SC_RTP1 ;* RTP1 is executed from here. Then used for encryption key
|
||||
SYSCOM SC_AFSNAMES ;* A list of all BFS and MFS encountered by the system
|
||||
SYSCOM SC_FILE_SYSOBJ ;* 23 the file handle for the SYSOBJ file
|
||||
SYSCOM SC_FILE_SYSDICT ;* 24 The file handle for the SYSDICT file
|
||||
SYSCOM SC_USER ;* 25 anchor This is @USERNAME, the name of the current user
|
||||
SYSCOM SC_DBID ;* 26 anchor This is @DBID, the name of the current account
|
||||
SYSCOM SC_LIST
|
||||
SYSCOM SC_TODAY ;* Today's date, used by RLIST
|
||||
SYSCOM SC_SUNDAY0 ;* Day of the week (0-6) Sunday = 0
|
||||
SYSCOM SC_SUNDAY7 ;* Day of the week (1-7) Sunday = 7
|
||||
SYSCOM SC_ATUSER0 ;* 31 (C01F) anchor This is @USER0
|
||||
SYSCOM SC_ATUSER1 ;* 32 (C020) anchor This is @USER1
|
||||
SYSCOM SC_ATUSER2 ;* 33 (C021) anchor This is @USER2
|
||||
SYSCOM SC_ATUSER3 ;* 34 (C022) anchor This is @USER3
|
||||
SYSCOM SC_ATUSER4 ;* 35 (C023) anchor This is @USER4
|
||||
SYSCOM SC_CURR_PROGRAM ;* 36 (C024) moveable used by debugger
|
||||
SYSCOM SC_CURRENT_LINE ;* 37 (C025) moveable Used by debugger current line number
|
||||
SYSCOM SC_SYSTEM_STATE ;* 38 (C026) State of engine '' - uninitialized;'0' - initialized;'1' - Ready to terminate
|
||||
SYSCOM SC_DBG_BUFFER ;* 39 (C027) moveable multipurpose var for the debugger
|
||||
SYSCOM SC_WORKLIST ;* 40 (C028) Real questionable variable
|
||||
SYSCOM SC_ATID ;* 41 (C029) (C0anchor) This is @ID
|
||||
SYSCOM SC_ATREC ;* 42 (C02A) (C0anchor) This is @RECORD
|
||||
SYSCOM SC_DATA_LIST ;* 43 (C02B) (anchor) This is @data
|
||||
SYSCOM SC_ADMIN ;* 44 (C02C) The user has administrative privilege
|
||||
|
||||
SYSCOM SC_SQL_PARAMS ;* 45 (C02d) @SQL_PARAMS Passed parameters in compiled SQL
|
||||
SYSCOM SC_SQL_CURSPARAMS ;* 46 (C02E) @CURS_PARAMS Passed parameters for SQL cursors
|
||||
SYSCOM SC_SQL_NCACHEIDS ;* 47 (C02F) @NCACHEIDS Normalized query id cache
|
||||
SYSCOM SC_SQL_NCACHEDATA(8) ;* 48 (C030) @NCACHEDATA() Normalized query record cache
|
||||
SYSCOM SC_FILE_SYSPROCS ;* 49 (C031) The file handle for the SYSPROCS table
|
||||
|
||||
SYSCOM SC_FLAGS ;* 50 (C032) debug flags (trace, break, etc.)
|
||||
SYSCOM SC_SYSPROCNAMES ;* 51 (C033) used by the compiler to protect system procedures
|
||||
SYSCOM SC_SQL_SQBUFFS(20) ;* 52 (C034) @SQBUFFS( ) Sub Query Buffers
|
||||
SYSCOM SC_SQL_SQBUFF_CURS ;* 53 (C035) Subquery buffer to cursor map
|
||||
SYSCOM SC_SQL_CURS_SQBUFF ;* 54 (C036) Cursor to Subquery Buffer map
|
||||
SYSCOM SC_SQL_CURSSLOTS ;* 55 (C037) SQL cursor to ReAL cursor map
|
||||
SYSCOM SC_SQL_PROJEX ;* 56 (C038) PROJEX meta object cache
|
||||
SYSCOM SC_ATLIMIT ;* 57 (C039) @LIMIT moveable RLIST count limit
|
||||
SYSCOM SC_NEXT_GROUP ;* 58 (C03A) moveable list variable
|
||||
SYSCOM SC_PRI_NAME ;* 59 (C03B)
|
||||
|
||||
SYSCOM SC_PRI_DICT ;* 60 (C03C)
|
||||
SYSCOM SC_PRI_FILE ;* 61 (C03D) anchor @PRI.FILE
|
||||
SYSCOM SC_COMPILER ;* 62 (C03E) This holds a copy of the compiler, RBASIC_RUN record in the verbs file
|
||||
SYSCOM SC_ATLIST_ACTIVE ;* 63 (C03F) Used in conjunction with LIST, is the data in LIST current
|
||||
SYSCOM SC_LIST_OFF ;* 64 (C040)
|
||||
SYSCOM SC_REDUCTION_SPEC ;* 65 (C041)
|
||||
SYSCOM SC_SORT_SPEC ;* 66 (C042)
|
||||
SYSCOM SC_ATANS ;* 67 (C043) anchor This is @ANS
|
||||
SYSCOM SC_ATDICT ;* 68 (C044) anchor This is @DICT
|
||||
SYSCOM SC_SQL_FIRSTIDS ;* 69 (C045) Used by SQL FETCH
|
||||
|
||||
SYSCOM SC_SQL_LASTIDS ;* 70 (C046) Used by SQL FETCH
|
||||
SYSCOM SC_SQL_SKIPWHERE ;* 71 (C047) Place holder for optimization flag
|
||||
SYSCOM SC_SQL_LIKE ;* 72 (C048) Like buffer information
|
||||
SYSCOM SC_CONCURRENCY ;* 73 (C049) Concurrency scheme for SQL bond optimization
|
||||
SYSCOM SC_ATCONV ;* 74 (C04A)
|
||||
SYSCOM SC_ATFORMAT ;* 75 (C04B)
|
||||
SYSCOM SC_ATHEADER ;* 76 (C04C) anchor @header
|
||||
SYSCOM SC_DATE_FORMAT ;* 77 (C04D) moveable
|
||||
SYSCOM SC_ATWINDOW ;* 78 (C04E) current win id in event hdlrs
|
||||
SYSCOM SC_IO_PROC ;* 79 (C04F) moveable select variable
|
||||
|
||||
SYSCOM SC_ATRECUR0 ;* 80 (C050) anchor This is @RECUR0
|
||||
SYSCOM SC_ATRECUR1 ;* 81 (C051) anchor This is @RECUR1
|
||||
SYSCOM SC_ATRECUR2 ;* 82 (C052) anchor This is @RECUR2
|
||||
SYSCOM SC_ATRECUR3 ;* 83 (C053) anchor This is @RECUR3
|
||||
SYSCOM SC_ATRECUR4 ;* 84 (C054) anchor This is @RECUR4
|
||||
SYSCOM SC_MVCOUNT ;* 85 (C055) anchor This is @MV
|
||||
SYSCOM SC_ATRECCOUNT ;* 86 (C056) anchor This is @RECCOUNT or @REC_COUNT
|
||||
SYSCOM SC_ATQUERY_DICT ;* 87 (C057) anchor @query.dict
|
||||
SYSCOM SC_DST_RECORDS(9) ;* 88 (C058) sql distinct records cache
|
||||
SYSCOM SC_DST_OFFSETS(9) ;* 89 (C059) sql distinct keys cache
|
||||
|
||||
SYSCOM SC_DST_HANDLES(9) ;* 90 (C05A) sql distinct table handles
|
||||
SYSCOM SC_DST_HASHTABLES(9) ;* 91 (C05B) sql distinct hash tables
|
||||
SYSCOM SC_ATLPTRWIDE ;* 92 (C05C) anchor This is @LPTRWIDE
|
||||
SYSCOM SC_ATLPTRHIGH ;* 93 (C05D) anchor This is @LPTRHIGH
|
||||
SYSCOM SC_FVSYSREPOS ;* 94 (C05E) to be fv for SYSREPOS
|
||||
SYSCOM SC_FVSYSREPOSLOG ;* 95 (C05F) to be fv for SYSREPOSLOG
|
||||
SYSCOM SC_FILE_REPOSEXE ;* 96 (C060) to be fv for SYSREPOSEVENTEXES
|
||||
SYSCOM SC_ATTCL_STACK ;* 97 (C061) @tcl.stack
|
||||
SYSCOM SC_DRIVER ;* 98 (C062) Used by op91, vspace and
|
||||
SYSCOM SC_LONG_LIST ;* 99 (C063) moveable select variable
|
||||
|
||||
SYSCOM SC_LIST_LEVEL ;* 100 (C064) moveable select variable
|
||||
SYSCOM SC_ATCURSORS(8,12) ;* 101 (C065)anchor @cursors select cursors
|
||||
SYSCOM SC_SORT_FILE ;* 102 (C066)name of the sort file
|
||||
SYSCOM SC_APPID ;* 103 (C067)
|
||||
SYSCOM SC_APPINFO ;* 104 (C068)
|
||||
SYSCOM SC_NEXTREQARGS ;* 105 (C069) Delayed request arguments
|
||||
SYSCOM SC_IDXSVR ;* 106 (C06A)flag for dedicate index server
|
||||
SYSCOM SC_ENGINE_LOGGING_REQ ;* 107 (C06B)
|
||||
SYSCOM SC_HUSH ;* 108 (C06C) Curtis - Patrick Alpha3 fix
|
||||
SYSCOM SC_ATPRIVILEGE ;* 109 (C06D)
|
||||
|
||||
SYSCOM SC_ATSTATION ;* 110 (C06E) anchor This is @STATION
|
||||
SYSCOM SC_ATVIEW_MODE ;* 111 (C06F) @VIEW.MODE
|
||||
SYSCOM SC_LINEAR_HASH_FRAMES ;* 112 (C070) lh vars
|
||||
SYSCOM SC_ATHEADING ;* 113 (C071) anchor
|
||||
SYSCOM SC_ATFOOTING ;* 114 (C072) anchor
|
||||
SYSCOM SC_ATPAGE ;* 115 (C073) anchor @page
|
||||
SYSCOM SC_ATBREAK1 ;* 116 (C074) @BREAK
|
||||
SYSCOM SC_ATBREAK2 ;* 117 (C075)
|
||||
SYSCOM SC_ATBREAK3 ;* 118 (C076)
|
||||
SYSCOM SC_ATFIRST_PAGE ;* 119 (C077)
|
||||
|
||||
SYSCOM SC_ATFIRST_COLHEAD ;* 120 (C078)
|
||||
SYSCOM SC_ATCOLHEADING ;* 121 (C079)
|
||||
SYSCOM SC_ATCOLLENGTH ;* 122 (C07A)
|
||||
SYSCOM SC_ATCOLHEAD ;* 123 (C07B)
|
||||
SYSCOM SC_ATCHACTIVE ;* 124 (C07C)
|
||||
SYSCOM SC_EXT_LIST ;* 125 (C07D) moveable select variable
|
||||
SYSCOM SC_CMDLINE ;* 126 (C07E) moveable DOS command line
|
||||
SYSCOM SC_LOCKED_USER_ID ;* 127 (C07F) Moveable user lock semaphore
|
||||
SYSCOM SC_LABELED_COMMON_NAMES ;* 128 (C080) moveable List of all LABELED COMMON names, defined so far
|
||||
SYSCOM SC_LABELED_COMMON_SPTS ;* 129 (C081) Moveable Location of descriptors for the above labeled common vars
|
||||
|
||||
SYSCOM SC_ATREDUCTION_DONE ;* 130 (C082) moveable select variable
|
||||
SYSCOM SC_ATRETURN_VALUE ;* 131 (C083) moveable ??? The value being returned by a FUNCTION is placed here
|
||||
SYSCOM SC_XLATE_KEYS ;* 132 (C084)
|
||||
SYSCOM SC_XLATE_LRU ;* 133 (C085)
|
||||
SYSCOM SC_SYS_LOCKS(8) ;* 134 (C086)
|
||||
SYSCOM SC_USER_LIST ;* 135 (C087) list of users registered on this database
|
||||
SYSCOM SC_ADMIN_LIST ;* 136 (C088) list of admin flags per user
|
||||
SYSCOM SC_PASSWORD_LIST ;* 137 (C089) list of encrypted passwords per user
|
||||
SYSCOM SC_XLATE_RESET ;* 138 (C08A) anchor
|
||||
SYSCOM SC_PROT_DOCONV ;* 139 (C08B) @IOCONV do conversion on read or write
|
||||
|
||||
SYSCOM SC_PROT_DEFCONV ;* 140 (C08C) default environmental conversion
|
||||
SYSCOM SC_PROT_LOCKMODE ;* 141 (C08D) @LOCKMODE used to specify implicit or explicit lock mode
|
||||
SYSCOM SC_PROT_HANDLES ;* 142 (C08E) handles of tables involved in a transaction
|
||||
SYSCOM SC_PROT_TABLEDATA ;* 143 (C08F) data about tables involved in a transaction
|
||||
SYSCOM SC_PROT_TRANSSTATE ;* 144 (C090) current state of transaction
|
||||
SYSCOM SC_PROT_TRANSDATA ;* 145 (C091) data about current transaction
|
||||
SYSCOM SC_PROT_CONSISTENCY ;* 146 (C092) @CONSISTENCY_LEVEL transaction consistency level
|
||||
SYSCOM SC_PROT_TABLELOCKS(8) ;* 147 (C093) handles for tables locked in a transaction
|
||||
SYSCOM SC_PROT_LOCKDATA(7) ;* 148 (C094) information about locks held in a transaction
|
||||
SYSCOM SC_PROT_TRANSHANDLES ;* 149 (C095) handles of transaction temporary tables
|
||||
|
||||
SYSCOM SC_PROT_CURSCONV ;* 150 (C096) defeats conversion logic
|
||||
SYSCOM SC_PROT_SPECS ;* 151 (C097) protection specs for tables
|
||||
SYSCOM SC_PROT_SPECS_LRU ;* 152 (C098) LRU information for sc_prot_specs
|
||||
SYSCOM SC_AT_INSERT ;* 153 (C099) @INSERT
|
||||
SYSCOM SC_XO_DEFAULTS ;* 154 (C09A)<1>=default XOInstance() options
|
||||
SYSCOM SC_DATASOURCETYPE ;* 155 (C09B) current DataSource type (used by DSO)
|
||||
SYSCOM SC_ATPSEUDO ;* 156 (C09C) anchor This is @PSEUDO
|
||||
SYSCOM SC_ATPRIORITY_INT ;* 157 (C09D) @priority.int
|
||||
SYSCOM SC_ATUPPER_CASE ;* 158 (C09E) anchor This is a string of all upper case letters
|
||||
SYSCOM SC_ATLOWER_CASE ;* 159 (C09F) anchor This is a string of all lower case letters
|
||||
|
||||
SYSCOM SC_LHLICENSING ;* 160 (C0A0) set to true for OI/WG runtimes with user count > 1
|
||||
SYSCOM SC_LHENABLED ;* 161 (C0A1) if SC_LHLICENSING, this is set to TRUE$ by RTP57 when the user semaphore is actually set
|
||||
SYSCOM SC_LHFILESUSED ;* 162 (C0A2) if SC_LHLICENSING, this is a list of LH files that have been opened
|
||||
SYSCOM SC_ATPROG_CHAR ;* 163 (C0A3) @PROG.CHAR
|
||||
SYSCOM SC_ATMW ;* 164 (C0A4) @MW
|
||||
SYSCOM SC_CTRL_TYPES ;* 165 (C0A5) holds control types info
|
||||
SYSCOM SC_REPOSMIRROR ;* 166 (C0A6) Mirror data: mirrorHandle : @RM : configdata
|
||||
SYSCOM SC_ATDEFAULT_STOPS ;* 167 (C0A7) @DEFAULT.STOPS anchor xref stop list
|
||||
SYSCOM SC_ATPAGE_LINE ;* 168 (C0A8) @PAGE_LINE
|
||||
SYSCOM SC_QHANDLE ;* 169 (C0A9) handle to queue
|
||||
|
||||
SYSCOM SC_REQID ;* 170 (C0AA) request is (aka procid )
|
||||
SYSCOM SC_EXEC_COMMAND ;* 171 (C0AB) Current command
|
||||
SYSCOM SC_SPSTATUS ;* 172 (C0AC) stored procedure status
|
||||
SYSCOM SC_SPSTATCODE ;* 173 (C0AD) stored procedure status code string
|
||||
SYSCOM SC_SPSTATTEMPL ;* 174 (C0AE) status code template
|
||||
SYSCOM SC_SPABORT ;* 175 (C0AF)
|
||||
SYSCOM SC_SPTYPE ;* 176 (C0B0) Store procedure type
|
||||
SYSCOM SC_SPARGDTYPES ;* 177 (C0B1) Argument data types
|
||||
SYSCOM SC_SPRECDTYPES ;* 178 (C0B2) Record data types (template)
|
||||
SYSCOM SC_SPWRECDTYPES ;* 179 (C0B3) Working record data types
|
||||
|
||||
SYSCOM SC_ATCRTWIDE ;* 180 (C0B4) @CRTWIDE
|
||||
SYSCOM SC_ATCUR_BUF ;* 181 (C0B5) @CUR.BUF
|
||||
SYSCOM SC_ATMACRO_WORDS ;* 182 (C0B6) @MACRO.WORDS
|
||||
SYSCOM SC_ATMACRO_HEX ;* 183 (C0B7) @MACRO.HEX
|
||||
SYSCOM SC_ATMACRO_MODE ;* 184 (C0B8) @MACRO.MODE
|
||||
SYSCOM SC_ATMESSAGES ;* 185 (C0B9) @MESSAGES
|
||||
SYSCOM SC_ATFILTER ;* 186 (C0BA) @FILTER
|
||||
SYSCOM SC_ATSTATLIST ;* 187 (C0BB) @STATLIST
|
||||
SYSCOM SC_ATSTATREC ;* 188 (C0BC) @STATREC
|
||||
SYSCOM SC_ATSTATPOS ;* 189 (C0BD) @STATPOS
|
||||
SYSCOM SC_ENCACTIVE ;* 190 (C0BE) OpenInsight security encryption
|
||||
|
||||
SYSCOM SC_ATCAPTURE ;* 191 (C0BF) @capture
|
||||
SYSCOM SC_ATSCRIPT ;* 192 (C0C0) @SCRIPT
|
||||
SYSCOM SC_ATSTATUS_ON ;* 193 (C0C1) @STATUS.ON
|
||||
SYSCOM SC_ATMODAL ;* 194 (C0C2) @MODAL
|
||||
SYSCOM SC_DICT_MODE ;* 195 (C0C3) @DICT.MODE** new anchor Dict call mode ( LAST SELET PROC IN AREV )
|
||||
SYSCOM SC_ATTYPEAHEAD ;* 196 (C0C4) @TYPEAHEAD
|
||||
SYSCOM SC_ATBROWSE_LIST ;* 197 (C0C5) @BROWSE.LIST
|
||||
SYSCOM SC_ATBROWSE_MODE ;* 198 (C0C6) @BROWSE.MODE
|
||||
SYSCOM SC_ATFILTER_MODE ;* 199 (C0C7) @FILTER.MODE
|
||||
SYSCOM SC_ATHW ;* 200 (C0C8) @HW
|
||||
|
||||
SYSCOM SC_FILE_SYSLOGINS ;* 201 (C0C9) file handle for SYSLOGINS table (v3.5)
|
||||
SYSCOM SC_KEY_SYSLOGINS ;* 202 (C0CA) this session's key to the SYSLOGINS table (v3.5)
|
||||
SYSCOM SC_LOGGED_ON ;* 203 (C0CB) the date/time value that this session started (v3.5)
|
||||
SYSCOM SC_CHAR_MAPS ;* 204 (C0CC) moveable Character collation maps
|
||||
SYSCOM SC_ATFILE_ERROR ;* 205 (C0CD) anchor @file.error Contains information about last I/O error
|
||||
SYSCOM SC_MEM_ALLOC ;* 206 (C0CE) memory allocated open engine specific
|
||||
SYSCOM SC_INDEXLIST ;* 207 (C0CF) old @index.time ) info for index flushing logic
|
||||
SYSCOM SC_ATROLLOUT_FILE ;* 208 (C0D0) @ROLLOUT.FILE moveable
|
||||
SYSCOM SC_ATFILE_ERROR_MODE ;* 209 (C0D1) anchor @file.error.mode
|
||||
SYSCOM SC_LOCKED_TABLES ;* 210 (C0D2)
|
||||
|
||||
SYSCOM SC_EP ;* 211 (C0D3) @EP Encrypted Password for Bonds
|
||||
SYSCOM SC_LND_DATA ;* 212 (C0D4) Misc language/national data sets
|
||||
SYSCOM SC_LND_NAMES ;* 213 (C0D5) Names of langage/national data sets
|
||||
SYSCOM SC_LND_POINT ;* 214 (C0D6) Pointer to default language/national data set
|
||||
SYSCOM SC_HW_ENV ;* 215 (C0D7) Node Hardware environent: byte 1 = current display mode, bytes 2-> =name of INI file with config.
|
||||
SYSCOM SC_ATLEVEL ;* 216 (C0D8) CURRENT LEVEL OF TCL
|
||||
SYSCOM SC_ATPRECISION ;* 217 (C0D9) Number of decimal digits of precision
|
||||
SYSCOM SC_CM_NAMES ;* 217 (C0DA)
|
||||
SYSCOM SC_CM_POINT ;* 219 (C0DB)
|
||||
SYSCOM SC_ATENVIRON_SET ;* 220 (C0DC) moveable @environ.set
|
||||
*
|
||||
* mtr 12-6-06
|
||||
* We extended the SC addressspace to 250 today in order to bring back more of the system common needed for Arev32, and to add some more as needed for the pick compatibility.
|
||||
|
||||
SYSCOM SC_SAVE(8,26) ;* 221 (C0DD) EXECUTE saves the previous level's state here
|
||||
SYSCOM SC_ATCRT_MAX_Y ;* 222 (C0DE) @CRTMAXHIGH
|
||||
SYSCOM SC_DEMO ;* 223 (C0DF)
|
||||
SYSCOM SC_TCL_STATE ;* 224 (C0E0)
|
||||
SYSCOM SC_RESET_ROUTINE ;* 225 (C0E1) holds code and command for TCL level 1
|
||||
SYSCOM SC_ATSENTENCE ;* 226 (C0E2) @SENTENCE the current tcl line being processed
|
||||
SYSCOM SC_FILE_VOC ;* 227 (C0E3) The file handle for the VOC file
|
||||
SYSCOM SC_DICT_VOC ;* 228 (C0E4) The file handle for the DICT_VOC file
|
||||
SYSCOM SC_CHAIN_LINE ;* 229 (C0E5) Place to pass a command to RTP18
|
||||
SYSCOM SC_PARSE_TCL ;* 230 (C0E6) The parsed command line - @RM delimited word list
|
||||
SYSCOM SC_VERB ;* 231 (C0E7) Name of last verb executed at tcl (example :EDIT VOC *, VERB= "EDIT")
|
||||
SYSCOM SC_VERBS_FILE ;* 232 (C0E8) The file handle for the file in last TCL command
|
||||
SYSCOM SC_BREAKKEY ;* 233 (C0E9)
|
||||
SYSCOM SC_ABORT_FLAG ;* 234 (C0EA)
|
||||
SYSCOM SC_ATSCREEN_SAVE ;* 235 (C0EB)screen image for view mode
|
||||
SYSCOM SC_ATXW ;* 236 (C0EC) @XW
|
||||
SYSCOM SC_VIEW_SCREEN ;* 237 (C0ED)
|
||||
SYSCOM SC_VIEW_PARAMS ;* 238 (C0EE)
|
||||
SYSCOM SC_MULTI_LIMIT ;* 239 (C0EF)
|
||||
SYSCOM SC_CURR_EXEC_CNT ;* 240 (C0F0)
|
||||
SYSCOM SC_FROM_PROC ;* 241 (C0F1)
|
||||
SYSCOM SC_ATSAVE_SELECT ;* 242 (C0F2) @SAVE.SELECT
|
||||
SYSCOM SC_BREAK_TABLE ;* 243 (C0F3) debug's break table
|
||||
SYSCOM SC_TRACE_TABLE ;* 244 (C0F4) debug's trace table
|
||||
SYSCOM SC_PROMPT_STR ;* 245 (C0F5)
|
||||
SYSCOM SC_OPTIONS ;* 246 (C0F6) Each bit in this variable represents a system option See the equates below OPTION.EQUATES
|
||||
SYSCOM SC_OPTLIST ;* 247 (C0F7)
|
||||
SYSCOM SC_MOD_FLAGS ;* 248 (C0F8)
|
||||
SYSCOM SC_LOADER_SEMAPHORE ;* 249 (C0F9)
|
||||
|
||||
* mtr 12-13-06
|
||||
* bumped the number up to 320 for further availability
|
||||
|
||||
SYSCOM SC_ATQUERY_DEPTH ;* 250 (C0FA)*
|
||||
SYSCOM SC_ATQUERY_TABLE ;* 251 (C0FB)*
|
||||
SYSCOM SC_ATEW ;* 252 (C0FC) This is @EW
|
||||
SYSCOM SC_ATAW ;* 253 (C0FD) This is @AW
|
||||
SYSCOM SC_SPACER1 ;* 254- SPACE HOLDER
|
||||
SYSCOM SC_SPACER2 ;* 255- SPACE HOLDER
|
||||
SYSCOM SC_ATPLAYDELAY ;* 256 (C10100)
|
||||
SYSCOM SC_ATBACKGRND_TIME ;* 257 (C10101)
|
||||
SYSCOM SC_ATINT_CONST ;* 258 (C10201) This is @INT_CONST
|
||||
SYSCOM SC_ATEDIT_KEYS ;* 259 (C10301) This is @EDIT_KEYS
|
||||
SYSCOM SC_TAB_STOPS ;* 260 (C10401) Used by the EDITOR
|
||||
SYSCOM SC_ATMV_KEYS ;* 261 (C10501) @MV.KEYS
|
||||
SYSCOM SC_ATMOVE_KEYS ;* 262 (C10601) This is @MOVE_KEYS
|
||||
SYSCOM SC_ATMACRO_KEYS ;* 263 (C10701) @MACRO.KEYS
|
||||
SYSCOM SC_ATUTOR ;* 264 (C10801) @TUTOR
|
||||
SYSCOM SC_ATPAGE_REC ;* 265 (C10901) Used by Report Writer, repl. ATATRBP.PTR
|
||||
SYSCOM SC_ATWINDOW_LEVEL ;* 266 (C10A01) @WINDOW.LEVEL
|
||||
SYSCOM SC_ATSTATATR ;* 267 (C10B01) @statatr
|
||||
SYSCOM SC_ATSCRIBE_MODE ;* 268 (C10C01) @SCRIBE.MODE
|
||||
SYSCOM SC_ATPW ;* 269 (C10D01) This is @PW
|
||||
SYSCOM SC_ATPLAYBACK ;* 270 (C10E01) @PLAYBACK
|
||||
SYSCOM SC_ATENVIRON_KEYS ;* 271 (C10F01) @ENVIRON.KEYS
|
||||
* MTR 12-18-06
|
||||
SYSCOM SC_SYMBOL_TABLE ;* 272 (C11001) used by Arev debuger
|
||||
SYSCOM SC_PREV_PROG ;* 273 (C11101) used by Arev debugger
|
||||
SYSCOM SC_MASTER_OPTIONS ;* 274 (C11201) Used by rtp29
|
||||
SYSCOM SC_VIDEO_DATA ;* 275 (C11301) Video card data, byte 1 = type, byte 2 = "CGA flag", bytes 3 & 4 = display adapter RAM segment (i.e. B800) */
|
||||
* MTR 12-26-06
|
||||
SYSCOM SC_ATHELP_LEVEL ;* 276 (C11401)
|
||||
SYSCOM SC_ATCRTLFMAX ;* 277 (C11501)
|
||||
SYSCOM SC_ATCRTLFS ;* 278 (C11601)
|
||||
|
||||
|
||||
|
||||
*****************************
|
||||
* OPTION.EQUATES
|
||||
EQU D.OPT TO BITAND(SC_OPTIONS,1)
|
||||
EQU O.OPT TO BITAND(SC_OPTIONS,2)
|
||||
EQU P.OPT TO BITAND(SC_OPTIONS,4)
|
||||
EQU T.OPT TO BITAND(SC_OPTIONS,8)
|
||||
EQU X.OPT TO BITAND(SC_OPTIONS,16)
|
||||
EQU I.OPT TO BITAND(SC_OPTIONS,32)
|
||||
EQU R.OPT TO BITAND(SC_OPTIONS,64)
|
||||
EQU N.OPT TO BITAND(SC_OPTIONS,128)
|
||||
EQU S.OPT TO BITAND(SC_OPTIONS,256)
|
||||
EQU C.OPT TO BITAND(SC_OPTIONS,512)
|
||||
EQU L.OPT TO BITAND(SC_OPTIONS,1024)
|
||||
EQU E.OPT TO BITAND(SC_OPTIONS,2048)
|
||||
EQU WRITE.OPT TO BITAND(SC_OPTIONS,4096)
|
||||
EQU U.OPT TO BITAND(SC_OPTIONS,8192)
|
||||
EQU A.OPT TO BITAND(SC_OPTIONS,16384)
|
||||
EQU K.OPT TO BITAND(SC_OPTIONS,32768)
|
||||
EQU B.OPT TO BITAND(SC_OPTIONS,65536)
|
||||
EQU F.OPT TO BITAND(SC_OPTIONS,131072)
|
||||
*
|
||||
EQU ONLY.MOD TO BITAND(SC_MOD_FLAGS,1)
|
||||
EQU IDSUPP.MOD TO BITAND(SC_MOD_FLAGS,2)
|
||||
EQU COLSUPP.MOD TO BITAND(SC_MOD_FLAGS,4)
|
||||
EQU HDRSUPP.MOD TO BITAND(SC_MOD_FLAGS,8)
|
||||
EQU DETSUPP.MOD TO BITAND(SC_MOD_FLAGS,16)
|
||||
EQU DBLSPC.MOD TO BITAND(SC_MOD_FLAGS,32)
|
||||
EQU ERRORSUPP.MOD TO BITAND(SC_MOD_FLAGS,64)
|
||||
*
|
||||
EQU NETWORK.FLAG TO BITAND(RUNTIME(),32768)
|
||||
EQU NETWORK.MASK TO \48692047656E6521\
|
||||
*
|
||||
* Meta objects are stored in the FRAMES array so they can be thrown
|
||||
* out by the garbage collect if necessary.
|
||||
*
|
||||
EQU ROS.FRAME.CACHE TO 0
|
||||
EQU ROS.FRAME.CACHE.TOP TO 9
|
||||
EQU OCONV.RUN TO SC_FRAMES(10)
|
||||
EQU WITH.RUN TO SC_FRAMES(11)
|
||||
EQU WITH0.RUN TO SC_FRAMES(12)
|
||||
EQU SORT.RUN TO SC_FRAMES(13)
|
||||
EQU TEMPLATE.CACHE TO 14
|
||||
EQU TEMPLATE.NAMES TO SC_FRAMES(14)
|
||||
EQU TEMPLATE.CACHE.TOP TO 40
|
||||
EQU XLATE.CACHE TO 41
|
||||
EQU XLATE.CACHE.TOP TO 49
|
||||
|
||||
*$INSERT AREV_BP, SELECT.CONSTANTS
|
||||
** INCLUDED SOURCE: AREV_BP,SELECT.CONSTANTS **
|
||||
* MISC EQUATES *
|
||||
EQUATE MAX.WORK.LIST.LEN$ TO 32768
|
||||
EQUATE MAX.SORT.KEY.LEN$ TO 32600
|
||||
EQUATE MAX.LIST.LEN$ TO 65527
|
||||
EQUATE MAX.LIMIT$ TO 9E99 ;* WHAT TO SET LIMIT TO TO AVOID LIMIT
|
||||
|
||||
* SELECT MODE NUMERIC CODES *
|
||||
|
||||
EQUATE COMPAT.SELECT$ TO 0
|
||||
EQUATE SETTING.SELECT$ TO 1
|
||||
EQUATE USING.SELECT$ TO 2
|
||||
EQUATE ASSIGN.SELECT$ TO 3
|
||||
|
||||
* REDUCE MODE NUMERIC CODES *
|
||||
|
||||
EQUATE NEW.REDUCE$ TO 0
|
||||
EQUATE SETTING.REDUCE$ TO 1
|
||||
EQUATE AND.REDUCE$ TO 2
|
||||
EQUATE OR.REDUCE$ TO 3
|
||||
|
||||
* SEEK MODE NUMERIC CODES *
|
||||
|
||||
EQUATE TOP.SEEK$ TO 0
|
||||
EQUATE BOTTOM.SEEK$ TO 1
|
||||
EQUATE CURRENT.SEEK$ TO 2
|
||||
EQUATE MARK.SEEK$ TO 3
|
||||
EQUATE RESTORE.SEEK$ TO 4
|
||||
|
||||
* FIELD POSITIONS FOR NEXT.GROUP *
|
||||
* GROUP.LAST$:
|
||||
* USED BY ALL SELECT MODES. IN INDEX MODE IS THE LAST NODE ID FOR CURRENT LIST
|
||||
* GROUP.FIELD$:
|
||||
* IN EXTRA LIST INDEX MODE IS THE FIELD NUMBER OF THE CURRENT LIST IN MEMORY
|
||||
* GROUP.FIRST$:
|
||||
* IN INDEX MODE IS THE FIRST NODE ID FOR THE CURRENT LIST IN MEMORY
|
||||
*
|
||||
EQUATE GROUP.LAST$ TO 1
|
||||
EQUATE GROUP.FIELD$ TO 2
|
||||
EQUATE GROUP.FIRST$ TO 3
|
||||
|
||||
* FIELD POSITIONS FOR LONG.LIST *
|
||||
* USED IN EXTERNAL SELECT MODE AND BREAK SORT INDEX MODE *
|
||||
* THE INDEX OF THE CURRENT OVERFLOW LIST IN THE LISTS FILE *
|
||||
*
|
||||
EQUATE LONG.LIST.NUMBER$ TO 1
|
||||
*
|
||||
* THE LARGEST INDEX OF THE OVERFLOWS IN THE LISTS FILE *
|
||||
EQUATE LONG.LIST.MAX$ TO 2
|
||||
|
||||
* CODES FOR LIST.ACTIVE *
|
||||
EQUATE INACTIVE.SELECT$ TO 0
|
||||
EQUATE LATENT.FILE.SELECT$ TO 1
|
||||
EQUATE LATENT.INDEX.SELECT$ TO 2
|
||||
EQUATE EXTRN.SELECT$ TO 3
|
||||
|
||||
* CODES FOR READNEXT DIRECTION *
|
||||
EQUATE ASND.TERM$ TO 0
|
||||
EQUATE ASND.NONTERM$ TO 1
|
||||
EQUATE DSND.TERM$ TO 2
|
||||
EQUATE DSND.NONTERM$ TO 3
|
||||
|
||||
|
||||
|
||||
* SECONDS ALLOWED BETWEEN BREAKS WHILE IN READNEXT *
|
||||
EQUATE BREAK.TIME$ TO 10
|
||||
|
||||
EQUATE V119.INITIALIZE$ TO 'I'
|
||||
EQUATE V119.SORT$ TO 'S'
|
||||
EQUATE V119.WRITE$ TO 'W'
|
||||
EQUATE V119.EXTRACT$ TO 'E'
|
||||
EQUATE V119.MERGE$ TO 'M'
|
||||
EQUATE V119.LONG.EXTRACT$ TO 'L'
|
||||
EQUATE V119.DELETE$ TO 'D'
|
||||
|
||||
*** CURSORS ARRAY EQUATES ***
|
||||
|
||||
EQUATE MAX.CURSORS$ TO 8
|
||||
EQUATE MAX.CURSOR.ELEMENTS$ TO 12
|
||||
|
||||
EQUATE CURS.LIST$ TO 1 ;* referenced by number in OP118
|
||||
EQUATE CURS.LIST.OFF$ TO 2 ;* referenced by number in OP118
|
||||
EQUATE CURS.EXT.LIST$ TO 3
|
||||
EQUATE CURS.NEXT.GROUP$ TO 4
|
||||
EQUATE CURS.LIST.ACTIVE$ TO 5
|
||||
EQUATE CURS.LONG.LIST$ TO 6
|
||||
EQUATE CURS.QUERY.DICT$ TO 7
|
||||
EQUATE CURS.PRI.FILE$ TO 8
|
||||
EQUATE CURS.REDUCTION.SPEC$ TO 9
|
||||
EQUATE CURS.SORT.SPEC$ TO 10
|
||||
EQUATE CURS.REDUCTION.DONE$ TO 11 ;* refereced by number in OP118
|
||||
EQUATE CURS.IO.PROC$ TO 12 ;* Cursor I/O process
|
||||
|
||||
EQUATE BY.DSND.FLAG$ TO '#' ;* FLAG FOR SELECT BY FIELD NAMES
|
||||
|
||||
* CODES FOR SORT.SPEC FIELD 1 *
|
||||
EQUATE SORT.DIR$ TO 1
|
||||
EQUATE SORT.JUST$ TO 2
|
||||
EQUATE BOTTOM.VAL$ TO 3
|
||||
EQUATE TOP.VAL$ TO 4
|
||||
EQUATE SORT.NAME$ TO 5
|
||||
|
||||
* CODES FOR BY.LIST FIELD 1 *
|
||||
EQUATE BY.F1.NAME$ TO 1
|
||||
EQUATE BY.F1.BOTTOM$ TO 2
|
||||
EQUATE BY.F1.TOP$ TO 3
|
||||
|
||||
* SORT.SPEC DEFINES *
|
||||
|
||||
EQUATE SORT.BYS$ TO 2 ;* FLAG TRUE IF DESCEND
|
||||
EQUATE SORT.FMTS$ TO 3 ;* 'AL' 'AR'
|
||||
EQUATE SORT.MULT$ TO 4 ;* FLAG TRUE IF MULTI-VALUE
|
||||
EQUATE SORT.CALC$ TO 5 ;* VALUE TRUE IF FIELD IS SYMBOLIC
|
||||
EQUATE SORT.FIELDS$ TO 6 ;* FIELD NAMES OR NUMBERS
|
||||
EQUATE SORT.EXPLODE$ TO 7 ;* ANY MULTI-VALUES
|
||||
EQUATE SORT.ID.ONLY$ TO 8 ;* SORTING ONLY BY @ID
|
||||
|
||||
* REDUCTION.SPEC DEFINES *
|
||||
EQUATE REDUCT.SCRIPT$ TO 1 ;* R/LIST WITH SCRIPT
|
||||
EQUATE REDUCT.SPEC.RANGE$ TO 2 ;* RANGE INFO FOR FEED FORWARD TO SELECT
|
||||
EQUATE RANGE.FIELD$ TO 1
|
||||
EQUATE RANGE.BOTTOM.VAL$ TO 2
|
||||
EQUATE RANGE.TOP.VAL$ TO 3
|
||||
EQUATE REDUCT.DONE$ TO 4
|
||||
EQUATE REDUCT.CASE.FORCE$ TO 3 ;* FIELD 3 FORCE CASE FLAG (INSENSITIVITY)
|
||||
*
|
||||
* IF REDUCT.DONE IS TRUE THEN, IF THE RANGE IS USED BY THE SELECT THEN
|
||||
* THAT WILL SATISFY ALL REDUCTION AND REDUCTION.DONE MAY BE SET TO TRUE
|
||||
|
||||
*** SELECT.SEEK STATUS ERROR CODES ***
|
||||
EQUATE SEEK.ERR.BAD.CURS$ TO 1 ;* INVALID CURSOR
|
||||
EQUATE SEEK.ERR.BAD.MODE$ TO 2 ;* INVALID MODE
|
||||
EQUATE SEEK.ERR.BAD.POS$ TO 3 ;* INVALID POSITION
|
||||
EQUATE SEEK.ERR.NO.SEL$ TO 4 ;* NO ACTIVE SELECT
|
||||
EQUATE SEEK.ERR.BAD.SEL$ TO 5 ;* INVALID SELECT MODE
|
||||
EQUATE SEEK.ERR.BAD.RN$ TO 6 ;* ERROR IN READNEXT
|
||||
EQUATE SEEK.ERR.BAD.BRN$ TO 7 ;* ERROR IN BLOCK READNEXT
|
||||
EQUATE SEEK.ERR.BAD.IRN$ TO 8 ;* ERROR IN INDEX READNEXT
|
||||
EQUATE SEEK.ERR.BAD.ERN$ TO 9 ;* ERROR IN EXTERNAL READNEXT
|
||||
* Source Date: 18:54:30 21 MAY 1992 Build ID: AREV*2.2.18 Level: 2.2
|
||||
|
||||
*÷ COMMON Variables (Terminate with '%') :
|
||||
|
||||
*÷ LABELED COMMON Variables (Terminate with '@') :
|
||||
|
||||
|
||||
*÷ EQUATE Variables (Terminate with '$') :
|
||||
|
||||
EQU COSMO$ TO 'Copyright (C) 1987, COSMOS, INC.'
|
||||
EQU TRUE$ TO 1
|
||||
EQU FALSE$ TO 0
|
||||
EQU YES$ TO 1
|
||||
EQU NO$ TO 0
|
||||
EQU OTHERWISE$ TO 1
|
||||
|
||||
*÷ LOCAL Variables :
|
||||
|
||||
*÷ DECLARED - FUNCTIONS called :
|
||||
|
||||
*÷ DECLARED - SUBROUTINES called :
|
||||
|
||||
*÷ INDIRECT - FUNCTIONS/SUBROUTINES called if known (Make COMMENTS) :
|
||||
*
|
||||
*============================================================================
|
||||
|
||||
TRANSFER SC_LIST TO SAVE1
|
||||
SAVE2 = SC_ATLIST_ACTIVE
|
||||
SAVE2 := @RM:SC_LONG_LIST
|
||||
SAVE2 := @RM:SC_EXT_LIST
|
||||
SAVE2 := @RM:SC_LIST_OFF
|
||||
SAVE2 := @RM:SC_PRI_FILE
|
||||
SAVE2 := @RM:SC_ATQUERY_DICT
|
||||
SAVE2 := @RM:SC_REDUCTION_SPEC
|
||||
SAVE2 := @RM:SC_SORT_SPEC
|
||||
SAVE2 := @RM:SC_ATREDUCTION_DONE
|
||||
SAVE2 := @RM:SC_IO_PROC
|
||||
SAVE3 = SC_NEXT_GROUP
|
||||
SC_ATLIST_ACTIVE = INACTIVE.SELECT$
|
||||
SC_LIST_LEVEL += 1
|
||||
|
||||
return
|
||||
* Source Date: 13:54:30 03 MAY 1992 Build ID: AREV*2.2.5 Level: 2.2
|
||||
|
||||
* PreCompiled On 01/17/2007 at 11:57:18AM OpenInsight version CTO
|
||||
1031
SYSPROG/STPROC/SYSLISTS_SETALIAS_SUB.txt
Normal file
1031
SYSPROG/STPROC/SYSLISTS_SETALIAS_SUB.txt
Normal file
File diff suppressed because it is too large
Load Diff
24
SYSPROG/STPROC/TEMP.txt
Normal file
24
SYSPROG/STPROC/TEMP.txt
Normal file
@ -0,0 +1,24 @@
|
||||
Compile Subroutine Temp(dummy)
|
||||
|
||||
Debug
|
||||
|
||||
Open 'SYSENV' To hSysenv Then
|
||||
Open 'TEMP_SYSENV' To hNewSysenv Then
|
||||
Select hSysenv
|
||||
EOF = 0
|
||||
Loop
|
||||
Readnext Key Else EOF = 1
|
||||
Until EOF
|
||||
//If IndexC(Key, 'SRP', 1) then
|
||||
Read Rec From hSysenv, Key Then
|
||||
Write Rec To hNewSysenv, Key Else
|
||||
Debug
|
||||
end
|
||||
End
|
||||
//end
|
||||
Repeat
|
||||
End
|
||||
End
|
||||
|
||||
|
||||
return
|
||||
24
SYSPROG/STPROC/TEMP2.txt
Normal file
24
SYSPROG/STPROC/TEMP2.txt
Normal file
@ -0,0 +1,24 @@
|
||||
Compile Subroutine Temp2(dummy)
|
||||
|
||||
debug
|
||||
|
||||
Open 'SYSENV' To hSysenv Then
|
||||
Open 'TEMP_SYSENV' To hTempSysenv Then
|
||||
Select hSysenv
|
||||
EOF = 0
|
||||
Loop
|
||||
Readnext Key Else EOF = 1
|
||||
Until EOF
|
||||
|
||||
Read Rec From hSysenv, Key Then
|
||||
Write Rec To hTempSysenv, Key Else
|
||||
Debug
|
||||
end
|
||||
End
|
||||
|
||||
Repeat
|
||||
End
|
||||
End
|
||||
|
||||
|
||||
return
|
||||
12
SYSPROG/STPROC/TEST_LDAP.txt
Normal file
12
SYSPROG/STPROC/TEST_LDAP.txt
Normal file
@ -0,0 +1,12 @@
|
||||
Compile Function Test_LDAP(Param1)
|
||||
|
||||
Declare Function RTI_LDAP_Groups_For_User
|
||||
|
||||
Main:
|
||||
|
||||
debug
|
||||
ADGroups = RTI_LDAP_Groups_for_User('STIEBERD', 'infineon')
|
||||
|
||||
Return
|
||||
|
||||
|
||||
60
SYSPROG/STPROC/T_CLEAN_SYSLISTS.txt
Normal file
60
SYSPROG/STPROC/T_CLEAN_SYSLISTS.txt
Normal file
@ -0,0 +1,60 @@
|
||||
Subroutine t_clean_syslists(void)
|
||||
|
||||
|
||||
Open 'SYSLISTS' To f_syslists Else
|
||||
debug
|
||||
x = 'wtf?'
|
||||
Return ''
|
||||
End
|
||||
|
||||
debug
|
||||
list = ''
|
||||
done = ''
|
||||
Select f_syslists
|
||||
Loop
|
||||
Readnext id Else done = 1
|
||||
Until done
|
||||
killit = 0
|
||||
Begin Case
|
||||
Case id[1,1] eq '$'; killit = 1
|
||||
Case Index(id, '__',1)
|
||||
Case Indexc(id, 'BARRY',1)
|
||||
Case Indexc(id, 'SEAN',1)
|
||||
Case Indexc(id, 'BOBC',1)
|
||||
Case Count(id,'*') gt 1 And Index(id, '201', 1) ; killit = 1
|
||||
Case Count(id,'*') gt 1 And Index(id, '*15', 1) ; killit = 1
|
||||
Case Count(id,'*') gt 1 And Index(id, '*14', 1) ; killit = 1
|
||||
Case id[1,2] _Eqc 'W*'
|
||||
test = id[-1,'B*']
|
||||
test = test[1,'.']
|
||||
If test gt 0 And test lt date() Then
|
||||
killit = 1
|
||||
end
|
||||
End Case
|
||||
If killit Then
|
||||
list<-1> = id
|
||||
End
|
||||
|
||||
Repeat
|
||||
debug
|
||||
|
||||
id = ''
|
||||
col = ''
|
||||
Loop
|
||||
Remove id From list at col Setting mark
|
||||
If id # '' Then
|
||||
test = id[-1,'B*']
|
||||
Begin Case
|
||||
Case Index(test, '.',1)
|
||||
Case alpha(test)
|
||||
Case Num(test)
|
||||
id = Field(id, '*', 1, Count(id, '*'))
|
||||
End Case
|
||||
If id # '' Then
|
||||
Call Delete_Save_Select(id)
|
||||
Call Set_Status(0)
|
||||
end
|
||||
End
|
||||
While mark
|
||||
repeat
|
||||
Return ''
|
||||
449
SYSPROG/STPROC/WINDOWS_SERVICES.txt
Normal file
449
SYSPROG/STPROC/WINDOWS_SERVICES.txt
Normal file
@ -0,0 +1,449 @@
|
||||
Function Windows_Services(@Service, @Params)
|
||||
/***********************************************************************************************************************
|
||||
|
||||
This program is proprietary and is not to be used by or disclosed to others, nor is it to be copied without written
|
||||
permission from SRP Computer Solutions, Inc.
|
||||
|
||||
Name : Windows_Services
|
||||
|
||||
Description : Handler program for all module related services.
|
||||
|
||||
Notes : The generic parameters should contain all the necessary information to process the services. Often
|
||||
this will be information like the data Record and Key ID.
|
||||
|
||||
Parameters :
|
||||
Service [in] -- Name of the service being requested
|
||||
Error [out] -- Any errors that were created
|
||||
Param1-10 [in/out] -- Additional request parameter holders
|
||||
Response [out] -- Response to be sent back to the Controller (MCP) or requesting procedure
|
||||
|
||||
History : (Date, Initials, Notes)
|
||||
05/14/13 dmb Original programmer.
|
||||
05/15/13 dmb Add the IsRunning and Close service. Update the GetHandle service to use the GetTopWindow
|
||||
API function.
|
||||
05/22/13 dmb Add Hide, Show, Maximize, and Minimize services (all based on the ShowWindow API).
|
||||
10/02/13 dmb [SRPFW-18] Add IsVisible service.
|
||||
11/11/13 dmb [SRPFW-75] Add RunEXE and OpenFile services.
|
||||
11/12/13 dmb [SRPFW-76] Add KillEXE service.
|
||||
03/28/20 dmb [SRPFW-304] Update services to use Error_Services when applicable.
|
||||
05/13/20 dmb [SRPFW-312] Add MakeActive service.
|
||||
|
||||
***********************************************************************************************************************/
|
||||
|
||||
#pragma precomp SRP_PreCompiler
|
||||
|
||||
$insert LOGICAL
|
||||
$insert SERVICE_SETUP
|
||||
|
||||
// General Windows API equates
|
||||
Equ WM_USER to 1024
|
||||
Equ WM_CLOSE to 16
|
||||
Equ WM_COMMAND to 273
|
||||
Equ WM_LBUTTONDOWN to 513 ; // 0x0201
|
||||
Equ WM_LBUTTONUP to 514 ; // 0x0202
|
||||
Equ WM_LBUTTONDBLCLK to 515 ; // 0x0203
|
||||
Equ WM_RBUTTONDOWN to 516 ; // 0x0204
|
||||
Equ WM_RBUTTONUP to 517 ; // 0x0205
|
||||
Equ WM_PARENTNOTIFY to 528 ; // 0x0210
|
||||
Equ WM_SYSCOLORCHANGE to 21 ; // 0x0015
|
||||
Equ WM_SETCURSOR to 32 ; // 0x0020
|
||||
Equ WM_SIZE to 5 ; // 0x0005
|
||||
Equ WM_MOVE to 3 ; // 0x0003
|
||||
Equ WM_GETMINMAXINFO to 36 ; // 0x0024
|
||||
Equ WM_WINDOWPOSCHANGING to 70
|
||||
|
||||
// ShowWindow API equates
|
||||
Equ SW_FORCEMINIMIZE to 11
|
||||
Equ SW_HIDE to 0
|
||||
Equ SW_MAXIMIZE to 3
|
||||
Equ SW_MINIMIZE to 6
|
||||
Equ SW_RESTORE to 9
|
||||
Equ SW_SHOW to 5
|
||||
Equ SW_SHOWDEFAULT to 10
|
||||
Equ SW_SHOWMAXIMIZED to 3
|
||||
Equ SW_SHOWMINIMIZED to 2
|
||||
Equ SW_SHOWMINNOACTIVE to 7
|
||||
Equ SW_SHOWNA to 8
|
||||
Equ SW_SHOWNOACTIVATE to 4
|
||||
Equ SW_SHOWNORMAL to 1
|
||||
|
||||
Declare function Windows_Services, WinAPI_MoveWindow, WinAPI_GetWindowTextA, WinAPI_GetWindow, WinAPI_IsWindow
|
||||
Declare function FindWindow, PostMessage, ShowWindow, IsWindowVisible
|
||||
Declare function SRP_GetTopWindow, ShellExecute, Kill_Application, Utility
|
||||
Declare subroutine Windows_Services, SRP_SetForeGroundWindow
|
||||
|
||||
GoToService else
|
||||
Error_Services('Set', Service : ' is not a valid service request within the ' : ServiceModule : ' services module.')
|
||||
end
|
||||
|
||||
Return Response else ''
|
||||
|
||||
|
||||
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
|
||||
// Service Parameter Options
|
||||
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
|
||||
Options BOOLEAN = True$, False$
|
||||
|
||||
|
||||
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
|
||||
// Services
|
||||
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
|
||||
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
// SetSize
|
||||
//
|
||||
// Param1 - Handle to the window.
|
||||
// Param2 - Class Name to the window. This is ignored if there is a handle.
|
||||
// Param3 - Caption text of the window. This is ignored if there is a handle or class name.
|
||||
// Param4 - X Position.
|
||||
// Param5 - Y Position.
|
||||
// Param6 - Width.
|
||||
// Param7 - Height.
|
||||
//
|
||||
// Sets the size of the window.
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
Service SetSize(Handle, ClassName, CaptionText, XPos, YPos, Width, Height)
|
||||
|
||||
If Len(Handle) EQ 0 then
|
||||
Begin Case
|
||||
Case Len(ClassName)
|
||||
Handle = Windows_Services('GetHandle', ClassName)
|
||||
|
||||
Case Len(CaptionText)
|
||||
Handle = Windows_Services('GetHandle', '', CaptionText)
|
||||
|
||||
End Case
|
||||
end
|
||||
|
||||
If Handle GT 0 then
|
||||
rv = WinAPI_MoveWindow(Handle, XPos, YPos, Width, Height, True$)
|
||||
end else
|
||||
Error_Services('Add', 'No valid window was passed in to the ' : Service : ' service.')
|
||||
end
|
||||
|
||||
end service
|
||||
|
||||
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
// IsRunning
|
||||
//
|
||||
// Param1 - Handle to the window.
|
||||
// Param2 - Class Name to the window. This is ignored if there is a handle.
|
||||
// Param3 - Caption text of the window. This is ignored if there is a handle or class name.
|
||||
//
|
||||
// Returns True if the window is running or False is not.
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
Service IsRunning(Handle, ClassName, CaptionText)
|
||||
|
||||
Begin Case
|
||||
Case Len(Handle)
|
||||
If WinAPI_IsWindow(Handle) else Handle = ''
|
||||
|
||||
Case Len(ClassName)
|
||||
Handle = Windows_Services('GetHandle', ClassName)
|
||||
|
||||
Case Len(CaptionText)
|
||||
Handle = Windows_Services('GetHandle', '', CaptionText)
|
||||
|
||||
End Case
|
||||
|
||||
Response = (Handle GT 0)
|
||||
|
||||
end service
|
||||
|
||||
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
// IsVisible
|
||||
//
|
||||
// Param1 - Handle to the window.
|
||||
// Param2 - Class Name to the window. This is ignored if there is a handle.
|
||||
// Param3 - Caption text of the window. This is ignored if there is a handle or class name.
|
||||
//
|
||||
// Returns True if the window is visible or False is not.
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
Service IsVisible(Handle, ClassName, CaptionText)
|
||||
|
||||
Begin Case
|
||||
Case Len(Handle)
|
||||
If WinAPI_IsWindow(Handle) else Handle = ''
|
||||
|
||||
Case Len(ClassName)
|
||||
Handle = Windows_Services('GetHandle', ClassName)
|
||||
|
||||
Case Len(CaptionText)
|
||||
Handle = Windows_Services('GetHandle', '', CaptionText)
|
||||
|
||||
End Case
|
||||
|
||||
Response = (IsWindowVisible(Handle) GT 0)
|
||||
|
||||
end service
|
||||
|
||||
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
// RunEXE
|
||||
//
|
||||
// Param1 - Full path and file name of the executable to run.
|
||||
//
|
||||
// Runs an executable program. This uses the RUNWIN service without any special flags. Therefore all executables will be
|
||||
// launched modelessly and in normal mode.
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
Service RunEXE(PathToEXE)
|
||||
|
||||
If Len(PathToEXE) then
|
||||
AppInfo = Utility('RUNWIN', PathToEXE)
|
||||
If Len(AppInfo<2>) else
|
||||
Error_Services('Add', Quote(PathToExe) : ' is an invalid executable file provided to the ' : Service : ' service.')
|
||||
end
|
||||
end else
|
||||
Error_Services('Add', 'No path to an executable file was provided to the ' : Service : ' service.')
|
||||
end
|
||||
|
||||
end service
|
||||
|
||||
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
// OpenFile
|
||||
//
|
||||
// Param1 - Full path and file name to open.
|
||||
//
|
||||
// Opens an OS file. This uses the ShellExecute Windows API without any special flags.
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
Service OpenFile(PathToFile)
|
||||
|
||||
If Len(PathToFile) then
|
||||
rv = ShellExecute('', 'open' : \00\, PathToFile : \00\, '' : \00\, '' : \00\, 0)
|
||||
end else
|
||||
Error_Services('Add', 'No path to a file was provided to the ' : Service : ' service.')
|
||||
end
|
||||
|
||||
end service
|
||||
|
||||
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
// Close
|
||||
//
|
||||
// Param1 - Handle to the window.
|
||||
// Param2 - Class Name to the window. This is ignored if there is a handle.
|
||||
// Param3 - Caption text of the window. This is ignored if there is a handle or class name.
|
||||
//
|
||||
// Close the window. If the class name or window caption is passed in, only the first instance of any window will be
|
||||
// closed. The developer will need to call the Close service multiple times until there are no more matching windows.
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
Service Close(Handle, ClassName, CaptionText)
|
||||
|
||||
If Len(Handle) EQ 0 then
|
||||
Begin Case
|
||||
Case Len(ClassName)
|
||||
Handle = Windows_Services('GetHandle', ClassName)
|
||||
|
||||
Case Len(CaptionText)
|
||||
Handle = Windows_Services('GetHandle', '', CaptionText)
|
||||
|
||||
End Case
|
||||
end
|
||||
|
||||
If Handle GT 0 then
|
||||
rv = PostMessage(Handle, WM_CLOSE, 0, 0)
|
||||
end else
|
||||
Error_Services('Add', 'No valid window was passed in to the ' : Service : ' service.')
|
||||
end
|
||||
|
||||
end service
|
||||
|
||||
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
// KillEXE
|
||||
//
|
||||
// Param1 - Full path and file name of the executable to run.
|
||||
// Param2 - Caption text of the window.
|
||||
//
|
||||
// Attempts to kill a running executable program. Returns a 1 if successful, or a negative number if unsuccessful.
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
Service KillEXE(EXEName, CaptionText)
|
||||
|
||||
Results = ''
|
||||
|
||||
If Len(EXEName) OR Len(CaptionText) then
|
||||
Results = Kill_Application(EXEName, CaptionText, TimeoutDelay, True$)
|
||||
end else
|
||||
Error_Services('Add', 'No valid executable file or caption was provided to the ' : Service : ' service.')
|
||||
end
|
||||
|
||||
Response = Results
|
||||
|
||||
end service
|
||||
|
||||
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
// Hide
|
||||
//
|
||||
// Param1 - Handle to the window.
|
||||
// Param2 - Class Name to the window. This is ignored if there is a handle.
|
||||
// Param3 - Caption text of the window. This is ignored if there is a handle or class name.
|
||||
//
|
||||
// Hide the window. If the class name or window caption is passed in, only the first instance of any window will be
|
||||
// hidden. The developer will need to call the Hide service multiple times until there are no more matching windows.
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
Service Hide(Handle, ClassName, CaptionText)
|
||||
|
||||
CmdShow = SW_HIDE
|
||||
GoSub ShowWindowAPI
|
||||
|
||||
end service
|
||||
|
||||
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
// Show
|
||||
//
|
||||
// Param1 - Handle to the window.
|
||||
// Param2 - Class Name to the window. This is ignored if there is a handle.
|
||||
// Param3 - Caption text of the window. This is ignored if there is a handle or class name.
|
||||
//
|
||||
// Activates the window and displays it in its current size and position. If the class name or window caption is passed
|
||||
// in, only the first instance of any window will be hidden. The developer will need to call the Hide service multiple
|
||||
// times until there are no more matching windows.
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
Service Show(Handle, ClassName, CaptionText)
|
||||
|
||||
CmdShow = SW_SHOW
|
||||
GoSub ShowWindowAPI
|
||||
|
||||
end service
|
||||
|
||||
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
// Maximize
|
||||
//
|
||||
// Param1 - Handle to the window.
|
||||
// Param2 - Class Name to the window. This is ignored if there is a handle.
|
||||
// Param3 - Caption text of the window. This is ignored if there is a handle or class name.
|
||||
//
|
||||
// Maximizes the specified window. If the class name or window caption is passed in, only the first instance of any
|
||||
// window will be hidden. The developer will need to call the Hide service multiple times until there are no more
|
||||
// matching windows.
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
Service Maximize(Handle, ClassName, CaptionText)
|
||||
|
||||
CmdShow = SW_MAXIMIZE
|
||||
GoSub ShowWindowAPI
|
||||
|
||||
end service
|
||||
|
||||
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
// Minimize
|
||||
//
|
||||
// Param1 - Handle to the window.
|
||||
// Param2 - Class Name to the window. This is ignored if there is a handle.
|
||||
// Param3 - Caption text of the window. This is ignored if there is a handle or class name.
|
||||
//
|
||||
// Minimizes the specified window. If the class name or window caption is passed in, only the first instance of any
|
||||
// window will be hidden. The developer will need to call the Hide service multiple times until there are no more
|
||||
// matching windows.
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
Service Minimize(Handle, ClassName, CaptionText)
|
||||
|
||||
CmdShow = SW_MINIMIZE
|
||||
GoSub ShowWindowAPI
|
||||
|
||||
end service
|
||||
|
||||
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
// MakeActive
|
||||
//
|
||||
// Handle - Handle to the window. - [Required]
|
||||
//
|
||||
// Brings the window to the foreground and makes it active. This uses the SetForegroundWindow API:
|
||||
// https://docs.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-setforegroundwindow
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
Service MakeActive(Handle)
|
||||
|
||||
If Handle NE '' then
|
||||
SRP_SetForeGroundWindow(Handle)
|
||||
end
|
||||
|
||||
end service
|
||||
|
||||
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
// GetHandle
|
||||
//
|
||||
// Param1 - Class Name to the window.
|
||||
// Param2 - Caption text of the window. This is ignored if there is a handle or class name.
|
||||
// Param3 - Flag that determines if all handles should be returned rather than the first match. Only works when finding
|
||||
// handles by CaptionText.
|
||||
//
|
||||
// Gets the handle for the window.
|
||||
//----------------------------------------------------------------------------------------------------------------------
|
||||
Service GetHandle(ClassName, CaptionText, AllHandles)
|
||||
|
||||
Handle = ''
|
||||
If AllHandles NE True$ then AllHandles = False$
|
||||
|
||||
Begin Case
|
||||
Case Len(ClassName)
|
||||
// The FindWindow API returns the handle of a valid class name that is already running.
|
||||
Handle = FindWindow(ClassName : \00\, '')
|
||||
|
||||
Case Len(CaptionText)
|
||||
// The GetTopWindow API will return the handle of the first window running in z-order.
|
||||
StartHandle = SRP_GetTopWindow('')
|
||||
NextHandle = StartHandle
|
||||
TextBuffer = Str(\00\, 100)
|
||||
// The GetWindowText API will return the caption text of the window.
|
||||
rv = WinAPI_GetWindowTextA(NextHandle, TextBuffer, Len(TextBuffer))
|
||||
ThisCaption = TextBuffer[1, \00\]
|
||||
If ThisCaption EQ CaptionText then Handle = NextHandle : @FM
|
||||
|
||||
// If the top window is not a match, then use the GetWindow API to retrieve the next running window's
|
||||
// handle. Continue to loop through each window until a match is found or there are no more windows
|
||||
// to process.
|
||||
If Len(Handle) EQ 0 OR AllHandles = True$ then
|
||||
Loop
|
||||
Until (NextHandle EQ 0) OR (Len(Handle) AND AllHandles EQ False$)
|
||||
NextHandle = WinAPI_GetWindow(NextHandle, 2)
|
||||
TextBuffer = Str(\00\, 100)
|
||||
rv = WinAPI_GetWindowTextA(NextHandle, TextBuffer, Len(TextBuffer))
|
||||
ThisCaption = TextBuffer[1, \00\]
|
||||
If ThisCaption EQ CaptionText then
|
||||
Locate NextHandle in Handle using @FM setting fPos else
|
||||
Handle := NextHandle : @FM
|
||||
end
|
||||
end
|
||||
Repeat
|
||||
end
|
||||
Handle[-1, 1] = '' ; // Strip off the final @FM
|
||||
|
||||
End Case
|
||||
|
||||
Response = Handle
|
||||
|
||||
end service
|
||||
|
||||
|
||||
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
|
||||
// Internal GoSubs
|
||||
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////?
|
||||
|
||||
ShowWindowAPI:
|
||||
|
||||
If Len(Handle) EQ 0 then
|
||||
Begin Case
|
||||
Case Len(ClassName)
|
||||
Handle = Windows_Services('GetHandle', ClassName)
|
||||
|
||||
Case Len(CaptionText)
|
||||
Handle = Windows_Services('GetHandle', '', CaptionText)
|
||||
|
||||
End Case
|
||||
end
|
||||
|
||||
If Handle GT 0 then
|
||||
rv = ShowWindow(Handle, CmdShow)
|
||||
end else
|
||||
Error_Services('Add', 'No valid window was passed in to the ' : Service : ' service.')
|
||||
end
|
||||
|
||||
return
|
||||
295
SYSPROG/STPROC/WM_MFS.txt
Normal file
295
SYSPROG/STPROC/WM_MFS.txt
Normal file
@ -0,0 +1,295 @@
|
||||
COMPILE SUBROUTINE WM_MFS(Code, BFS, Handle, Name, FMC, Record, Status)
|
||||
|
||||
DECLARE Subroutine Msg, FSMsg, Set_Status
|
||||
DECLARE FUNCTION Set_Status, Get_Status, obj_WM_In, obj_WM_Out
|
||||
|
||||
COMMON /FILENAME/ Files_Array, Handles_Array
|
||||
|
||||
FS = DELETE(BFS,1,1,1)
|
||||
NEXTFS = FS<1,1,1>
|
||||
@FILE.ERROR = ''
|
||||
|
||||
$INSERT FILE.SYSTEM.ONGOSUB
|
||||
$INSERT FILE.SYSTEM.EQUATES
|
||||
$INSERT MSG_EQUATES
|
||||
$INSERT DICT_EQUATES
|
||||
$INSERT WM_OUT_EQUATES
|
||||
$INSERT WM_IN_EQUATES
|
||||
$INSERT WO_MAT_EQUATES
|
||||
|
||||
EQU ReadRec$ TO 1
|
||||
|
||||
*EQU WO_MAT_WMI_CURR_STATUS$ TO 48
|
||||
*EQU WO_MAT_WMO_CURR_STATUS$ TO 49
|
||||
|
||||
RETURN
|
||||
|
||||
/* Directly called functions - don't pass to next file system */
|
||||
|
||||
INSTALL:
|
||||
FLUSH:
|
||||
UNLOCK.ALL:
|
||||
FLUSH.CACHE:
|
||||
|
||||
Status = 1
|
||||
RETURN
|
||||
|
||||
/* Not available to MFS */
|
||||
|
||||
LOCK.SEMAPHORE:
|
||||
UNLOCK.SEMAPHORE:
|
||||
SET.USER.SEMAPHORE:
|
||||
|
||||
RETURN
|
||||
|
||||
/* Directory level calls */
|
||||
|
||||
CREATE.MEDIA:
|
||||
OPEN.MEDIA:
|
||||
CLOSE.MEDIA:
|
||||
READ.MEDIA:
|
||||
WRITE.MEDIA:
|
||||
GROUP.NUMBER:
|
||||
RECORD.COUNT:
|
||||
CREATE.FILE:
|
||||
RENAME.FILE:
|
||||
MOVE.FILE:
|
||||
DELETE.FILE:
|
||||
|
||||
Goto NEXT.FS
|
||||
|
||||
OPEN.FILE:
|
||||
|
||||
* Call BFS in order to get file handle
|
||||
|
||||
FS = DELETE(BFS,1,1,1)
|
||||
NEXTFS = FS<1,1,1>
|
||||
CALL @NEXTFS(Code, FS, Handle, Name, FMC, Record, Status)
|
||||
|
||||
* Load handle and file name into labelled common
|
||||
|
||||
IF Status THEN
|
||||
LOCATE Name IN Files_Array USING @FM SETTING POS THEN
|
||||
Handles_Array<POS> = Record
|
||||
END ELSE
|
||||
Files_Array<-1> = Name
|
||||
Handles_Array<-1> = Record
|
||||
END
|
||||
END
|
||||
RETURN
|
||||
|
||||
CLEARFILE:
|
||||
REMAKE.FILE:
|
||||
SELECT:
|
||||
READNEXT:
|
||||
CLEARSELECT:
|
||||
|
||||
READ.RECORD:
|
||||
READO.RECORD:
|
||||
|
||||
GOTO NEXT.FS
|
||||
|
||||
* * * * * * *
|
||||
WRITE.RECORD:
|
||||
* * * * * * *
|
||||
|
||||
* Get original record and compare with RECORD being written
|
||||
LOCATE Handle IN Handles_Array USING @FM SETTING POS ELSE
|
||||
mesg = "Missing file handle in WM_MFS!|"
|
||||
mesg := handle
|
||||
MSG('',mesg)
|
||||
GOTO NEXT.FS
|
||||
END
|
||||
|
||||
FileName = Files_Array<POS>[1,'*'] ;* Extract corresponding file name
|
||||
|
||||
Write_Flag = 0
|
||||
OrgRecord = ''
|
||||
NextFS = BFS<1,1,2>
|
||||
|
||||
CALL @NextFS(ReadRec$, FS, Handle, Name, FMC, OrgRecord, Status) ;* Read old record
|
||||
|
||||
OPEN 'WO_MAT' TO WOMatFile ELSE
|
||||
MSG('',"Unable to open 'WO_MAT' table in WM_MFS")
|
||||
GOTO NEXT.FS
|
||||
END
|
||||
|
||||
IF FileName = 'WM_IN' THEN
|
||||
|
||||
WONo = Name[1,'*']
|
||||
WOStep = Name[COL2()+1,'*']
|
||||
CassNo = Name[COL2()+1,'*']
|
||||
|
||||
Set_Status(0)
|
||||
NewStatus = obj_WM_In('CurrStatus',Name:@RM:RECORD)
|
||||
|
||||
IF Get_Status(errCode) THEN
|
||||
NewStatus = 'ERR'
|
||||
END
|
||||
|
||||
WOMatKey = WONo:'*':CassNo
|
||||
READ WOMatRec FROM WOMatFile,WOMatKey THEN
|
||||
|
||||
SlotCnt = COUNT(RECORD<WM_IN_SLOT_NO$>,@VM) + (RECORD<WM_IN_SLOT_NO$> NE '')
|
||||
|
||||
FOR I = 1 TO SlotCnt
|
||||
WOMatRec<WO_MAT_SLOT_MET_NO$,I> = RECORD<WM_IN_SLOT_MET_NO$,I>
|
||||
NEXT I
|
||||
|
||||
IF WOMatRec<WO_MAT_WMI_CURR_STATUS$> NE NewStatus THEN
|
||||
WOMatRec<WO_MAT_WMI_CURR_STATUS$> = NewStatus
|
||||
END
|
||||
|
||||
WRITE WOMatRec ON WOMatFile,WOMatKey ELSE Null
|
||||
|
||||
END ELSE
|
||||
*MSG('',"Unable to read 'WO_MAT' record ":QUOTE(WOMatKey):" in WM_MFS")
|
||||
GOTO NEXT.FS
|
||||
END
|
||||
|
||||
|
||||
END ;* End of check for WM_IN table
|
||||
|
||||
|
||||
IF FileName = 'WM_OUT' THEN
|
||||
|
||||
WONo = Name[1,'*']
|
||||
WOStep = Name[COL2()+1,'*']
|
||||
CassNo = Name[COL2()+1,'*']
|
||||
|
||||
Set_Status(0)
|
||||
NewStatus = obj_WM_Out('CurrStatus',Name:@RM:RECORD)
|
||||
|
||||
IF Get_Status(errCode) THEN
|
||||
NewStatus = 'ERR'
|
||||
END
|
||||
|
||||
WOMatKey = WONo:'*':CassNo
|
||||
|
||||
READ WOMatRec FROM WOMatFile,WOMatKey ELSE WOMatRec = ''
|
||||
|
||||
* Smaller outbound boxes won't have WO_MAT records when the are being created so it happens here.
|
||||
|
||||
WOMatRec<WO_MAT_WMO_CURR_STATUS$> = NewStatus ;* Original code
|
||||
|
||||
SlotCnt = COUNT(RECORD<WM_OUT_SLOT_NO$>,@VM) + (RECORD<WM_OUT_SLOT_NO$> NE '')
|
||||
|
||||
FOR I = 1 TO Slotcnt
|
||||
*WOMatRec<WO_MAT_EPO_SLOT$,I> = RECORD<WM_OUT_SLOT_NO$,I>
|
||||
|
||||
WOMatRec<WO_MAT_EPO_SLOT$,I> = I ;* 8/4/2011 JCH Keep all slot numbers for EPOS
|
||||
|
||||
InCassNo = RECORD<WM_OUT_IN_CASS_NO$,I>
|
||||
InSlotNo = RECORD<WM_OUT_IN_SLOT_NO$,I>
|
||||
|
||||
IF InCassNo NE '' AND InSlotNo NE '' THEN
|
||||
WOMatRec<WO_MAT_EPOS_WFR_IN$,I> = WONo:'.':InCassNo:'.':InSlotNo
|
||||
END ELSE
|
||||
WOMatRec<WO_MAT_EPOS_WFR_IN$,I> = ''
|
||||
END
|
||||
|
||||
RDSNo = RECORD<WM_OUT_RDS$,I>
|
||||
|
||||
IF RDSNo NE '' THEN
|
||||
WOMatRec<WO_MAT_EPOS_RUN_ID$,I> = RDSNo:'.':RECORD<WM_OUT_POCKET$,I>:'.':RECORD<WM_OUT_ZONE$,I>
|
||||
END ELSE
|
||||
WOMatRec<WO_MAT_EPOS_RUN_ID$,I> = ''
|
||||
END
|
||||
|
||||
WOMatRec<WO_MAT_EPOS_NCR$,I> = RECORD<WM_OUT_SLOT_NCR$,I>
|
||||
WOMatRec<WO_MAT_EPOS_MET_NO$,I> = '' ;* Not used
|
||||
|
||||
MUWONo = RECORD<WM_OUT_MU_WO_NO$,I>
|
||||
|
||||
IF MUWONo NE '' THEN
|
||||
WOMatRec<WO_MAT_EPOS_REP_WAFER_ID$,I> = MUWONo:'.':RECORD<WM_OUT_MU_CASS_NO$,I>:'.':RECORD<WM_OUT_MU_SLOT_NO$,I>
|
||||
END ELSE
|
||||
WOMatRec<WO_MAT_EPOS_REP_WAFER_ID$,I> = ''
|
||||
END
|
||||
|
||||
MuWfrID = RECORD<WM_OUT_UMW_CASS_ID$,I>
|
||||
|
||||
IF MuWfrID NE '' THEN
|
||||
WOMatRec<WO_MAT_EPOS_MOVED_TO$,I> = MuWfrID[1,'.']:'.':FIELD(MuWfrID,'.',3):'.':RECORD<WM_OUT_UMW_SLOT_NO$,I>
|
||||
END ELSE
|
||||
WOMatRec<WO_MAT_EPOS_MOVED_TO$,I> = ''
|
||||
END
|
||||
|
||||
NEXT I
|
||||
|
||||
|
||||
WRITE WOMatRec ON WOMatFile,WOMatKey ELSE Null
|
||||
|
||||
|
||||
END ;* End of check for WM_OUT table
|
||||
|
||||
|
||||
|
||||
GOTO NEXT.FS
|
||||
|
||||
|
||||
* * * * * * *
|
||||
DELETE.RECORD:
|
||||
* * * * * * *
|
||||
|
||||
LOCATE Handle IN Handles_Array USING @FM SETTING POS ELSE
|
||||
mesg = "Missing file handle in DUEIN_MFS!|"
|
||||
mesg := handle
|
||||
MSG('',mesg)
|
||||
GOTO NEXT.FS
|
||||
END
|
||||
|
||||
FileName = Files_Array<POS>[1,'*'] ;* Extract corresponding file name
|
||||
|
||||
OPEN 'WO_MAT' TO WOMatFile ELSE
|
||||
MSG('',"Unable to Open 'WO_MAT' table in DueIn_MFS")
|
||||
GOTO NEXT.FS
|
||||
END
|
||||
|
||||
OrgRecord = ''
|
||||
NextFS = BFS<1,1,2>
|
||||
|
||||
CALL @NextFS(ReadRec$, FS, Handle, Name, FMC, OrgRecord, Status) ;* Read old record
|
||||
|
||||
WONo = Name[1,'*']
|
||||
WOStep = Name[COL2()+1,'*']
|
||||
CassNo = Name[COL2()+1,'*']
|
||||
|
||||
WOMatKey = WONo:'*':CassNo
|
||||
|
||||
READ WOMatRec FROM WOMatFile,WOMatKey THEN
|
||||
IF FileName = 'WM_IN' THEN
|
||||
WOMatRec<WO_MAT_WMI_CURR_STATUS$> = ''
|
||||
END
|
||||
|
||||
IF FileName = 'WM_OUT' THEN
|
||||
WOMatRec<WO_MAT_WMO_CURR_STATUS$> = ''
|
||||
END
|
||||
|
||||
WRITE WOMatRec ON WOMatFile,WOMatKey ELSE Null
|
||||
END ELSE
|
||||
*MSG('',"Unable to read 'WO_MAT' record ":QUOTE(WOMatKey):" in WM_MFS")
|
||||
GOTO NEXT.FS
|
||||
END
|
||||
|
||||
GOTO NEXT.FS
|
||||
|
||||
/* Unused calls */
|
||||
LOCK.RECORD:
|
||||
UNLOCK.RECORD:
|
||||
RESERVED:
|
||||
OMNI.SCRIPT:
|
||||
|
||||
CREATE.INDEX:
|
||||
DELETE.INDEX:
|
||||
SELECT.INDEX:
|
||||
UPDATE.INDEX:
|
||||
READNEXT.INDEX:
|
||||
|
||||
NEXT.FS:
|
||||
|
||||
FS = DELETE(BFS,1,1,1)
|
||||
NEXTFS = FS<1,1,1>
|
||||
CALL @NEXTFS(Code, FS, Handle, Name, FMC, Record, Status)
|
||||
RETURN
|
||||
|
||||
Reference in New Issue
Block a user