1//Source of this test file: https://github.com/patrickTingen/DataDigger/blob/master/DataDiggerLib.p
2&ANALYZE-SUSPEND _VERSION-NUMBER AB_v10r12
3&ANALYZE-RESUME
4&ANALYZE-SUSPEND _UIB-CODE-BLOCK _CUSTOM _DEFINITIONS Procedure
5/*------------------------------------------------------------------------
6
7 Name: DataDiggerLib.p
8 Desc: Library for DataDigger functions
9
10------------------------------------------------------------------------*/
11/* This .W file was created with the Progress AppBuilder. */
12/*----------------------------------------------------------------------*/
13DEFINE VARIABLE gcSaveDatabaseList AS CHARACTER NO-UNDO.
14DEFINE VARIABLE giDataserverNr AS INTEGER NO-UNDO. /* [JAG 01-11-2019] */
15DEFINE VARIABLE glDirtyCache AS LOGICAL NO-UNDO.
16
17/* Buildnr, temp-tables and forward defs */
18{ DataDigger.i }
19
20PROCEDURE GetUserNameA EXTERNAL "ADVAPI32.DLL":
21 DEFINE INPUT PARAMETER mUserId AS MEMPTR NO-UNDO.
22 DEFINE INPUT-OUTPUT PARAMETER intBufferSize AS LONG NO-UNDO.
23 DEFINE RETURN PARAMETER intResult AS SHORT NO-UNDO.
24END PROCEDURE.
25
26/* Detect bitness of running Progress version
27 * See Progress kb #54631
28 */
29&IF PROVERSION <= '8' &THEN /* OE 10+ */
30 &IF PROVERSION >= '11.3' &THEN /* PROCESS-ARCHITECTURE function is available */
31 &IF PROCESS-ARCHITECTURE = 32 &THEN /* 32-bit pointers */
32 &GLOBAL-DEFINE POINTERTYPE LONG
33 &GLOBAL-DEFINE POINTERBYTES 4
34 &ELSEIF PROCESS-ARCHITECTURE = 64 &THEN /* 64-bit pointers */
35 &GLOBAL-DEFINE POINTERTYPE INT64
36 &GLOBAL-DEFINE POINTERBYTES 8
37 &ENDIF /* PROCESS-ARCHITECTURE */
38 &ELSE /* Can't check architecture pre-11.3 so default to 32-bit */
39 &GLOBAL-DEFINE POINTERTYPE LONG
40 &GLOBAL-DEFINE POINTERBYTES 4
41 &ENDIF /* PROVERSION > 11.3 */
42&ELSE /* pre-OE10 always 32-bit on Windows */
43 &GLOBAL-DEFINE POINTERTYPE LONG
44 &GLOBAL-DEFINE POINTERBYTES 4
45&ENDIF /* PROVERSION < 8 */
46
47PROCEDURE GetKeyboardState EXTERNAL "user32.dll":
48 DEFINE INPUT PARAMETER KBState AS {&POINTERTYPE}. /* memptr */
49 DEFINE RETURN PARAMETER RetVal AS LONG. /* bool */
50END PROCEDURE.
51
52/* Windows API entry point */
53PROCEDURE ShowScrollBar EXTERNAL "user32.dll":
54 DEFINE INPUT PARAMETER hwnd AS LONG.
55 DEFINE INPUT PARAMETER fnBar AS LONG.
56 DEFINE INPUT PARAMETER fShow AS LONG.
57 DEFINE RETURN PARAMETER ReturnValue AS LONG.
58END PROCEDURE.
59
60PROCEDURE SendMessageA EXTERNAL "user32.dll":
61 DEFINE INPUT PARAMETER hwnd AS long NO-UNDO.
62 DEFINE INPUT PARAMETER wmsg AS long NO-UNDO.
63 DEFINE INPUT PARAMETER wparam AS long NO-UNDO.
64 DEFINE INPUT PARAMETER lparam AS long NO-UNDO.
65 DEFINE RETURN PARAMETER rc AS long NO-UNDO.
66END PROCEDURE.
67
68PROCEDURE RedrawWindow EXTERNAL "user32.dll":
69 DEFINE INPUT PARAMETER v-hwnd AS LONG NO-UNDO.
70 DEFINE INPUT PARAMETER v-rect AS LONG NO-UNDO.
71 DEFINE INPUT PARAMETER v-rgn AS LONG NO-UNDO.
72 DEFINE INPUT PARAMETER v-flags AS LONG NO-UNDO.
73 DEFINE RETURN PARAMETER v-ret AS LONG NO-UNDO.
74END PROCEDURE.
75
76PROCEDURE SetWindowTextA EXTERNAL "user32.dll":
77 DEFINE INPUT PARAMETER hwnd AS long.
78 DEFINE INPUT PARAMETER txt AS CHARACTER.
79END PROCEDURE.
80
81PROCEDURE GetWindow EXTERNAL "user32.dll" :
82 DEFINE INPUT PARAMETER hwnd AS LONG.
83 DEFINE INPUT PARAMETER uCmd AS LONG.
84 DEFINE RETURN PARAMETER hwndOther AS LONG.
85END PROCEDURE.
86
87PROCEDURE GetParent EXTERNAL "user32.dll" :
88 DEFINE INPUT PARAMETER hwndChild AS LONG.
89 DEFINE RETURN PARAMETER hwndParent AS LONG.
90END PROCEDURE.
91
92PROCEDURE GetCursorPos EXTERNAL "user32":
93 DEFINE INPUT PARAMETER lpPoint AS {&POINTERTYPE}. /* memptr */
94 DEFINE RETURN PARAMETER ReturnValue AS LONG.
95END PROCEDURE.
96
97PROCEDURE GetSysColor EXTERNAL "user32.dll":
98 DEFINE INPUT PARAMETER nDspElement AS LONG.
99 DEFINE RETURN PARAMETER COLORREF AS LONG.
100END PROCEDURE.
101
102PROCEDURE ScreenToClient EXTERNAL "user32.dll" :
103 DEFINE INPUT PARAMETER hWnd AS LONG.
104 DEFINE INPUT PARAMETER lpPoint AS MEMPTR.
105END PROCEDURE.
106
107/* Transparency */
108PROCEDURE SetWindowLongA EXTERNAL "user32.dll":
109 DEFINE INPUT PARAMETER HWND AS LONG.
110 DEFINE INPUT PARAMETER nIndex AS LONG.
111 DEFINE INPUT PARAMETER dwNewLong AS LONG.
112 DEFINE RETURN PARAMETER stat AS LONG.
113END PROCEDURE.
114
115PROCEDURE SetLayeredWindowAttributes EXTERNAL "user32.dll":
116 DEFINE INPUT PARAMETER HWND AS LONG.
117 DEFINE INPUT PARAMETER crKey AS LONG.
118 DEFINE INPUT PARAMETER bAlpha AS SHORT.
119 DEFINE INPUT PARAMETER dwFlagsas AS LONG.
120 DEFINE RETURN PARAMETER stat AS SHORT.
121END PROCEDURE.
122
123
124/* Find out if a file is locked */
125&GLOBAL-DEFINE GENERIC_WRITE 1073741824 /* &H40000000 */
126&GLOBAL-DEFINE OPEN_EXISTING 3
127&GLOBAL-DEFINE FILE_SHARE_READ 1 /* = &H1 */
128&GLOBAL-DEFINE FILE_ATTRIBUTE_NORMAL 128 /* = &H80 */
129
130PROCEDURE CreateFileA EXTERNAL "kernel32":
131 DEFINE INPUT PARAMETER lpFileName AS CHARACTER.
132 DEFINE INPUT PARAMETER dwDesiredAccess AS LONG.
133 DEFINE INPUT PARAMETER dwShareMode AS LONG.
134 DEFINE INPUT PARAMETER lpSecurityAttributes AS LONG.
135 DEFINE INPUT PARAMETER dwCreationDisposition AS LONG.
136 DEFINE INPUT PARAMETER dwFlagsAndAttributes AS LONG.
137 DEFINE INPUT PARAMETER hTemplateFile AS LONG.
138 DEFINE RETURN PARAMETER ReturnValue AS LONG.
139END PROCEDURE.
140
141PROCEDURE CloseHandle EXTERNAL "kernel32" :
142 DEFINE INPUT PARAMETER hObject AS LONG.
143 DEFINE RETURN PARAMETER ReturnValue AS LONG.
144END PROCEDURE.
145
146/* Used in update check / about window */
147PROCEDURE URLDownloadToFileA EXTERNAL "URLMON.DLL" :
148 DEFINE INPUT PARAMETER pCaller AS LONG.
149 DEFINE INPUT PARAMETER szURL AS CHARACTER.
150 DEFINE INPUT PARAMETER szFilename AS CHARACTER.
151 DEFINE INPUT PARAMETER dwReserved AS LONG.
152 DEFINE INPUT PARAMETER lpfnCB AS LONG.
153 DEFINE RETURN PARAMETER ReturnValue AS LONG.
154END PROCEDURE. /* URLDownloadToFileA */
155
156PROCEDURE DeleteUrlCacheEntry EXTERNAL "WININET.DLL" :
157 DEFINE INPUT PARAMETER lbszUrlName AS CHARACTER.
158END PROCEDURE. /* DeleteUrlCacheEntry */
159
160DEFINE TEMP-TABLE ttColor NO-UNDO
161 FIELD cName AS CHARACTER
162 FIELD iColor AS INTEGER
163 INDEX iPrim AS PRIMARY cName.
164
165DEFINE TEMP-TABLE ttFont NO-UNDO
166 FIELD cName AS CHARACTER
167 FIELD iFont AS INTEGER
168 INDEX iPrim AS PRIMARY cName.
169
170/* If you have trouble with the cache, disable it in the settings screen */
171DEFINE VARIABLE glCacheTableDefs AS LOGICAL NO-UNDO.
172DEFINE VARIABLE glCacheFieldDefs AS LOGICAL NO-UNDO.
173
174/* Vars for caching dirnames */
175DEFINE VARIABLE gcProgramDir AS CHARACTER NO-UNDO.
176DEFINE VARIABLE gcWorkFolder AS CHARACTER NO-UNDO.
177
178/* Locking / unlocking windows */
179&GLOBAL-DEFINE WM_SETREDRAW 11
180&GLOBAL-DEFINE RDW_ALLCHILDREN 128
181&GLOBAL-DEFINE RDW_ERASE 4
182&GLOBAL-DEFINE RDW_INVALIDATE 1
183
184/* _UIB-CODE-BLOCK-END */
185&ANALYZE-RESUME
186
187
188&ANALYZE-SUSPEND _UIB-PREPROCESSOR-BLOCK
189
190/* ******************** Preprocessor Definitions ******************** */
191
192&Scoped-define PROCEDURE-TYPE Procedure
193&Scoped-define DB-AWARE no
194
195
196
197/* _UIB-PREPROCESSOR-BLOCK-END */
198&ANALYZE-RESUME
199
200
201/* ************************ Function Prototypes ********************** */
202
203&IF DEFINED(EXCLUDE-addConnection) = 0 &THEN
204
205&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD addConnection Procedure
206FUNCTION addConnection RETURNS LOGICAL
207 ( pcDatabase AS CHARACTER
208 , pcSection AS CHARACTER ) FORWARD.
209
210/* _UIB-CODE-BLOCK-END */
211&ANALYZE-RESUME
212
213&ENDIF
214
215&IF DEFINED(EXCLUDE-formatQueryString) = 0 &THEN
216
217&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD formatQueryString Procedure
218FUNCTION formatQueryString RETURNS CHARACTER
219 ( INPUT pcQueryString AS CHARACTER
220 , INPUT plExpanded AS LOGICAL ) FORWARD.
221
222/* _UIB-CODE-BLOCK-END */
223&ANALYZE-RESUME
224
225&ENDIF
226
227&IF DEFINED(EXCLUDE-getColor) = 0 &THEN
228
229&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD getColor Procedure
230FUNCTION getColor RETURNS INTEGER
231 ( pcName AS CHARACTER ) FORWARD.
232
233/* _UIB-CODE-BLOCK-END */
234&ANALYZE-RESUME
235
236&ENDIF
237
238&IF DEFINED(EXCLUDE-getColorByRGB) = 0 &THEN
239
240&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD getColorByRGB Procedure
241FUNCTION getColorByRGB RETURNS INTEGER
242 ( piRed AS INTEGER
243 , piGreen AS INTEGER
244 , piBlue AS INTEGER
245 ) FORWARD.
246
247/* _UIB-CODE-BLOCK-END */
248&ANALYZE-RESUME
249
250&ENDIF
251
252&IF DEFINED(EXCLUDE-getColumnLabel) = 0 &THEN
253
254&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD getColumnLabel Procedure
255FUNCTION getColumnLabel RETURNS CHARACTER
256 ( INPUT phFieldBuffer AS HANDLE ) FORWARD.
257
258/* _UIB-CODE-BLOCK-END */
259&ANALYZE-RESUME
260
261&ENDIF
262
263&IF DEFINED(EXCLUDE-getColumnWidthList) = 0 &THEN
264
265&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD getColumnWidthList Procedure
266FUNCTION getColumnWidthList RETURNS CHARACTER
267 ( INPUT phBrowse AS HANDLE ) FORWARD.
268
269/* _UIB-CODE-BLOCK-END */
270&ANALYZE-RESUME
271
272&ENDIF
273
274&IF DEFINED(EXCLUDE-getDatabaseList) = 0 &THEN
275
276&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD getDatabaseList Procedure
277FUNCTION getDatabaseList RETURNS CHARACTER FORWARD.
278
279/* _UIB-CODE-BLOCK-END */
280&ANALYZE-RESUME
281
282&ENDIF
283
284&IF DEFINED(EXCLUDE-getEscapedData) = 0 &THEN
285
286&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD getEscapedData Procedure
287FUNCTION getEscapedData RETURNS CHARACTER
288 ( pcTarget AS CHARACTER
289 , pcString AS CHARACTER ) FORWARD.
290
291/* _UIB-CODE-BLOCK-END */
292&ANALYZE-RESUME
293
294&ENDIF
295
296&IF DEFINED(EXCLUDE-getFieldList) = 0 &THEN
297
298&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD getFieldList Procedure
299FUNCTION getFieldList RETURNS CHARACTER
300 ( pcDatabase AS CHARACTER
301 , pcFile AS CHARACTER
302 ) FORWARD.
303
304/* _UIB-CODE-BLOCK-END */
305&ANALYZE-RESUME
306
307&ENDIF
308
309&IF DEFINED(EXCLUDE-getFileCategory) = 0 &THEN
310
311&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD getFileCategory Procedure
312FUNCTION getFileCategory RETURNS CHARACTER
313 ( piFileNumber AS INTEGER
314 , pcFileName AS CHARACTER
315 ) FORWARD.
316
317/* _UIB-CODE-BLOCK-END */
318&ANALYZE-RESUME
319
320&ENDIF
321
322&IF DEFINED(EXCLUDE-getFont) = 0 &THEN
323
324&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD getFont Procedure
325FUNCTION getFont RETURNS INTEGER
326 ( pcName AS CHARACTER ) FORWARD.
327
328/* _UIB-CODE-BLOCK-END */
329&ANALYZE-RESUME
330
331&ENDIF
332
333&IF DEFINED(EXCLUDE-getImagePath) = 0 &THEN
334
335&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD getImagePath Procedure
336FUNCTION getImagePath RETURNS CHARACTER
337 ( pcImage AS CHARACTER ) FORWARD.
338
339/* _UIB-CODE-BLOCK-END */
340&ANALYZE-RESUME
341
342&ENDIF
343
344&IF DEFINED(EXCLUDE-getIndexFields) = 0 &THEN
345
346&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD getIndexFields Procedure
347FUNCTION getIndexFields RETURNS CHARACTER
348 ( INPUT pcDatabaseName AS CHARACTER
349 , INPUT pcTableName AS CHARACTER
350 , INPUT pcFlags AS CHARACTER
351 ) FORWARD.
352
353/* _UIB-CODE-BLOCK-END */
354&ANALYZE-RESUME
355
356&ENDIF
357
358&IF DEFINED(EXCLUDE-getKeyList) = 0 &THEN
359
360&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD getKeyList Procedure
361FUNCTION getKeyList RETURNS CHARACTER
362 ( /* parameter-definitions */ ) FORWARD.
363
364/* _UIB-CODE-BLOCK-END */
365&ANALYZE-RESUME
366
367&ENDIF
368
369&IF DEFINED(EXCLUDE-getLinkInfo) = 0 &THEN
370
371&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD getLinkInfo Procedure
372FUNCTION getLinkInfo RETURNS CHARACTER
373 ( INPUT pcFieldName AS CHARACTER
374 ) FORWARD.
375
376/* _UIB-CODE-BLOCK-END */
377&ANALYZE-RESUME
378
379&ENDIF
380
381&IF DEFINED(EXCLUDE-getMaxLength) = 0 &THEN
382
383&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD getMaxLength Procedure
384FUNCTION getMaxLength RETURNS INTEGER
385 ( cFieldList AS CHARACTER ) FORWARD.
386
387/* _UIB-CODE-BLOCK-END */
388&ANALYZE-RESUME
389
390&ENDIF
391
392&IF DEFINED(EXCLUDE-getOsErrorDesc) = 0 &THEN
393
394&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD getOsErrorDesc Procedure
395FUNCTION getOsErrorDesc RETURNS CHARACTER
396 (INPUT piOsError AS INTEGER) FORWARD.
397
398/* _UIB-CODE-BLOCK-END */
399&ANALYZE-RESUME
400
401&ENDIF
402
403&IF DEFINED(EXCLUDE-getProgramDir) = 0 &THEN
404
405&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD getProgramDir Procedure
406FUNCTION getProgramDir RETURNS CHARACTER
407 ( /* parameter-definitions */ ) FORWARD.
408
409/* _UIB-CODE-BLOCK-END */
410&ANALYZE-RESUME
411
412&ENDIF
413
414&IF DEFINED(EXCLUDE-getQuery) = 0 &THEN
415
416&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD getQuery Procedure
417FUNCTION getQuery RETURNS CHARACTER
418 ( INPUT pcDatabase AS CHARACTER
419 , INPUT pcTable AS CHARACTER
420 , INPUT piQuery AS INTEGER
421 ) FORWARD.
422
423/* _UIB-CODE-BLOCK-END */
424&ANALYZE-RESUME
425
426&ENDIF
427
428&IF DEFINED(EXCLUDE-getReadableQuery) = 0 &THEN
429
430&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD getReadableQuery Procedure
431FUNCTION getReadableQuery RETURNS CHARACTER
432 ( INPUT pcQuery AS CHARACTER ) FORWARD.
433
434/* _UIB-CODE-BLOCK-END */
435&ANALYZE-RESUME
436
437&ENDIF
438
439&IF DEFINED(EXCLUDE-getRegistry) = 0 &THEN
440
441&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD getRegistry Procedure
442FUNCTION getRegistry RETURNS CHARACTER
443 ( pcSection AS CHARACTER
444 , pcKey AS CHARACTER
445 ) FORWARD.
446
447/* _UIB-CODE-BLOCK-END */
448&ANALYZE-RESUME
449
450&ENDIF
451
452&IF DEFINED(EXCLUDE-getSchemaHolder) = 0 &THEN
453
454&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD getSchemaHolder Procedure
455FUNCTION getSchemaHolder RETURNS CHARACTER
456 ( INPUT pcDataSrNameOrDbName AS CHARACTER
457 ) FORWARD.
458
459/* _UIB-CODE-BLOCK-END */
460&ANALYZE-RESUME
461
462&ENDIF
463
464&IF DEFINED(EXCLUDE-getStackSize) = 0 &THEN
465
466&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD getStackSize Procedure
467FUNCTION getStackSize RETURNS INTEGER() FORWARD.
468
469/* _UIB-CODE-BLOCK-END */
470&ANALYZE-RESUME
471
472&ENDIF
473
474&IF DEFINED(EXCLUDE-getTableDesc) = 0 &THEN
475
476&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD getTableDesc Procedure
477FUNCTION getTableDesc RETURNS CHARACTER
478 ( INPUT pcDatabase AS CHARACTER
479 , INPUT pcTable AS CHARACTER
480 ) FORWARD.
481
482/* _UIB-CODE-BLOCK-END */
483&ANALYZE-RESUME
484
485&ENDIF
486
487&IF DEFINED(EXCLUDE-getTableLabel) = 0 &THEN
488
489&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD getTableLabel Procedure
490FUNCTION getTableLabel RETURNS CHARACTER
491 ( INPUT pcDatabase AS CHARACTER
492 , INPUT pcTable AS CHARACTER
493 ) FORWARD.
494
495/* _UIB-CODE-BLOCK-END */
496&ANALYZE-RESUME
497
498&ENDIF
499
500&IF DEFINED(EXCLUDE-getTableList) = 0 &THEN
501
502&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD getTableList Procedure
503FUNCTION getTableList RETURNS CHARACTER
504 ( INPUT pcDatabaseFilter AS CHARACTER
505 , INPUT pcTableFilter AS CHARACTER
506 ) FORWARD.
507
508/* _UIB-CODE-BLOCK-END */
509&ANALYZE-RESUME
510
511&ENDIF
512
513&IF DEFINED(EXCLUDE-getUserName) = 0 &THEN
514
515&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD getUserName Procedure
516FUNCTION getUserName RETURNS CHARACTER
517 ( /* parameter-definitions */ ) FORWARD.
518
519/* _UIB-CODE-BLOCK-END */
520&ANALYZE-RESUME
521
522&ENDIF
523
524&IF DEFINED(EXCLUDE-getWidgetUnderMouse) = 0 &THEN
525
526&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD getWidgetUnderMouse Procedure
527FUNCTION getWidgetUnderMouse RETURNS HANDLE
528 ( phFrame AS HANDLE ) FORWARD.
529
530/* _UIB-CODE-BLOCK-END */
531&ANALYZE-RESUME
532
533&ENDIF
534
535&IF DEFINED(EXCLUDE-getWorkFolder) = 0 &THEN
536
537&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD getWorkFolder Procedure
538FUNCTION getWorkFolder RETURNS CHARACTER
539 ( /* parameter-definitions */ ) FORWARD.
540
541/* _UIB-CODE-BLOCK-END */
542&ANALYZE-RESUME
543
544&ENDIF
545
546&IF DEFINED(EXCLUDE-getXmlNodeName) = 0 &THEN
547
548&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD getXmlNodeName Procedure
549FUNCTION getXmlNodeName RETURNS CHARACTER
550 ( pcFieldName AS CHARACTER ) FORWARD.
551
552/* _UIB-CODE-BLOCK-END */
553&ANALYZE-RESUME
554
555&ENDIF
556
557&IF DEFINED(EXCLUDE-isDataServer) = 0 &THEN
558
559&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD isDataServer Procedure
560FUNCTION isDataServer RETURNS LOGICAL
561 ( INPUT pcDataSrNameOrDbName AS CHARACTER
562 ) FORWARD.
563
564/* _UIB-CODE-BLOCK-END */
565&ANALYZE-RESUME
566
567&ENDIF
568
569&IF DEFINED(EXCLUDE-isDefaultFontsChanged) = 0 &THEN
570
571&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD isDefaultFontsChanged Procedure
572FUNCTION isDefaultFontsChanged RETURNS LOGICAL
573 ( /* parameter-definitions */ ) FORWARD.
574
575/* _UIB-CODE-BLOCK-END */
576&ANALYZE-RESUME
577
578&ENDIF
579
580&IF DEFINED(EXCLUDE-isFileLocked) = 0 &THEN
581
582&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD isFileLocked Procedure
583FUNCTION isFileLocked RETURNS LOGICAL
584 ( pcFileName AS CHARACTER ) FORWARD.
585
586/* _UIB-CODE-BLOCK-END */
587&ANALYZE-RESUME
588
589&ENDIF
590
591&IF DEFINED(EXCLUDE-isMouseOver) = 0 &THEN
592
593&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD isMouseOver Procedure
594FUNCTION isMouseOver RETURNS LOGICAL
595 ( phWidget AS HANDLE ) FORWARD.
596
597/* _UIB-CODE-BLOCK-END */
598&ANALYZE-RESUME
599
600&ENDIF
601
602&IF DEFINED(EXCLUDE-isTableFilterUsed) = 0 &THEN
603
604&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD isTableFilterUsed Procedure
605FUNCTION isTableFilterUsed RETURNS LOGICAL
606 ( INPUT TABLE ttTableFilter ) FORWARD.
607
608/* _UIB-CODE-BLOCK-END */
609&ANALYZE-RESUME
610
611&ENDIF
612
613&IF DEFINED(EXCLUDE-isValidCodePage) = 0 &THEN
614
615&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD isValidCodePage Procedure
616FUNCTION isValidCodePage RETURNS LOGICAL
617 (pcCodepage AS CHARACTER) FORWARD.
618
619/* _UIB-CODE-BLOCK-END */
620&ANALYZE-RESUME
621
622&ENDIF
623
624&IF DEFINED(EXCLUDE-readFile) = 0 &THEN
625
626&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD readFile Procedure
627FUNCTION readFile RETURNS LONGCHAR
628 (pcFilename AS CHARACTER) FORWARD.
629
630/* _UIB-CODE-BLOCK-END */
631&ANALYZE-RESUME
632
633&ENDIF
634
635&IF DEFINED(EXCLUDE-removeConnection) = 0 &THEN
636
637&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD removeConnection Procedure
638FUNCTION removeConnection RETURNS LOGICAL
639 ( pcDatabase AS CHARACTER ) FORWARD.
640
641/* _UIB-CODE-BLOCK-END */
642&ANALYZE-RESUME
643
644&ENDIF
645
646&IF DEFINED(EXCLUDE-resolveOsVars) = 0 &THEN
647
648&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD resolveOsVars Procedure
649FUNCTION resolveOsVars RETURNS CHARACTER
650 ( pcString AS CHARACTER ) FORWARD.
651
652/* _UIB-CODE-BLOCK-END */
653&ANALYZE-RESUME
654
655&ENDIF
656
657&IF DEFINED(EXCLUDE-resolveSequence) = 0 &THEN
658
659&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD resolveSequence Procedure
660FUNCTION resolveSequence RETURNS CHARACTER
661 ( pcString AS CHARACTER ) FORWARD.
662
663/* _UIB-CODE-BLOCK-END */
664&ANALYZE-RESUME
665
666&ENDIF
667
668&IF DEFINED(EXCLUDE-setColor) = 0 &THEN
669
670&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD setColor Procedure
671FUNCTION setColor RETURNS INTEGER
672 ( pcName AS CHARACTER
673 , piColor AS INTEGER) FORWARD.
674
675/* _UIB-CODE-BLOCK-END */
676&ANALYZE-RESUME
677
678&ENDIF
679
680&IF DEFINED(EXCLUDE-setColumnWidthList) = 0 &THEN
681
682&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD setColumnWidthList Procedure
683FUNCTION setColumnWidthList RETURNS LOGICAL
684 ( INPUT phBrowse AS HANDLE
685 , INPUT pcWidthList AS CHARACTER) FORWARD.
686
687/* _UIB-CODE-BLOCK-END */
688&ANALYZE-RESUME
689
690&ENDIF
691
692&IF DEFINED(EXCLUDE-setLinkInfo) = 0 &THEN
693
694&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD setLinkInfo Procedure
695FUNCTION setLinkInfo RETURNS LOGICAL
696 ( INPUT pcFieldName AS CHARACTER
697 , INPUT pcValue AS CHARACTER
698 ) FORWARD.
699
700/* _UIB-CODE-BLOCK-END */
701&ANALYZE-RESUME
702
703&ENDIF
704
705&IF DEFINED(EXCLUDE-setRegistry) = 0 &THEN
706
707&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD setRegistry Procedure
708FUNCTION setRegistry RETURNS CHARACTER
709 ( pcSection AS CHARACTER
710 , pcKey AS CHARACTER
711 , pcValue AS CHARACTER
712 ) FORWARD.
713
714/* _UIB-CODE-BLOCK-END */
715&ANALYZE-RESUME
716
717&ENDIF
718
719
720/* *********************** Procedure Settings ************************ */
721
722&ANALYZE-SUSPEND _PROCEDURE-SETTINGS
723/* Settings for THIS-PROCEDURE
724 Type: Procedure
725 Allow:
726 Frames: 0
727 Add Fields to: Neither
728 Other Settings: CODE-ONLY COMPILE
729 */
730&ANALYZE-RESUME _END-PROCEDURE-SETTINGS
731
732/* ************************* Create Window ************************** */
733
734&ANALYZE-SUSPEND _CREATE-WINDOW
735/* DESIGN Window definition (used by the UIB)
736 CREATE WINDOW Procedure ASSIGN
737 HEIGHT = 41
738 WIDTH = 57.4.
739/* END WINDOW DEFINITION */
740 */
741&ANALYZE-RESUME
742
743
744
745
746&ANALYZE-SUSPEND _UIB-CODE-BLOCK _CUSTOM _MAIN-BLOCK Procedure
747
748
749/* *************************** Main Block *************************** */
750
751/* terminate it. */
752ON CLOSE OF THIS-PROCEDURE
753DO:
754 DEFINE VARIABLE cEnvironment AS CHARACTER NO-UNDO.
755 cEnvironment = SUBSTITUTE('DataDigger-&1', getUserName() ).
756
757 UNLOAD 'DataDiggerHelp' NO-ERROR.
758 UNLOAD 'DataDigger' NO-ERROR.
759 UNLOAD cEnvironment NO-ERROR.
760END. /* CLOSE OF THIS-PROCEDURE */
761
762/* Caching settings must be set from within UI.
763 * Since the library might be started from DataDigger.p
764 * we cannot rely on the registry being loaded yet
765 */
766glCacheTableDefs = TRUE.
767glCacheFieldDefs = TRUE.
768
769/* _UIB-CODE-BLOCK-END */
770&ANALYZE-RESUME
771
772
773/* ********************** Internal Procedures *********************** */
774
775&IF DEFINED(EXCLUDE-applyChoose) = 0 &THEN
776
777&ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE applyChoose Procedure
778PROCEDURE applyChoose :
779/* Apply the choose event to a dynamically created widget
780 */
781 DEFINE INPUT PARAMETER pihWidget AS HANDLE NO-UNDO.
782
783 IF VALID-HANDLE(pihWidget) THEN
784 DO:
785 PUBLISH "debugInfo" (3, SUBSTITUTE("Apply CHOOSE to &1 &2", pihWidget:TYPE, pihWidget:NAME)).
786 APPLY 'choose' TO pihWidget.
787 END.
788
789END PROCEDURE. /* applyChoose */
790
791/* _UIB-CODE-BLOCK-END */
792&ANALYZE-RESUME
793
794&ENDIF
795
796&IF DEFINED(EXCLUDE-applyEvent) = 0 &THEN
797
798&ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE applyEvent Procedure
799PROCEDURE applyEvent :
800/* Apply an event to a dynamically created widget
801 */
802 DEFINE INPUT PARAMETER pihWidget AS HANDLE NO-UNDO.
803 DEFINE INPUT PARAMETER pcEvent AS CHARACTER NO-UNDO.
804
805 IF VALID-HANDLE(pihWidget) THEN
806 DO:
807 PUBLISH "debugInfo" (3, SUBSTITUTE("Apply &1 to &2 &3", CAPS(pcEvent), pihWidget:TYPE, pihWidget:NAME)).
808 APPLY pcEvent TO pihWidget.
809 END.
810
811END PROCEDURE. /* applyEvent */
812
813/* _UIB-CODE-BLOCK-END */
814&ANALYZE-RESUME
815
816&ENDIF
817
818&IF DEFINED(EXCLUDE-checkBackupFolder) = 0 &THEN
819
820&ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE checkBackupFolder Procedure
821PROCEDURE checkBackupFolder :
822/* If backup is on, create a folder for it
823 */
824 DEFINE OUTPUT PARAMETER plFolderOk AS LOGICAL NO-UNDO.
825 DEFINE VARIABLE cFolder AS CHARACTER NO-UNDO.
826
827 IF LOGICAL(getRegistry("DataDigger:Backup","BackupOnCreate"))
828 OR LOGICAL(getRegistry("DataDigger:Backup","BackupOnDelete"))
829 OR LOGICAL(getRegistry("DataDigger:Backup","BackupOnDelete")) THEN
830 DO:
831 RUN getDumpFileName
832 ( INPUT 'dump' /* action */
833 , INPUT '' /* database */
834 , INPUT '' /* table */
835 , INPUT '' /* extension */
836 , INPUT getRegistry("DataDigger:Backup", "BackupDir") /* template */
837 , OUTPUT cFolder
838 ).
839 RUN createFolder(cFolder).
840
841 /* Now check if folder is actually created */
842 FILE-INFO:FILE-NAME = cFolder.
843 plFolderOk = (FILE-INFO:FULL-PATHNAME <> ?).
844
845 IF NOT plFolderOk THEN
846 DO:
847 RUN showHelp('CannotCreateBackupFolder', cFolder).
848 setRegistry("DataDigger:Backup","BackupOnCreate", "NO").
849 setRegistry("DataDigger:Backup","BackupOnUpdate", "NO").
850 setRegistry("DataDigger:Backup","BackupOnDelete", "NO").
851 END.
852 END.
853 ELSE
854 plFolderOk = TRUE.
855
856END PROCEDURE. /* checkBackupFolder */
857
858/* _UIB-CODE-BLOCK-END */
859&ANALYZE-RESUME
860
861&ENDIF
862
863&IF DEFINED(EXCLUDE-checkDir) = 0 &THEN
864
865&ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE checkDir Procedure
866PROCEDURE checkDir :
867/* Check if a folder exists, is accessible etc
868 */
869 DEFINE INPUT PARAMETER pcFileName AS CHARACTER NO-UNDO.
870 DEFINE OUTPUT PARAMETER pcError AS CHARACTER NO-UNDO.
871
872 DEFINE VARIABLE cDumpDir AS CHARACTER NO-UNDO.
873 DEFINE VARIABLE cDirToCreate AS CHARACTER NO-UNDO.
874 DEFINE VARIABLE iDir AS INTEGER NO-UNDO.
875
876 PUBLISH "debugInfo" (3, SUBSTITUTE("Check &1", pcFileName)).
877
878 /* If no path is given, use startup folder */
879 cDumpDir = SUBSTRING(pcFileName, 1, R-INDEX(pcFileName,"\")).
880 IF cDumpDir = '' THEN cDumpDir = '.'.
881
882 /* We cannot use the program dir itself */
883 FILE-INFO:FILE-NAME = cDumpDir.
884 IF TRIM(FILE-INFO:FULL-PATHNAME,'\/') = TRIM(getProgramDir(),"/\") THEN
885 DO:
886 pcError = getRegistry('DataDigger:Help', 'ExportToProgramdir:message').
887 RETURN.
888 END.
889
890 PUBLISH "debugInfo" (3, SUBSTITUTE("Dir = &1", cDumpDir)).
891
892 /* Ask to overwrite if it already exists */
893 FILE-INFO:FILE-NAME = pcFileName.
894 IF FILE-INFO:FULL-PATHNAME <> ? THEN
895 DO:
896 PUBLISH "debugInfo" (3, SUBSTITUTE("Already exists as &1 (&2)", FILE-INFO:FULL-PATHNAME, FILE-INFO:FILE-TYPE)).
897
898 IF FILE-INFO:FILE-TYPE MATCHES '*F*' THEN
899 DO:
900 RUN showHelp('OverwriteDumpFile', pcFileName).
901 IF getRegistry('DataDigger:Help', 'OverwriteDumpFile:answer') <> '1' THEN
902 DO:
903 /* Do not remember the answer "No" for this question, otherwise it will be
904 * confusing the next time the user encounters this situation
905 */
906 setRegistry('DataDigger:Help', 'OverwriteDumpFile:answer',?).
907 pcError = 'Aborted by user.'.
908 RETURN.
909 END.
910
911 /* Write access to this file? */
912 IF NOT FILE-INFO:FILE-TYPE MATCHES '*W*' THEN
913 DO:
914 pcError = SUBSTITUTE('Cannot overwrite output file "&1"', pcFileName).
915 RETURN.
916 END.
917 END.
918
919 /* If a dir already exists with the same name as the output file, we cannot create it */
920 IF FILE-INFO:FILE-TYPE MATCHES '*D*' THEN
921 DO:
922 pcError = SUBSTITUTE('A directory named "&1" exists; cannot create a file with the same name.', pcFileName).
923 RETURN.
924 END.
925 END.
926
927 /* Check dir */
928 FILE-INFO:FILE-NAME = cDumpDir.
929 IF cDumpDir <> "" /* Don't complain about not using a dir */
930 AND FILE-INFO:FULL-PATHNAME = ? THEN
931 DO:
932 RUN showHelp('CreateDumpDir', cDumpDir).
933 IF getRegistry('DataDigger:Help', 'CreateDumpDir:answer') <> '1' THEN
934 DO:
935 pcError = 'Aborted by user.'.
936 RETURN.
937 END.
938 END.
939
940 /* Try to create path + file. Progress will not raise an error if it already exists */
941 cDirToCreate = ENTRY(1,cDumpDir,'\').
942 DO iDir = 2 TO NUM-ENTRIES(cDumpDir,'\').
943
944 /* In which dir do we want to create a subdir? */
945 IF iDir = 2 THEN
946 FILE-INFO:FILE-NAME = cDirToCreate + '\'.
947 ELSE
948 FILE-INFO:FILE-NAME = cDirToCreate.
949
950 /* Does it even exist? */
951 IF FILE-INFO:FULL-PATHNAME = ? THEN
952 DO:
953 pcError = SUBSTITUTE('Directory "&1" does not exist.', cDirToCreate).
954 PUBLISH "debugInfo" (3, SUBSTITUTE("Error: &1", pcError)).
955 RETURN.
956 END.
957
958 /* Check if the dir is writable */
959 IF FILE-INFO:FILE-TYPE MATCHES '*X*' /* Happens on CD-ROM drives */
960 OR ( FILE-INFO:FILE-TYPE MATCHES '*D*'
961 AND NOT FILE-INFO:FILE-TYPE MATCHES '*W*' ) THEN
962 DO:
963 pcError = SUBSTITUTE('No write-access to directory: "&1"', cDirToCreate).
964 PUBLISH "debugInfo" (3, SUBSTITUTE("Error: &1", pcError)).
965 RETURN.
966 END.
967
968 /* Seems to exist and to be writable. */
969 cDirToCreate = cDirToCreate + '\' + ENTRY(iDir,cDumpDir,'\').
970
971 /* If a file already exists with the same name, we cannot create a dir */
972 FILE-INFO:FILE-NAME = cDirToCreate.
973 IF FILE-INFO:FILE-TYPE MATCHES '*F*' THEN
974 DO:
975 pcError = SUBSTITUTE('A file named "&1" exists; cannot create a dir with the same name.', cDirToCreate).
976 PUBLISH "debugInfo" (3, SUBSTITUTE("Error: &1", pcError)).
977 RETURN.
978 END.
979
980 /* Create the dir. Creating an existing dir gives no error */
981 OS-CREATE-DIR value(cDirToCreate).
982 IF OS-ERROR <> 0 THEN
983 DO:
984 pcError = getOsErrorDesc(OS-ERROR).
985 PUBLISH "debugInfo" (3, SUBSTITUTE("Error: &1", pcError)).
986 RETURN.
987 END. /* error */
988
989 END. /* iDir */
990
991END PROCEDURE. /* checkDir */
992
993/* _UIB-CODE-BLOCK-END */
994&ANALYZE-RESUME
995
996&ENDIF
997
998&IF DEFINED(EXCLUDE-clearColorCache) = 0 &THEN
999
1000&ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE clearColorCache Procedure
1001PROCEDURE clearColorCache :
1002/* Clear the registry cache
1003 */
1004 PUBLISH "debugInfo" (3, SUBSTITUTE("Clearing color cache")).
1005 EMPTY TEMP-TABLE ttColor.
1006
1007END PROCEDURE. /* clearColorCache */
1008
1009/* _UIB-CODE-BLOCK-END */
1010&ANALYZE-RESUME
1011
1012&ENDIF
1013
1014&IF DEFINED(EXCLUDE-clearDiskCache) = 0 &THEN
1015
1016&ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE clearDiskCache Procedure
1017PROCEDURE clearDiskCache :
1018/* Clear the cache files on disk
1019 */
1020 DEFINE VARIABLE cFile AS CHARACTER NO-UNDO EXTENT 3.
1021
1022 PUBLISH "debugInfo" (3, SUBSTITUTE("Clearing disk cache")).
1023
1024 FILE-INFORMATION:FILE-NAME = getWorkFolder() + "cache".
1025 IF FILE-INFORMATION:FULL-PATHNAME = ? THEN RETURN.
1026
1027 INPUT FROM OS-DIR(FILE-INFORMATION:FULL-PATHNAME).
1028 REPEAT:
1029 IMPORT cFile.
1030 IF cFile[1] MATCHES "*.xml" THEN OS-DELETE VALUE( cFile[2]).
1031 END.
1032 INPUT CLOSE.
1033
1034END PROCEDURE. /* clearDiskCache */
1035
1036/* _UIB-CODE-BLOCK-END */
1037&ANALYZE-RESUME
1038
1039&ENDIF
1040
1041&IF DEFINED(EXCLUDE-clearFontCache) = 0 &THEN
1042
1043&ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE clearFontCache Procedure
1044PROCEDURE clearFontCache :
1045/* Clear the font cache
1046 */
1047 PUBLISH "debugInfo" (3, SUBSTITUTE("Clearing font cache")).
1048 EMPTY TEMP-TABLE ttFont.
1049
1050END PROCEDURE. /* clearFontCache */
1051
1052/* _UIB-CODE-BLOCK-END */
1053&ANALYZE-RESUME
1054
1055&ENDIF
1056
1057&IF DEFINED(EXCLUDE-clearMemoryCache) = 0 &THEN
1058
1059&ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE clearMemoryCache Procedure
1060PROCEDURE clearMemoryCache :
1061/* Clear the memory cache
1062 */
1063 PUBLISH "debugInfo" (3, SUBSTITUTE("Clearing memory cache")).
1064 EMPTY TEMP-TABLE ttFieldCache.
1065
1066END PROCEDURE. /* clearMemoryCache */
1067
1068/* _UIB-CODE-BLOCK-END */
1069&ANALYZE-RESUME
1070
1071&ENDIF
1072
1073&IF DEFINED(EXCLUDE-clearRegistryCache) = 0 &THEN
1074
1075&ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE clearRegistryCache Procedure
1076PROCEDURE clearRegistryCache :
1077/* Clear the registry cache
1078 */
1079 PUBLISH "debugInfo" (3, SUBSTITUTE("Clearing registry cache")).
1080 EMPTY TEMP-TABLE ttConfig.
1081
1082END PROCEDURE. /* clearRegistryCache */
1083
1084/* _UIB-CODE-BLOCK-END */
1085&ANALYZE-RESUME
1086
1087&ENDIF
1088
1089&IF DEFINED(EXCLUDE-collectQueryInfo) = 0 &THEN
1090
1091&ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE collectQueryInfo Procedure
1092PROCEDURE collectQueryInfo :
1093/* Fill the query temp-table
1094 */
1095 DEFINE INPUT PARAMETER pcDatabase AS CHARACTER NO-UNDO.
1096 DEFINE INPUT PARAMETER pcTable AS CHARACTER NO-UNDO.
1097
1098 DEFINE VARIABLE iMaxQueryHistory AS INTEGER NO-UNDO.
1099 DEFINE VARIABLE iQueryNr AS INTEGER NO-UNDO.
1100 DEFINE VARIABLE iLoop AS INTEGER NO-UNDO.
1101 DEFINE VARIABLE cSetting AS CHARACTER NO-UNDO.
1102
1103 DEFINE BUFFER bQuery FOR ttQuery.
1104 {&timerStart}
1105
1106 /* Delete all known queries in memory of this table */
1107 FOR EACH bQuery
1108 WHERE bQuery.cDatabase = pcDatabase
1109 AND bQuery.cTable = pcTable:
1110 DELETE bQuery.
1111 END.
1112
1113 iMaxQueryHistory = INTEGER(getRegistry("DataDigger", "MaxQueryHistory" )).
1114 IF iMaxQueryHistory = 0 THEN RETURN. /* no query history wanted */
1115
1116 /* If it is not defined use default setting */
1117 IF iMaxQueryHistory = ? THEN iMaxQueryHistory = 10.
1118
1119 collectQueries:
1120 DO iLoop = 1 TO iMaxQueryHistory:
1121 cSetting = getRegistry( SUBSTITUTE("DB:&1", pcDatabase)
1122 , SUBSTITUTE('&1:query:&2', pcTable, iLoop )).
1123
1124 IF cSetting = '<Empty>' THEN NEXT collectQueries.
1125
1126 IF cSetting <> ? THEN
1127 DO:
1128 CREATE bQuery.
1129 ASSIGN
1130 iQueryNr = iQueryNr + 1
1131 bQuery.cDatabase = pcDatabase
1132 bQuery.cTable = pcTable
1133 bQuery.iQueryNr = iQueryNr
1134 bQuery.cQueryTxt = cSetting.
1135 END.
1136 ELSE
1137 LEAVE collectQueries.
1138
1139 END. /* 1 .. MaxQueryHistory */
1140 {&timerStop}
1141END PROCEDURE. /* collectQueryInfo */
1142
1143/* _UIB-CODE-BLOCK-END */
1144&ANALYZE-RESUME
1145
1146&ENDIF
1147
1148&IF DEFINED(EXCLUDE-correctFilterList) = 0 &THEN
1149
1150&ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE correctFilterList Procedure
1151PROCEDURE correctFilterList :
1152/* Move negative entries from positive list to negative
1153 */
1154 DEFINE INPUT-OUTPUT PARAMETER pcPositive AS CHARACTER NO-UNDO.
1155 DEFINE INPUT-OUTPUT PARAMETER pcNegative AS CHARACTER NO-UNDO.
1156
1157 DEFINE VARIABLE iWord AS INTEGER NO-UNDO.
1158
1159 /* Strip entries that start with a ! */
1160 IF INDEX(pcPositive,"!") > 0 THEN
1161 DO:
1162 DO iWord = 1 TO NUM-ENTRIES(pcPositive):
1163 IF ENTRY(iWord,pcPositive) BEGINS "!" THEN
1164 DO:
1165 /* Add this word to the negative-list */
1166 pcNegative = TRIM(pcNegative + ',' + TRIM(ENTRY(iWord,pcPositive),'!'),',').
1167
1168 /* And wipe it from the positive-list */
1169 ENTRY(iWord,pcPositive) = ''.
1170 END.
1171 END.
1172
1173 /* Remove empty elements */
1174 pcPositive = TRIM(pcPositive,',').
1175 REPEAT WHILE INDEX(pcPositive,',,') > 0:
1176 pcPositive = REPLACE(pcPositive,',,',',').
1177 END.
1178 END.
1179
1180END PROCEDURE. /* correctFilterList */
1181
1182/* _UIB-CODE-BLOCK-END */
1183&ANALYZE-RESUME
1184
1185&ENDIF
1186
1187&IF DEFINED(EXCLUDE-createFolder) = 0 &THEN
1188
1189&ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE createFolder Procedure
1190PROCEDURE createFolder :
1191/* Create a folder structure
1192 */
1193 DEFINE INPUT PARAMETER pcFolder AS CHARACTER NO-UNDO.
1194
1195 DEFINE VARIABLE iElement AS INTEGER NO-UNDO.
1196 DEFINE VARIABLE cPath AS CHARACTER NO-UNDO.
1197
1198 /* c:\temp\somefolder\subfolder\ */
1199 DO iElement = 1 TO NUM-ENTRIES(pcFolder,'\'):
1200 cPath = SUBSTITUTE('&1\&2', cPath, ENTRY(iElement,pcFolder,'\')).
1201 cPath = LEFT-TRIM(cPath,'\').
1202
1203 IF iElement > 1 THEN OS-CREATE-DIR VALUE(cPath).
1204 END.
1205
1206END PROCEDURE. /* createFolder */
1207
1208/* _UIB-CODE-BLOCK-END */
1209&ANALYZE-RESUME
1210
1211&ENDIF
1212
1213&IF DEFINED(EXCLUDE-dumpRecord) = 0 &THEN
1214
1215&ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE dumpRecord Procedure
1216PROCEDURE dumpRecord :
1217/* Dump the record(s) to disk
1218 */
1219 DEFINE INPUT PARAMETER pcAction AS CHARACTER NO-UNDO.
1220 DEFINE INPUT PARAMETER phSource AS HANDLE NO-UNDO.
1221 DEFINE OUTPUT PARAMETER plContinue AS LOGICAL NO-UNDO.
1222
1223 DEFINE VARIABLE hExportTT AS HANDLE NO-UNDO.
1224 DEFINE VARIABLE hExportTtBuffer AS HANDLE NO-UNDO.
1225 DEFINE VARIABLE hBuffer AS HANDLE NO-UNDO.
1226 DEFINE VARIABLE cFileName AS CHARACTER NO-UNDO.
1227 DEFINE VARIABLE cError AS CHARACTER NO-UNDO.
1228 DEFINE VARIABLE cMessage AS CHARACTER NO-UNDO.
1229 DEFINE VARIABLE iRow AS INTEGER NO-UNDO.
1230 DEFINE VARIABLE lDefaultDump AS LOGICAL NO-UNDO.
1231
1232 IF NOT VALID-HANDLE(phSource) THEN RETURN.
1233
1234 /* Protect against wrong input */
1235 IF LOOKUP(pcAction,'Dump,Create,Update,Delete') = 0 THEN
1236 DO:
1237 MESSAGE 'Unknown action' pcAction VIEW-AS ALERT-BOX INFORMATION BUTTONS OK.
1238 RETURN.
1239 END.
1240
1241 /* Determine appropriate buffer and populate an intermediate tt
1242 * with the data to export
1243 */
1244 CASE phSource:TYPE:
1245 WHEN 'buffer' THEN
1246 DO:
1247 hBuffer = phSource.
1248
1249 /* Create temptable-handle... */
1250 CREATE TEMP-TABLE hExportTt.
1251 hExportTt:CREATE-LIKE(SUBSTITUTE("&1.&2", hBuffer:DBNAME, hBuffer:TABLE)).
1252
1253 /* Prepare the TempTable... */
1254 hExportTt:TEMP-TABLE-PREPARE(SUBSTITUTE("&1", hBuffer:TABLE)).
1255 hExportTtBuffer = hExportTt:DEFAULT-BUFFER-HANDLE.
1256 hExportTtBuffer:BUFFER-CREATE().
1257 hExportTtBuffer:BUFFER-COPY(hBuffer).
1258 END.
1259
1260 WHEN 'browse' THEN
1261 DO:
1262 hBuffer = phSource:QUERY:GET-BUFFER-HANDLE(1).
1263
1264 /* Create temptable-handle... */
1265 CREATE TEMP-TABLE hExportTt.
1266 hExportTt:CREATE-LIKE(SUBSTITUTE("&1.&2", hBuffer:DBNAME, hBuffer:TABLE)).
1267
1268 /* Prepare the TempTable... */
1269 hExportTt:TEMP-TABLE-PREPARE(SUBSTITUTE("&1", hBuffer:TABLE)).
1270 hExportTtBuffer = hExportTt:DEFAULT-BUFFER-HANDLE.
1271
1272 /* Copy the records */
1273 DO iRow = 1 TO phSource:NUM-SELECTED-ROWS:
1274 phSource:FETCH-SELECTED-ROW(iRow).
1275 hExportTtBuffer:BUFFER-CREATE().
1276 hExportTtBuffer:BUFFER-COPY(hBuffer).
1277 END.
1278 END.
1279
1280 OTHERWISE RETURN.
1281 END CASE.
1282
1283 /* Do we need to dump at all?
1284 * If the setting=NO or if no setting at all, then don't do any checks
1285 */
1286 IF pcAction <> 'Dump'
1287 AND ( getRegistry('DataDigger:Backup','BackupOn' + pcAction) = ?
1288 OR logical(getRegistry('DataDigger:Backup','BackupOn' + pcAction)) = NO
1289 ) THEN
1290 DO:
1291 ASSIGN plContinue = YES.
1292 RETURN.
1293 END.
1294
1295 /* Determine the default name to save to */
1296 RUN getDumpFileName
1297 ( INPUT pcAction /* Dump | Create | Update | Delete */
1298 , INPUT hBuffer:DBNAME
1299 , INPUT hBuffer:TABLE
1300 , INPUT "XML"
1301 , INPUT ""
1302 , OUTPUT cFileName
1303 ).
1304
1305 RUN checkDir(INPUT cFileName, OUTPUT cError).
1306 IF cError <> "" THEN
1307 DO:
1308 MESSAGE cError VIEW-AS ALERT-BOX INFORMATION BUTTONS OK.
1309 RETURN.
1310 END.
1311
1312 /* Fix XML Node Names for fields in the tt */
1313 RUN setXmlNodeNames(INPUT hExportTt:DEFAULT-BUFFER-HANDLE).
1314
1315 /* See if the user has specified his own dump program
1316 */
1317 plContinue = ?. /* To see if it ran or not */
1318 PUBLISH "customDump"
1319 ( INPUT pcAction
1320 , INPUT hBuffer:DBNAME
1321 , INPUT hBuffer:TABLE
1322 , INPUT hExportTt
1323 , INPUT cFileName
1324 , OUTPUT cMessage
1325 , OUTPUT lDefaultDump
1326 , OUTPUT plContinue
1327 ).
1328
1329 IF plContinue <> ? THEN
1330 DO:
1331 IF cMessage <> "" THEN MESSAGE cMessage VIEW-AS ALERT-BOX INFORMATION BUTTONS OK.
1332 IF NOT lDefaultDump OR NOT plContinue THEN RETURN.
1333 END.
1334
1335 plContinue = hExportTT:WRITE-XML
1336 ( 'file' /* TargetType */
1337 , cFileName /* File */
1338 , YES /* Formatted */
1339 , ? /* Encoding */
1340 , ? /* SchemaLocation */
1341 , NO /* WriteSchema */
1342 , NO /* MinSchema */
1343 ).
1344
1345 DELETE OBJECT hExportTt.
1346END PROCEDURE. /* dumpRecord */
1347
1348/* _UIB-CODE-BLOCK-END */
1349&ANALYZE-RESUME
1350
1351&ENDIF
1352
1353&IF DEFINED(EXCLUDE-dynamicDump) = 0 &THEN
1354
1355&ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE dynamicDump Procedure
1356PROCEDURE dynamicDump :
1357/* Dump the data to a file that is similar to those of Progress self.
1358 */
1359 DEFINE INPUT PARAMETER pihBrowse AS HANDLE NO-UNDO.
1360 DEFINE INPUT PARAMETER picFile AS CHARACTER NO-UNDO.
1361
1362 DEFINE VARIABLE cTimeStamp AS CHARACTER NO-UNDO.
1363 DEFINE VARIABLE hBuffer AS HANDLE NO-UNDO EXTENT 5.
1364 DEFINE VARIABLE hColumn AS HANDLE NO-UNDO.
1365 DEFINE VARIABLE hField AS HANDLE NO-UNDO.
1366 DEFINE VARIABLE hQuery AS HANDLE NO-UNDO.
1367 DEFINE VARIABLE iBack AS INTEGER NO-UNDO.
1368 DEFINE VARIABLE iBuffer AS INTEGER NO-UNDO.
1369 DEFINE VARIABLE iColumn AS INTEGER NO-UNDO.
1370 DEFINE VARIABLE iExtent AS INTEGER NO-UNDO.
1371 DEFINE VARIABLE iRecords AS INTEGER NO-UNDO.
1372 DEFINE VARIABLE iTrailer AS INTEGER NO-UNDO.
1373 DEFINE VARIABLE lFirst AS LOGICAL NO-UNDO.
1374
1375 hQuery = pihBrowse:QUERY.
1376
1377 /* Accept max 5 buffers for a query */
1378 DO iBuffer = 1 TO min(5, hQuery:NUM-BUFFERS):
1379 hBuffer[iBuffer] = hQuery:GET-BUFFER-HANDLE(iBuffer).
1380 END.
1381
1382 ASSIGN
1383 iRecords = 0
1384 cTimeStamp = STRING(YEAR( TODAY),"9999":u) + "/":u
1385 + string(MONTH(TODAY),"99":u ) + "/":u
1386 + string(DAY( TODAY),"99":u ) + "-":u
1387 + string(TIME,"HH:MM:SS":u).
1388
1389 hQuery:GET-FIRST.
1390
1391 /* Open outputfile */
1392 OUTPUT to value(picFile) no-echo no-map.
1393 EXPORT ?.
1394 iBack = seek(output) - 1.
1395 SEEK OUTPUT TO 0.
1396
1397 REPEAT WHILE NOT hQuery:QUERY-OFF-END
1398 ON STOP UNDO, LEAVE:
1399
1400 ASSIGN
1401 iRecords = iRecords + 1
1402 lFirst = TRUE
1403 .
1404
1405 PROCESS EVENTS.
1406
1407 browseColumn:
1408 DO iColumn = 1 TO pihBrowse:NUM-COLUMNS:
1409
1410 /* Grab the handle */
1411 hColumn = pihBrowse:GET-BROWSE-COLUMN(iColumn).
1412
1413 /* Skip invisible columns */
1414 IF NOT hColumn:VISIBLE THEN NEXT browseColumn.
1415
1416 /* Find the buffer the column belongs to */
1417 SearchLoop:
1418 DO iBuffer = 1 TO 5:
1419 ASSIGN hField = hBuffer[iBuffer]:BUFFER-FIELD(hColumn:NAME) NO-ERROR.
1420 IF ERROR-STATUS:ERROR = FALSE
1421 AND hField <> ? THEN
1422 LEAVE SearchLoop.
1423 END.
1424
1425 /* If no column found, something weird happened */
1426 IF hField = ? THEN NEXT browseColumn.
1427
1428 IF hField:DATA-TYPE = "recid":u THEN NEXT browseColumn.
1429
1430 IF lFirst THEN
1431 lFirst = FALSE.
1432 ELSE
1433 DO:
1434 SEEK OUTPUT TO seek(output) - iBack.
1435 PUT CONTROL ' ':u.
1436 END.
1437
1438 IF hField:EXTENT > 1 THEN
1439 DO iExtent = 1 TO hField:EXTENT:
1440 IF iExtent > 1 THEN
1441 DO:
1442 SEEK OUTPUT TO SEEK(OUTPUT) - iBack.
1443 PUT CONTROL ' ':u.
1444 END.
1445
1446 EXPORT hField:BUFFER-VALUE(iExtent).
1447 END.
1448 ELSE
1449 EXPORT hField:BUFFER-VALUE.
1450 END.
1451
1452 hQuery:GET-NEXT().
1453 END.
1454
1455 /* Add a checksum and nr of records at the end of the file.
1456 */
1457 PUT UNFORMATTED ".":u SKIP.
1458 iTrailer = SEEK(OUTPUT).
1459
1460 PUT UNFORMATTED
1461 "PSC":u
1462 SKIP "filename=":u hBuffer[1]:TABLE
1463 SKIP "records=":u STRING(iRecords,"9999999999999":u)
1464 SKIP "ldbname=":u hBuffer[1]:DBNAME
1465 SKIP "timestamp=":u cTimeStamp
1466 SKIP "numformat=":u ASC(SESSION:NUMERIC-SEPARATOR) ",":u ASC(SESSION:NUMERIC-DECIMAL-POINT)
1467 SKIP "dateformat=":u SESSION:DATE-FORMAT "-":u SESSION:YEAR-OFFSET
1468 SKIP "map=NO-MAP":u
1469 SKIP "cpstream=":u SESSION:CPSTREAM
1470 SKIP ".":u
1471 SKIP STRING(iTrailer,"9999999999":u)
1472 SKIP.
1473
1474 OUTPUT CLOSE.
1475
1476END PROCEDURE. /* dynamicDump */
1477
1478/* _UIB-CODE-BLOCK-END */
1479&ANALYZE-RESUME
1480
1481&ENDIF
1482
1483&IF DEFINED(EXCLUDE-flushRegistry) = 0 &THEN
1484
1485&ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE flushRegistry Procedure
1486PROCEDURE flushRegistry :
1487/* Flush all dirty registry settings to disk
1488*/
1489 {&timerStart}
1490
1491 IF glDirtyCache THEN
1492 RUN saveConfigFileSorted.
1493
1494 {&timerStop}
1495END PROCEDURE. /* flushRegistry */
1496
1497/* _UIB-CODE-BLOCK-END */
1498&ANALYZE-RESUME
1499
1500&ENDIF
1501
1502&IF DEFINED(EXCLUDE-getColumnSort) = 0 &THEN
1503
1504&ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE getColumnSort Procedure
1505PROCEDURE getColumnSort :
1506/* Return the column nr the browse is sorted on
1507 */
1508 DEFINE INPUT PARAMETER phBrowse AS HANDLE NO-UNDO.
1509 DEFINE OUTPUT PARAMETER pcColumn AS CHARACTER NO-UNDO.
1510 DEFINE OUTPUT PARAMETER plAscending AS LOGICAL NO-UNDO.
1511
1512 DEFINE VARIABLE hColumn AS HANDLE NO-UNDO.
1513 DEFINE VARIABLE iColumn AS INTEGER NO-UNDO.
1514
1515 {&timerStart}
1516
1517 #BrowseColumns:
1518 DO iColumn = 1 TO phBrowse:NUM-COLUMNS:
1519 hColumn = phBrowse:GET-BROWSE-COLUMN(iColumn).
1520 IF hColumn:SORT-ASCENDING <> ? THEN
1521 DO:
1522 ASSIGN
1523 pcColumn = hColumn:NAME
1524 plAscending = hColumn:SORT-ASCENDING
1525 .
1526 LEAVE #BrowseColumns.
1527 END.
1528 END.
1529
1530 IF pcColumn = '' THEN
1531 ASSIGN
1532 pcColumn = phBrowse:GET-BROWSE-COLUMN(1):name
1533 plAscending = TRUE.
1534
1535 PUBLISH "debugInfo" (3, SUBSTITUTE("Sorting &1 on &2", STRING(plAscending,"up/down"), pcColumn)).
1536
1537 {&timerStop}
1538
1539END PROCEDURE. /* getColumnSort */
1540
1541/* _UIB-CODE-BLOCK-END */
1542&ANALYZE-RESUME
1543
1544&ENDIF
1545
1546&IF DEFINED(EXCLUDE-getDumpFileName) = 0 &THEN
1547
1548&ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE getDumpFileName Procedure
1549PROCEDURE getDumpFileName :
1550/* Return a file name based on a template
1551 */
1552 DEFINE INPUT PARAMETER pcAction AS CHARACTER NO-UNDO.
1553 DEFINE INPUT PARAMETER pcDatabase AS CHARACTER NO-UNDO.
1554 DEFINE INPUT PARAMETER pcTable AS CHARACTER NO-UNDO.
1555 DEFINE INPUT PARAMETER pcExtension AS CHARACTER NO-UNDO.
1556 DEFINE INPUT PARAMETER pcTemplate AS CHARACTER NO-UNDO.
1557 DEFINE OUTPUT PARAMETER pcFileName AS CHARACTER NO-UNDO.
1558
1559 DEFINE VARIABLE cLastDir AS CHARACTER NO-UNDO.
1560 DEFINE VARIABLE cDayOfWeek AS CHARACTER NO-UNDO EXTENT 7 INITIAL ['Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat'].
1561 DEFINE VARIABLE cDumpName AS CHARACTER NO-UNDO.
1562 DEFINE VARIABLE cDumpDir AS CHARACTER NO-UNDO.
1563 DEFINE VARIABLE cBackupDir AS CHARACTER NO-UNDO.
1564 DEFINE VARIABLE hBuffer AS HANDLE NO-UNDO.
1565 DEFINE VARIABLE cUserId AS CHARACTER NO-UNDO.
1566
1567 /* Checks */
1568 IF LOOKUP(pcAction, "Dump,Create,Update,Delete") = 0 THEN
1569 DO:
1570 MESSAGE 'Unknown action' pcAction VIEW-AS ALERT-BOX.
1571 RETURN.
1572 END.
1573
1574 /* If not provided, find the template from the settings,
1575 * depending on the action we want to perform.
1576 */
1577 IF pcTemplate = ? OR pcTemplate = "" THEN
1578 DO:
1579 IF pcAction = 'Dump' THEN
1580 pcFileName = "<DUMPDIR>" + getRegistry("DumpAndLoad", "DumpFileTemplate").
1581 ELSE
1582 pcFileName = "<BACKUPDIR>" + getRegistry("DataDigger:Backup", "BackupFileTemplate").
1583 END.
1584 ELSE
1585 pcFileName = pcTemplate.
1586
1587 IF pcFileName = ? THEN pcFileName = "".
1588
1589 PUBLISH "debugInfo" (3, SUBSTITUTE("Dump to: &1", pcFileName)).
1590
1591 /* Dump dir / backup dir / last-used dir from settings */
1592 cDumpDir = RIGHT-TRIM(getRegistry("DumpAndLoad", "DumpDir"),'/\') + '\'.
1593 IF cDumpDir = ? OR cDumpDir = '' THEN cDumpDir = "<WORKDIR>dump\".
1594
1595 cBackupDir = RIGHT-TRIM(getRegistry("DataDigger:Backup", "BackupDir"),'/\') + '\'.
1596 IF cBackupDir = ? OR cBackupDir = '' THEN cBackupDir = "<WORKDIR>backup\".
1597
1598 cLastDir = RIGHT-TRIM(getRegistry("DumpAndLoad", "DumpLastFileName"),'/\').
1599 cLastDir = SUBSTRING(cLastDir,1,R-INDEX(cLastDir,"\")).
1600 IF cLastDir = ? THEN cLastDir = "<WORKDIR>dump".
1601 cLastDir = RIGHT-TRIM(cLastDir,'\').
1602
1603 /* Find _file for the dump-name */
1604 CREATE BUFFER hBuffer FOR TABLE SUBSTITUTE('&1._file', pcDatabase) NO-ERROR.
1605 IF VALID-HANDLE(hBuffer) THEN
1606 DO:
1607 hBuffer:FIND-UNIQUE(SUBSTITUTE('where _file-name = &1 and _File._File-Number < 32768', QUOTER(pcTable)),NO-LOCK).
1608 IF hBuffer:AVAILABLE THEN
1609 cDumpName = hBuffer::_dump-name.
1610 ELSE
1611 cDumpName = pcTable.
1612 END.
1613 ELSE
1614 cDumpName = pcTable.
1615 IF cDumpName = ? THEN cDumpName = pcTable.
1616
1617 /* If you have no db connected, userid gives back unknown value
1618 * which misbehaves in a replace statement */
1619 cUserId = USERID(LDBNAME(1)).
1620 IF cUserId = ? THEN cUserId = ''.
1621
1622 PUBLISH "debugInfo" (3, SUBSTITUTE("DumpDir : &1", cDumpDir)).
1623 PUBLISH "debugInfo" (3, SUBSTITUTE("BackupDir: &1", cBackupDir)).
1624 PUBLISH "debugInfo" (3, SUBSTITUTE("LastDir : &1", cLastDir)).
1625 PUBLISH "debugInfo" (3, SUBSTITUTE("DumpName : &1", cDumpName)).
1626
1627 /* Now resolve all tags */
1628 pcFileName = REPLACE(pcFileName,"<DUMPDIR>" , cDumpDir ).
1629 pcFileName = REPLACE(pcFileName,"<BACKUPDIR>", cBackupDir ).
1630 pcFileName = REPLACE(pcFileName,"<LASTDIR>" , cLastDir ).
1631 pcFileName = REPLACE(pcFileName,"<PROGDIR>" , getWorkFolder() ).
1632 pcFileName = REPLACE(pcFileName,"<WORKDIR>" , getWorkFolder() ).
1633
1634 pcFileName = REPLACE(pcFileName,"<ACTION>" , pcAction ).
1635 pcFileName = REPLACE(pcFileName,"<USERID>" , cUserId ).
1636 pcFileName = REPLACE(pcFileName,"<DB>" , pcDatabase ).
1637 pcFileName = REPLACE(pcFileName,"<TABLE>" , pcTable ).
1638 pcFileName = REPLACE(pcFileName,"<DUMPNAME>" , cDumpName ).
1639 pcFileName = REPLACE(pcFileName,"<EXT>" , pcExtension ).
1640
1641 pcFileName = REPLACE(pcFileName,"<TIMESTAMP>", "<YEAR><MONTH><DAY>.<HH><MM><SS>" ).
1642 pcFileName = REPLACE(pcFileName,"<DATE>" , "<YEAR>-<MONTH>-<DAY>" ).
1643 pcFileName = REPLACE(pcFileName,"<TIME>" , "<HH>:<MM>:<SS>" ).
1644 pcFileName = REPLACE(pcFileName,"<WEEKDAY>" , STRING(WEEKDAY(TODAY)) ).
1645 pcFileName = REPLACE(pcFileName,"<DAYNAME>" , cDayOfWeek[WEEKDAY(today)] ).
1646
1647 pcFileName = REPLACE(pcFileName,"<YEAR>" , STRING(YEAR (TODAY),"9999") ).
1648 pcFileName = REPLACE(pcFileName,"<MONTH>" , STRING(MONTH(TODAY), "99") ).
1649 pcFileName = REPLACE(pcFileName,"<DAY>" , STRING(DAY (TODAY), "99") ).
1650 pcFileName = REPLACE(pcFileName,"<HH>" , ENTRY(1,STRING(TIME,"HH:MM:SS"),":" ) ).
1651 pcFileName = REPLACE(pcFileName,"<MM>" , ENTRY(2,STRING(TIME,"HH:MM:SS"),":" ) ).
1652 pcFileName = REPLACE(pcFileName,"<SS>" , ENTRY(3,STRING(TIME,"HH:MM:SS"),":" ) ).
1653
1654 /* Get rid of annoying slashes */
1655 pcFileName = TRIM(pcFileName,'/\').
1656
1657 /* Get rid of double slashes (except at the beginning for UNC paths) */
1658 pcFileName = SUBSTRING(pcFileName,1,1) + REPLACE(SUBSTRING(pcFileName,2),'\\','\').
1659
1660 /* Sequences */
1661 pcFileName = resolveSequence(pcFileName).
1662
1663 /* OS-vars */
1664 pcFileName = resolveOsVars(pcFileName).
1665
1666 /* Make lower */
1667 pcFileName = LC(pcFileName).
1668 PUBLISH "debugInfo" (3, SUBSTITUTE("Dump to: &1", pcFileName)).
1669
1670END PROCEDURE. /* getDumpFileName */
1671
1672/* _UIB-CODE-BLOCK-END */
1673&ANALYZE-RESUME
1674
1675&ENDIF
1676
1677&IF DEFINED(EXCLUDE-getFavourites) = 0 &THEN
1678
1679&ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE getFavourites Procedure
1680PROCEDURE getFavourites :
1681/* Extract favourites from config table into own tt
1682*/
1683 DEFINE OUTPUT PARAMETER TABLE FOR ttFavGroup.
1684
1685 DEFINE BUFFER bfConfig FOR ttConfig.
1686 DEFINE BUFFER btFavGroup FOR ttFavGroup.
1687
1688 EMPTY TEMP-TABLE ttFavGroup.
1689
1690 FOR EACH bfConfig
1691 WHERE bfConfig.cSection = 'DataDigger:Favourites'
1692 AND bfConfig.cSetting > "":
1693
1694 CREATE btFavGroup.
1695 ASSIGN
1696 btFavGroup.cGroup = bfConfig.cSetting
1697 btFavGroup.cTables = bfConfig.cValue.
1698 END.
1699
1700 /* If no groups are found, create a default one */
1701 IF NOT CAN-FIND(FIRST btFavGroup) THEN
1702 DO:
1703 CREATE btFavGroup.
1704 ASSIGN btFavGroup.cGroup = 'MyFavourites'.
1705 END.
1706
1707END PROCEDURE. /* getFavourites */
1708
1709/* _UIB-CODE-BLOCK-END */
1710&ANALYZE-RESUME
1711
1712&ENDIF
1713
1714&IF DEFINED(EXCLUDE-getFields) = 0 &THEN
1715
1716&ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE getFields Procedure
1717PROCEDURE getFields :
1718/* Fill the fields temp-table
1719 */
1720 DEFINE INPUT PARAMETER pcDatabase AS CHARACTER NO-UNDO.
1721 DEFINE INPUT PARAMETER pcTableName AS CHARACTER NO-UNDO.
1722 DEFINE OUTPUT PARAMETER DATASET FOR dsFields.
1723
1724 DEFINE VARIABLE cCacheFile AS CHARACTER NO-UNDO.
1725 DEFINE VARIABLE cPrimIndexFields AS CHARACTER NO-UNDO.
1726 DEFINE VARIABLE cQuery AS CHARACTER NO-UNDO.
1727 DEFINE VARIABLE cSelectedFields AS CHARACTER NO-UNDO.
1728 DEFINE VARIABLE cUniqueIndexFields AS CHARACTER NO-UNDO.
1729 DEFINE VARIABLE cSDBName AS CHARACTER NO-UNDO.
1730 DEFINE VARIABLE hBufferField AS HANDLE NO-UNDO.
1731 DEFINE VARIABLE hBufferFile AS HANDLE NO-UNDO.
1732 DEFINE VARIABLE hQuery AS HANDLE NO-UNDO.
1733 DEFINE VARIABLE iFieldExtent AS INTEGER NO-UNDO.
1734 DEFINE VARIABLE iFieldOrder AS INTEGER NO-UNDO.
1735 DEFINE VARIABLE lDataField AS LOGICAL NO-UNDO.
1736 DEFINE VARIABLE iDataOrder AS INTEGER NO-UNDO.
1737 DEFINE VARIABLE i AS INTEGER NO-UNDO.
1738
1739 DEFINE BUFFER bTable FOR ttTable.
1740 DEFINE BUFFER bField FOR ttField.
1741 DEFINE BUFFER bColumn FOR ttColumn.
1742 DEFINE BUFFER bFieldCache FOR ttFieldCache.
1743 DEFINE BUFFER bColumnCache FOR ttColumnCache.
1744 DEFINE BUFFER bTableFilter FOR ttTableFilter.
1745
1746 {&timerStart}
1747
1748 /* Clean up first */
1749 EMPTY TEMP-TABLE bField.
1750 EMPTY TEMP-TABLE bColumn.
1751
1752 /* For dataservers, use the schema name [dataserver] */
1753 ASSIGN cSDBName = SDBNAME(pcDatabase).
1754
1755 /* Return if no db connected */
1756 IF NUM-DBS = 0 THEN RETURN.
1757
1758 /* caching */
1759 IF glCacheFieldDefs THEN
1760 DO:
1761 /* Find the table. Should exist. */
1762 FIND bTable WHERE bTable.cDatabase = pcDatabase AND bTable.cTableName = pcTableName NO-ERROR.
1763 IF NOT AVAILABLE bTable THEN RETURN.
1764
1765 /* Verify whether the CRC is still the same. If not, kill the cache */
1766 PUBLISH "DD:Timer" ("start", 'getFields - step 1: verify CRC').
1767 CREATE BUFFER hBufferFile FOR TABLE cSDBName + "._File".
1768
1769 hBufferFile:FIND-UNIQUE(SUBSTITUTE('where _file-name = &1 and _File._File-Number < 32768', QUOTER(pcTableName)),NO-LOCK).
1770 IF hBufferFile::_crc <> bTable.cCrc THEN
1771 DO:
1772 /* It seems that it is not possible to refresh the schema cache of the running
1773 * session. You just have to restart your session.
1774 */
1775 PUBLISH "debugInfo" (1, SUBSTITUTE("File CRC changed, kill cache and build new")).
1776 FOR EACH bFieldCache WHERE bFieldCache.cTableCacheId = bTable.cCacheId:
1777 DELETE bFieldCache.
1778 END.
1779 FOR EACH bColumnCache WHERE bColumnCache.cTableCacheId = bTable.cCacheId:
1780 DELETE bColumnCache.
1781 END.
1782
1783 /* Get a fresh list of tables */
1784 RUN getTables(INPUT TABLE bTableFilter, OUTPUT TABLE bTable).
1785
1786 /* Find the table back. Should exist. */
1787 FIND bTable WHERE bTable.cDatabase = pcDatabase AND bTable.cTableName = pcTableName NO-ERROR.
1788 IF NOT AVAILABLE bTable THEN RETURN.
1789 END.
1790 PUBLISH "DD:Timer" ("stop", 'getFields - step 1: verify CRC').
1791
1792 /* First look in the memory-cache */
1793 IF CAN-FIND(FIRST bFieldCache WHERE bFieldCache.cTableCacheId = bTable.cCacheId) THEN
1794 DO:
1795 PUBLISH "DD:Timer" ("start", 'getFields - step 2: check memory cache').
1796 PUBLISH "debugInfo" (3, SUBSTITUTE("Get from memory-cache")).
1797
1798 FOR EACH bFieldCache WHERE bFieldCache.cTableCacheId = bTable.cCacheId:
1799 CREATE bField.
1800 BUFFER-COPY bFieldCache TO bField.
1801 END.
1802
1803 FOR EACH bColumnCache WHERE bColumnCache.cTableCacheId = bTable.cCacheId:
1804 CREATE bColumn.
1805 BUFFER-COPY bColumnCache TO bColumn.
1806 END.
1807
1808 /* Update with settings from registry */
1809 RUN updateFields(INPUT pcDatabase, INPUT pcTableName, INPUT-OUTPUT TABLE bField).
1810
1811 PUBLISH "DD:Timer" ("stop", 'getFields - step 2: check memory cache').
1812 RETURN.
1813 END.
1814
1815 /* See if disk cache exists */
1816 cCacheFile = SUBSTITUTE('&1cache\&2.xml', getWorkFolder(), bTable.cCacheId).
1817 PUBLISH "debugInfo" (2, SUBSTITUTE("Cachefile: &1", cCacheFile)).
1818
1819 IF SEARCH(cCacheFile) <> ? THEN
1820 DO:
1821 PUBLISH "DD:Timer" ("start", 'getFields - step 3: get from disk cache').
1822 PUBLISH "debugInfo" (3, SUBSTITUTE("Get from disk cache")).
1823 DATASET dsFields:READ-XML("file", cCacheFile, "empty", ?, ?, ?, ?).
1824
1825 /* Add to memory cache, so the next time it's even faster */
1826 IF TEMP-TABLE bField:HAS-RECORDS THEN
1827 DO:
1828 PUBLISH "debugInfo" (3, SUBSTITUTE("Add to first-level cache")).
1829 FOR EACH bField {&TABLE-SCAN}:
1830 CREATE bFieldCache.
1831 BUFFER-COPY bField TO bFieldCache.
1832 END.
1833
1834 FOR EACH bColumn {&TABLE-SCAN}:
1835 CREATE bColumnCache.
1836 BUFFER-COPY bColumn TO bColumnCache.
1837 END.
1838 END.
1839
1840 /* Update with settings from registry */
1841 RUN updateFields(INPUT pcDatabase, INPUT pcTableName, INPUT-OUTPUT TABLE bField).
1842
1843 PUBLISH "DD:Timer" ("stop", 'getFields - step 3: get from disk cache').
1844 RETURN.
1845 END.
1846
1847 PUBLISH "debugInfo" (3, SUBSTITUTE("Not found in any cache, build tables...")).
1848 END.
1849
1850 /*
1851 * If we get here, the table either cannot be found in the cache
1852 * or caching is disabled. Either way, fill the tt with fields
1853 */
1854 PUBLISH "DD:Timer" ("start", 'getFields - step 4: build cache').
1855 FIND bTable WHERE bTable.cDatabase = pcDatabase AND bTable.cTableName = pcTableName NO-ERROR.
1856 IF NOT AVAILABLE bTable THEN RETURN.
1857
1858 CREATE BUFFER hBufferFile FOR TABLE cSDBName + "._File".
1859 CREATE BUFFER hBufferField FOR TABLE cSDBName + "._Field".
1860
1861 CREATE QUERY hQuery.
1862 hQuery:SET-BUFFERS(hBufferFile,hBufferField).
1863
1864 cQuery = SUBSTITUTE("FOR EACH &1._File WHERE &1._file._file-name = '&2' AND _File._File-Number < 32768 NO-LOCK, " +
1865 " EACH &1._Field OF &1._File NO-LOCK BY _ORDER"
1866 , cSDBName
1867 , pcTableName
1868 ).
1869
1870 hQuery:QUERY-PREPARE(cQuery).
1871 hQuery:QUERY-OPEN().
1872 hQuery:GET-FIRST().
1873
1874 /* Get list of fields in primary index. */
1875 cPrimIndexFields = getIndexFields(cSDBName, pcTableName, "P").
1876
1877 /* Get list of fields in all unique indexes. */
1878 cUniqueIndexFields = getIndexFields(cSDBName, pcTableName, "U").
1879
1880 /* Get list of all previously selected fields */
1881 cSelectedFields = getRegistry(SUBSTITUTE("DB:&1",pcDatabase), SUBSTITUTE("&1:Fields",pcTableName)).
1882
1883 /* If none selected, set mask to 'all' */
1884 IF cSelectedFields = ? THEN cSelectedFields = '*'.
1885
1886 REPEAT WHILE NOT hQuery:QUERY-OFF-END:
1887
1888 CREATE bField.
1889 ASSIGN
1890 iFieldOrder = iFieldOrder + 1
1891 bField.cTableCacheId = bTable.cCacheId
1892 bField.cDatabase = pcDatabase
1893 bField.cTablename = pcTableName
1894 bField.cFieldName = hBufferField:BUFFER-FIELD('_field-name'):BUFFER-VALUE
1895
1896 bField.lShow = CAN-DO(cSelectedFields, hBufferField:BUFFER-FIELD('_field-name'):BUFFER-VALUE)
1897 bField.iOrder = iFieldOrder
1898 bField.iOrderOrg = iFieldOrder
1899
1900 bField.cFullName = hBufferField:BUFFER-FIELD('_field-name'):BUFFER-VALUE
1901 bField.cDataType = hBufferField:BUFFER-FIELD('_data-type'):BUFFER-VALUE
1902 bField.cInitial = hBufferField:BUFFER-FIELD('_initial'):BUFFER-VALUE
1903 bField.cFormat = hBufferField:BUFFER-FIELD('_format'):BUFFER-VALUE
1904 bField.cFormatOrg = hBufferField:BUFFER-FIELD('_format'):BUFFER-VALUE
1905 bField.iWidth = hBufferField:BUFFER-FIELD('_width'):BUFFER-VALUE
1906 bField.cLabel = hBufferField:BUFFER-FIELD('_label'):BUFFER-VALUE
1907 bField.lPrimary = CAN-DO(cPrimIndexFields, bField.cFieldName)
1908 bField.iExtent = hBufferField:BUFFER-FIELD('_Extent'):BUFFER-VALUE
1909 bField.lMandatory = hBufferField:BUFFER-FIELD('_mandatory'):BUFFER-VALUE
1910 bField.lUniqueIdx = CAN-DO(cUniqueIndexFields,bField.cFieldName)
1911
1912 /* New fields as per v19 */
1913 bField.cColLabel = hBufferField:BUFFER-FIELD('_Col-label'):BUFFER-VALUE
1914 bField.iDecimals = hBufferField:BUFFER-FIELD('_Decimals'):BUFFER-VALUE
1915 bField.iFieldRpos = hBufferField:BUFFER-FIELD('_Field-rpos'):BUFFER-VALUE
1916 bField.cValExp = hBufferField:BUFFER-FIELD('_ValExp'):BUFFER-VALUE
1917 bField.cValMsg = hBufferField:BUFFER-FIELD('_ValMsg'):BUFFER-VALUE
1918 bField.cHelp = hBufferField:BUFFER-FIELD('_Help'):BUFFER-VALUE
1919 bField.cDesc = hBufferField:BUFFER-FIELD('_Desc'):BUFFER-VALUE
1920 bField.cViewAs = hBufferField:BUFFER-FIELD('_View-as'):BUFFER-VALUE
1921 .
1922 ASSIGN
1923 bField.cXmlNodeName = getXmlNodeName(bField.cFieldName)
1924 .
1925
1926 /* Make a list of fields on table level */
1927 bTable.cFields = bTable.cFields + "," + bField.cFieldName.
1928
1929 /* Some types should not be shown like CLOB BLOB and RAW */
1930 lDataField = (LOOKUP(bField.cDataType, 'clob,blob,raw') = 0).
1931
1932 /* Create TT records for each column to show, except for CLOB / BLOB / RAW */
1933 IF lDataField = TRUE THEN
1934 DO iFieldExtent = (IF bField.iExtent = 0 THEN 0 ELSE 1) TO bField.iExtent:
1935
1936 iDataOrder = iDataOrder + 1.
1937
1938 CREATE bColumn.
1939 ASSIGN
1940 bColumn.cTableCacheId = bTable.cCacheId
1941 bColumn.cDatabase = bField.cDatabase
1942 bColumn.cTableName = bField.cTablename
1943 bColumn.cFieldName = bField.cFieldName
1944 bColumn.iExtent = iFieldExtent
1945 bColumn.cFullName = bField.cFieldName + (IF iFieldExtent > 0 THEN SUBSTITUTE("[&1]", iFieldExtent) ELSE "")
1946 bColumn.iColumnNr = iDataOrder
1947 bColumn.iOrder = bField.iOrder
1948 bColumn.cLabel = bField.cLabel
1949 .
1950 PUBLISH "debugInfo"(3,SUBSTITUTE("Field &1 created", bColumn.cFullName)).
1951 END. /* For each extent nr */
1952
1953 hQuery:GET-NEXT().
1954 END.
1955 hQuery:QUERY-CLOSE().
1956
1957 DELETE OBJECT hQuery.
1958 DELETE OBJECT hBufferField.
1959 DELETE OBJECT hBufferFile.
1960
1961 /* Fieldlist */
1962 bTable.cFields = SUBSTRING(bTable.cFields,2).
1963
1964 /* Add columns for recid/rowid */
1965 DO i = 1 TO 2:
1966
1967 CREATE bField.
1968 ASSIGN
1969 iFieldOrder = iFieldOrder + 1
1970 bField.cTableCacheId = bTable.cCacheId
1971 bField.cDatabase = pcDatabase
1972 bField.cTablename = pcTableName
1973 bField.cFieldName = ENTRY(i,"RECID,ROWID")
1974 bField.lShow = FALSE
1975 bField.iOrder = iFieldOrder
1976 bField.iOrderOrg = iFieldOrder
1977 bField.cFieldName = bField.cFieldName
1978 bField.cFullName = bField.cFieldName
1979 bField.cDataType = 'character'
1980 bField.cInitial = ''
1981 bField.cFormat = ENTRY(i,"X(20),X(24)")
1982 bField.cFormatOrg = bField.cFormat
1983 bField.cLabel = bField.cFieldName
1984 bField.lPrimary = NO
1985 bField.iExtent = 0
1986 .
1987
1988 iDataOrder = iDataOrder + 1.
1989 CREATE bColumn.
1990 ASSIGN
1991 bColumn.cTableCacheId = bField.cTableCacheId
1992 bColumn.cDatabase = bField.cDatabase
1993 bColumn.cTableName = bField.cTablename
1994 bColumn.cFieldName = bField.cFieldName
1995 bColumn.iExtent = 0
1996 bColumn.cFullName = bField.cFieldName
1997 bColumn.iColumnNr = iDataOrder
1998 bColumn.iOrder = bField.iOrder
1999 bColumn.cLabel = bField.cLabel
2000 .
2001 END.
2002 PUBLISH "DD:Timer" ("stop", 'getFields - step 4: build cache').
2003
2004 /* Update the cache */
2005 IF glCacheFieldDefs THEN
2006 DO:
2007 /* Add to disk cache */
2008 PUBLISH "DD:Timer" ("start", 'getFields - step 5: save to disk').
2009 PUBLISH "debugInfo" (3, SUBSTITUTE("Add to second-level cache.")).
2010 DATASET dsFields:WRITE-XML( "file", cCacheFile, YES, ?, ?, NO, NO).
2011
2012 /* Add to memory cache */
2013 PUBLISH "debugInfo" (3, SUBSTITUTE("Add to first-level cache.")).
2014 FOR EACH bField {&TABLE-SCAN}:
2015 CREATE bFieldCache.
2016 BUFFER-COPY bField TO bFieldCache.
2017 END.
2018
2019 FOR EACH bColumn {&TABLE-SCAN}:
2020 CREATE bColumnCache.
2021 BUFFER-COPY bColumn TO bColumnCache.
2022 END.
2023 PUBLISH "DD:Timer" ("stop", 'getFields - step 5: save to disk').
2024 END.
2025
2026 /* Update fields with settings from registry */
2027 RUN updateFields(INPUT pcDatabase, INPUT pcTableName, INPUT-OUTPUT TABLE bField).
2028
2029 {&timerStop}
2030
2031END PROCEDURE. /* getFields */
2032
2033/* _UIB-CODE-BLOCK-END */
2034&ANALYZE-RESUME
2035
2036&ENDIF
2037
2038&IF DEFINED(EXCLUDE-getMouseXY) = 0 &THEN
2039
2040&ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE getMouseXY Procedure
2041PROCEDURE getMouseXY :
2042/* Get the position of the mouse relative to the frame
2043 */
2044 DEFINE INPUT PARAMETER phFrame AS HANDLE NO-UNDO.
2045 DEFINE OUTPUT PARAMETER piMouseX AS INTEGER NO-UNDO.
2046 DEFINE OUTPUT PARAMETER piMouseY AS INTEGER NO-UNDO.
2047
2048 DEFINE VARIABLE lp AS MEMPTR NO-UNDO.
2049 {&_proparse_prolint-nowarn(varusage)}
2050 DEFINE VARIABLE iRet AS INT64 NO-UNDO.
2051
2052 SET-SIZE( LP ) = 16.
2053
2054 {&_proparse_prolint-nowarn(varusage)}
2055 RUN GetCursorPos(INPUT GET-POINTER-VALUE(lp), OUTPUT iRet).
2056
2057 RUN ScreenToClient ( INPUT phFrame:HWND, INPUT lp ).
2058 piMouseX = GET-LONG( lp, 1 ).
2059 piMouseY = GET-LONG( lp, 5 ).
2060 SET-SIZE( LP ) = 0.
2061
2062 PUBLISH "debugInfo" (3, SUBSTITUTE("Mouse X/Y = &1 / &2", piMouseX, piMouseY)).
2063
2064END PROCEDURE. /* getMouseXY */
2065
2066/* _UIB-CODE-BLOCK-END */
2067&ANALYZE-RESUME
2068
2069&ENDIF
2070
2071&IF DEFINED(EXCLUDE-getQueryTable) = 0 &THEN
2072
2073&ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE getQueryTable Procedure
2074PROCEDURE getQueryTable :
2075/* Get the ttQuery table
2076 * Note: This procedure just returns the table, no further logic needed.
2077 */
2078 DEFINE OUTPUT PARAMETER table FOR ttQuery.
2079
2080END PROCEDURE. /* getQueryTable */
2081
2082/* _UIB-CODE-BLOCK-END */
2083&ANALYZE-RESUME
2084
2085&ENDIF
2086
2087&IF DEFINED(EXCLUDE-getRegistryTable) = 0 &THEN
2088
2089&ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE getRegistryTable Procedure
2090PROCEDURE getRegistryTable :
2091/* Return complete registry tt
2092 */
2093 DEFINE OUTPUT PARAMETER TABLE FOR ttConfig.
2094
2095END PROCEDURE. /* getRegistryTable */
2096
2097/* _UIB-CODE-BLOCK-END */
2098&ANALYZE-RESUME
2099
2100&ENDIF
2101
2102&IF DEFINED(EXCLUDE-getTables) = 0 &THEN
2103
2104&ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE getTables Procedure
2105PROCEDURE getTables :
2106/* Fill ttTable with all currently connected databases.
2107 */
2108 DEFINE INPUT PARAMETER TABLE FOR ttTableFilter.
2109 DEFINE OUTPUT PARAMETER TABLE FOR ttTable.
2110
2111 DEFINE VARIABLE cCacheFile AS CHARACTER NO-UNDO.
2112 DEFINE VARIABLE hDbBuffer AS HANDLE NO-UNDO.
2113 DEFINE VARIABLE hDbStatusBuffer AS HANDLE NO-UNDO.
2114 DEFINE VARIABLE hDbQuery AS HANDLE NO-UNDO.
2115 DEFINE VARIABLE iDatabase AS INTEGER NO-UNDO.
2116 DEFINE VARIABLE cCacheTimeStamp AS CHARACTER NO-UNDO.
2117 DEFINE VARIABLE cCacheDir AS CHARACTER NO-UNDO.
2118 DEFINE VARIABLE cSchemaCacheFile AS CHARACTER NO-UNDO.
2119 DEFINE VARIABLE cOneCacheFile AS CHARACTER NO-UNDO.
2120
2121 DEFINE BUFFER bTable FOR ttTable.
2122 DEFINE BUFFER bTableXml FOR ttTableXml.
2123
2124 {&timerStart}
2125
2126 /* Dataserver support can be for:
2127 *
2128 * V9: "PROGRESS,AS400,ORACLE,MSS,ODBC"
2129 * V10: "PROGRESS,ORACLE,MSS,ODBC" (from V10 no native support for AS400)
2130 * V11: "PROGRESS,ORACLE,MSS,ODBC"
2131 * V12: "PROGRESS,ORACLE,MSS" (from V12 no ODBC support anymore)
2132 *
2133 */
2134 EMPTY TEMP-TABLE ttTable.
2135 CREATE WIDGET-POOL "metaInfo".
2136
2137 #Database:
2138 DO iDatabase = 1 TO NUM-DBS:
2139 IF DBTYPE(iDatabase) <> "PROGRESS" THEN NEXT #Database.
2140
2141 /* Compose name of the cache file. Use date/time of last schema change in the name */
2142 IF glCacheTableDefs THEN
2143 DO:
2144 CREATE BUFFER hDbStatusBuffer FOR TABLE LDBNAME(iDatabase) + "._DbStatus" IN WIDGET-POOL "metaInfo".
2145 hDbStatusBuffer:FIND-FIRST("",NO-LOCK).
2146
2147 ASSIGN
2148 cCacheTimeStamp = REPLACE(REPLACE(hDbStatusBuffer::_dbstatus-cachestamp," ","_"),":","")
2149 cCacheFile = SUBSTITUTE("&1cache\db.&2.&3.xml", getWorkFolder(), LDBNAME(iDatabase), cCacheTimeStamp ).
2150
2151 DELETE OBJECT hDbStatusBuffer.
2152 END.
2153
2154 /* If caching enabled and there is a cache file, read it */
2155 IF glCacheTableDefs AND SEARCH(cCacheFile) <> ? THEN
2156 DO:
2157 PUBLISH "debugInfo" (3, SUBSTITUTE("Get table list from cache file &1", cCacheFile)).
2158 TEMP-TABLE ttTable:READ-XML("file", cCacheFile, "APPEND", ?, ?, ?, ?).
2159
2160 cCacheDir = SUBSTITUTE( "&1cache", getWorkFolder() ).
2161 INPUT FROM OS-DIR(cCacheDir).
2162 #ReadSchemaCache:
2163 REPEAT:
2164 IMPORT cSchemaCacheFile.
2165
2166 IF cSchemaCacheFile BEGINS SUBSTITUTE("db.&1;", LDBNAME(iDatabase))
2167 AND ENTRY(NUM-ENTRIES(cSchemaCacheFile, ".") - 1, cSchemaCacheFile, ".") = ENTRY (NUM-ENTRIES(cCacheFile, ".") - 1, cCacheFile, ".") /* Check timestamp */
2168 THEN
2169 DO:
2170 cOneCacheFile = SUBSTITUTE( "&1\&2", cCacheDir, cSchemaCacheFile).
2171 TEMP-TABLE ttTable:READ-XML("file", cOneCacheFile, "APPEND", ?, ?, ?, ?).
2172 END.
2173 END.
2174 INPUT CLOSE.
2175 END.
2176
2177 /* Otherwise build it */
2178 ELSE
2179 DO:
2180 CREATE ALIAS 'dictdb' FOR DATABASE VALUE(LDBNAME(iDatabase)).
2181 RUN getSchema.p(INPUT TABLE ttTable BY-REFERENCE).
2182
2183 /* Save cache file for next time */
2184 IF glCacheTableDefs THEN
2185 DO:
2186 /* Move the tables of the current db to a separate tt so we can dump it. */
2187 EMPTY TEMP-TABLE ttTableXml.
2188
2189 CREATE QUERY hDbQuery IN WIDGET-POOL "metaInfo".
2190 CREATE BUFFER hDbBuffer FOR TABLE LDBNAME(iDatabase) + "._Db" IN WIDGET-POOL "metaInfo".
2191
2192 hDbQuery:SET-BUFFERS(hDbBuffer).
2193 hDbQuery:QUERY-PREPARE("FOR EACH _Db NO-LOCK WHERE _Db._Db-local = TRUE").
2194 hDbQuery:QUERY-OPEN().
2195
2196 #DB:
2197 REPEAT:
2198 hDbQuery:GET-NEXT().
2199 IF hDbQuery:QUERY-OFF-END THEN LEAVE #DB.
2200
2201 FOR EACH bTable
2202 WHERE bTable.cDatabase = (IF hDbBuffer::_Db-slave THEN hDbBuffer::_Db-name ELSE LDBNAME(iDatabase)):
2203 CREATE bTableXml.
2204 BUFFER-COPY bTable TO bTableXml.
2205 END.
2206 END.
2207
2208 hDbQuery:QUERY-CLOSE().
2209 DELETE OBJECT hDbQuery.
2210 DELETE OBJECT hDbBuffer.
2211
2212 TEMP-TABLE ttTableXml:WRITE-XML("file", cCacheFile, YES, ?, ?, NO, NO).
2213 EMPTY TEMP-TABLE ttTableXml.
2214
2215 /* Support Dataservers */
2216 FOR EACH bTable
2217 WHERE bTable.cSchemaHolder = LDBNAME(iDatabase)
2218 BREAK BY bTable.cDatabase
2219 BY bTable.cTableName:
2220
2221 IF FIRST-OF(bTable.cDatabase) THEN
2222 DO:
2223 cCacheFile = SUBSTITUTE( "&1cache\db.&2;&3.&4.xml"
2224 , getWorkFolder()
2225 , LDBNAME(iDatabase)
2226 , bTable.cDatabase
2227 , cCacheTimeStamp
2228 ).
2229 EMPTY TEMP-TABLE bTableXml.
2230 END.
2231
2232 CREATE bTableXml.
2233 BUFFER-COPY bTable TO bTableXml.
2234
2235 IF LAST-OF(bTable.cDatabase) THEN
2236 DO:
2237 TEMP-TABLE bTableXml:WRITE-XML("file", cCacheFile, YES, ?, ?, NO, NO).
2238 EMPTY TEMP-TABLE bTableXml.
2239 END. /* IF LAST-OF */
2240 END. /* FOR EACH bTable */
2241 END. /* IF glCacheTableDefs THEN */
2242 END. /* tt empty */
2243 END. /* 1 to num-dbs */
2244
2245 DELETE WIDGET-POOL "metaInfo".
2246
2247 /* Apply filter to collection of tables */
2248 RUN getTablesFiltered(INPUT TABLE ttTableFilter, OUTPUT TABLE ttTable).
2249
2250 /* Get table properties from the INI file */
2251 RUN getTableStats(INPUT-OUTPUT TABLE ttTable).
2252
2253 {&timerStop}
2254
2255END PROCEDURE. /* getTables */
2256
2257/* _UIB-CODE-BLOCK-END */
2258&ANALYZE-RESUME
2259
2260&ENDIF
2261
2262&IF DEFINED(EXCLUDE-getTablesFiltered) = 0 &THEN
2263
2264&ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE getTablesFiltered Procedure
2265PROCEDURE getTablesFiltered :
2266/* Determine whether tables in the ttTable are visible given a user defined filter
2267 */
2268 {&timerStart}
2269 DEFINE INPUT PARAMETER TABLE FOR ttTableFilter.
2270 DEFINE OUTPUT PARAMETER TABLE FOR ttTable.
2271
2272 DEFINE VARIABLE cSearchFld AS CHARACTER NO-UNDO.
2273 DEFINE VARIABLE cThisField AS CHARACTER NO-UNDO.
2274 DEFINE VARIABLE iSearch AS INTEGER NO-UNDO.
2275 DEFINE VARIABLE iField AS INTEGER NO-UNDO.
2276 DEFINE VARIABLE lRejected AS LOGICAL NO-UNDO.
2277 DEFINE VARIABLE lFieldFound AS LOGICAL NO-UNDO.
2278 DEFINE VARIABLE lNormal AS LOGICAL NO-UNDO.
2279 DEFINE VARIABLE lSchema AS LOGICAL NO-UNDO.
2280 DEFINE VARIABLE lVst AS LOGICAL NO-UNDO.
2281 DEFINE VARIABLE lSql AS LOGICAL NO-UNDO.
2282 DEFINE VARIABLE lOther AS LOGICAL NO-UNDO.
2283 DEFINE VARIABLE lHidden AS LOGICAL NO-UNDO.
2284 DEFINE VARIABLE lFrozen AS LOGICAL NO-UNDO.
2285 DEFINE VARIABLE cNameShow AS CHARACTER NO-UNDO.
2286 DEFINE VARIABLE cNameHide AS CHARACTER NO-UNDO.
2287 DEFINE VARIABLE cFieldShow AS CHARACTER NO-UNDO.
2288 DEFINE VARIABLE cFieldHide AS CHARACTER NO-UNDO.
2289
2290 /* This table **SHOULD** exist and have exactly 1 record */
2291 FIND ttTableFilter NO-ERROR.
2292 IF NOT AVAILABLE ttTableFilter THEN RETURN.
2293
2294 ASSIGN
2295 lNormal = ttTableFilter.lShowNormal
2296 lSchema = ttTableFilter.lShowSchema
2297 lVst = ttTableFilter.lShowVst
2298 lSql = ttTableFilter.lShowSql
2299 lOther = ttTableFilter.lShowOther
2300 lHidden = ttTableFilter.lShowHidden
2301 lFrozen = ttTableFilter.lShowFrozen
2302 cNameShow = ttTableFilter.cTableNameShow
2303 cNameHide = ttTableFilter.cTableNameHide
2304 cFieldShow = ttTableFilter.cTableFieldShow
2305 cFieldHide = ttTableFilter.cTableFieldHide
2306 .
2307
2308 /* Reset the filters to sane values if needed */
2309 IF cNameShow = '' OR cNameShow = ? THEN cNameShow = '*'.
2310 IF cNameHide = '*' OR cNameHide = ? THEN cNameHide = '' .
2311 IF cFieldShow = '*' OR cFieldShow = ? THEN cFieldShow = ''.
2312 IF cFieldHide = '*' OR cFieldHide = ? THEN cFieldHide = ''.
2313
2314 /* Move elements starting with "!" from pos-list to neg-list */
2315 RUN correctFilterList(INPUT-OUTPUT cNameShow, INPUT-OUTPUT cNameHide).
2316 RUN correctFilterList(INPUT-OUTPUT cFieldShow, INPUT-OUTPUT cFieldHide).
2317
2318 #Table:
2319 FOR EACH ttTable {&TABLE-SCAN}:
2320 /* Init table to false until proven otherwise */
2321 ASSIGN ttTable.lShowInList = FALSE.
2322
2323 /* Check against filter-to-hide */
2324 IF CAN-DO(cNameHide,ttTable.cTableName) THEN NEXT #Table.
2325
2326 /* Check against filter-to-show */
2327 IF NOT CAN-DO(cNameShow,ttTable.cTableName) THEN NEXT #Table.
2328
2329 /* User tables : _file-number > 0 AND _file-number < 32000
2330 * Schema tables : _file-number > -80 AND _file-number < 0
2331 * Virtual system tables: _file-number < -16384
2332 * SQL catalog tables : _file-name BEGINS "_sys"
2333 */
2334 IF NOT lNormal AND ttTable.cCategory = 'Normal' THEN NEXT #Table.
2335 IF NOT lSchema AND ttTable.cCategory = 'Schema' THEN NEXT #Table.
2336 IF NOT lVst AND ttTable.cCategory = 'VST' THEN NEXT #Table.
2337 IF NOT lSql AND ttTable.cCategory = 'SQL' THEN NEXT #Table.
2338 IF NOT lOther AND ttTable.cCategory = 'Other' THEN NEXT #Table.
2339
2340 /* Handling for Hidden and Frozen apply only to user tables otherwise it will be too confusing
2341 * because Schema, VST and SQL tables are all by default hidden and frozen.
2342 */
2343 IF NOT lHidden AND ttTable.cCategory = 'Application' AND ttTable.lHidden = TRUE THEN NEXT #Table.
2344 IF NOT lFrozen AND ttTable.cCategory = 'Application' AND ttTable.lFrozen = TRUE THEN NEXT #Table.
2345
2346 /* Fields that must be in the list */
2347 DO iSearch = 1 TO NUM-ENTRIES(cFieldShow):
2348 cSearchFld = ENTRY(iSearch,cFieldShow).
2349
2350 /* If no wildcards used, we can simply CAN-DO */
2351 IF INDEX(cSearchFld,"*") = 0 THEN
2352 DO:
2353 IF NOT CAN-DO(ttTable.cFields, cSearchFld) THEN NEXT #Table.
2354 END.
2355 ELSE
2356 DO:
2357 lFieldFound = FALSE.
2358
2359 #Field:
2360 DO iField = 1 TO NUM-ENTRIES(ttTable.cFields):
2361 cThisField = ENTRY(iField,ttTable.cFields).
2362 IF CAN-DO(cSearchFld,cThisField) THEN
2363 DO:
2364 lFieldFound = TRUE.
2365 LEAVE #Field.
2366 END.
2367 END.
2368 IF NOT lFieldFound THEN NEXT #Table.
2369 END.
2370 END.
2371
2372 /* Fields that may not be in the list */
2373 DO iSearch = 1 TO NUM-ENTRIES(cFieldHide):
2374 cSearchFld = ENTRY(iSearch,cFieldHide).
2375
2376 /* If no wildcards used, we can simply CAN-DO */
2377 IF INDEX(cSearchFld,"*") = 0 THEN
2378 DO:
2379 IF CAN-DO(ttTable.cFields, cSearchFld) THEN NEXT #Table.
2380 END.
2381 ELSE
2382 DO:
2383 lRejected = FALSE.
2384 #Field:
2385 DO iField = 1 TO NUM-ENTRIES(ttTable.cFields):
2386 cThisField = ENTRY(iField,ttTable.cFields).
2387 IF CAN-DO(cSearchFld,cThisField) THEN
2388 DO:
2389 lRejected = TRUE.
2390 LEAVE #Field.
2391 END.
2392 END. /* do iField */
2393 IF lRejected THEN NEXT #Table.
2394 END. /* else */
2395 END. /* do iSearch */
2396
2397 /* If we get here, we should add the table */
2398 ASSIGN ttTable.lShowInList = TRUE.
2399 END. /* for each ttTable */
2400
2401 {&timerStop}
2402END PROCEDURE. /* getTablesFiltered */
2403
2404/* _UIB-CODE-BLOCK-END */
2405&ANALYZE-RESUME
2406
2407&ENDIF
2408
2409&IF DEFINED(EXCLUDE-getTableStats) = 0 &THEN
2410
2411&ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE getTableStats Procedure
2412PROCEDURE getTableStats :
2413/* Get table statistics from the INI file
2414 */
2415 DEFINE INPUT-OUTPUT PARAMETER table FOR ttTable.
2416
2417 DEFINE VARIABLE cIniFile AS CHARACTER NO-UNDO.
2418 DEFINE VARIABLE cLine AS CHARACTER NO-UNDO.
2419 DEFINE VARIABLE cSection AS CHARACTER NO-UNDO.
2420 DEFINE VARIABLE cDatabase AS CHARACTER NO-UNDO.
2421
2422 /* Read the ini file as plain text and parse the lines.
2423 *
2424 * The normal way would be to do a FOR-EACH on the _file table and
2425 * retrieve the information needed. But if you have a large database
2426 * (or a lot of databases), this becomes VERY slow. Searching the
2427 * other way around by parsing the INI is a lot faster.
2428 */
2429 {&timerStart}
2430
2431 cIniFile = SUBSTITUTE('&1DataDigger-&2.ini', getWorkFolder(), getUserName() ).
2432 IF SEARCH(cIniFile) = ? THEN RETURN.
2433
2434 INPUT FROM VALUE(cIniFile).
2435
2436 #ReadLine:
2437 REPEAT:
2438 /* Sometimes lines get screwed up and are waaaay too long
2439 * for the import statement. So just ignore those.
2440 */
2441 IMPORT UNFORMATTED cLine NO-ERROR.
2442 IF ERROR-STATUS:ERROR THEN NEXT #ReadLine.
2443
2444 /* Find DB sections */
2445 IF cLine MATCHES '[DB:*]' THEN
2446 DO:
2447 cSection = TRIM(cLine,'[]').
2448 cDatabase = ENTRY(2,cSection,":").
2449 END.
2450
2451 /* Only process lines of database-sections */
2452 IF NOT cSection BEGINS "DB:" THEN NEXT #ReadLine.
2453
2454 /* Only process setting lines */
2455 IF NOT cLine MATCHES '*:*=*' THEN NEXT #ReadLine.
2456
2457 /* Filter out some settings */
2458 IF cLine MATCHES "*:QueriesServed=*" THEN
2459 DO:
2460 FIND FIRST ttTable
2461 WHERE ttTable.cDatabase = cDatabase
2462 AND ttTable.cTableName = ENTRY(1,cLine,':') NO-ERROR.
2463
2464 IF AVAILABLE ttTable THEN
2465 DO:
2466 ttTable.iNumQueries = INTEGER(ENTRY(2,cLine,'=')) NO-ERROR.
2467 IF ttTable.iNumQueries = ? THEN ttTable.iNumQueries = 0.
2468 END.
2469 END. /* queriesServed */
2470
2471 ELSE
2472 IF cLine MATCHES "*:LastUsed=*" THEN
2473 DO:
2474 FIND FIRST ttTable
2475 WHERE ttTable.cDatabase = cDatabase
2476 AND ttTable.cTableName = ENTRY(1,cLine,':') NO-ERROR.
2477
2478 IF AVAILABLE ttTable THEN
2479 ttTable.tLastUsed = DATETIME(ENTRY(2,cLine,'=')) NO-ERROR.
2480
2481 END. /* lastUsed */
2482
2483 END. /* repeat */
2484 INPUT CLOSE.
2485
2486 {&timerStop}
2487
2488END PROCEDURE. /* getTableStats */
2489
2490/* _UIB-CODE-BLOCK-END */
2491&ANALYZE-RESUME
2492
2493&ENDIF
2494
2495&IF DEFINED(EXCLUDE-initTableFilter) = 0 &THEN
2496
2497&ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE initTableFilter Procedure
2498PROCEDURE initTableFilter :
2499/* Set table filter values back to their initial values
2500 */
2501 DEFINE INPUT-OUTPUT PARAMETER TABLE FOR ttTableFilter.
2502
2503 EMPTY TEMP-TABLE ttTableFilter.
2504 CREATE ttTableFilter.
2505
2506 /* Set visibility of schema tables */
2507 ttTableFilter.lShowSchema = LOGICAL(getRegistry('DataDigger','ShowHiddenTables')).
2508 IF ttTableFilter.lShowSchema = ? THEN ttTableFilter.lShowSchema = NO.
2509
2510END PROCEDURE. /* initTableFilter */
2511
2512/* _UIB-CODE-BLOCK-END */
2513&ANALYZE-RESUME
2514
2515&ENDIF
2516
2517&IF DEFINED(EXCLUDE-loadSettings) = 0 &THEN
2518
2519&ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE loadSettings Procedure
2520PROCEDURE loadSettings :
2521/* Load settings from ini files
2522*/
2523 DEFINE VARIABLE lValue AS LOGICAL NO-UNDO.
2524
2525 /* Help file is least important, so read that first */
2526 RUN readConfigFile( SUBSTITUTE("&1DataDiggerHelp.ini", getProgramDir() ), FALSE).
2527
2528 /* General DD settings (always in program folder) */
2529 RUN readConfigFile( SUBSTITUTE("&1DataDigger.ini", getProgramDir() ), FALSE).
2530
2531 /* Per-user settings */
2532 RUN readConfigFile( SUBSTITUTE("&1DataDigger-&2.ini", getWorkFolder(), getUserName() ), TRUE).
2533
2534 /* When all ini-files have been read, we can determine whether
2535 * caching needs to be enabled
2536 */
2537 lValue = LOGICAL(getRegistry("DataDigger:Cache","TableDefs")) NO-ERROR.
2538 IF lValue <> ? THEN ASSIGN glCacheTableDefs = lValue.
2539
2540END PROCEDURE. /* loadSettings */
2541
2542/* _UIB-CODE-BLOCK-END */
2543&ANALYZE-RESUME
2544
2545&ENDIF
2546
2547&IF DEFINED(EXCLUDE-lockWindow) = 0 &THEN
2548
2549&ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE lockWindow Procedure
2550PROCEDURE lockWindow :
2551/* Lock / unlock updates that Windows does to windows.
2552 */
2553 DEFINE INPUT PARAMETER phWindow AS HANDLE NO-UNDO.
2554 DEFINE INPUT PARAMETER plLock AS LOGICAL NO-UNDO.
2555
2556 {&_proparse_prolint-nowarn(varusage)}
2557 DEFINE VARIABLE iRet AS INTEGER NO-UNDO.
2558 DEFINE BUFFER ttWindowLock FOR ttWindowLock.
2559
2560 {&timerStart}
2561 PUBLISH "debugInfo" (3, SUBSTITUTE("Window &1, lock: &2", phWindow:TITLE, STRING(plLock,"ON/OFF"))).
2562
2563 IF NOT VALID-HANDLE(phWindow) THEN RETURN.
2564
2565 /* Find window in our tt of locked windows */
2566 FIND ttWindowLock WHERE ttWindowLock.hWindow = phWindow NO-ERROR.
2567 IF NOT AVAILABLE ttWindowLock THEN
2568 DO:
2569 /* If we try to unlock a window thats not in the tt, just go back */
2570 IF NOT plLock THEN RETURN.
2571
2572 /* Otherwise create a tt record for it */
2573 CREATE ttWindowLock.
2574 ttWindowLock.hWindow = phWindow.
2575 END.
2576
2577 /* Because commands to lock or unlock may be nested, keep track
2578 * of the number of locks/unlocks using a semaphore.
2579 *
2580 * The order of commands may be:
2581 * lockWindow(yes). -> actually lock the window
2582 * lockWindow(yes). -> do nothing
2583 * lockWindow(yes). -> do nothing
2584 * lockWindow(no). -> do nothing
2585 * lockWindow(no). -> do nothing
2586 * lockWindow(yes). -> do nothing
2587 * lockWindow(no). -> do nothing
2588 * lockWindow(no). -> actually unlock the window
2589 */
2590 IF plLock THEN
2591 ttWindowLock.iLockCounter = ttWindowLock.iLockCounter + 1.
2592 ELSE
2593 ttWindowLock.iLockCounter = ttWindowLock.iLockCounter - 1.
2594
2595 PUBLISH "debugInfo" (3, SUBSTITUTE("Lock counter: &1", ttWindowLock.iLockCounter)).
2596
2597 /* Now, only lock when the semaphore is increased to 1 */
2598 IF plLock AND ttWindowLock.iLockCounter = 1 THEN
2599 DO:
2600 {&_proparse_prolint-nowarn(varusage)}
2601 RUN SendMessageA( phWindow:HWND /* {&window-name}:hwnd */
2602 , {&WM_SETREDRAW}
2603 , 0
2604 , 0
2605 , OUTPUT iRet
2606 ).
2607 END.
2608
2609 /* And only unlock after the last unlock command */
2610 ELSE IF ttWindowLock.iLockCounter <= 0 THEN
2611 DO:
2612 {&_proparse_prolint-nowarn(varusage)}
2613 RUN SendMessageA( phWindow:HWND /* {&window-name}:hwnd */
2614 , {&WM_SETREDRAW}
2615 , 1
2616 , 0
2617 , OUTPUT iRet
2618 ).
2619
2620 {&_proparse_prolint-nowarn(varusage)}
2621 RUN RedrawWindow( phWindow:HWND /* {&window-name}:hwnd */
2622 , 0
2623 , 0
2624 , {&RDW_ALLCHILDREN} + {&RDW_ERASE} + {&RDW_INVALIDATE}
2625 , OUTPUT iRet
2626 ).
2627
2628 /* Don't delete, creating records is more expensive than re-use, so just reset */
2629 ttWindowLock.iLockCounter = 0.
2630 END.
2631
2632 {&timerStop}
2633
2634END PROCEDURE. /* lockWindow */
2635
2636/* _UIB-CODE-BLOCK-END */
2637&ANALYZE-RESUME
2638
2639&ENDIF
2640
2641&IF DEFINED(EXCLUDE-readConfigFile) = 0 &THEN
2642
2643&ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE readConfigFile Procedure
2644PROCEDURE readConfigFile :
2645/* Read the ini-file and create tt records for it
2646 */
2647 DEFINE INPUT PARAMETER pcConfigFile AS CHARACTER NO-UNDO.
2648 DEFINE INPUT PARAMETER plUserSettings AS LOGICAL NO-UNDO.
2649
2650 DEFINE VARIABLE cFile AS LONGCHAR NO-UNDO.
2651 DEFINE VARIABLE cLine AS CHARACTER NO-UNDO.
2652 DEFINE VARIABLE cChunk AS LONGCHAR NO-UNDO.
2653 DEFINE VARIABLE cSection AS CHARACTER NO-UNDO.
2654 DEFINE VARIABLE cTrimChars AS CHARACTER NO-UNDO.
2655 DEFINE VARIABLE iLine AS INTEGER NO-UNDO.
2656
2657 {&timerStart}
2658 DEFINE BUFFER bfConfig FOR ttConfig.
2659
2660 /* Read file in 1 pass to memory */
2661 IF SEARCH(pcConfigFile) = ? THEN RETURN.
2662 COPY-LOB FILE pcConfigFile TO cFile NO-CONVERT NO-ERROR.
2663 IF ERROR-STATUS:ERROR THEN cFile = readFile(pcConfigFile).
2664
2665 cTrimChars = " " + CHR(1) + "~r". /* space / chr-1 / LF */
2666
2667 /* Process line by line */
2668 #LineLoop:
2669 DO iLine = 1 TO NUM-ENTRIES(cFile,"~n"):
2670
2671 cChunk = ENTRY(iLine,cFile,"~n").
2672 cChunk = SUBSTRING(cChunk, 1,20000). /* trim very long lines */
2673 cLine = TRIM(cChunk, cTrimChars). /* remove junk */
2674
2675 /* Section line */
2676 IF cLine MATCHES "[*]" THEN
2677 DO:
2678 cSection = TRIM(cLine,"[]").
2679 NEXT #LineLoop.
2680 END.
2681
2682 /* Ignore weird settings within [DB:xxxx] sections */
2683 IF cSection BEGINS 'DB:'
2684 AND NUM-ENTRIES( TRIM(ENTRY(1,cLine,"=")), ':') = 1 THEN NEXT #LineLoop.
2685
2686 /* Config line */
2687 FIND bfConfig
2688 WHERE bfConfig.cSection = cSection
2689 AND bfConfig.cSetting = TRIM(ENTRY(1,cLine,"=")) NO-ERROR.
2690
2691 IF NOT AVAILABLE bfConfig THEN
2692 DO:
2693 CREATE bfConfig.
2694 ASSIGN
2695 bfConfig.cSection = cSection
2696 bfConfig.cSetting = TRIM(ENTRY(1,cLine,"="))
2697 .
2698 END.
2699
2700 /* Config line /might/ already exist. This can happen if you have
2701 * the same setting in multiple .ini files.
2702 */
2703 ASSIGN
2704 bfConfig.cValue = TRIM(SUBSTRING(cLine, INDEX(cLine,"=") + 1))
2705 bfConfig.lUser = plUserSettings.
2706 END.
2707
2708 {&timerStop}
2709END PROCEDURE. /* readConfigFile */
2710
2711/* _UIB-CODE-BLOCK-END */
2712&ANALYZE-RESUME
2713
2714&ENDIF
2715
2716&IF DEFINED(EXCLUDE-resetAnswers) = 0 &THEN
2717
2718&ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE resetAnswers Procedure
2719PROCEDURE resetAnswers :
2720/* Reset answers to all 'do not ask again' questions
2721*/
2722 {&timerStart}
2723 DEFINE BUFFER bfConfig FOR ttConfig.
2724
2725 FOR EACH bfConfig
2726 WHERE bfConfig.cSection = 'DataDigger:Help'
2727 AND (bfConfig.cSetting MATCHES '*:hidden' OR bfConfig.cSetting MATCHES '*:answer'):
2728 setRegistry(bfConfig.cSection, bfConfig.cSetting, ?).
2729 END. /* for each bfConfig */
2730
2731 RUN flushRegistry.
2732
2733 {&timerStop}
2734
2735END PROCEDURE. /* resetAnswers */
2736
2737/* _UIB-CODE-BLOCK-END */
2738&ANALYZE-RESUME
2739
2740&ENDIF
2741
2742&IF DEFINED(EXCLUDE-resizeFilterFields) = 0 &THEN
2743
2744&ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE resizeFilterFields Procedure
2745PROCEDURE resizeFilterFields :
2746/* Redraw the browse filter fields
2747 */
2748 DEFINE INPUT PARAMETER phLeadButton AS HANDLE NO-UNDO.
2749 DEFINE INPUT PARAMETER pcFilterFields AS CHARACTER NO-UNDO.
2750 DEFINE INPUT PARAMETER pcButtons AS CHARACTER NO-UNDO.
2751 DEFINE INPUT PARAMETER phBrowse AS HANDLE NO-UNDO.
2752
2753 DEFINE VARIABLE iField AS INTEGER NO-UNDO.
2754 DEFINE VARIABLE iButton AS INTEGER NO-UNDO.
2755 DEFINE VARIABLE iCurrentPos AS INTEGER NO-UNDO.
2756 DEFINE VARIABLE iRightEdge AS INTEGER NO-UNDO.
2757 DEFINE VARIABLE iWidth AS INTEGER NO-UNDO.
2758 DEFINE VARIABLE hColumn AS HANDLE NO-UNDO.
2759 DEFINE VARIABLE hButton AS HANDLE NO-UNDO.
2760 DEFINE VARIABLE hFilterField AS HANDLE NO-UNDO.
2761 DEFINE VARIABLE iFilter AS INTEGER NO-UNDO.
2762
2763 {&timerStart}
2764
2765 /* To prevent drawing error, make all fields small */
2766 PUBLISH "DD:Timer" ("start", "resizeFilterFields:makeSmall").
2767 DO iField = 1 TO NUM-ENTRIES(pcFilterFields):
2768 hFilterField = HANDLE(ENTRY(iField,pcFilterFields)).
2769 hFilterField:VISIBLE = NO.
2770 hFilterField:X = phBrowse:X.
2771 hFilterField:Y = phBrowse:Y - 23.
2772 hFilterField:WIDTH-PIXELS = 1.
2773 END.
2774 PUBLISH "DD:Timer" ("stop", "resizeFilterFields:makeSmall").
2775
2776 /* Start by setting the buttons at the proper place. Do this right to left */
2777 PUBLISH "DD:Timer" ("start", "resizeFilterFields:reposition").
2778 ASSIGN iRightEdge = phBrowse:X + phBrowse:WIDTH-PIXELS.
2779 DO iButton = NUM-ENTRIES(pcButtons) TO 1 BY -1:
2780 hButton = HANDLE(ENTRY(iButton,pcButtons)).
2781 hButton:X = iRightEdge - hButton:WIDTH-PIXELS.
2782 hButton:Y = phBrowse:Y - 23. /* filter buttons close to the browse */
2783 iRightEdge = hButton:X + 0. /* A little margin between buttons */
2784 END.
2785 PUBLISH "DD:Timer" ("stop", "resizeFilterFields:reposition").
2786
2787 /* The left side of the left button is the maximum point
2788 * Fortunately, this value is already in iRightEdge.
2789 * Resize and reposition the fields from left to right,
2790 * use the space between browse:x and iRightEdge
2791 */
2792
2793 /* Take the left side of the first visible column as a starting point. */
2794 PUBLISH "DD:Timer" ("start", "resizeFilterFields:firstVisibleColumn").
2795 firstVisibleColumn:
2796 DO iField = 1 TO phBrowse:NUM-COLUMNS:
2797 hColumn = phBrowse:GET-BROWSE-COLUMN(iField):HANDLE.
2798
2799 IF hColumn:X > 0 AND hColumn:VISIBLE THEN
2800 DO:
2801 iCurrentPos = phBrowse:X + hColumn:X.
2802 LEAVE firstVisibleColumn.
2803 END.
2804 END.
2805 PUBLISH "DD:Timer" ("stop", "resizeFilterFields:firstVisibleColumn").
2806
2807 PUBLISH "DD:Timer" ("start", "resizeFilterFields:#Field").
2808 #Field:
2809 DO iField = 1 TO phBrowse:NUM-COLUMNS:
2810
2811 hColumn = phBrowse:GET-BROWSE-COLUMN(iField):handle.
2812
2813 /* Some types cannot have a filter */
2814 IF hColumn:DATA-TYPE = 'raw' THEN NEXT #Field.
2815
2816 iFilter = iFilter + 1.
2817 IF iFilter > NUM-ENTRIES(pcFilterFields) THEN LEAVE #Field.
2818
2819 /* Determine the handle of the filterfield */
2820 hFilterField = HANDLE(ENTRY(iFilter, pcFilterFields)).
2821
2822 /* If the column is hidden, make the filter hidden and go to the next */
2823 IF NOT hColumn:VISIBLE THEN
2824 DO:
2825 hFilterField:VISIBLE = NO.
2826 NEXT #Field.
2827 END.
2828
2829 /* Where *are* we ?? */
2830 iCurrentPos = phBrowse:X + hColumn:X.
2831
2832 /* If the columns have been resized, some columns might have fallen off the screen */
2833 IF hColumn:X < 1 THEN NEXT #Field.
2834
2835 /* Does it fit on the screen? */
2836 IF iCurrentPos >= iRightEdge - 5 THEN LEAVE #Field. /* accept some margin */
2837
2838 /* Where will this field end? And does it fit? */
2839 iWidth = hColumn:WIDTH-PIXELS + 4.
2840 IF iCurrentPos + iWidth > iRightEdge THEN iWidth = iRightEdge - iCurrentPos.
2841
2842 /* Ok, seems to fit */
2843 hFilterField:X = iCurrentPos.
2844 hFilterField:WIDTH-PIXELS = iWidth.
2845 iCurrentPos = iCurrentPos + iWidth.
2846 hFilterField:VISIBLE = phBrowse:VISIBLE. /* take over the visibility of the browse */
2847 END.
2848 PUBLISH "DD:Timer" ("stop", "resizeFilterFields:#Field").
2849
2850 /* Place lead-button at the utmost left */
2851 IF VALID-HANDLE(phLeadButton) THEN
2852 ASSIGN
2853 phLeadButton:X = phBrowse:X
2854 phLeadButton:Y = phBrowse:Y - 23.
2855
2856 {&timerStop}
2857
2858END PROCEDURE. /* resizeFilterFields */
2859
2860/* _UIB-CODE-BLOCK-END */
2861&ANALYZE-RESUME
2862
2863&ENDIF
2864
2865&IF DEFINED(EXCLUDE-restoreWindowPos) = 0 &THEN
2866
2867&ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE restoreWindowPos Procedure
2868PROCEDURE restoreWindowPos :
2869/* Restore position / size of a window
2870 */
2871 DEFINE INPUT PARAMETER phWindow AS HANDLE NO-UNDO.
2872 DEFINE INPUT PARAMETER pcWindowName AS CHARACTER NO-UNDO.
2873
2874 DEFINE VARIABLE iValue AS INTEGER NO-UNDO.
2875
2876 iValue = INTEGER(getRegistry(pcWindowName, 'Window:x' )).
2877 IF iValue = ? THEN iValue = INTEGER(getRegistry('DataDigger', 'Window:x' )) + 50.
2878 ASSIGN phWindow:X = iValue NO-ERROR.
2879
2880 iValue = INTEGER(getRegistry(pcWindowName, 'Window:y' )).
2881 IF iValue = ? THEN iValue = INTEGER(getRegistry('DataDigger', 'Window:y' )) + 50.
2882 IF iValue <> ? THEN ASSIGN phWindow:Y = iValue NO-ERROR.
2883
2884 iValue = INTEGER(getRegistry(pcWindowName, 'Window:height' )).
2885 IF iValue = ? OR iValue = 0 THEN iValue = INTEGER(getRegistry('DataDigger', 'Window:height' )) - 100.
2886 ASSIGN phWindow:HEIGHT-PIXELS = iValue NO-ERROR.
2887
2888 iValue = INTEGER(getRegistry(pcWindowName, 'Window:width' )).
2889 IF iValue = ? OR iValue = 0 THEN iValue = INTEGER(getRegistry('DataDigger', 'Window:width' )) - 100.
2890 ASSIGN phWindow:WIDTH-PIXELS = iValue NO-ERROR.
2891
2892 /* Force a redraw */
2893 APPLY 'window-resized' TO phWindow.
2894
2895END PROCEDURE. /* restoreWindowPos */
2896
2897/* _UIB-CODE-BLOCK-END */
2898&ANALYZE-RESUME
2899
2900&ENDIF
2901
2902&IF DEFINED(EXCLUDE-saveConfigFileSorted) = 0 &THEN
2903
2904&ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE saveConfigFileSorted Procedure
2905PROCEDURE saveConfigFileSorted :
2906/* Save settings file sorted
2907 */
2908 DEFINE VARIABLE cUserConfigFile AS CHARACTER NO-UNDO.
2909 DEFINE BUFFER bfConfig FOR ttConfig.
2910
2911 {&timerStart}
2912
2913 /* Clean up rubbish settings data */
2914 FOR EACH bfConfig
2915 WHERE bfConfig.cSetting = '' OR bfConfig.cSetting = ?
2916 OR bfConfig.cValue = '' OR bfConfig.cValue = ?:
2917 DELETE bfConfig.
2918 END.
2919
2920 cUserConfigFile = SUBSTITUTE("&1DataDigger-&2.ini", getWorkFolder(), getUserName() ).
2921 OUTPUT TO VALUE(cUserConfigFile).
2922
2923 FOR EACH bfConfig
2924 WHERE bfConfig.lUser = TRUE
2925 BREAK BY (bfConfig.cSection BEGINS "DataDigger") DESCENDING
2926 BY bfConfig.cSection
2927 BY bfConfig.cSetting:
2928
2929 IF FIRST-OF(bfConfig.cSection) THEN PUT UNFORMATTED SUBSTITUTE("[&1]",bfConfig.cSection) SKIP.
2930 PUT UNFORMATTED SUBSTITUTE("&1=&2",bfConfig.cSetting, bfConfig.cValue) SKIP.
2931 IF LAST-OF(bfConfig.cSection) THEN PUT UNFORMATTED SKIP(1).
2932 END.
2933
2934 OUTPUT CLOSE.
2935 glDirtyCache = FALSE.
2936
2937 {&timerStop}
2938END PROCEDURE. /* saveConfigFileSorted */
2939
2940/* _UIB-CODE-BLOCK-END */
2941&ANALYZE-RESUME
2942
2943&ENDIF
2944
2945&IF DEFINED(EXCLUDE-saveQuery) = 0 &THEN
2946
2947&ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE saveQuery Procedure
2948PROCEDURE saveQuery :
2949/* Save a single query to the INI file.
2950 */
2951 DEFINE INPUT PARAMETER pcDatabase AS CHARACTER NO-UNDO.
2952 DEFINE INPUT PARAMETER pcTable AS CHARACTER NO-UNDO.
2953 DEFINE INPUT PARAMETER pcQuery AS CHARACTER NO-UNDO.
2954
2955 DEFINE VARIABLE cQuery AS CHARACTER NO-UNDO.
2956 DEFINE VARIABLE iNewNr AS INTEGER NO-UNDO.
2957
2958 DEFINE BUFFER bQuery FOR ttQuery.
2959
2960 {&timerStart}
2961
2962 /* Prepare query for saving in ini-file */
2963 cQuery = pcQuery.
2964 cQuery = REPLACE(cQuery,'~n',CHR(1)).
2965 cQuery = REPLACE(cQuery,{&QUERYSEP},CHR(1)).
2966 IF cQuery = '' THEN RETURN.
2967
2968 /* Get the table with queries again, because they might be
2969 * changed if the user has more than one window open.
2970 */
2971 RUN collectQueryInfo(pcDatabase, pcTable).
2972
2973 /* Save current query in the tt. If it already is in the
2974 * TT then just move it to the top
2975 */
2976 FIND bQuery
2977 WHERE bQuery.cDatabase = pcDatabase
2978 AND bQuery.cTable = pcTable
2979 AND bQuery.cQueryTxt = cQuery NO-ERROR.
2980
2981 IF AVAILABLE bQuery THEN
2982 DO:
2983 ASSIGN bQuery.iQueryNr = 0.
2984 END.
2985 ELSE
2986 DO:
2987 CREATE bQuery.
2988 ASSIGN bQuery.cDatabase = pcDatabase
2989 bQuery.cTable = pcTable
2990 bQuery.iQueryNr = 0
2991 bQuery.cQueryTxt = cQuery.
2992 END.
2993
2994 /* The ttQuery temp-table is already filled, renumber it */
2995 #QueryLoop:
2996 REPEAT PRESELECT EACH bQuery
2997 WHERE bQuery.cDatabase = pcDatabase
2998 AND bQuery.cTable = pcTable
2999 BY bQuery.iQueryNr:
3000
3001 FIND NEXT bQuery NO-ERROR.
3002 IF NOT AVAILABLE bQuery THEN LEAVE #QueryLoop.
3003 ASSIGN
3004 iNewNr = iNewNr + 1
3005 bQuery.iQueryNr = iNewNr.
3006 END.
3007
3008 /* And save it to the INI-file */
3009 RUN saveQueryTable(table bQuery, pcDatabase, pcTable).
3010
3011 {&timerStop}
3012END PROCEDURE. /* saveQuery */
3013
3014/* _UIB-CODE-BLOCK-END */
3015&ANALYZE-RESUME
3016
3017&ENDIF
3018
3019&IF DEFINED(EXCLUDE-saveQueryTable) = 0 &THEN
3020
3021&ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE saveQueryTable Procedure
3022PROCEDURE saveQueryTable :
3023/* Save the queries in the TT to the INI file with a max of MaxQueryHistory
3024 */
3025 DEFINE INPUT PARAMETER table FOR ttQuery.
3026 DEFINE INPUT PARAMETER pcDatabase AS CHARACTER NO-UNDO.
3027 DEFINE INPUT PARAMETER pcTable AS CHARACTER NO-UNDO.
3028
3029 DEFINE VARIABLE iMaxQueryHistory AS INTEGER NO-UNDO.
3030 DEFINE VARIABLE iQuery AS INTEGER NO-UNDO.
3031 DEFINE VARIABLE cSetting AS CHARACTER NO-UNDO.
3032
3033 DEFINE BUFFER bQuery FOR ttQuery.
3034
3035 {&timerStart}
3036
3037 iMaxQueryHistory = INTEGER(getRegistry("DataDigger", "MaxQueryHistory" )).
3038 IF iMaxQueryHistory = 0 THEN RETURN. /* no query history wanted */
3039
3040 /* If it is not defined use default setting */
3041 IF iMaxQueryHistory = ? THEN iMaxQueryHistory = 10.
3042
3043 iQuery = 1.
3044
3045 #SaveQuery:
3046 FOR EACH bQuery
3047 WHERE bQuery.cDatabase = pcDatabase
3048 AND bQuery.cTable = pcTable
3049 BY bQuery.iQueryNr:
3050
3051 cSetting = bQuery.cQueryTxt.
3052 IF cSetting = '' THEN NEXT #SaveQuery.
3053
3054 setRegistry( SUBSTITUTE("DB:&1", pcDatabase)
3055 , SUBSTITUTE('&1:query:&2', pcTable, iQuery)
3056 , cSetting).
3057 iQuery = iQuery + 1.
3058 IF iQuery > iMaxQueryHistory THEN LEAVE #SaveQuery.
3059 END.
3060
3061 /* Delete higher nrs than MaxQueryHistory */
3062 DO WHILE iQuery <= iMaxQueryHistory:
3063
3064 setRegistry( SUBSTITUTE("DB:&1", pcDatabase)
3065 , SUBSTITUTE('&1:query:&2', pcTable, iQuery)
3066 , ?).
3067 iQuery = iQuery + 1.
3068 END. /* iQuery .. MaxQueryHistory */
3069
3070 {&timerStop}
3071END PROCEDURE. /* saveQueryTable */
3072
3073/* _UIB-CODE-BLOCK-END */
3074&ANALYZE-RESUME
3075
3076&ENDIF
3077
3078&IF DEFINED(EXCLUDE-saveWindowPos) = 0 &THEN
3079
3080&ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE saveWindowPos Procedure
3081PROCEDURE saveWindowPos :
3082/* Save position / size of a window
3083 */
3084 DEFINE INPUT PARAMETER phWindow AS HANDLE NO-UNDO.
3085 DEFINE INPUT PARAMETER pcWindowName AS CHARACTER NO-UNDO.
3086
3087 setRegistry(pcWindowName, "Window:x" , STRING(phWindow:X) ).
3088 setRegistry(pcWindowName, "Window:y" , STRING(phWindow:Y) ).
3089 setRegistry(pcWindowName, "Window:height", STRING(phWindow:HEIGHT-PIXELS) ).
3090 setRegistry(pcWindowName, "Window:width" , STRING(phWindow:WIDTH-PIXELS) ).
3091
3092END PROCEDURE. /* saveWindowPos */
3093
3094/* _UIB-CODE-BLOCK-END */
3095&ANALYZE-RESUME
3096
3097&ENDIF
3098
3099&IF DEFINED(EXCLUDE-setCaching) = 0 &THEN
3100
3101&ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE setCaching Procedure
3102PROCEDURE setCaching :
3103/* Set the cache vars for the library
3104 */
3105 glCacheTableDefs = LOGICAL( getRegistry("DataDigger:Cache","TableDefs") ).
3106 glCacheFieldDefs = LOGICAL( getRegistry("DataDigger:Cache","FieldDefs") ).
3107
3108END PROCEDURE. /* setCaching */
3109
3110/* _UIB-CODE-BLOCK-END */
3111&ANALYZE-RESUME
3112
3113&ENDIF
3114
3115&IF DEFINED(EXCLUDE-setFavourite) = 0 &THEN
3116
3117&ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE setFavourite Procedure
3118PROCEDURE setFavourite :
3119/* Set / unset / toggle a table as favourite
3120*/
3121 DEFINE INPUT PARAMETER pcTable AS CHARACTER NO-UNDO.
3122 DEFINE INPUT PARAMETER pcGroupName AS CHARACTER NO-UNDO.
3123 DEFINE INPUT PARAMETER plFavourite AS LOGICAL NO-UNDO.
3124
3125 DEFINE VARIABLE i AS INTEGER NO-UNDO.
3126 DEFINE VARIABLE cList AS CHARACTER NO-UNDO.
3127
3128 cList = getRegistry("DataDigger:Favourites", pcGroupName).
3129 IF cList = ? THEN cList = ''.
3130 i = LOOKUP(pcTable, cList).
3131
3132 /* Toggle setting? */
3133 IF plFavourite = ? THEN plFavourite = (i = 0).
3134
3135 /* Add to favourites */
3136 IF NOT plFavourite AND i > 0 THEN
3137 DO:
3138 ENTRY(i, cList) = ''.
3139 cList = REPLACE(cList,',,',',').
3140 cList = TRIM(cList,',').
3141 END.
3142
3143 /* Remove from favourites */
3144 IF plFavourite AND i = 0 THEN
3145 cList = TRIM(SUBSTITUTE('&1,&2', cList, pcTable),',').
3146
3147 setRegistry("DataDigger:Favourites", pcGroupName, cList).
3148
3149END PROCEDURE. /* setFavourite */
3150
3151/* _UIB-CODE-BLOCK-END */
3152&ANALYZE-RESUME
3153
3154&ENDIF
3155
3156&IF DEFINED(EXCLUDE-setLabelPosition) = 0 &THEN
3157
3158&ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE setLabelPosition Procedure
3159PROCEDURE setLabelPosition :
3160/* Correct the position of the label for larger fonts
3161 */
3162 DEFINE INPUT PARAMETER phWidget AS HANDLE NO-UNDO.
3163
3164 /* Move horizontally far enough from the widget */
3165 phWidget:SIDE-LABEL-HANDLE:X = phWidget:X
3166 - FONT-TABLE:GET-TEXT-WIDTH-PIXELS(phWidget:SIDE-LABEL-HANDLE:SCREEN-VALUE, phWidget:FRAME:FONT)
3167 - (IF phWidget:TYPE = 'fill-in' THEN 5 ELSE 0)
3168 .
3169
3170END PROCEDURE. /* setLabelPosition */
3171
3172/* _UIB-CODE-BLOCK-END */
3173&ANALYZE-RESUME
3174
3175&ENDIF
3176
3177&IF DEFINED(EXCLUDE-setSortArrow) = 0 &THEN
3178
3179&ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE setSortArrow Procedure
3180PROCEDURE setSortArrow :
3181/* Set the sorting arrow on a browse
3182 */
3183 DEFINE INPUT PARAMETER phBrowse AS HANDLE NO-UNDO.
3184 DEFINE INPUT PARAMETER pcSortField AS CHARACTER NO-UNDO.
3185 DEFINE INPUT PARAMETER plAscending AS LOGICAL NO-UNDO.
3186
3187 DEFINE VARIABLE iColumn AS INTEGER NO-UNDO.
3188 DEFINE VARIABLE hColumn AS HANDLE NO-UNDO.
3189 DEFINE VARIABLE lSortFound AS LOGICAL NO-UNDO.
3190
3191 {&timerStart}
3192
3193 DO iColumn = 1 TO phBrowse:NUM-COLUMNS:
3194 hColumn = phBrowse:GET-BROWSE-COLUMN(iColumn).
3195
3196 /* If you apply the sort to the same column, the order
3197 * of sorting is inverted.
3198 */
3199 IF hColumn:NAME = pcSortField THEN
3200 DO:
3201 phBrowse:SET-SORT-ARROW(iColumn, plAscending ).
3202 lSortFound = TRUE.
3203
3204 /* Setting is one of: ColumnSortFields | ColumnSortIndexes | ColumnSortTables */
3205 setRegistry( 'DataDigger'
3206 , SUBSTITUTE('ColumnSort&1', SUBSTRING(phBrowse:NAME,3))
3207 , SUBSTITUTE('&1,&2',iColumn, plAscending)
3208 ).
3209 END.
3210 ELSE
3211 phBrowse:SET-SORT-ARROW(iColumn, ? ). /* erase existing arrow */
3212 END.
3213
3214 /* If no sort is found, delete setting */
3215 IF NOT lSortFound THEN
3216 setRegistry( 'DataDigger', SUBSTITUTE('ColumnSort&1', SUBSTRING(phBrowse:NAME,3)), ?).
3217
3218 {&timerStop}
3219
3220END PROCEDURE. /* setSortArrow */
3221
3222/* _UIB-CODE-BLOCK-END */
3223&ANALYZE-RESUME
3224
3225&ENDIF
3226
3227&IF DEFINED(EXCLUDE-setTransparency) = 0 &THEN
3228
3229&ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE setTransparency Procedure
3230PROCEDURE setTransparency :
3231/* Set transparency level for a frame, using Windows api
3232 */
3233 DEFINE INPUT PARAMETER phFrame AS HANDLE NO-UNDO.
3234 DEFINE INPUT PARAMETER piLevel AS INTEGER NO-UNDO.
3235
3236 &SCOPED-DEFINE GWL_EXSTYLE -20
3237 &SCOPED-DEFINE WS_EX_LAYERED 524288
3238 &SCOPED-DEFINE LWA_ALPHA 2
3239 &SCOPED-DEFINE WS_EX_TRANSPARENT 32
3240
3241 {&_proparse_prolint-nowarn(varusage)}
3242 DEFINE VARIABLE stat AS INTEGER NO-UNDO.
3243
3244 /* Set WS_EX_LAYERED on this window */
3245 {&_proparse_prolint-nowarn(varusage)}
3246 RUN SetWindowLongA(phFrame:HWND, {&GWL_EXSTYLE}, {&WS_EX_LAYERED}, OUTPUT stat).
3247
3248 /* Make this window transparent (0 - 255) */
3249 {&_proparse_prolint-nowarn(varusage)}
3250 RUN SetLayeredWindowAttributes(phFrame:HWND, 0, piLevel, {&LWA_ALPHA}, OUTPUT stat).
3251
3252END PROCEDURE. /* setTransparency */
3253
3254/* _UIB-CODE-BLOCK-END */
3255&ANALYZE-RESUME
3256
3257&ENDIF
3258
3259&IF DEFINED(EXCLUDE-setXmlNodeNames) = 0 &THEN
3260
3261&ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE setXmlNodeNames Procedure
3262PROCEDURE setXmlNodeNames :
3263/* Set the XML-NODE-NAMES of all fields in a buffer
3264 */
3265 DEFINE INPUT PARAMETER phTable AS HANDLE NO-UNDO.
3266 DEFINE VARIABLE iField AS INTEGER NO-UNDO.
3267
3268 DO iField = 1 TO phTable:NUM-FIELDS:
3269 phTable:BUFFER-FIELD(iField):XML-NODE-NAME = getXmlNodeName(phTable:BUFFER-FIELD(iField):NAME).
3270 END.
3271
3272END PROCEDURE. /* setXmlNodeNames */
3273
3274/* _UIB-CODE-BLOCK-END */
3275&ANALYZE-RESUME
3276
3277&ENDIF
3278
3279&IF DEFINED(EXCLUDE-showHelp) = 0 &THEN
3280
3281&ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE showHelp Procedure
3282PROCEDURE showHelp :
3283/* Show a help message and save answer to ini
3284 */
3285 DEFINE INPUT PARAMETER pcTopic AS CHARACTER NO-UNDO.
3286 DEFINE INPUT PARAMETER pcStrings AS CHARACTER NO-UNDO.
3287
3288 DEFINE VARIABLE cButtons AS CHARACTER NO-UNDO.
3289 DEFINE VARIABLE cMessage AS CHARACTER NO-UNDO.
3290 DEFINE VARIABLE cPrg AS CHARACTER NO-UNDO.
3291 DEFINE VARIABLE cTitle AS CHARACTER NO-UNDO.
3292 DEFINE VARIABLE cType AS CHARACTER NO-UNDO.
3293 DEFINE VARIABLE cUrl AS CHARACTER NO-UNDO.
3294 DEFINE VARIABLE cCanHide AS CHARACTER NO-UNDO.
3295 DEFINE VARIABLE iButtonPressed AS INTEGER NO-UNDO.
3296 DEFINE VARIABLE lDontShowAgain AS LOGICAL NO-UNDO.
3297 DEFINE VARIABLE lCanHide AS LOGICAL NO-UNDO.
3298 DEFINE VARIABLE lHidden AS LOGICAL NO-UNDO.
3299 DEFINE VARIABLE iString AS INTEGER NO-UNDO.
3300 DEFINE VARIABLE cUserString AS CHARACTER NO-UNDO EXTENT 9.
3301
3302 /* If no message, then just return */
3303 cMessage = getRegistry('DataDigger:Help', pcTopic + ':message').
3304
3305 /* What to start? */
3306 cUrl = getRegistry('DataDigger:Help', pcTopic + ':url').
3307 cPrg = getRegistry('DataDigger:Help', pcTopic + ':program').
3308 cCanHide = getRegistry('DataDigger:Help', pcTopic + ':canHide').
3309 cCanHide = TRIM(cCanHide).
3310 lCanHide = LOGICAL(cCanHide) NO-ERROR.
3311 IF lCanHide = ? THEN lCanHide = TRUE.
3312
3313 IF cMessage = ? THEN
3314 DO:
3315 IF cUrl = ? AND cPrg = ? THEN RETURN.
3316 lHidden = YES. /* suppress empty text window */
3317 iButtonPressed = 1. /* forces to start the url or prog */
3318 END.
3319
3320 /* If type is unknown, set to QUESTION if there is a question mark in the message */
3321 cType = getRegistry('DataDigger:Help', pcTopic + ':type').
3322 IF cType = ? THEN cType = (IF cMessage MATCHES '*?*' THEN 'Question' ELSE 'Message').
3323
3324 /* If no button labels defined, set them based on message type */
3325 cButtons = getRegistry('DataDigger:Help', pcTopic + ':buttons').
3326 IF cButtons = ? THEN cButtons = (IF cType = 'Question' THEN '&Yes,&No,&Cancel' ELSE '&Ok').
3327
3328 /* If title is empty, set it to the type of the message */
3329 cTitle = getRegistry('DataDigger:Help', pcTopic + ':title').
3330 IF cTitle = ? THEN cTitle = cType.
3331
3332 /* If hidden has strange value, set it to NO */
3333 lHidden = LOGICAL(getRegistry('DataDigger:Help', pcTopic + ':hidden')) NO-ERROR.
3334 IF lHidden = ? THEN lHidden = NO.
3335
3336 /* If ButtonPressed has strange value, set hidden to NO */
3337 iButtonPressed = INTEGER( getRegistry('DataDigger:Help',pcTopic + ':answer') ) NO-ERROR.
3338 IF iButtonPressed = ? THEN lHidden = NO.
3339
3340 /* if we have no message, but we do have an URL or prog, then
3341 * dont show an empty message box.
3342 */
3343 IF cMessage = ? THEN
3344 ASSIGN
3345 lHidden = YES /* suppress empty text window */
3346 iButtonPressed = 1. /* forces to start the url or prog */
3347
3348 /* Fill in strings in message */
3349 DO iString = 1 TO NUM-ENTRIES(pcStrings):
3350 cUserString[iString] = ENTRY(iString,pcStrings).
3351 END.
3352
3353 cMessage = SUBSTITUTE( cMessage
3354 , cUserString[1]
3355 , cUserString[2]
3356 , cUserString[3]
3357 , cUserString[4]
3358 , cUserString[5]
3359 , cUserString[6]
3360 , cUserString[7]
3361 , cUserString[8]
3362 , cUserString[9]
3363 ).
3364
3365 /* If not hidden, show the message and let the user choose an answer */
3366 IF NOT lHidden THEN
3367 DO:
3368 RUN VALUE( getProgramDir() + 'dQuestion.w')
3369 ( INPUT cTitle
3370 , INPUT cMessage
3371 , INPUT cButtons
3372 , INPUT lCanHide
3373 , OUTPUT iButtonPressed
3374 , OUTPUT lDontShowAgain
3375 ).
3376
3377 IF lDontShowAgain THEN
3378 setRegistry('DataDigger:Help', pcTopic + ':hidden', 'yes').
3379 END.
3380
3381 /* Start external things if needed */
3382 IF iButtonPressed = 1 THEN
3383 DO:
3384 IF cUrl <> ? THEN OS-COMMAND NO-WAIT START (cUrl).
3385 IF cPrg <> ? THEN RUN VALUE(cPrg) NO-ERROR.
3386 END.
3387
3388 /* Save answer */
3389 setRegistry('DataDigger:Help',pcTopic + ':answer', STRING(iButtonPressed)).
3390
3391END PROCEDURE. /* showHelp */
3392
3393/* _UIB-CODE-BLOCK-END */
3394&ANALYZE-RESUME
3395
3396&ENDIF
3397
3398&IF DEFINED(EXCLUDE-showScrollbars) = 0 &THEN
3399
3400&ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE showScrollbars Procedure
3401PROCEDURE showScrollbars :
3402/* Hide or show scrollbars the hard way
3403 */
3404 DEFINE INPUT PARAMETER ip-Frame AS HANDLE NO-UNDO.
3405 DEFINE INPUT PARAMETER ip-horizontal AS LOGICAL NO-UNDO.
3406 DEFINE INPUT PARAMETER ip-vertical AS LOGICAL NO-UNDO.
3407
3408 {&_proparse_prolint-nowarn(varusage)}
3409 DEFINE VARIABLE iv-retint AS INTEGER NO-UNDO.
3410
3411 {&timerStart}
3412
3413 IF NOT VALID-HANDLE(ip-Frame) OR ip-Frame:HWND = ? THEN RETURN.
3414
3415 &scoped-define SB_HORZ 0
3416 &scoped-define SB_VERT 1
3417 &scoped-define SB_BOTH 3
3418 &scoped-define SB_THUMBPOSITION 4
3419
3420 {&_proparse_prolint-nowarn(varusage)}
3421 RUN ShowScrollBar ( ip-Frame:HWND,
3422 {&SB_HORZ},
3423 IF ip-horizontal THEN -1 ELSE 0,
3424 OUTPUT iv-retint ).
3425
3426 {&_proparse_prolint-nowarn(varusage)}
3427 RUN ShowScrollBar ( ip-Frame:HWND,
3428 {&SB_VERT},
3429 IF ip-vertical THEN -1 ELSE 0,
3430 OUTPUT iv-retint ).
3431
3432 &undefine SB_HORZ
3433 &undefine SB_VERT
3434 &undefine SB_BOTH
3435 &undefine SB_THUMBPOSITION
3436
3437 {&timerStop}
3438END PROCEDURE. /* ShowScrollbars */
3439
3440/* _UIB-CODE-BLOCK-END */
3441&ANALYZE-RESUME
3442
3443&ENDIF
3444
3445&IF DEFINED(EXCLUDE-unlockWindow) = 0 &THEN
3446
3447&ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE unlockWindow Procedure
3448PROCEDURE unlockWindow :
3449/* Force a window to unlock
3450 */
3451 DEFINE INPUT PARAMETER phWindow AS HANDLE NO-UNDO.
3452
3453 {&_proparse_prolint-nowarn(varusage)}
3454 DEFINE VARIABLE iRet AS INTEGER NO-UNDO.
3455 DEFINE BUFFER ttWindowLock FOR ttWindowLock.
3456
3457 PUBLISH "debugInfo" (3, SUBSTITUTE("Window &1, force to unlock", phWindow:TITLE)).
3458
3459 /* Find window in our tt of locked windows */
3460 FIND ttWindowLock WHERE ttWindowLock.hWindow = phWindow NO-ERROR.
3461 IF NOT AVAILABLE ttWindowLock THEN RETURN.
3462
3463 IF ttWindowLock.iLockCounter > 0 THEN
3464 DO:
3465 {&_proparse_prolint-nowarn(varusage)}
3466 RUN SendMessageA(phWindow:HWND, {&WM_SETREDRAW}, 1, 0, OUTPUT iRet).
3467
3468 {&_proparse_prolint-nowarn(varusage)}
3469 RUN RedrawWindow(phWindow:HWND, 0, 0, {&RDW_ALLCHILDREN} + {&RDW_ERASE} + {&RDW_INVALIDATE}, OUTPUT iRet).
3470
3471 DELETE ttWindowLock.
3472 END.
3473
3474END PROCEDURE. /* unlockWindow */
3475
3476/* _UIB-CODE-BLOCK-END */
3477&ANALYZE-RESUME
3478
3479&ENDIF
3480
3481&IF DEFINED(EXCLUDE-updateFields) = 0 &THEN
3482
3483&ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE updateFields Procedure
3484PROCEDURE updateFields :
3485/* Update the fields temp-table with settings from registry
3486 */
3487 DEFINE INPUT PARAMETER pcDatabase AS CHARACTER NO-UNDO.
3488 DEFINE INPUT PARAMETER pcTableName AS CHARACTER NO-UNDO.
3489 DEFINE INPUT-OUTPUT PARAMETER TABLE FOR ttField.
3490
3491 DEFINE VARIABLE cCustomFormat AS CHARACTER NO-UNDO.
3492 DEFINE VARIABLE cSelectedFields AS CHARACTER NO-UNDO.
3493 DEFINE VARIABLE cFieldOrder AS CHARACTER NO-UNDO.
3494 DEFINE VARIABLE iColumnOrder AS INTEGER NO-UNDO.
3495 DEFINE VARIABLE iFieldOrder AS INTEGER NO-UNDO.
3496 DEFINE VARIABLE iMaxExtent AS INTEGER NO-UNDO.
3497 DEFINE VARIABLE lRecRowAtEnd AS LOGICAL NO-UNDO.
3498
3499 DEFINE BUFFER bField FOR ttField.
3500 DEFINE BUFFER bColumn FOR ttColumn.
3501
3502 {&timerStart}
3503 PUBLISH "debugInfo" (1, SUBSTITUTE("Update field definitions for &1.&2", pcDatabase, pcTableName)).
3504
3505 /* Get list of all previously selected fields */
3506 cSelectedFields = getRegistry(SUBSTITUTE("DB:&1",pcDatabase), SUBSTITUTE("&1:fields",pcTableName)).
3507 IF cSelectedFields = ? THEN cSelectedFields = '!RECID,!ROWID,*'.
3508
3509 /* Get field ordering */
3510 cFieldOrder = getRegistry(SUBSTITUTE('DB:&1',pcDatabase), SUBSTITUTE('&1:fieldOrder',pcTableName)).
3511
3512 /* RECID and ROWID at the end? */
3513 IF cFieldOrder <> ? THEN
3514 DO:
3515 lRecRowAtEnd = LOOKUP("ROWID", cFieldOrder) > NUM-ENTRIES(cFieldOrder) - 2 AND LOOKUP("RECID", cFieldOrder) > NUM-ENTRIES(cFieldOrder) - 2.
3516 PUBLISH "debugInfo" (2, SUBSTITUTE("Field order for table &1: &2", pcTableName, cFieldOrder)).
3517 PUBLISH "debugInfo" (3, SUBSTITUTE("Rowid/recid at the end for table &1: &2", pcTableName, lRecRowAtEnd)).
3518 END.
3519
3520 FOR EACH bField {&TABLE-SCAN}:
3521
3522 /* Due to a bug the nr of decimals may be set on non-decimal fields
3523 * See PKB P185263 (article 18087) for more information
3524 * http://knowledgebase.progress.com/articles/Article/P185263
3525 */
3526 IF bField.cDataType <> 'DECIMAL' THEN bField.iDecimals = ?.
3527
3528 /* Was this field selected? */
3529 bField.lShow = CAN-DO(cSelectedFields, bField.cFullName).
3530
3531 /* Customization option for the user to show/hide certain fields */
3532 PUBLISH "DD:Timer" ("start", 'customShowField').
3533 PUBLISH 'customShowField' (pcDatabase, pcTableName, bField.cFieldName, INPUT-OUTPUT bField.lShow).
3534 PUBLISH "DD:Timer" ("stop", 'customShowField').
3535
3536 /* Customization option for the user to adjust the format */
3537 PUBLISH "DD:Timer" ("start", 'customFormat').
3538 PUBLISH 'customFormat' (pcDatabase, pcTableName, bField.cFieldName, bField.cDatatype, INPUT-OUTPUT bField.cFormat).
3539 PUBLISH "DD:Timer" ("stop", 'customFormat').
3540
3541 /* Restore changed field format. */
3542 cCustomFormat = getRegistry(SUBSTITUTE("DB:&1",pcDatabase), SUBSTITUTE("&1.&2:format",pcTableName,bField.cFieldName) ).
3543 IF cCustomFormat <> ? THEN bField.cFormat = cCustomFormat.
3544
3545 /* Restore changed field order. */
3546 bField.iOrder = LOOKUP(bField.cFullName,cFieldOrder).
3547 IF bField.iOrder = ? THEN bField.iOrder = bField.iOrderOrg.
3548
3549 /* Keep track of highest nr */
3550 iFieldOrder = MAXIMUM(iFieldOrder,bField.iOrder).
3551
3552 END. /* f/e bField */
3553
3554 /* Only show first X of an extent */
3555 iMaxExtent = INTEGER(getRegistry("DataDigger","MaxExtent")) NO-ERROR.
3556 IF iMaxExtent = ? THEN iMaxExtent = 100.
3557 IF iMaxExtent > 0 THEN
3558 FOR EACH bColumn WHERE bColumn.iExtent > iMaxExtent:
3559 DELETE bColumn.
3560 END.
3561
3562 IF CAN-FIND(FIRST bField WHERE bField.iOrder = 0) THEN
3563 DO:
3564 /* Set new fields (no order assigned) at the end */
3565 FOR EACH bField WHERE bField.iOrder = 0 BY bField.iFieldRpos:
3566 ASSIGN
3567 iFieldOrder = iFieldOrder + 1
3568 bField.iOrder = iFieldOrder.
3569 END.
3570
3571 /* If RECID+ROWID should be at the end then re-assign them */
3572 IF lRecRowAtEnd THEN
3573 FOR EACH bField
3574 WHERE bField.cFieldName = "RECID" OR bField.cFieldName = "ROWID" BY bField.iOrder:
3575 ASSIGN
3576 iFieldOrder = iFieldOrder + 1
3577 bField.iOrder = iFieldOrder.
3578 END.
3579 END.
3580
3581 /* Reorder fields to get rid of gaps */
3582 iFieldOrder = 0.
3583 #FieldLoop:
3584 REPEAT PRESELECT EACH bField BY bField.iOrder:
3585 FIND NEXT bField NO-ERROR.
3586 IF NOT AVAILABLE bField THEN LEAVE #FieldLoop.
3587 ASSIGN
3588 iFieldOrder = iFieldOrder + 1
3589 bField.iOrder = iFieldOrder.
3590 END.
3591
3592 /* Assign order nrs to columns to handle extents */
3593 iColumnOrder = 0.
3594 FOR EACH bField BY bField.iOrder:
3595 FOR EACH bColumn WHERE bColumn.cFieldName = bField.cFieldName BY bColumn.cFieldName:
3596 iColumnOrder = iColumnOrder + 1.
3597 bColumn.iColumnNr = iColumnOrder.
3598 END.
3599 END.
3600
3601 {&timerStop}
3602END PROCEDURE. /* updateFields */
3603
3604/* _UIB-CODE-BLOCK-END */
3605&ANALYZE-RESUME
3606
3607&ENDIF
3608
3609&IF DEFINED(EXCLUDE-updateMemoryCache) = 0 &THEN
3610
3611&ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE updateMemoryCache Procedure
3612PROCEDURE updateMemoryCache :
3613/* Update the memory cache with current settings
3614 */
3615 DEFINE INPUT PARAMETER pcDatabase AS CHARACTER NO-UNDO.
3616 DEFINE INPUT PARAMETER pcTableName AS CHARACTER NO-UNDO.
3617 DEFINE INPUT PARAMETER TABLE FOR ttField.
3618 DEFINE INPUT PARAMETER TABLE FOR ttColumn.
3619
3620 DEFINE BUFFER bField FOR ttField.
3621 DEFINE BUFFER bColumn FOR ttColumn.
3622 DEFINE BUFFER bFieldCache FOR ttFieldCache.
3623 DEFINE BUFFER bColumnCache FOR ttColumnCache.
3624
3625 PUBLISH "debugInfo" (2, SUBSTITUTE("Update first-level cache for &1.&2", pcDatabase, pcTableName)).
3626
3627 /* Delete old */
3628 FOR EACH bFieldCache
3629 WHERE bFieldCache.cDatabase = pcDatabase
3630 AND bFieldCache.cTableName = pcTableName:
3631
3632 DELETE bFieldCache.
3633 END.
3634
3635 FOR EACH bColumnCache
3636 WHERE bColumnCache.cDatabase = pcDatabase
3637 AND bColumnCache.cTableName = pcTableName:
3638
3639 DELETE bColumnCache.
3640 END.
3641
3642 /* Create new */
3643 FOR EACH bField {&TABLE-SCAN}:
3644 CREATE bFieldCache.
3645 BUFFER-COPY bField TO bFieldCache.
3646 END.
3647
3648 FOR EACH bColumn {&TABLE-SCAN}:
3649 CREATE bColumnCache.
3650 BUFFER-COPY bColumn TO bColumnCache.
3651 END.
3652
3653END PROCEDURE. /* updateMemoryCache */
3654
3655/* _UIB-CODE-BLOCK-END */
3656&ANALYZE-RESUME
3657
3658&ENDIF
3659
3660/* ************************ Function Implementations ***************** */
3661
3662&IF DEFINED(EXCLUDE-addConnection) = 0 &THEN
3663
3664&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION addConnection Procedure
3665FUNCTION addConnection RETURNS LOGICAL
3666 ( pcDatabase AS CHARACTER
3667 , pcSection AS CHARACTER ) :
3668 /* Add a connection to the temp-table
3669 */
3670 IF NOT CAN-FIND(ttDatabase WHERE ttDatabase.cLogicalName = pcDatabase) THEN
3671 DO:
3672 CREATE ttDatabase.
3673 ASSIGN
3674 ttDatabase.cLogicalName = pcDatabase
3675 ttDatabase.cSection = pcSection
3676 .
3677 END.
3678 RETURN TRUE.
3679
3680END FUNCTION.
3681
3682/* _UIB-CODE-BLOCK-END */
3683&ANALYZE-RESUME
3684
3685&ENDIF
3686
3687&IF DEFINED(EXCLUDE-formatQueryString) = 0 &THEN
3688
3689&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION formatQueryString Procedure
3690FUNCTION formatQueryString RETURNS CHARACTER
3691 ( INPUT pcQueryString AS CHARACTER
3692 , INPUT plExpanded AS LOGICAL ) :
3693 /* Return a properly formatted query string
3694 */
3695 DEFINE VARIABLE cReturnValue AS CHARACTER NO-UNDO.
3696
3697 {&timerStart}
3698 cReturnValue = pcQueryString.
3699 IF cReturnValue <> '' AND cReturnValue <> ? THEN
3700 DO:
3701 /* There might be chr(1) chars in the text (if read from ini, for example)
3702 * Replace these with normal CRLF, then proceed
3703 */
3704 cReturnValue = REPLACE(cReturnValue,CHR(1),'~n').
3705
3706 IF plExpanded THEN
3707 cReturnValue = REPLACE(cReturnValue, {&QUERYSEP}, '~n').
3708 ELSE
3709 cReturnValue = REPLACE(cReturnValue, '~n', {&QUERYSEP}).
3710 END.
3711
3712 RETURN cReturnValue.
3713 {&timerStop}
3714
3715END FUNCTION. /* formatQueryString */
3716
3717/* _UIB-CODE-BLOCK-END */
3718&ANALYZE-RESUME
3719
3720&ENDIF
3721
3722&IF DEFINED(EXCLUDE-getColor) = 0 &THEN
3723
3724&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION getColor Procedure
3725FUNCTION getColor RETURNS INTEGER
3726 ( pcName AS CHARACTER ) :
3727 /* Return the color number for a color name
3728 */
3729 DEFINE BUFFER bColor FOR ttColor.
3730
3731 FIND bColor WHERE bColor.cName = pcName NO-ERROR.
3732 IF NOT AVAILABLE bColor THEN
3733 RETURN setColor(pcName,?).
3734 ELSE
3735 RETURN bColor.iColor. /* Function return value. */
3736
3737END FUNCTION. /* getColor */
3738
3739/* _UIB-CODE-BLOCK-END */
3740&ANALYZE-RESUME
3741
3742&ENDIF
3743
3744&IF DEFINED(EXCLUDE-getColorByRGB) = 0 &THEN
3745
3746&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION getColorByRGB Procedure
3747FUNCTION getColorByRGB RETURNS INTEGER
3748 ( piRed AS INTEGER
3749 , piGreen AS INTEGER
3750 , piBlue AS INTEGER
3751 ):
3752 /* Return the color number for a RGB combination
3753 * if needed, add color to color table.
3754 */
3755 DEFINE VARIABLE i AS INTEGER NO-UNDO.
3756
3757 /* See if already exists */
3758 DO i = 0 TO COLOR-TABLE:NUM-ENTRIES - 1:
3759 IF COLOR-TABLE:GET-RED-VALUE(i) = piRed
3760 AND COLOR-TABLE:GET-GREEN-VALUE(i) = piGreen
3761 AND COLOR-TABLE:GET-BLUE-VALUE(i) = piBlue THEN RETURN i.
3762 END.
3763
3764 /* Define new color */
3765 i = COLOR-TABLE:NUM-ENTRIES.
3766 COLOR-TABLE:NUM-ENTRIES = COLOR-TABLE:NUM-ENTRIES + 1.
3767 COLOR-TABLE:SET-DYNAMIC(i, TRUE).
3768 COLOR-TABLE:SET-RED-VALUE (i, piRed ).
3769 COLOR-TABLE:SET-GREEN-VALUE(i, piGreen).
3770 COLOR-TABLE:SET-BLUE-VALUE (i, piBlue ).
3771
3772 RETURN i.
3773
3774END FUNCTION. /* getColorByRGB */
3775
3776/* _UIB-CODE-BLOCK-END */
3777&ANALYZE-RESUME
3778
3779&ENDIF
3780
3781&IF DEFINED(EXCLUDE-getColumnLabel) = 0 &THEN
3782
3783&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION getColumnLabel Procedure
3784FUNCTION getColumnLabel RETURNS CHARACTER
3785 ( INPUT phFieldBuffer AS HANDLE ):
3786 /* Return column label, based on settings
3787 */
3788 DEFINE VARIABLE cColumnLabel AS CHARACTER NO-UNDO.
3789 DEFINE VARIABLE cTemplate AS CHARACTER NO-UNDO.
3790
3791 {&timerStart}
3792
3793 cTemplate = getRegistry("DataDigger","ColumnLabelTemplate").
3794 IF cTemplate = ? OR cTemplate = "" THEN cTemplate = "&1".
3795
3796 cColumnLabel = SUBSTITUTE(cTemplate
3797 , phFieldBuffer::cFullName
3798 , phFieldBuffer::iOrder
3799 , phFieldBuffer::cLabel
3800 ).
3801 RETURN cColumnLabel.
3802 {&timerStop}
3803
3804END FUNCTION. /* getColumnLabel */
3805
3806/* _UIB-CODE-BLOCK-END */
3807&ANALYZE-RESUME
3808
3809&ENDIF
3810
3811&IF DEFINED(EXCLUDE-getColumnWidthList) = 0 &THEN
3812
3813&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION getColumnWidthList Procedure
3814FUNCTION getColumnWidthList RETURNS CHARACTER
3815 ( INPUT phBrowse AS HANDLE ):
3816 /* returns a list of all fields and their width like:
3817 * custnum:12,custname:20,city:12
3818 */
3819 DEFINE VARIABLE cWidthList AS CHARACTER NO-UNDO.
3820 DEFINE VARIABLE hColumn AS HANDLE NO-UNDO.
3821 DEFINE VARIABLE iColumn AS INTEGER NO-UNDO.
3822
3823 {&timerStart}
3824
3825 DO iColumn = 1 TO phBrowse:NUM-COLUMNS:
3826
3827 hColumn = phBrowse:GET-BROWSE-COLUMN(iColumn).
3828 cWidthList = SUBSTITUTE('&1,&2:&3'
3829 , cWidthList
3830 , hColumn:NAME
3831 , hColumn:WIDTH-PIXELS
3832 ).
3833 END.
3834
3835 RETURN TRIM(cWidthList,',').
3836 {&timerStop}
3837
3838END FUNCTION. /* getColumnWidthList */
3839
3840/* _UIB-CODE-BLOCK-END */
3841&ANALYZE-RESUME
3842
3843&ENDIF
3844
3845&IF DEFINED(EXCLUDE-getDatabaseList) = 0 &THEN
3846
3847&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION getDatabaseList Procedure
3848FUNCTION getDatabaseList RETURNS CHARACTER:
3849 /* Return a comma separated list of all connected databases
3850 */
3851 DEFINE VARIABLE cDatabaseList AS CHARACTER NO-UNDO.
3852 DEFINE VARIABLE cSchemaHolders AS CHARACTER NO-UNDO.
3853 DEFINE VARIABLE iCount AS INTEGER NO-UNDO.
3854 DEFINE VARIABLE cDbType AS CHARACTER NO-UNDO.
3855 DEFINE VARIABLE cLogicalDbName AS CHARACTER NO-UNDO.
3856 DEFINE VARIABLE iPos AS INTEGER NO-UNDO.
3857
3858 DEFINE BUFFER bDataserver FOR ttDataserver.
3859
3860 {&timerStart}
3861
3862 /* Support Dataservers */
3863 IF gcSaveDatabaseList <> ""
3864 AND PROGRAM-NAME(2) BEGINS "initializeObjects " THEN RETURN gcSaveDatabaseList.
3865
3866 /* Make a list of schema holders */
3867 #Db:
3868 DO iCount = 1 TO NUM-DBS:
3869 ASSIGN
3870 cDbType = DBTYPE(iCount)
3871 cLogicalDbName = LDBNAME(iCount).
3872
3873 IF cDbType <> 'PROGRESS' THEN
3874 cSchemaHolders = cSchemaHolders + ',' + SDBNAME(iCount).
3875
3876 cDbType = DBTYPE(iCount).
3877 IF cDbType <> "PROGRESS" THEN NEXT #Db.
3878
3879 cDatabaseList = cDatabaseList + ',' + cLogicalDbName.
3880 END.
3881
3882 /* Build list of all databases. Skip if already in the list of schemaholders */
3883 #Db:
3884 DO iCount = 1 TO NUM-DBS:
3885 ASSIGN
3886 cDbType = DBTYPE(iCount)
3887 cLogicalDbName = LDBNAME(iCount).
3888
3889 IF LOOKUP(LDBNAME(iCount), cSchemaHolders) > 0 OR cDbType <> "PROGRESS" THEN NEXT #Db.
3890
3891 CREATE ALIAS dictdb FOR DATABASE VALUE(cLogicalDbName).
3892 RUN getDataserver.p
3893 ( INPUT cLogicalDbName
3894 , INPUT-OUTPUT giDataserverNr
3895 , INPUT-OUTPUT TABLE bDataserver
3896 ).
3897 DELETE ALIAS dictdb.
3898 END.
3899
3900 /* Support dataservers */
3901 FOR EACH bDataserver BY bDataserver.cLDbNameSchema:
3902 /* Remove schemaholder from database list */
3903 IF bDataserver.lDontShowSchemaHr THEN
3904 DO:
3905 iPos = LOOKUP(bDataserver.cLDbNameSchema, cDatabaseList).
3906 IF iPos > 0
3907 AND NOT CAN-FIND(FIRST ttTable WHERE ttTable.cDatabase = bDataserver.cLDbNameSchema
3908 AND ttTable.lHidden = NO) THEN
3909 DO:
3910 ENTRY(iPos, cDatabaseList) = "".
3911 cDatabaseList = TRIM(REPLACE(cDatabaseList, ",,", ","), ",").
3912 END.
3913 END.
3914
3915 /* Add dataserver to database list */
3916 iPos = LOOKUP(bDataserver.cLDbNameDataserver, cDatabaseList).
3917 IF bDataserver.lConnected THEN
3918 DO:
3919 IF iPos = 0 THEN cDatabaseList = TRIM(cDatabaseList + "," + bDataserver.cLDbNameDataserver, ",").
3920 END. /* IF bDataserver.lConnected */
3921
3922 ELSE
3923 DO:
3924 IF iPos > 0 THEN
3925 DO:
3926 ENTRY(iPos, cDatabaseList) = "".
3927 cDatabaseList = TRIM(REPLACE(cDatabaseList, ",,", ","), ",").
3928 END. /* IF iPos > 0 */
3929 END. /* else */
3930 END. /* FOR EACH bDataserver */
3931
3932 ASSIGN
3933 cDatabaseList = TRIM(cDatabaseList, ',')
3934 gcSaveDatabaseList = cDatabaseList.
3935
3936 RETURN cDatabaseList.
3937
3938 {&timerStop}
3939END FUNCTION. /* getDatabaseList */
3940
3941/* _UIB-CODE-BLOCK-END */
3942&ANALYZE-RESUME
3943
3944&ENDIF
3945
3946&IF DEFINED(EXCLUDE-getEscapedData) = 0 &THEN
3947
3948&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION getEscapedData Procedure
3949FUNCTION getEscapedData RETURNS CHARACTER
3950 ( pcTarget AS CHARACTER
3951 , pcString AS CHARACTER ) :
3952 /* Return html- or 4gl-safe string
3953 */
3954 DEFINE VARIABLE cOutput AS CHARACTER NO-UNDO.
3955 DEFINE VARIABLE iTmp AS INTEGER NO-UNDO.
3956
3957 {&timerStart}
3958
3959 /* Garbage in, garbage out */
3960 cOutput = pcString.
3961
3962 CASE pcTarget:
3963 WHEN "HTML" THEN
3964 DO:
3965 cOutput = REPLACE(cOutput,"<","<").
3966 cOutput = REPLACE(cOutput,">",">").
3967 END.
3968
3969 WHEN "4GL" THEN
3970 DO:
3971 /* Replace single quotes because we are using them for 4GL separating too */
3972 cOutput = REPLACE(cOutput, "'", "~~'").
3973
3974 /* Replace CHR's 1 till 13 */
3975 DO iTmp = 1 TO 13:
3976 cOutput = REPLACE(cOutput, CHR(iTmp), "' + chr(" + string(iTmp) + ") + '").
3977 END.
3978 END.
3979 END CASE.
3980
3981 RETURN cOutput.
3982 {&timerStop}
3983
3984END FUNCTION. /* getEscapedData */
3985
3986/* _UIB-CODE-BLOCK-END */
3987&ANALYZE-RESUME
3988
3989&ENDIF
3990
3991&IF DEFINED(EXCLUDE-getFieldList) = 0 &THEN
3992
3993&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION getFieldList Procedure
3994FUNCTION getFieldList RETURNS CHARACTER
3995 ( pcDatabase AS CHARACTER
3996 , pcFile AS CHARACTER
3997 ):
3998 /* Return a comma separated list of all fields of a table
3999 */
4000 DEFINE VARIABLE hQuery AS HANDLE NO-UNDO.
4001 DEFINE VARIABLE hFile AS HANDLE NO-UNDO.
4002 DEFINE VARIABLE hField AS HANDLE NO-UNDO.
4003 DEFINE VARIABLE cFields AS CHARACTER NO-UNDO.
4004
4005 CREATE BUFFER hFile FOR TABLE pcDatabase + "._file".
4006 CREATE BUFFER hField FOR TABLE pcDatabase + "._field".
4007
4008 CREATE QUERY hQuery.
4009 hQuery:SET-BUFFERS(hFile,hField).
4010 hQuery:QUERY-PREPARE(SUBSTITUTE('FOR EACH _File WHERE _File-name = &1, EACH _Field OF _File', QUOTER(pcFile))).
4011 hQuery:QUERY-OPEN().
4012
4013 #CollectFields:
4014 REPEAT:
4015 hQuery:GET-NEXT().
4016 IF hQuery:QUERY-OFF-END THEN LEAVE #CollectFields.
4017 cFields = cFields + "," + hField::_Field-name.
4018 END. /* #CollectFields */
4019
4020 hQuery:QUERY-CLOSE().
4021 DELETE OBJECT hField.
4022 DELETE OBJECT hFile.
4023 DELETE OBJECT hQuery.
4024
4025 RETURN TRIM(cFields, ",").
4026
4027END FUNCTION. /* getFieldList */
4028
4029/* _UIB-CODE-BLOCK-END */
4030&ANALYZE-RESUME
4031
4032&ENDIF
4033
4034&IF DEFINED(EXCLUDE-getFileCategory) = 0 &THEN
4035
4036&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION getFileCategory Procedure
4037FUNCTION getFileCategory RETURNS CHARACTER
4038 ( piFileNumber AS INTEGER
4039 , pcFileName AS CHARACTER
4040 ) :
4041 /* Based on table name and -number, return the category for a table
4042 *
4043 * Application tables : _file-number > 0 AND _file-number < 32000
4044 * Schema tables : _file-number > -80 AND _file-number < 0
4045 * Virtual system tables: _file-number < -16384
4046 * SQL catalog tables : _file-name BEGINS "_sys"
4047 * Other tables : _file-number >= -16384 AND _file-number <= -80
4048 */
4049 IF piFileNumber > 0 AND piFileNumber < 32000 THEN RETURN 'Normal'.
4050 IF piFileNumber > -80 AND piFileNumber < 0 THEN RETURN 'Schema'.
4051 IF piFileNumber < -16384 THEN RETURN 'VST'.
4052 IF pcFileName BEGINS '_sys' THEN RETURN 'SQL'.
4053 IF piFileNumber >= -16384 AND piFileNumber <= -80 THEN RETURN 'Other'.
4054
4055 RETURN ''. /* Function return value. */
4056
4057END FUNCTION. /* getFileCategory */
4058
4059/* _UIB-CODE-BLOCK-END */
4060&ANALYZE-RESUME
4061
4062&ENDIF
4063
4064&IF DEFINED(EXCLUDE-getFont) = 0 &THEN
4065
4066&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION getFont Procedure
4067FUNCTION getFont RETURNS INTEGER
4068 ( pcName AS CHARACTER ) :
4069 /* Return the fontnumber for the type given
4070 */
4071 DEFINE BUFFER bFont FOR ttFont.
4072
4073 {&timerStart}
4074
4075 FIND bFont WHERE bFont.cName = pcName NO-ERROR.
4076 IF AVAILABLE bFont THEN RETURN bFont.iFont.
4077
4078 CREATE bFont.
4079 ASSIGN bFont.cName = pcName.
4080
4081 bFont.iFont = INTEGER(getRegistry('DataDigger:Fonts',pcName)) NO-ERROR.
4082
4083 IF bFont.iFont = ? OR bFont.iFont > 23 THEN
4084 CASE pcName:
4085 WHEN 'Default' THEN bFont.iFont = 4.
4086 WHEN 'Fixed' THEN bFont.iFont = 0.
4087 END CASE.
4088
4089 RETURN bFont.iFont. /* Function return value. */
4090 {&timerStop}
4091
4092END FUNCTION. /* getFont */
4093
4094/* _UIB-CODE-BLOCK-END */
4095&ANALYZE-RESUME
4096
4097&ENDIF
4098
4099&IF DEFINED(EXCLUDE-getImagePath) = 0 &THEN
4100
4101&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION getImagePath Procedure
4102FUNCTION getImagePath RETURNS CHARACTER
4103 ( pcImage AS CHARACTER ) :
4104 /* Return the image path + icon set name
4105 */
4106 {&timerStart}
4107 RETURN SUBSTITUTE('&1Image/default_&2', getProgramDir(), pcImage).
4108 {&timerStop}
4109
4110END FUNCTION. /* getImagePath */
4111
4112/* _UIB-CODE-BLOCK-END */
4113&ANALYZE-RESUME
4114
4115&ENDIF
4116
4117&IF DEFINED(EXCLUDE-getIndexFields) = 0 &THEN
4118
4119&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION getIndexFields Procedure
4120FUNCTION getIndexFields RETURNS CHARACTER
4121 ( INPUT pcDatabaseName AS CHARACTER
4122 , INPUT pcTableName AS CHARACTER
4123 , INPUT pcFlags AS CHARACTER
4124 ) :
4125 /* Return the index fields of a table.
4126 */
4127 DEFINE VARIABLE cWhere AS CHARACTER NO-UNDO.
4128 DEFINE VARIABLE hQuery AS HANDLE NO-UNDO.
4129 DEFINE VARIABLE hFieldBuffer AS HANDLE NO-UNDO.
4130 DEFINE VARIABLE hFileBuffer AS HANDLE NO-UNDO.
4131 DEFINE VARIABLE hIndexBuffer AS HANDLE NO-UNDO.
4132 DEFINE VARIABLE hIndexFieldBuffer AS HANDLE NO-UNDO.
4133 DEFINE VARIABLE cFieldList AS CHARACTER NO-UNDO.
4134
4135 {&timerStart}
4136
4137 CREATE BUFFER hFileBuffer FOR TABLE pcDatabaseName + "._File".
4138 CREATE BUFFER hIndexBuffer FOR TABLE pcDatabaseName + "._Index".
4139 CREATE BUFFER hIndexFieldBuffer FOR TABLE pcDatabaseName + "._Index-Field".
4140 CREATE BUFFER hFieldBuffer FOR TABLE pcDatabaseName + "._Field".
4141
4142 CREATE QUERY hQuery.
4143 hQuery:SET-BUFFERS(hFileBuffer,hIndexBuffer,hIndexFieldBuffer,hFieldBuffer).
4144
4145 {&_proparse_ prolint-nowarn(longstrings)}
4146 cWhere = SUBSTITUTE("FOR EACH &1._file WHERE &1._file._file-name = &2 AND _File._File-Number < 32768, ~
4147 EACH &1._index OF &1._file WHERE TRUE &3 &4, ~
4148 EACH &1._index-field OF &1._index, ~
4149 EACH &1._field OF &1._index-field"
4150 , pcDatabaseName
4151 , QUOTER(pcTableName)
4152 , (IF CAN-DO(pcFlags,"U") THEN "AND _index._unique = true" ELSE "")
4153 , (IF CAN-DO(pcFlags,"P") THEN "AND recid(_index) = _file._prime-index" ELSE "")
4154 ).
4155
4156 IF hQuery:QUERY-PREPARE (cWhere) THEN
4157 DO:
4158 hQuery:QUERY-OPEN().
4159 hQuery:GET-FIRST(NO-LOCK).
4160 REPEAT WHILE NOT hQuery:QUERY-OFF-END:
4161 cFieldList = cFieldList + "," + trim(hFieldBuffer:BUFFER-FIELD("_field-name"):string-value).
4162 hQuery:GET-NEXT(NO-LOCK).
4163 END.
4164 END.
4165
4166 cFieldList = TRIM(cFieldList, ",").
4167
4168 hQuery:QUERY-CLOSE.
4169
4170 DELETE OBJECT hFileBuffer.
4171 DELETE OBJECT hIndexBuffer.
4172 DELETE OBJECT hIndexFieldBuffer.
4173 DELETE OBJECT hFieldBuffer.
4174 DELETE OBJECT hQuery.
4175
4176 RETURN cFieldList. /* Function return value. */
4177 {&timerStop}
4178END FUNCTION. /* getIndexFields */
4179
4180/* _UIB-CODE-BLOCK-END */
4181&ANALYZE-RESUME
4182
4183&ENDIF
4184
4185&IF DEFINED(EXCLUDE-getKeyList) = 0 &THEN
4186
4187&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION getKeyList Procedure
4188FUNCTION getKeyList RETURNS CHARACTER
4189 ( /* parameter-definitions */ ) :
4190 /* Return a list of special keys pressed
4191 */
4192 DEFINE VARIABLE mKeyboardState AS MEMPTR NO-UNDO.
4193 {&_proparse_prolint-nowarn(varusage)}
4194 DEFINE VARIABLE iReturnValue AS INT64 NO-UNDO.
4195 DEFINE VARIABLE cKeyList AS CHARACTER NO-UNDO.
4196
4197 SET-SIZE(mKeyboardState) = 256.
4198
4199 /* Get the current state of the keyboard */
4200 {&_proparse_prolint-nowarn(varusage)}
4201 RUN GetKeyboardState(GET-POINTER-VALUE(mKeyboardState), OUTPUT iReturnValue) NO-ERROR.
4202
4203 /* try to suppress error: 'C' Call Stack has been compromised after calling in (6069) */
4204 IF NOT ERROR-STATUS:ERROR THEN
4205 DO:
4206 IF GET-BITS(GET-BYTE(mKeyboardState, 1 + 16), 8, 1) = 1 THEN cKeyList = TRIM(cKeyList + ",SHIFT",",").
4207 IF GET-BITS(GET-BYTE(mKeyboardState, 1 + 17), 8, 1) = 1 THEN cKeyList = TRIM(cKeyList + ",CTRL",",").
4208 IF GET-BITS(GET-BYTE(mKeyboardState, 1 + 18), 8, 1) = 1 THEN cKeyList = TRIM(cKeyList + ",ALT",",").
4209 END.
4210
4211 SET-SIZE(mKeyboardState) = 0.
4212 RETURN cKeyList. /* Function return value. */
4213
4214END FUNCTION. /* getKeyList */
4215
4216/* _UIB-CODE-BLOCK-END */
4217&ANALYZE-RESUME
4218
4219&ENDIF
4220
4221&IF DEFINED(EXCLUDE-getLinkInfo) = 0 &THEN
4222
4223&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION getLinkInfo Procedure
4224FUNCTION getLinkInfo RETURNS CHARACTER
4225 ( INPUT pcFieldName AS CHARACTER
4226 ):
4227 /* Save name/value of a field.
4228 */
4229 DEFINE BUFFER bLinkInfo FOR ttLinkInfo.
4230 {&timerStart}
4231 FIND bLinkInfo WHERE bLinkInfo.cField = pcFieldName NO-ERROR.
4232
4233 RETURN (IF AVAILABLE bLinkInfo THEN bLinkInfo.cValue ELSE "").
4234 {&timerStop}
4235END FUNCTION. /* getLinkInfo */
4236
4237/* _UIB-CODE-BLOCK-END */
4238&ANALYZE-RESUME
4239
4240&ENDIF
4241
4242&IF DEFINED(EXCLUDE-getMaxLength) = 0 &THEN
4243
4244&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION getMaxLength Procedure
4245FUNCTION getMaxLength RETURNS INTEGER
4246 ( cFieldList AS CHARACTER ) :
4247 /* Return the length of the longest element in a comma separated list
4248 */
4249 DEFINE VARIABLE iField AS INTEGER NO-UNDO.
4250 DEFINE VARIABLE iMaxLength AS INTEGER NO-UNDO.
4251 {&timerStart}
4252
4253 /* Get max field length */
4254 DO iField = 1 TO NUM-ENTRIES(cFieldList):
4255 iMaxLength = MAXIMUM(iMaxLength,LENGTH(ENTRY(iField,cFieldList))).
4256 END.
4257
4258 RETURN iMaxLength. /* Function return value. */
4259 {&timerStop}
4260END FUNCTION. /* getMaxLength */
4261
4262/* _UIB-CODE-BLOCK-END */
4263&ANALYZE-RESUME
4264
4265&ENDIF
4266
4267&IF DEFINED(EXCLUDE-getOsErrorDesc) = 0 &THEN
4268
4269&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION getOsErrorDesc Procedure
4270FUNCTION getOsErrorDesc RETURNS CHARACTER
4271 (INPUT piOsError AS INTEGER):
4272 /* Return string for os-error
4273 */
4274 CASE piOsError:
4275 WHEN 0 THEN RETURN "No error ".
4276 WHEN 1 THEN RETURN "Not owner ".
4277 WHEN 2 THEN RETURN "No such file or directory".
4278 WHEN 3 THEN RETURN "Interrupted system call ".
4279 WHEN 4 THEN RETURN "I/O error ".
4280 WHEN 5 THEN RETURN "Bad file number ".
4281 WHEN 6 THEN RETURN "No more processes ".
4282 WHEN 7 THEN RETURN "Not enough core memory ".
4283 WHEN 8 THEN RETURN "Permission denied ".
4284 WHEN 9 THEN RETURN "Bad address ".
4285 WHEN 10 THEN RETURN "File exists ".
4286 WHEN 11 THEN RETURN "No such device ".
4287 WHEN 12 THEN RETURN "Not a directory ".
4288 WHEN 13 THEN RETURN "Is a directory ".
4289 WHEN 14 THEN RETURN "File table overflow ".
4290 WHEN 15 THEN RETURN "Too many open files ".
4291 WHEN 16 THEN RETURN "File too large ".
4292 WHEN 17 THEN RETURN "No space left on device ".
4293 WHEN 18 THEN RETURN "Directory not empty ".
4294 OTHERWISE RETURN "Unmapped error ".
4295 END CASE.
4296
4297END FUNCTION. /* getOsErrorDesc */
4298
4299/* _UIB-CODE-BLOCK-END */
4300&ANALYZE-RESUME
4301
4302&ENDIF
4303
4304&IF DEFINED(EXCLUDE-getProgramDir) = 0 &THEN
4305
4306&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION getProgramDir Procedure
4307FUNCTION getProgramDir RETURNS CHARACTER
4308 ( /* parameter-definitions */ ) :
4309 /* Return the DataDigger install dir, including a backslash
4310 */
4311
4312 /* Cached the value in a global var (about 100x as fast) */
4313 IF gcProgramDir = '' THEN
4314 DO:
4315 /* this-procedure:file-name will return the .p name without path when the
4316 * procedure us run without full path. We need to seek it in the propath.
4317 */
4318 FILE-INFO:FILE-NAME = THIS-PROCEDURE:FILE-NAME.
4319 IF FILE-INFO:FULL-PATHNAME = ? THEN
4320 DO:
4321 IF SUBSTRING(THIS-PROCEDURE:FILE-NAME,LENGTH(THIS-PROCEDURE:FILE-NAME) - 1, 2) = ".p" THEN
4322 FILE-INFO:FILE-NAME = SUBSTRING(THIS-PROCEDURE:FILE-NAME,1,LENGTH(THIS-PROCEDURE:FILE-NAME) - 2) + ".r".
4323 END.
4324
4325 gcProgramDir = SUBSTRING(FILE-INFO:FULL-PATHNAME,1,R-INDEX(FILE-INFO:FULL-PATHNAME,'\')).
4326 PUBLISH "message"(50,gcProgramDir).
4327 END.
4328
4329 RETURN gcProgramDir.
4330
4331END FUNCTION. /* getProgramDir */
4332
4333/* _UIB-CODE-BLOCK-END */
4334&ANALYZE-RESUME
4335
4336&ENDIF
4337
4338&IF DEFINED(EXCLUDE-getQuery) = 0 &THEN
4339
4340&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION getQuery Procedure
4341FUNCTION getQuery RETURNS CHARACTER
4342 ( INPUT pcDatabase AS CHARACTER
4343 , INPUT pcTable AS CHARACTER
4344 , INPUT piQuery AS INTEGER
4345 ) :
4346 /* Get previously used query nr <piQuery>
4347 */
4348 DEFINE BUFFER bQuery FOR ttQuery.
4349
4350 FIND bQuery
4351 WHERE bQuery.cDatabase = pcDatabase
4352 AND bQuery.cTable = pcTable
4353 AND bQuery.iQueryNr = piQuery NO-ERROR.
4354
4355 IF AVAILABLE bQuery THEN
4356 RETURN bQuery.cQueryTxt.
4357 ELSE
4358 RETURN ?.
4359
4360END FUNCTION. /* getQuery */
4361
4362/* _UIB-CODE-BLOCK-END */
4363&ANALYZE-RESUME
4364
4365&ENDIF
4366
4367&IF DEFINED(EXCLUDE-getReadableQuery) = 0 &THEN
4368
4369&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION getReadableQuery Procedure
4370FUNCTION getReadableQuery RETURNS CHARACTER
4371 ( INPUT pcQuery AS CHARACTER ):
4372 /* Return a query as a string that is readable for humans.
4373 */
4374 DEFINE VARIABLE hQuery AS HANDLE NO-UNDO.
4375
4376 /* Accept query or query-handle */
4377 hQuery = WIDGET-HANDLE(pcQuery) NO-ERROR.
4378 IF VALID-HANDLE( hQuery ) THEN
4379 DO:
4380 hQuery = WIDGET-HANDLE(pcQuery).
4381 pcQuery = hQuery:PREPARE-STRING.
4382 END.
4383
4384 pcQuery = REPLACE(pcQuery,' EACH ' ,' EACH ').
4385 pcQuery = REPLACE(pcQuery,' FIRST ',' FIRST ').
4386 pcQuery = REPLACE(pcQuery,' WHERE ', '~n WHERE ').
4387 pcQuery = REPLACE(pcQuery,' AND ' , '~n AND ').
4388 pcQuery = REPLACE(pcQuery,' BY ' , '~n BY ').
4389 pcQuery = REPLACE(pcQuery,' FIELDS ()','').
4390 pcQuery = REPLACE(pcQuery,'FOR EACH ' ,'FOR EACH ').
4391 pcQuery = REPLACE(pcQuery,' NO-LOCK', ' NO-LOCK').
4392 pcQuery = REPLACE(pcQuery,' INDEXED-REPOSITION', '').
4393
4394 pcQuery = pcQuery + '~n'.
4395
4396 RETURN pcQuery.
4397END FUNCTION. /* getReadableQuery */
4398
4399/* _UIB-CODE-BLOCK-END */
4400&ANALYZE-RESUME
4401
4402&ENDIF
4403
4404&IF DEFINED(EXCLUDE-getRegistry) = 0 &THEN
4405
4406&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION getRegistry Procedure
4407FUNCTION getRegistry RETURNS CHARACTER
4408 ( pcSection AS CHARACTER
4409 , pcKey AS CHARACTER
4410 ) :
4411 /* Get a value from the registry.
4412 */
4413 {&timerStart}
4414 DEFINE BUFFER bDatabase FOR ttDatabase.
4415 DEFINE BUFFER bConfig FOR ttConfig.
4416
4417 /* If this is a DB-specific section then replace db name if needed */
4418 IF pcSection BEGINS "DB:" THEN
4419 DO:
4420 FIND bDatabase WHERE bDatabase.cLogicalName = ENTRY(2,pcSection,":") NO-ERROR.
4421 IF AVAILABLE bDatabase THEN pcSection = "DB:" + bDatabase.cSection.
4422 END.
4423
4424 /* Load settings if there is nothing in the config table */
4425 IF NOT TEMP-TABLE ttConfig:HAS-RECORDS THEN
4426 RUN loadSettings.
4427
4428 /* Search in settings tt */
4429 FIND bConfig WHERE bConfig.cSection = pcSection AND bConfig.cSetting = pcKey NO-ERROR.
4430
4431 RETURN ( IF AVAILABLE bConfig THEN bConfig.cValue ELSE ? ).
4432 {&timerStop}
4433END FUNCTION. /* getRegistry */
4434
4435/* _UIB-CODE-BLOCK-END */
4436&ANALYZE-RESUME
4437
4438&ENDIF
4439
4440&IF DEFINED(EXCLUDE-getSchemaHolder) = 0 &THEN
4441
4442&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION getSchemaHolder Procedure
4443FUNCTION getSchemaHolder RETURNS CHARACTER
4444 ( INPUT pcDataSrNameOrDbName AS CHARACTER
4445 ):
4446 DEFINE BUFFER bDataserver FOR ttDataserver.
4447
4448 FIND bDataserver WHERE bDataserver.cLDBNameDataserver = pcDataSrNameOrDbName NO-ERROR.
4449 RETURN (IF AVAILABLE bDataserver THEN bDataserver.cLDBNameSchema ELSE pcDataSrNameOrDbName).
4450
4451END FUNCTION. /* getSchemaHolder */
4452
4453/* _UIB-CODE-BLOCK-END */
4454&ANALYZE-RESUME
4455
4456&ENDIF
4457
4458&IF DEFINED(EXCLUDE-getStackSize) = 0 &THEN
4459
4460&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION getStackSize Procedure
4461FUNCTION getStackSize RETURNS INTEGER():
4462 /* Return value of the -s session setting
4463 */
4464 DEFINE VARIABLE cList AS CHARACTER NO-UNDO.
4465 DEFINE VARIABLE cParm AS CHARACTER CASE-SENSITIVE NO-UNDO.
4466 DEFINE VARIABLE cSetting AS CHARACTER NO-UNDO.
4467 DEFINE VARIABLE cValue AS CHARACTER NO-UNDO.
4468 DEFINE VARIABLE iParm AS INTEGER NO-UNDO.
4469 DEFINE VARIABLE iStackSize AS INTEGER NO-UNDO.
4470
4471 cList = SESSION:STARTUP-PARAMETERS.
4472
4473 DO iParm = 1 TO NUM-ENTRIES(cList):
4474 cSetting = ENTRY(iParm,cList) + " ".
4475 cParm = ENTRY(1,cSetting," ").
4476 cValue = ENTRY(2,cSetting," ").
4477
4478 IF cParm = "-s" THEN
4479 DO:
4480 iStackSize = INTEGER(cValue) NO-ERROR.
4481 IF ERROR-STATUS:ERROR THEN iStackSize = 0.
4482 END.
4483 END.
4484
4485 /* If not defined, report the default */
4486 IF iStackSize = 0 THEN iStackSize = 40.
4487
4488 RETURN iStackSize.
4489END FUNCTION. /* getStackSize */
4490
4491/* _UIB-CODE-BLOCK-END */
4492&ANALYZE-RESUME
4493
4494&ENDIF
4495
4496&IF DEFINED(EXCLUDE-getTableDesc) = 0 &THEN
4497
4498&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION getTableDesc Procedure
4499FUNCTION getTableDesc RETURNS CHARACTER
4500 ( INPUT pcDatabase AS CHARACTER
4501 , INPUT pcTable AS CHARACTER
4502 ) :
4503 DEFINE BUFFER bTable FOR ttTable.
4504
4505 FIND bTable
4506 WHERE bTable.cDatabase = pcDatabase
4507 AND bTable.cTableName = pcTable NO-ERROR.
4508
4509 RETURN (IF AVAILABLE bTable THEN bTable.cTableDesc ELSE '').
4510
4511END FUNCTION. /* getTableDesc */
4512
4513/* _UIB-CODE-BLOCK-END */
4514&ANALYZE-RESUME
4515
4516&ENDIF
4517
4518&IF DEFINED(EXCLUDE-getTableLabel) = 0 &THEN
4519
4520&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION getTableLabel Procedure
4521FUNCTION getTableLabel RETURNS CHARACTER
4522 ( INPUT pcDatabase AS CHARACTER
4523 , INPUT pcTable AS CHARACTER
4524 ) :
4525 DEFINE BUFFER bTable FOR ttTable.
4526
4527 FIND bTable
4528 WHERE bTable.cDatabase = pcDatabase
4529 AND bTable.cTableName = pcTable NO-ERROR.
4530
4531 RETURN (IF AVAILABLE bTable AND bTable.cTableLabel <> ? THEN bTable.cTableLabel ELSE '').
4532
4533END FUNCTION. /* getTableLabel */
4534
4535/* _UIB-CODE-BLOCK-END */
4536&ANALYZE-RESUME
4537
4538&ENDIF
4539
4540&IF DEFINED(EXCLUDE-getTableList) = 0 &THEN
4541
4542&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION getTableList Procedure
4543FUNCTION getTableList RETURNS CHARACTER
4544 ( INPUT pcDatabaseFilter AS CHARACTER
4545 , INPUT pcTableFilter AS CHARACTER
4546 ) :
4547 /* Get a filtered list of all tables in the current database
4548 */
4549 DEFINE VARIABLE cTableList AS CHARACTER NO-UNDO.
4550 DEFINE VARIABLE cQuery AS CHARACTER NO-UNDO.
4551
4552 DEFINE BUFFER bTable FOR ttTable.
4553 DEFINE QUERY qTable FOR bTable.
4554
4555 {&timerStart}
4556 IF pcDatabaseFilter = '' OR pcDatabaseFilter = ? THEN pcDatabaseFilter = '*'.
4557
4558 /* Build query */
4559 cQuery = SUBSTITUTE('for each bTable where cDatabase matches &1', QUOTER(pcDatabaseFilter)).
4560 cQuery = SUBSTITUTE("&1 and cTableName matches &2", cQuery, QUOTER(pcTableFilter )).
4561
4562 QUERY qTable:QUERY-PREPARE( SUBSTITUTE('&1 by cTableName', cQuery)).
4563 QUERY qTable:QUERY-OPEN.
4564 QUERY qTable:GET-FIRST.
4565
4566 /* All fields */
4567 REPEAT WHILE NOT QUERY qTable:QUERY-OFF-END:
4568 cTableList = cTableList + "," + bTable.cTableName.
4569 QUERY qTable:GET-NEXT.
4570 END.
4571 QUERY qTable:QUERY-CLOSE.
4572
4573 cTableList = LEFT-TRIM(cTableList, ",").
4574
4575 RETURN cTableList. /* Function return value. */
4576 {&timerStop}
4577END FUNCTION. /* getTableList */
4578
4579/* _UIB-CODE-BLOCK-END */
4580&ANALYZE-RESUME
4581
4582&ENDIF
4583
4584&IF DEFINED(EXCLUDE-getUserName) = 0 &THEN
4585
4586&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION getUserName Procedure
4587FUNCTION getUserName RETURNS CHARACTER
4588 ( /* parameter-definitions */ ) :
4589 /* Return login name of user
4590 */
4591 DEFINE VARIABLE cUserName AS LONGCHAR NO-UNDO.
4592 DEFINE VARIABLE intResult AS INTEGER NO-UNDO.
4593 DEFINE VARIABLE intSize AS INTEGER NO-UNDO.
4594 DEFINE VARIABLE mUserId AS MEMPTR NO-UNDO.
4595
4596 {&startTimer}
4597
4598 /* Otherwise determine the value */
4599 SET-SIZE(mUserId) = 256.
4600 intSize = 255.
4601
4602 RUN GetUserNameA(INPUT mUserId, INPUT-OUTPUT intSize, OUTPUT intResult).
4603 COPY-LOB mUserId FOR (intSize - 1) TO cUserName NO-CONVERT.
4604
4605 IF intResult <> 1 OR cUserName = "" OR cUserName = ? THEN
4606 cUserName = "default".
4607 ELSE
4608 cUserName = REPLACE(cUserName,".","").
4609
4610 RETURN STRING(cUserName). /* Function return value. */
4611
4612 {&stopTimer}
4613END FUNCTION. /* getUserName */
4614
4615/* _UIB-CODE-BLOCK-END */
4616&ANALYZE-RESUME
4617
4618&ENDIF
4619
4620&IF DEFINED(EXCLUDE-getWidgetUnderMouse) = 0 &THEN
4621
4622&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION getWidgetUnderMouse Procedure
4623FUNCTION getWidgetUnderMouse RETURNS HANDLE
4624 ( phFrame AS HANDLE ) :
4625 /* Return the handle of the widget that is currently under the mouse cursor
4626 */
4627 DEFINE VARIABLE hWidget AS HANDLE NO-UNDO.
4628 DEFINE VARIABLE iMouseX AS INTEGER NO-UNDO.
4629 DEFINE VARIABLE iMouseY AS INTEGER NO-UNDO.
4630
4631 {&timerStart}
4632 hWidget = phFrame:FIRST-CHILD:first-child.
4633 RUN getMouseXY(INPUT phFrame, OUTPUT iMouseX, OUTPUT iMouseY).
4634
4635 REPEAT WHILE VALID-HANDLE(hWidget):
4636
4637 IF hWidget:TYPE <> "RECTANGLE"
4638 AND iMouseX >= hWidget:X
4639 AND iMouseX <= hWidget:X + hWidget:WIDTH-PIXELS
4640 AND iMouseY >= hWidget:Y
4641 AND iMouseY <= hWidget:Y + hWidget:HEIGHT-PIXELS THEN RETURN hWidget.
4642
4643 hWidget = hWidget:NEXT-SIBLING.
4644 END.
4645
4646 RETURN ?.
4647 {&timerStop}
4648END FUNCTION. /* getWidgetUnderMouse */
4649
4650/* _UIB-CODE-BLOCK-END */
4651&ANALYZE-RESUME
4652
4653&ENDIF
4654
4655&IF DEFINED(EXCLUDE-getWorkFolder) = 0 &THEN
4656
4657&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION getWorkFolder Procedure
4658FUNCTION getWorkFolder RETURNS CHARACTER
4659 ( /* parameter-definitions */ ) :
4660
4661 /* Cached the value in a global var */
4662 IF gcWorkFolder = '' THEN
4663 DO:
4664 gcWorkFolder = getRegistry("DataDigger", "WorkFolder").
4665
4666 /* Possibility to specify where DD files are created */
4667 IF gcWorkFolder = ? OR gcWorkFolder = '' THEN
4668 gcWorkFolder = getProgramDir().
4669 ELSE
4670 DO:
4671 gcWorkFolder = RIGHT-TRIM(gcWorkFolder,'/\') + '\'.
4672 gcWorkFolder = resolveOsVars(gcWorkFolder).
4673 RUN createFolder(gcWorkFolder).
4674
4675 FILE-INFO:FILE-NAME = gcWorkFolder.
4676 IF FILE-INFO:FULL-PATHNAME = ? THEN gcWorkFolder = getProgramDir().
4677 END.
4678 END.
4679
4680 RETURN gcWorkFolder.
4681
4682END FUNCTION. /* getWorkFolder */
4683
4684/* _UIB-CODE-BLOCK-END */
4685&ANALYZE-RESUME
4686
4687&ENDIF
4688
4689&IF DEFINED(EXCLUDE-getXmlNodeName) = 0 &THEN
4690
4691&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION getXmlNodeName Procedure
4692FUNCTION getXmlNodeName RETURNS CHARACTER
4693 ( pcFieldName AS CHARACTER ) :
4694 /* Return a name that is safe to use in XML output
4695 */
4696 pcFieldName = REPLACE(pcFieldName,'%', '_').
4697 pcFieldName = REPLACE(pcFieldName,'#', '_').
4698
4699 RETURN pcFieldName.
4700
4701END FUNCTION. /* getXmlNodeName */
4702
4703/* _UIB-CODE-BLOCK-END */
4704&ANALYZE-RESUME
4705
4706&ENDIF
4707
4708&IF DEFINED(EXCLUDE-isDataServer) = 0 &THEN
4709
4710&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION isDataServer Procedure
4711FUNCTION isDataServer RETURNS LOGICAL
4712 ( INPUT pcDataSrNameOrDbName AS CHARACTER
4713 ):
4714 RETURN CAN-FIND(ttDataserver WHERE ttDataserver.cLDBNameDataserver = pcDataSrNameOrDbName).
4715
4716END FUNCTION. /* isDataServer */
4717
4718/* _UIB-CODE-BLOCK-END */
4719&ANALYZE-RESUME
4720
4721&ENDIF
4722
4723&IF DEFINED(EXCLUDE-isDefaultFontsChanged) = 0 &THEN
4724
4725&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION isDefaultFontsChanged Procedure
4726FUNCTION isDefaultFontsChanged RETURNS LOGICAL
4727 ( /* parameter-definitions */ ) :
4728 /* Returns whether the default fonts 0-7 were changed.
4729 */
4730 DEFINE VARIABLE cFontSize AS CHARACTER NO-UNDO EXTENT 8.
4731 DEFINE VARIABLE i AS INTEGER NO-UNDO.
4732
4733 /* These are the expected fontsizes of the text 'DataDigger' */
4734 cFontSize[1] = '70/14'. /* font0 */
4735 cFontSize[2] = '54/13'. /* font1 */
4736 cFontSize[3] = '70/14'. /* font2 */
4737 cFontSize[4] = '70/14'. /* font3 */
4738 cFontSize[5] = '54/13'. /* font4 */
4739 cFontSize[6] = '70/16'. /* font5 */
4740 cFontSize[7] = '65/13'. /* font6 */
4741 cFontSize[8] = '54/13'. /* font7 */
4742
4743 checkFont:
4744 DO i = 0 TO 7:
4745 IF cFontSize[i + 1] <> SUBSTITUTE('&1/&2'
4746 , FONT-TABLE:GET-TEXT-WIDTH-PIXELS('DataDigger',i)
4747 , FONT-TABLE:GET-TEXT-HEIGHT-PIXELS(i)
4748 ) THEN RETURN TRUE.
4749 END. /* checkFont */
4750
4751 RETURN FALSE.
4752
4753END FUNCTION. /* isDefaultFontsChanged */
4754
4755/* _UIB-CODE-BLOCK-END */
4756&ANALYZE-RESUME
4757
4758&ENDIF
4759
4760&IF DEFINED(EXCLUDE-isFileLocked) = 0 &THEN
4761
4762&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION isFileLocked Procedure
4763FUNCTION isFileLocked RETURNS LOGICAL
4764 ( pcFileName AS CHARACTER ) :
4765 /* Check whether a file is locked on the file system
4766 */
4767 DEFINE VARIABLE iFileHandle AS INTEGER NO-UNDO.
4768 {&_proparse_prolint-nowarn(varusage)}
4769 DEFINE VARIABLE nReturn AS INTEGER NO-UNDO.
4770
4771 /* Try to lock the file agains writing */
4772 RUN CreateFileA ( INPUT pcFileName
4773 , INPUT {&GENERIC_WRITE}
4774 , {&FILE_SHARE_READ}
4775 , 0
4776 , {&OPEN_EXISTING}
4777 , {&FILE_ATTRIBUTE_NORMAL}
4778 , 0
4779 , OUTPUT iFileHandle
4780 ).
4781
4782 /* Release file handle */
4783 {&_proparse_prolint-nowarn(varusage)}
4784 RUN CloseHandle (INPUT iFileHandle, OUTPUT nReturn).
4785
4786 RETURN (iFileHandle = -1).
4787
4788END FUNCTION. /* isFileLocked */
4789
4790/* _UIB-CODE-BLOCK-END */
4791&ANALYZE-RESUME
4792
4793&ENDIF
4794
4795&IF DEFINED(EXCLUDE-isMouseOver) = 0 &THEN
4796
4797&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION isMouseOver Procedure
4798FUNCTION isMouseOver RETURNS LOGICAL
4799 ( phWidget AS HANDLE ) :
4800 /* Return whether the mouse is currently over a certain widget
4801 */
4802 DEFINE VARIABLE iMouseX AS INTEGER NO-UNDO.
4803 DEFINE VARIABLE iMouseY AS INTEGER NO-UNDO.
4804
4805 IF NOT VALID-HANDLE(phWidget) THEN RETURN FALSE.
4806 RUN getMouseXY(INPUT phWidget:FRAME, OUTPUT iMouseX, OUTPUT iMouseY).
4807
4808 RETURN ( iMouseX >= phWidget:X
4809 AND iMouseX <= phWidget:X + phWidget:WIDTH-PIXELS
4810 AND iMouseY >= phWidget:Y
4811 AND iMouseY <= phWidget:Y + phWidget:HEIGHT-PIXELS ).
4812
4813END FUNCTION. /* isMouseOver */
4814
4815/* _UIB-CODE-BLOCK-END */
4816&ANALYZE-RESUME
4817
4818&ENDIF
4819
4820&IF DEFINED(EXCLUDE-isTableFilterUsed) = 0 &THEN
4821
4822&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION isTableFilterUsed Procedure
4823FUNCTION isTableFilterUsed RETURNS LOGICAL
4824 ( INPUT TABLE ttTableFilter ) :
4825 /* Returns whether any setting is used for table filtering
4826 */
4827 FIND ttTableFilter NO-ERROR.
4828 IF NOT AVAILABLE ttTableFilter THEN RETURN FALSE.
4829
4830 /* Main toggles */
4831 IF ttTableFilter.lShowNormal = FALSE
4832 OR ttTableFilter.lShowSchema <> LOGICAL(getRegistry('DataDigger','ShowHiddenTables'))
4833 OR ttTableFilter.lShowVst = TRUE
4834 OR ttTableFilter.lShowSql = TRUE
4835 OR ttTableFilter.lShowOther = TRUE
4836 OR ttTableFilter.lShowHidden = TRUE
4837 OR ttTableFilter.lShowFrozen = TRUE THEN RETURN TRUE.
4838
4839 /* Show these tables */
4840 IF ttTableFilter.cTableNameShow <> ?
4841 AND ttTableFilter.cTableNameShow <> ''
4842 AND ttTableFilter.cTableNameShow <> '*' THEN RETURN TRUE.
4843
4844 /* But hide these */
4845 IF ttTableFilter.cTableNameHide <> ?
4846 AND ttTableFilter.cTableNameHide <> '' THEN RETURN TRUE.
4847
4848 /* Show only tables that contain all of these fields */
4849 IF ttTableFilter.cTableFieldShow <> ?
4850 AND ttTableFilter.cTableFieldShow <> ''
4851 AND ttTableFilter.cTableFieldShow <> '*' THEN RETURN TRUE.
4852
4853 /* But hide tables that contain any of these */
4854 IF ttTableFilter.cTableFieldHide <> ?
4855 AND ttTableFilter.cTableFieldHide <> '' THEN RETURN TRUE.
4856
4857 /* else */
4858 RETURN FALSE.
4859
4860END FUNCTION. /* isTableFilterUsed */
4861
4862/* _UIB-CODE-BLOCK-END */
4863&ANALYZE-RESUME
4864
4865&ENDIF
4866
4867&IF DEFINED(EXCLUDE-isValidCodePage) = 0 &THEN
4868
4869&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION isValidCodePage Procedure
4870FUNCTION isValidCodePage RETURNS LOGICAL
4871 (pcCodepage AS CHARACTER):
4872 /* Returns whether pcCodePage is valid
4873 */
4874 {&_proparse_prolint-nowarn(varusage)}
4875 DEFINE VARIABLE cDummy AS LONGCHAR NO-UNDO.
4876
4877 IF pcCodePage = '' THEN RETURN TRUE.
4878
4879 FIX-CODEPAGE(cDummy) = pcCodepage NO-ERROR.
4880 RETURN NOT ERROR-STATUS:ERROR.
4881
4882END FUNCTION. /* isValidCodePage */
4883
4884/* _UIB-CODE-BLOCK-END */
4885&ANALYZE-RESUME
4886
4887&ENDIF
4888
4889&IF DEFINED(EXCLUDE-readFile) = 0 &THEN
4890
4891&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION readFile Procedure
4892FUNCTION readFile RETURNS LONGCHAR
4893 (pcFilename AS CHARACTER):
4894 /* Read contents of a file as a longchar.
4895 */
4896 DEFINE VARIABLE cContent AS LONGCHAR NO-UNDO.
4897 DEFINE VARIABLE cLine AS CHARACTER NO-UNDO.
4898
4899 IF SEARCH(pcFilename) <> ? THEN
4900 DO:
4901 INPUT FROM VALUE(pcFilename).
4902 REPEAT:
4903 IMPORT UNFORMATTED cLine.
4904 cContent = cContent + "~n" + cLine.
4905 END.
4906 INPUT CLOSE.
4907 END.
4908
4909 RETURN cContent.
4910END FUNCTION. /* readFile */
4911
4912/* _UIB-CODE-BLOCK-END */
4913&ANALYZE-RESUME
4914
4915&ENDIF
4916
4917&IF DEFINED(EXCLUDE-removeConnection) = 0 &THEN
4918
4919&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION removeConnection Procedure
4920FUNCTION removeConnection RETURNS LOGICAL
4921 ( pcDatabase AS CHARACTER ) :
4922 /* Remove record from connection temp-table
4923 */
4924 DEFINE BUFFER bfDatabase FOR ttDatabase.
4925 FIND bfDatabase WHERE bfDatabase.cLogicalName = pcDatabase NO-ERROR.
4926 IF AVAILABLE bfDatabase THEN DELETE bfDatabase.
4927 RETURN TRUE.
4928
4929END FUNCTION. /* removeConnection */
4930
4931/* _UIB-CODE-BLOCK-END */
4932&ANALYZE-RESUME
4933
4934&ENDIF
4935
4936&IF DEFINED(EXCLUDE-resolveOsVars) = 0 &THEN
4937
4938&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION resolveOsVars Procedure
4939FUNCTION resolveOsVars RETURNS CHARACTER
4940 ( pcString AS CHARACTER ) :
4941
4942 /* Return a string with OS vars resolved
4943 */
4944 DEFINE VARIABLE i AS INTEGER NO-UNDO.
4945
4946 DO i = 1 TO NUM-ENTRIES(pcString,'%'):
4947 IF i MODULO 2 = 0
4948 AND OS-GETENV(ENTRY(i,pcString,'%')) <> ? THEN
4949 ENTRY(i,pcString,'%') = OS-GETENV(ENTRY(i,pcString,'%')).
4950 END.
4951
4952 pcString = REPLACE(pcString,'%','').
4953 RETURN pcString.
4954END FUNCTION. /* resolveOsVars */
4955
4956/* _UIB-CODE-BLOCK-END */
4957&ANALYZE-RESUME
4958
4959&ENDIF
4960
4961&IF DEFINED(EXCLUDE-resolveSequence) = 0 &THEN
4962
4963&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION resolveSequence Procedure
4964FUNCTION resolveSequence RETURNS CHARACTER
4965 ( pcString AS CHARACTER ) :
4966 /* Return a string where sequence nr for file is resolved
4967 */
4968 DEFINE VARIABLE iFileNr AS INTEGER NO-UNDO.
4969 DEFINE VARIABLE cSeqMask AS CHARACTER NO-UNDO .
4970 DEFINE VARIABLE cSeqFormat AS CHARACTER NO-UNDO .
4971 DEFINE VARIABLE cFileName AS CHARACTER NO-UNDO.
4972
4973 cFileName = pcString.
4974
4975 /* User can specify a sequence for the file. The length of
4976 * the tag sets the format: <###> translates to a 3-digit nr
4977 * Special case is <#> which translates to no leading zeros
4978 */
4979 IF INDEX(cFileName,'<#') > 0
4980 AND index(cFileName,'#>') > 0 THEN
4981 DO:
4982 cSeqMask = SUBSTRING(cFileName,INDEX(cFileName,'<#')). /* <#####>tralalala */
4983 cSeqMask = SUBSTRING(cSeqMask,1,INDEX(cSeqMask,'>')). /* <#####> */
4984 cSeqFormat = TRIM(cSeqMask,'<>'). /* ##### */
4985 cSeqFormat = REPLACE(cSeqFormat,'#','9').
4986 IF cSeqFormat = '9' THEN cSeqFormat = '>>>>>>>>>9'.
4987
4988 setFileNr:
4989 REPEAT:
4990 iFileNr = iFileNr + 1.
4991 IF SEARCH(REPLACE(cFileName,cSeqMask,TRIM(STRING(iFileNr,cSeqFormat)))) = ? THEN
4992 DO:
4993 cFileName = REPLACE(cFileName,cSeqMask,TRIM(STRING(iFileNr,cSeqFormat))).
4994 LEAVE setFileNr.
4995 END.
4996 END.
4997 END.
4998
4999 RETURN cFileName.
5000
5001END FUNCTION. /* resolveSequence */
5002
5003/* _UIB-CODE-BLOCK-END */
5004&ANALYZE-RESUME
5005
5006&ENDIF
5007
5008&IF DEFINED(EXCLUDE-setColor) = 0 &THEN
5009
5010&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION setColor Procedure
5011FUNCTION setColor RETURNS INTEGER
5012 ( pcName AS CHARACTER
5013 , piColor AS INTEGER) :
5014 /* Set color nr in the color tt
5015 */
5016 DEFINE BUFFER bColor FOR ttColor.
5017
5018 FIND bColor WHERE bColor.cName = pcName NO-ERROR.
5019 IF NOT AVAILABLE bColor THEN
5020 DO:
5021 CREATE bColor.
5022 ASSIGN bColor.cName = pcName.
5023 END.
5024
5025 /* Set to default value from settings */
5026 IF piColor = ? THEN
5027 DO:
5028 piColor = INTEGER(getRegistry('DataDigger:Colors', pcName)) NO-ERROR.
5029 IF ERROR-STATUS:ERROR THEN piColor = ?.
5030 END.
5031
5032 bColor.iColor = piColor.
5033 RETURN bColor.iColor.
5034
5035END FUNCTION. /* setColor */
5036
5037/* _UIB-CODE-BLOCK-END */
5038&ANALYZE-RESUME
5039
5040&ENDIF
5041
5042&IF DEFINED(EXCLUDE-setColumnWidthList) = 0 &THEN
5043
5044&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION setColumnWidthList Procedure
5045FUNCTION setColumnWidthList RETURNS LOGICAL
5046 ( INPUT phBrowse AS HANDLE
5047 , INPUT pcWidthList AS CHARACTER):
5048 /* Set all specified columns in pcWidthList to a specified width
5049 */
5050 DEFINE VARIABLE cColumnName AS CHARACTER NO-UNDO.
5051 DEFINE VARIABLE cListItem AS CHARACTER NO-UNDO.
5052 DEFINE VARIABLE hColumn AS HANDLE NO-UNDO.
5053 DEFINE VARIABLE iColumnWidth AS INTEGER NO-UNDO.
5054 DEFINE VARIABLE i AS INTEGER NO-UNDO.
5055 DEFINE VARIABLE j AS INTEGER NO-UNDO.
5056
5057 DO i = 1 TO NUM-ENTRIES(pcWidthList):
5058 cListItem = ENTRY(i,pcWidthList).
5059 cColumnName = ENTRY(1,cListItem,':') NO-ERROR.
5060 iColumnWidth = INTEGER(ENTRY(2,cListItem,':')) NO-ERROR.
5061
5062 DO j = 1 TO phBrowse:NUM-COLUMNS:
5063 hColumn = phBrowse:GET-BROWSE-COLUMN(j).
5064 IF hColumn:NAME = cColumnName THEN
5065 hColumn:WIDTH-PIXELS = iColumnWidth.
5066 END. /* j */
5067 END. /* i */
5068
5069 RETURN TRUE.
5070END FUNCTION. /* setColumnWidthList */
5071
5072/* _UIB-CODE-BLOCK-END */
5073&ANALYZE-RESUME
5074
5075&ENDIF
5076
5077&IF DEFINED(EXCLUDE-setLinkInfo) = 0 &THEN
5078
5079&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION setLinkInfo Procedure
5080FUNCTION setLinkInfo RETURNS LOGICAL
5081 ( INPUT pcFieldName AS CHARACTER
5082 , INPUT pcValue AS CHARACTER
5083 ):
5084 /* Save name/value of a field.
5085 */
5086 DEFINE BUFFER bLinkInfo FOR ttLinkInfo.
5087 {&timerStart}
5088
5089 PUBLISH "debugInfo" (2, SUBSTITUTE("Set linkinfo for field &1 to &2", pcFieldName, pcValue)).
5090
5091 FIND bLinkInfo WHERE bLinkInfo.cField = pcFieldName NO-ERROR.
5092 IF NOT AVAILABLE bLinkInfo THEN
5093 DO:
5094 CREATE bLinkInfo.
5095 ASSIGN bLinkInfo.cField = pcFieldName.
5096 END.
5097
5098 bLinkInfo.cValue = TRIM(pcValue).
5099
5100 RETURN TRUE. /* Function return value. */
5101 {&timerStop}
5102
5103END FUNCTION. /* setLinkInfo */
5104
5105/* _UIB-CODE-BLOCK-END */
5106&ANALYZE-RESUME
5107
5108&ENDIF
5109
5110&IF DEFINED(EXCLUDE-setRegistry) = 0 &THEN
5111
5112&ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION setRegistry Procedure
5113FUNCTION setRegistry RETURNS CHARACTER
5114 ( pcSection AS CHARACTER
5115 , pcKey AS CHARACTER
5116 , pcValue AS CHARACTER
5117 ) :
5118 /* Set a value in the registry.
5119 */
5120 {&timerStart}
5121 DEFINE BUFFER bfConfig FOR ttConfig.
5122
5123 FIND bfConfig
5124 WHERE bfConfig.cSection = pcSection
5125 AND bfConfig.cSetting = pcKey NO-ERROR.
5126
5127 IF NOT AVAILABLE bfConfig THEN
5128 DO:
5129 CREATE bfConfig.
5130 ASSIGN
5131 bfConfig.cSection = pcSection
5132 bfConfig.cSetting = pcKey.
5133
5134 glDirtyCache = TRUE.
5135 END.
5136
5137 IF pcValue = ? OR TRIM(pcValue) = '' THEN
5138 DO:
5139 DELETE bfConfig.
5140 glDirtyCache = TRUE.
5141 END.
5142 ELSE
5143 DO:
5144 ASSIGN
5145 bfConfig.lUser = TRUE
5146 bfConfig.cValue = pcValue.
5147
5148 IF bfConfig.cValue <> pcValue THEN glDirtyCache = TRUE.
5149 END.
5150
5151 RETURN "". /* Function return value. */
5152 {&timerStop}
5153
5154END FUNCTION. /* setRegistry */
5155
5156/* _UIB-CODE-BLOCK-END */
5157&ANALYZE-RESUME
5158
5159&ENDIFView as plain text