Module cWebApp.pkg
1//****************************************************************************//
2// //
3// $File name : WebApp.pkg //
4// $File title : WebApp Class (application "panel" class for entire app) //
5// $Author(s) : John Tuohy //
6// //
7// Confidential Trade Secret. //
8// Copyright 1999 Data Access Corporation, Miami FL, USA //
9// All Rights reserved //
10// DataFlex is a registered trademark of Data Access Corporation. //
11// //
12// $Rev History //
13// //
14// JJT 8/2/99 Created for Web App Studio // //
15// //
16//****************************************************************************//
17Use WebAppBase.pkg // Basic package support
18Use cVdfInternetSession.pkg // class support
19
20
21Type MEMORYSTATUS
22 Field MEMORYSTATUS.dwLength As Dword // sizeof(MEMORYSTATUS)
23 Field MEMORYSTATUS.dwMemoryLoad As Dword // percent of memory in use
24 Field MEMORYSTATUS.dwTotalPhys As Dword // bytes of physical memory
25 Field MEMORYSTATUS.dwAvailPhys As Dword // free physical memory bytes
26 Field MEMORYSTATUS.dwTotalPageFile As Dword // bytes of paging file
27 Field MEMORYSTATUS.dwAvailPageFile As Dword // free bytes of paging file
28 Field MEMORYSTATUS.dwTotalVirtual As Dword // user bytes of address space
29 Field MEMORYSTATUS.dwAvailVirtual As Dword // free user bytes
30End_Type // MEMORYSTATUS
31
32External_Function WNetGetUser "WNetGetUserA" MPR.DLL ;
33 Pointer lpName Pointer lpUser_Name Pointer lpLength Returns DWord
34
35External_Function GlobalMemoryStatus "GlobalMemoryStatus" Kernel32.Dll Pointer lpsMemoryStatus Returns Integer
36
37// values allowed for peAttachStatus.
38Enumeration_list
39 Define C_asUndefined
40 Define C_asAttaching
41 Define C_asDetaching
42 Define C_asAttached
43 Define C_asDetached
44End_Enumeration_list
45
46
47{ ClassLibrary=WebApp }
48{ ComponentType=WebAppClass }
49{ HelpTopic=cWebApp }
50Class cWebApp Is A cObject
51
52 Procedure Construct_Object
53 Integer iTemp
54 Handle hoCmdLine
55 Forward Send Construct_Object
56
57 { Category=Behavior }
58 { EnumList="C_asUndefined, C_asAttaching, C_asDetaching, C_asAttached, C_asDetached" }
59 Property integer peAttachStatus C_asUndefined
60
61 { Visibility=Private }
62 Property integer piXmlIndentCount 0
63
64
65 // When this object is created, we must already have an error handler object created.
66 // If this error is triggered, it's a programming mistake. In addition this error handler must
67 // understand a pre-defined set of messages (i.e. the handler must be based on cWebApperror). We
68 // do not check for that here. If an error handler exists, we assume you've provided the right one.
69 If (Error_object_id=0) Begin
70 Error DFERR_PROGRAM C_$MissingErrorHandlerObject
71 Abort
72 End
73
74 // An Application object must exist for WebApp to work. If missing, this is a fatal programming error
75 If (ghoApplication=0) Begin
76 Error DFERR_PROGRAM C_$MissingApplicationObject
77 Abort
78 End
79 // WebApp uses the command line object to process arguments. We will send countOfArgs
80 // to force the command-line object to get all arguments and load the in the object.
81 // This removes the argument...so you cannot use cmdline anywhere in a WebApp
82 Get phoCommandLine of ghoApplication To hoCmdLine
83 Get CountOfArgs of hoCmdLine to iTemp
84
85 Object oVDFInetSession is a cVDFInternetSession
86 End_Object
87
88
89 End_Procedure // Construct_Object
90
91 // Use to redirect html output for debugging purposes only.
92 // Legal values are: C_hoNormal C_hoFile C_hoConsole
93 // The values can be iORed together
94
95 { MethodType=Property }
96 { InitialValue=C_hoNormal }
97 { Category=Behavior }
98 Procedure Set peHtmlOutput integer iOutMode
99 Set peHtmlOutput of ghInetSession to iOutMode
100 End_Procedure
101
102 { MethodType=Property }
103 Function peHtmlOutput returns integer
104 Function_return (peHtmlOutput(ghInetSession))
105 End_Function
106
107 // return Id of WBP object for item
108 { MethodType=Property }
109 Function WBOHandle Integer iItem Returns Integer
110 Function_Return (Wpo_ID(ghInetSession,iItem))
111 End_Function
112
113 // get number of WBP items
114 { MethodType=Property }
115 Function WBOCount Returns integer
116 Function_Return (Wpo_Count(ghInetSession))
117 End_Function
118
119 Procedure EnumerateWBOs integer iMsg string sParam1 string sParam2 string sParam3
120 integer iCount iItem hWBO
121 Get WBOCount to iCount
122 For iItem from 0 to (iCount-1)
123 Get WBOHandle iItem to hWBO
124 Send iMsg to hWBO sParam1 sParam2 sParam3
125 Loop
126 End_Procedure
127
128 // return Id of WBP object for item
129 { MethodType=Property }
130 Function WSOHandle Integer iItem Returns Integer
131 Function_Return (Wso_ID(ghInetSession,iItem))
132 End_Function
133
134 // get number of WSO items
135 { MethodType=Property }
136 Function WSOCount Returns integer
137 Function_Return (Wso_Count(ghInetSession))
138 End_Function
139
140 Procedure EnumerateWSOs integer iMsg string sParam1 string sParam2 string sParam3
141 integer iCount iItem hWBO
142 Get WSOCount to iCount
143 For iItem from 0 to (iCount-1)
144 Get WSOHandle iItem to hWBO
145 Send iMsg to hWBO sParam1 sParam2 sParam3
146 Loop
147 End_Procedure
148
149
150 //
151 // Interface to support attaching and detaching WBOs and WebApps from sessions
152 //
153
154 // Clear the contents of all open files, except system files
155 Procedure DoDetachAllTables
156 integer hFile bIsSys
157 move 0 to hFile
158 repeat
159 get_Attribute DF_FILE_NEXT_OPENED of hFile to hFile
160 if (hFile>0) Begin
161 Get_Attribute DF_FILE_IS_SYSTEM_FILE of hFile to bIsSys
162 If not bIsSys Clear hFile // do not clear system files
163 End
164 until (hFile=0)
165 End_Procedure
166
167 { MethodType=Event }
168 Procedure OnDetachProcess
169 End_procedure
170
171 { Visibility=Private }
172 Procedure DoDetachProcess
173 integer i iWBOs eAttachStatus
174 integer bOldQueueErrors bOldAllErrorsToHtml
175 Handle hWBO
176 Integer eWebAppEndPointEnvironment
177 Get CurrentWebAppEnvironment of ghInetSession to eWebAppEndPointEnvironment
178
179 // if web service, don't do any kind of attach/detatch
180 If (eWebAppEndPointEnvironment=WebAppEnvWebService) Begin
181 Set peAttachStatus to C_asDetached
182 Procedure_Return
183 end
184
185 // Set error handling settings to report all errors, but not to html
186 Get pbAllErrorsToHtml of ghInetSession to bOldAllErrorsToHtml
187 Get pbQueueErrors of ghInetSession to bOldQueueErrors
188 Set pbAllErrorsToHtml of ghInetSession to False // no error output to html
189 Set pbQueueErrors of ghInetSession to False // do not queue errors, report them.
190
191 // the status before a detach should always C_asAttached. Check
192 Get peAttachStatus to eAttachStatus
193 If (eAttachStatus<>C_asAttached) ;
194 Send LogEvent 101 (SFormat(C_$WrongDoDetachStatus, eAttachStatus))
195
196 Set peAttachStatus to C_asDetaching
197 // User hook
198 Send OnDetachProcess
199 // send DoDetachProcess to all WBOs
200 Get WBOCount to iWBOs
201 decrement iWBOs
202 for i from 0 to iWBOs
203 Get WBOHandle i to hWBO
204 Send DoDetachProcess of hWBO
205 Loop
206 // Clear all of the open datafiles
207 Send DoDetachAllTables
208 Set peAttachStatus to C_asDetached
209
210 // restore error handling settings
211 Set pbQueueErrors of ghInetSession to bOldQueueErrors
212 Set pbAllErrorsToHtml of ghInetSession to bOldAllErrorsToHtml
213
214 End_procedure
215
216 { MethodType=Event }
217 Procedure OnAttachProcess
218 End_procedure
219
220
221 { Visibility=Private }
222 Procedure DoAttachProcess
223 integer i iWBOs eAttachStatus
224 integer bOldQueueErrors bOldAllErrorsToHtml
225 Handle hWBO
226 Integer eWebAppEndPointEnvironment
227 Get CurrentWebAppEnvironment of ghInetSession to eWebAppEndPointEnvironment
228
229 // if web service, don't do any kind of attach/detatch
230 If (eWebAppEndPointEnvironment=WebAppEnvWebService) Begin
231 Set peAttachStatus to C_asAttached
232 Procedure_Return
233 end
234
235
236 // Set error handling settings to report all errors, but not to html
237 Get pbAllErrorsToHtml of ghInetSession to bOldAllErrorsToHtml
238 Get pbQueueErrors of ghInetSession to bOldQueueErrors
239 Set pbAllErrorsToHtml of ghInetSession to False // no error output to html
240 Set pbQueueErrors of ghInetSession to False // do not queue errors, report them.
241
242 // the status before an attach should always C_asDetached or C_asUndefined.
243 // as of 12.1, if this fails, it is fatal. Attaching to a process that thinks it is
244 // still attached indicates something is very wrong. The process should be killed.
245 // Note that we allow bad status during a detach because that will get corrected or
246 // aborted if it tries to do another attach.
247 Get peAttachStatus to eAttachStatus
248 If (eAttachStatus<>C_asDetached and eAttachStatus<>C_asUndefined) Begin
249 Send LogEvent 102 (SFormat(C_$WrongDoAttachStatus, eAttachStatus))
250 Abort
251 End
252
253 Set peAttachStatus to C_asAttaching
254 // send DoAttachProcess to all WBOs
255 Get WBOCount to iWBOs
256 decrement iWBOs
257 for i from 0 to iWBOs
258 Get WBOHandle i to hWBO
259 Send DoAttachProcess of hWBO
260 Loop
261 // User hook
262 Send OnAttachProcess
263 Set peAttachStatus to C_asAttached
264
265 // restore error handling settings
266 Set pbQueueErrors of ghInetSession to bOldQueueErrors
267 Set pbAllErrorsToHtml of ghInetSession to bOldAllErrorsToHtml
268
269 End_procedure
270
271 procedure TrapError integer iError
272 send TrapError of Error_Object_id iError
273 end_procedure
274
275 procedure IgnoreError integer iError
276 send IgnoreError of Error_Object_id iError
277 end_procedure
278
279 procedure TrapAllErrors
280 send TrapAllerrors of Error_Object_id
281 end_procedure
282
283
284 Procedure LogEvent Integer iEventType String lpszEvent
285 if (ghInetSession>0) ;
286 Send LogEvent of ghInetSession iEventType lpszEvent
287 End_Procedure
288
289
290 // This provides all of the support for generating an XML WebApp document
291 // and for generating the text file (WebApp.txt). These messages are all private
292 // and are never used for a running webappe.
293
294 { Visibility=Private }
295 Procedure Add_Line String sVal
296 WriteLn sVal
297 End_Procedure // Add_Line
298
299
300 { Visibility=Private }
301 Procedure DoPublishInterface integer iPublishMode
302 Send EnumerateWBOs msg_DoPublishInterface iPublishMode "" ""
303 End_Procedure
304
305 { Visibility=Private }
306 Procedure Begin_XML_Tag string sTag
307 integer i
308 Get piXmlIndentCount to i
309 WriteLn (Repeat(" ",i)+"<"+sTag+">")
310 Set piXmlIndentCount to (i+1)
311 End_Procedure
312
313 { Visibility=Private }
314 Procedure End_XML_Tag string sTag
315 integer i
316 Get piXmlIndentCount to i
317 Decrement i
318 Set piXmlIndentCount to i
319 WriteLn (Repeat(" ",i)+"+sTag+">")
320 End_Procedure
321
322 { Visibility=Private }
323 Procedure Add_XML_Tag string sTag string sData string sElement
324 integer i
325 string sEle
326 If (Num_arguments>2) Move sElement to sEle
327 Get piXmlIndentCount to i
328 WriteLn (Repeat(" ",i) + "<" + sTag * sEle - ">" + htmlEncode(sData) + " + sTag + ">")
329 End_Procedure
330
331 { Visibility=Private }
332 Procedure Add_XML_Closed_Tag string sTag string sElement
333 integer i
334 string sEle
335 If (Num_arguments>1) Move sElement to sEle
336 Get piXmlIndentCount to i
337 WriteLn (Repeat(" ",i) + "<" + sTag * sEle - "/>")
338 End_Procedure // Add_XML_Closed_Tag
339
340
341 // ShowXMLRequests
342 // ---------------
343 // This method writes the Requestxxx method interface to WebApp.xml
344
345 { Visibility=Private }
346 Procedure ShowXMLRequests
347 // RequestClear
348 // ~~~~~~~~~~~~ // <Request>
349 Send Begin_XML_Tag 'Request RequestType="get"'
350 Send Add_XML_Tag 'RequestName' 'requestClear'
351 Send Add_XML_Tag 'RequestDescription' 'Clears a the passed table and all its parent DDOs.'
352 Send Begin_XML_Tag 'Params' // <Params>
353
354 // Parameter 1: sTable // <Param>
355 Send Begin_XML_Tag 'Param ParamType="ptTableName"'
356 Send Add_XML_Tag 'ParamName' 'sTable'
357 Send Add_XML_Tag 'ParamDescription' 'Name of the table to clear'
358 Send End_XML_Tag 'Param' // </Param>
359
360 // Parameter 1: bClearAll // <Param>
361 Send Begin_XML_Tag 'Param ParamType="ptBoolean"'
362 Send Add_XML_Tag 'ParamName' 'bClearAll'
363 Send Add_XML_Tag 'ParamDescription' 'Boolean value indicating if a clear or clear-all should be executed.'
364 Send End_XML_Tag 'Param' // </Param>
365 Send End_XML_Tag 'Params' // </Params>
366 Send End_XML_Tag 'Request' // </Request>
367
368 // RequestDDUpdate
369 // ~~~~~~~~~~~~~~~ // <Request>
370 Send Begin_XML_Tag 'Request RequestType="get"'
371 Send Add_XML_Tag 'RequestName' 'requestDDUpdate'
372 Send Add_XML_Tag 'RequestDescription' 'Requests an update and validation for the passed table and all its parents.'
373 Send Begin_XML_Tag 'Params' // <Params>
374
375 // Parameter 1: sTable // <Param>
376 Send Begin_XML_Tag 'Param ParamType="ptTableName"'
377 Send Add_XML_Tag 'ParamName' 'sTable'
378 Send Add_XML_Tag 'ParamDescription' 'Name of the table to update'
379 Send End_XML_Tag 'Param' // </Param>
380
381 // Parameter 2: bShowErrors // <Param>
382 Send Begin_XML_Tag 'Param ParamType="ptBoolean"'
383 Send Add_XML_Tag 'ParamName' 'bShowErrors'
384 Send Add_XML_Tag 'ParamDescription' 'Boolean value indicating if appropriate error messages will be displayed to the HTML Page.'
385 Send End_XML_Tag 'Param' // </Param>
386 Send End_XML_Tag 'Params' // </Params>
387 Send End_XML_Tag 'Request' // </Request>
388
389 // RequestDelete
390 // ~~~~~~~~~~~~~ // <Request>
391 Send Begin_XML_Tag 'Request RequestType="get"'
392 Send Add_XML_Tag 'RequestName' 'requestDelete'
393 Send Add_XML_Tag 'RequestDescription' 'Requests an attempt to delete the current row of the passed table.'
394 Send Begin_XML_Tag 'Params' // <Params>
395
396 // Parameter 1: sTable // <Param>
397 Send Begin_XML_Tag 'Param ParamType="ptTableName"'
398 Send Add_XML_Tag 'ParamName' 'sTable'
399 Send Add_XML_Tag 'ParamDescription' 'Name of the table to delete its current row'
400 Send End_XML_Tag 'Param' // </Param>
401 Send End_XML_Tag 'Params' // </Params>
402 Send End_XML_Tag 'Request' // </Request>
403
404 // RequestFind
405 // ~~~~~~~~~~~ // <Request>
406 Send Begin_XML_Tag 'Request RequestType="get"'
407 Send Add_XML_Tag 'RequestName' 'requestFind'
408 Send Add_XML_Tag 'RequestDescription' 'Finds a row in the passed table.'
409 Send Begin_XML_Tag 'Params' // <Params>
410
411 // Parameter 1: sTable // <Param>
412 Send Begin_XML_Tag 'Param ParamType="ptTableName"'
413 Send Add_XML_Tag 'ParamName' 'sTable'
414 Send Add_XML_Tag 'ParamDescription' 'Name of the table to find row'
415 Send End_XML_Tag 'Param' // </Param>
416
417 // Parameter 2: iIndex // <Param>
418 Send Begin_XML_Tag 'Param ParamType="ptUnspecified"'
419 Send Add_XML_Tag 'ParamName' 'iIndex'
420 Send Add_XML_Tag 'ParamDescription' 'Determines the find index.'
421 Send Begin_XML_Tag 'ParamValues' // <ParamValues>
422 Send Add_XML_Tag 'ParamValue' '1'
423 Send Add_XML_Tag 'ParamValue' '2'
424 Send Add_XML_Tag 'ParamValue' '3'
425 Send Add_XML_Tag 'ParamValue' '4'
426 Send Add_XML_Tag 'ParamValue' '5'
427 Send Add_XML_Tag 'ParamValue' '6'
428 Send Add_XML_Tag 'ParamValue' '7'
429 Send Add_XML_Tag 'ParamValue' '8'
430 Send Add_XML_Tag 'ParamValue' '9'
431 Send Add_XML_Tag 'ParamValue' '10'
432 Send Add_XML_Tag 'ParamValue' '11'
433 Send Add_XML_Tag 'ParamValue' '12'
434 Send Add_XML_Tag 'ParamValue' '13'
435 Send Add_XML_Tag 'ParamValue' '14'
436 Send Add_XML_Tag 'ParamValue' '15'
437 Send Add_XML_Tag 'ParamValue' '16'
438 Send Add_XML_Tag 'ParamValue' '0'
439 Send End_XML_Tag 'ParamValues' // </ParamValues>
440 Send End_XML_Tag 'Param' // </Param>
441
442 // Parameter 3: iMode // <Param>
443 Send Begin_XML_Tag 'Param ParamType="ptUnspecified"'
444 Send Add_XML_Tag 'ParamName' 'iMode'
445 Send Add_XML_Tag 'ParamDescription' 'Determines the find mode.'
446 Send Begin_XML_Tag 'ParamValues' // <ParamValues>
447 Send Add_XML_Tag 'ParamValue' 'LT'
448 Send Add_XML_Tag 'ParamValue' 'LE'
449 Send Add_XML_Tag 'ParamValue' 'EQ'
450 Send Add_XML_Tag 'ParamValue' 'GE'
451 Send Add_XML_Tag 'ParamValue' 'GT'
452 Send Add_XML_Tag 'ParamValue' 'NEXT_RECORD'
453 Send Add_XML_Tag 'ParamValue' 'FIRST_RECORD'
454 Send Add_XML_Tag 'ParamValue' 'LAST_RECORD'
455 Send End_XML_Tag 'ParamValues' // </ParamValues>
456 Send End_XML_Tag 'Param' // </Param>
457 Send End_XML_Tag 'Params' // </Params>
458 Send End_XML_Tag 'Request' // </Request>
459
460 // RequestFindByRecId
461 // ~~~~~~~~~~~~~~~~~~ // <Request>
462 Send Begin_XML_Tag 'Request RequestType="get"'
463 Send Add_XML_Tag 'RequestName' 'requestFindByRecId'
464 Send Add_XML_Tag 'RequestDescription' 'Finds the row for the passed table name and row ID.'
465 Send Begin_XML_Tag 'Params' // <Params>
466
467 // Parameter 1: sTable // <Param>
468 Send Begin_XML_Tag 'Param ParamType="ptTableName"'
469 Send Add_XML_Tag 'ParamName' 'sTable'
470 Send Add_XML_Tag 'ParamDescription' 'Name of the table to find the row'
471 Send End_XML_Tag 'Param' // </Param>
472
473 // Parameter 2: bShowErrors // <Param>
474 Send Begin_XML_Tag 'Param ParamType="ptUnspecified"'
475 Send Add_XML_Tag 'ParamName' 'iRowID'
476 Send Add_XML_Tag 'ParamDescription' 'Row number to be found.'
477 Send End_XML_Tag 'Param' // </Param>
478 Send End_XML_Tag 'Params' // </Params>
479 Send End_XML_Tag 'Request' // </Request>
480
481 // RequestSave
482 // ~~~~~~~~~~~ // <Request>
483 Send Begin_XML_Tag 'Request RequestType="get"'
484 Send Add_XML_Tag 'RequestName' 'requestSave'
485 Send Add_XML_Tag 'RequestDescription' 'Saves a row in the passed table and all its parents.'
486 Send Begin_XML_Tag 'Params' // <Params>
487
488 // Parameter 1: sTable // <Param>
489 Send Begin_XML_Tag 'Param ParamType="ptTableName"'
490 Send Add_XML_Tag 'ParamName' 'sTable'
491 Send Add_XML_Tag 'ParamDescription' 'Name of the table to perfom a save.'
492 Send End_XML_Tag 'Param' // </Param>
493 Send End_XML_Tag 'Params' // </Params>
494 Send End_XML_Tag 'Request' // </Request>
495 End_Procedure // ShowXMLRequests
496
497 // ShowXmlWebApp.dtd
498 // -----------------
499 // Inserts the usr\Global\Data\WebApp.dtd file into the WebApp.xml
500
501 { Visibility=Private }
502 Procedure ShowXmlWebApp.dtd
503 String sVdfRootDir
504 String sExclamation
505 String sInline
506
507 // Initialize Local variables......................
508 Move (Character(33)) To sExclamation
509
510 Get_Profile_String "Defaults" "VDFRootDir" To sVDFRootDir
511 If (Right(sVDFRootDir,1) = "\") Begin
512 Left sVDFRootDir To sVDFRootDir (Length(sVDFRootDir)-1)
513 End
514 Writeln ('<' - sExclamation - 'DOCTYPE WebApp [') // Open the dtd section
515
516 // Start inputting the WebApp.xml.................
517 Direct_Input (sVdfRootDir +'\Usr\Global\Data\WebApp.dtd')
518 While (not(Seqeof))
519 Readln sInLine
520 If (not(Seqeof)) Begin
521 // Make sure we don't re-insert the
522 // xml version stuff......................
523 If (Uppercase(Left(sInLine,14)) <> ") Begin
524 Writeln sInLine
525 End
526 End
527 Loop
528
529 Close_Input
530
531 Writeln ']>' // Close the dtd section
532 End_Procedure // ShowXmlWebApp.dtd
533
534
535 // ShowXMLWebAppInfo
536 // -----------------
537
538 { Visibility=Private }
539 Procedure ShowXMLWebAppInfo
540 integer iCount iItem hWBO
541 Boolean bFileExists
542
543 String sExclamation
544 String sVdfRootDir
545
546 // Initialize Local variables......................
547 Move (Character(33)) To sExclamation
548 Get_Profile_String "Defaults" "VDFRootDir" To sVDFRootDir
549 If (Right(sVDFRootDir,1) = "\") Begin
550 Left sVDFRootDir To sVDFRootDir (Length(sVDFRootDir)-1)
551 End
552 // Start Outputting the WebApp.xml.................
553 Direct_Output "WebApp.xml"
554
555 WriteLn ('')
556
557 // Test if the WebApp.dtd can be embedded?.........
558 File_Exist (sVdfRootDir +'\Usr\Global\Data\WebApp.dtd') bFileExists
559 If (bFileExists) Send ShowXmlWebApp.dtd
560 Else Writeln ('<' - sExclamation - 'DOCTYPE WebApp SYSTEM "WebApp.dtd">')
561
562 // Output the rest of the WebApp.xml...............
563 Send Begin_XML_Tag "WebApp" // <WebApp>
564 Send Begin_XML_Tag "DocSettings" // <DocSettings>
565 Send Add_XML_Tag "DTDVersion" "1.1"
566 Send End_XML_Tag "DocSettings" // </DocSettings>
567
568 Send Begin_XML_Tag "ApplicationInfo" // <ApplicationInfo>
569 Send Add_XML_Tag "Label" (psWorkspaceName(phoWorkspace(ghoApplication)) * "-" * psProduct(ghoApplication) * psVersion(ghoApplication))
570 Send Add_XML_Tag "Description" (psDescription(phoWorkspace(ghoApplication)))
571 Send Add_XML_Tag "Product" (psProduct(ghoApplication))
572 Send Add_XML_Tag "Copyright" "Not Used"
573 Send Add_XML_Tag "Version" (psVersion(ghoApplication))
574 Send Add_XML_Tag "Author" (psCompany(ghoApplication))
575 Send Add_XML_Tag "TableColumnDelimiter" "__"
576 Send End_XML_Tag "ApplicationInfo" // </ApplicationInfo>
577
578 Get WBOCount to iCount
579
580 If (iCount > 0) Begin
581 Send Begin_XML_Tag "WBOs" // <WBOs> (0 or 1)
582 For iItem from 0 to (iCount-1)
583 Get WBOHandle iItem to hWBO
584 Send Begin_XML_Tag "WBO" // <WBO> (1 or more)
585 Send ShowXML to hWBO Self
586 Send End_XML_Tag "WBO" // </WBO>
587 Loop
588 Send End_XML_Tag "WBOs" // </WBOs>
589 End // If there are any WBOs
590
591 Send Begin_XML_Tag "Requests" // <Requests>
592 Send ShowXMLRequests
593 Send End_XML_Tag "Requests" // </Requests>
594 Send End_XML_Tag "WebApp" // </WebApp>
595 Close_Output
596 End_Procedure // ShowXMLWebAppInfo
597
598 Procedure DoInterfaceReport
599 Send ShowXMLWebAppInfo
600 End_procedure
601
602
603 { Visibility=Private }
604 Procedure Show_Current_Directory
605 String sDir
606
607 Get_Current_Directory To sDir
608 Send Add_Line (SFormat(C_$CurrentDirectory, sDir))
609 End_Procedure // Show_Current_Directory
610
611 { Visibility=Private }
612 Procedure Show_Windows_Directory
613 String sWindir
614
615 Get_Windows_Directory To sWindir
616 Send Add_Line (SFormat(C_$WindowsDirectory, sWindir))
617 End_Procedure // Show_Windows_Directory
618
619 { Visibility=Private }
620 Function BuildInformation returns string
621 Handle hoVersionInfo
622 Boolean bIncluded
623 Integer iMajor iMinor iRelease iBuild
624 String sBuild
625 Get phoVersionInfo of ghoApplication To hoVersionInfo
626 Get pbIncluded of hoVersionInfo To bIncluded
627 If bIncluded Begin
628 Get piVersionMajor of hoVersionInfo To iMajor
629 Get piVersionMinor of hoVersionInfo To iMinor
630 Get piVersionRelease of hoVersionInfo To iRelease
631 Get piVersionBuild of hoVersionInfo To iBuild
632 Move (SFormat("%1.%2.%3.%4", iMajor, iMinor, iRelease, iBuild)) to sBuild
633 End
634 Function_return sBuild
635 End_Procedure
636
637 // This function reads the current username of windows and returns that
638 // name or an text unknown user
639 { Visibility=Private }
640 Function Network_User_Name Returns String
641 String sName sLength
642 Pointer lpName_Addr lpLength_Addr
643 Integer iRetval
644
645 Move (Repeat (Character (0), 255)) To sName
646 GetAddress Of sName To lpName_Addr
647 Move (DwordToBytes (255)) To sLength
648 GetAddress Of sLength To lpLength_Addr
649
650 Move (WNetGetUser (0, lpName_Addr, lpLength_Addr)) To iRetval
651
652 If (iRetval=0) Function_Return (CString (sName))
653 Else Function_Return "?????"
654 End_Function // Network_User_Name
655
656 { Visibility=Private }
657 Procedure Show_Current_User
658 Send Add_Line (SFormat(C_$NetworkUserName, Network_User_Name(self)))
659 End_Procedure // Show_Current_User
660
661 { Visibility=Private }
662 Procedure Show_Number_Format
663 Integer iFormat
664
665 Get_Attribute Df_Thousands_Separator To iFormat
666 Send Add_Line (SFormat(C_$ThousandsSeparator, Character(iFormat), iFormat))
667 Get_Number_Format To iFormat
668 Send Add_Line (SFormat(C_$DecimalSeparator, If (iFormat = 0, ".", ",")))
669 End_Procedure // Show_Number_Format
670
671 { Visibility=Private }
672 Procedure Show_Filelist_Name
673 String sFilename
674
675 Get_Attribute Df_Filelist_Name To sFilename
676 Send Add_Line (SFormat(C_$CurrentFilelist, sFilename))
677 End_Procedure // Show_Filelist_Name
678
679 { Visibility=Private }
680 Procedure Show_Lock_Delay
681 Integer iLockdelay
682
683 Get_Attribute Df_Lock_Delay To iLockdelay
684 Send Add_Line (SFormat(C_$DatabaseLockingDelay, iLockDelay))
685 End_Procedure // Show_Lock_Delay
686
687 { Visibility=Private }
688 Procedure Show_Lock_Timeout
689 Integer iLockTimeout
690
691 Get_Attribute Df_Lock_Timeout To iLockTimeout
692 Send Add_Line (SFormat(C_$DatabaseLockingTimeout, iLockTimeOut))
693 End_Procedure // Show_Lock_Timeout
694
695 { Visibility=Private }
696 Procedure Show_Date
697 Date dToday
698
699 Sysdate4 dToday
700 Send Add_Line (SFormat(C_$CurrentSystemDate, String(dToday)))
701 End_procedure // Show_Date
702
703 { Visibility=Private }
704 Procedure Show_Date_Format
705 Integer iDateFormat
706 String sDateFormat
707
708 Get_Attribute Df_Date_Format To iDateFormat
709 Case Begin
710 Case (iDateFormat=DF_DATE_USA) Move C_$USA To sDateFormat
711 Case (iDateformat=DF_DATE_EUROPEAN) Move C_$European To sDateFormat
712 Case (iDateformat=DF_DATE_MILITARY) Move C_$Military To sDateFormat
713 Case Else Move C_$UnknownDateType To sDateFormat
714 Case End
715 Send Add_Line (SFormat(C_$DateFormat, sDateformat))
716 End_Procedure // Show_Date_Format
717
718 { Visibility=Private }
719 Procedure Show_Memavail
720 Integer iMem
721
722 Memory iMem
723 Send Add_Line (SFormat(C_$AvailableMemory, iMem))
724 End_Procedure // Show_Memavail
725
726 { Visibility=Private }
727 Procedure Show_Systemresources
728 String sMemoryStatus
729 Pointer lpsMemoryStatus
730 Integer iVoid
731 Dword dwMemoryLoad dwTotalPhys dwAvailPhys dwTotalPageFile dwAvailPageFile dwTotalVirtual dwAvailVirtual
732
733 ZeroType MEMORYSTATUS To sMemoryStatus
734 GetAddress Of sMemoryStatus To lpsMemoryStatus
735
736 Moveint (GlobalMemoryStatus (lpsMemoryStatus)) To iVoid
737
738 GetBuff From sMemoryStatus At MEMORYSTATUS.dwMemoryLoad To dwMemoryLoad
739 GetBuff From sMemoryStatus At MEMORYSTATUS.dwTotalPhys To dwTotalPhys
740 GetBuff From sMemoryStatus At MEMORYSTATUS.dwAvailPhys To dwAvailPhys
741 GetBuff From sMemoryStatus At MEMORYSTATUS.dwTotalPageFile To dwTotalPageFile
742 GetBuff From sMemoryStatus At MEMORYSTATUS.dwAvailPageFile To dwAvailPageFile
743 GetBuff From sMemoryStatus At MEMORYSTATUS.dwTotalVirtual To dwTotalVirtual
744 GetBuff From sMemoryStatus At MEMORYSTATUS.dwAvailVirtual To dwAvailVirtual
745
746 Send Add_Line (SFormat(C_$MemoryUtilization, dwMemoryLoad))
747 Send Add_Line (SFormat(C_$AvailablePhysicalMemory, dwAvailPhys / dwTotalPhys * 100.0))
748 Send Add_Line (SFormat(C_$AvailablePagefileSpace, dwAvailPageFile / dwTotalPageFile * 100.0))
749 Send Add_Line (SFormat(C_$AvailableVirtualMemory, dwAvailVirtual / dwTotalVirtual * 100.0))
750 End_Procedure // Show_Systemresources
751
752 { Visibility=Private }
753 Procedure Show_Registration
754 String sRegName
755 Integer iSN
756 Registration sRegName iSN
757
758 Send Add_Line (SFormat(C_$Serial, iSN))
759 Send Add_Line (SFormat(C_$RegName, sRegName))
760 End_Procedure // Show_Current_Directory
761
762 //****************************************************************************
763 // We will send the message EnumerateWorkspaceData
764 // to the workspace object passing the an object and message to send back
765 // to this object. It is expected that the workspace object will send this
766 // message for every line of information it wants displayed (passing the
767 // information to be displayed
768 //****************************************************************************
769
770 register_procedure EnumerateWorkspaceData integer hObjId integer hmMessId
771
772 { Visibility=Private }
773 Procedure Show_WorkspaceInformation
774 Send EnumerateWorkspaceData of (phoWorkspace(ghoApplication)) self Msg_add_Line
775 End_Procedure
776
777 { Visibility=Private }
778 Function VersionStr integer iVer integer iRev integer iBld Returns string
779 Function_Return (string(iVer)-"."-string(iRev)-"."-string(iBld))
780 End_Function
781
782 { Visibility=Private }
783 Procedure Show_Versions
784 Integer iVersion iRevision iBuild
785 Version_information iVersion iRevision iBuild
786 Send Add_Line (SFormat(C_$RuntimeVersion, VersionStr(self,iVersion,iRevision,iBuild) ))
787 Send Add_Line (SFormat(C_$PackageVersion, VersionStr(self,PKG_VERSION, PKG_REVISION, PKG_BUILD) ))
788 Send Add_Line (SFormat(C_$FMACVersion, VersionStr(self,FMAC_VERSION, FMAC_REVISION, FMAC_BUILD) ))
789 End_Procedure
790
791
792 { Visibility=Private }
793 Procedure Show_Drivers
794 String Current_drvr
795 String Loadeddrvrs
796 Integer Number_of_drvrs
797 Integer Count
798
799 Move "" To Loadeddrvrs
800 Get_attribute DF_NUMBER_DRIVERS To Number_of_drvrs
801 For Count From 1 To Number_of_drvrs
802 Get_attribute DF_DRIVER_NAME Of Count To Current_drvr
803 If (Loadeddrvrs <> "") ;
804 Move (Append(Loadeddrvrs, ", ")) To Loadeddrvrs
805 Move (Append(Loadeddrvrs, Current_drvr)) To Loadeddrvrs
806 Loop
807 Send Add_Line (SFormat(C_$DatabaseDriver, Loadeddrvrs))
808 End_Procedure // Show_Drivers
809
810 { Visibility=Private }
811 Procedure ShowWebAppInfo
812 integer iCount iItem hWBO
813
814 Send Add_Line ("WebApp in Workspace:" * psWorkspaceName(phoWorkspace(ghoApplication)) * "-" * psDescription(phoWorkspace(ghoApplication)))
815 Send Add_Line ''
816 Send Add_line (psProduct(ghoApplication))
817 Send Add_line (psProgram(ghoApplication))
818 Send Add_line (C_$Version + ":" * psVersion(ghoApplication))
819 Send Add_line (C_$Build + ":" * BuildInformation(self))
820 Send Add_line (C_$Company + ":" * psCompany(ghoApplication))
821 Send Add_line ''
822
823 Get WBOCount to iCount
824 Send Add_Line C_$WebBusinessObjects
825 For iItem from 0 to (iCount-1)
826 Get WBOHandle iItem to hWBO
827 Send Add_Line (' ' + Object_Label(hWBO) * "-" * psDescription(hWBO) )
828 Loop
829 Send Add_line ''
830 End_Procedure
831
832 { Visibility=Private }
833 Procedure BuildSysInfoList
834
835 Direct_Output "WebApp.txt"
836
837 Send ShowWebAppInfo
838
839 register_procedure showWBOData
840 Send EnumerateWBOs msg_ShowWBOData self msg_add_Line 0
841
842 Send Show_WorkSpaceInformation // added to show WS info
843 Send Show_Drivers
844 Send Show_Current_User
845 Send Show_Windows_Directory
846 Send Show_Current_Directory
847 Send Show_Filelist_Name
848 Send Show_Registration
849 Send Show_Versions
850 Send Show_Memavail
851 Send Show_Number_Format
852 Send Show_Date_Format
853 Send Show_Lock_Delay
854 Send Show_Lock_Timeout
855 Send Show_Date
856 Send Show_Systemresources
857 Close_Output
858 End_Procedure
859
860
861 // This is what makes things happen.
862
863 // CmdLine Options:
864 // -x output XmlInterface, output txt interface
865 // If none, run app normally
866 //
867 Procedure StartWebApp
868 String sArg
869 Handle hoCmdLine
870 Integer i iArgs
871 Boolean bDoInterface
872 // read all cmdline arguments and see if any is a -x for do interface
873 Get phoCommandLine of ghoApplication To hoCmdLine
874 Get CountOfArgs of hoCmdLine to iArgs
875 For i from 1 to iArgs
876 Get Argument of hoCmdLine i to sArg
877 If (lowercase(trim(sArg))='-x') Move True to bDoInterface
878 Loop
879
880 If bDoInterface begin
881 Send DoInterfaceReport // writes out webApp.xml
882 Send BuildSysInfoList // writes out webApp.txt
883 End
884 Else Begin
885 // we create the com object as late as possible.
886 Send CreateComObject of ghInetSession
887 // This tells the error object that the WebApp Com object is now ready
888 // and can be used to handle errors.
889 Set phoInetSession of error_object_id to ghInetSession
890 Start_webApp
891 End
892 End_procedure
893
894
895End_Class
896
897
898
899