****************************************************************************** IDENTIFICATION DIVISION. PROGRAM-ID. FIND_FILE_WITH_SELECTION. * Auteur : Laurent QUIVOGNE * Ce programme fonctionne de façon analogue à LIB$FIND_FILE * On ne spécifie cependant qu'une spécification, une résultante spécification * et une spécification par défaut. * En revanche, on peut passer une item liste qui permettra de faire des * sélections sur les attributs du fichier... * * Format : CALL "FIND_FILE_WITH_SELECTION" USING * [BY REFERENCE ITEM_LIST] * [BY REFERENCE ITEM_LIST_INFO] * [BY DESCRIPTOR FILESPEC] * [BY DESCRIPTOR RESULT_FILESPEC] * [BY DESCRIPTOR DEFAULT_FILESPEC] * [BY REFERENCE RETOUR] * Avec : ITEM_LIST * l'item list se présente de la façon suivante : * * 31 0 * +---------------+---------------+ * | Item Code | Buffer length | * +---------------+---------------+ * | Buffer address | * +---------------+---------------+ * | OR flag | flags | * +---------------+---------------+ * ~ ~ * +-------------------------------+ * | 0 | * +-------------------------------+ * Avec : Buffer length : Longueur du buffer contenant votre valeur * Cette longueur doit correspondre à la longueur de l'item * correspondant. Utilisez pour cela les codes ATR$S_xxx * Item code : Code de l'item correspondant ATR$C_xxx * Buffer Address : Adresse de votre valeur. * flags : * 10 : Egal * 11 : Différent * 12 : Supérieur (ATTRIBUT > VALEUR DONNEE) * 13 : Supérieur ou égal * 14 : Inférieur * 15 : Inférieur ou égal * 20 : Egal string * 21 : Différent string * 22 : Supérieur (ATTRIBUT > VALEUR DONNEE) string * 23 : Supérieur ou égal string * 24 : Inférieur string * 25 : Inférieur ou égal string * OR flag * 1 : Vérifie la condition spécifiée ou * la suivante avec le même code * Exemple : OR flag = 1, flag = 1 : L'attribut spécifié est * supérieur à la valeur donnée OU vérifie la prochaine * condition. * * L'item list doit se terminer par un LONGWORD nul. * * Si vous passez une item list nulle (LONGWORD = 0), Vous pouvez omettre * les autres arguments et FIND_FILE_WITH_SELECTION remet à zéro ses * compteurs. Ceci permet d'arrêter une recherche pour en reprendre une * autre par la suite. Ceci permet également de libérer la mémoire occupée * par les précédents appels. * * ITEM_LIST_INFO * l'item list se présente de la façon suivante : * * 31 0 * +---------------+---------------+ * | Item Code | Buffer length | * +---------------+---------------+ * | Buffer address | * +---------------+---------------+ * ~ ~ * +-------------------------------+ * | 0 | * +-------------------------------+ * * Elle permet de récupérer dans des buffers write only des * informations. * LES DEUX ARGUMENTS ITEM-LIST SONT OPTIONNELS... * * FILESPEC : STRING * Spécification du ou des fichiers recherchés * * RESULT_FILESPEC : STRING * Spécification du fichier sélectionné. l'ensemble des fichiers * s'obtient par des appels successifs à la fonction. * * DEFAULT_FILESPEC : STRING * Spécification par défaut du ou des fichiers recherchés * * RETOUR : LONGWORD * Condition value : La fonction retourne : * o - les mêmes codes que LIB$FIND_FILE * o - LIB$_INVARG : Un argument est invalide... * ENVIRONMENT DIVISION. DATA DIVISION. WORKING-STORAGE SECTION. 01 FAB_ADDRESS PIC 9(9) COMP VALUE 0. 01 BUFFER_ADDRESS PIC 9(9) COMP VALUE 0. 01 BUFFER_PTR PIC 9(9) COMP. 01 ATRBLK_ADDRESS PIC 9(9) COMP. 01 ATRBLK_PTR PIC 9(9) COMP. 01 ITMLST_ADDRESS PIC 9(9) COMP VALUE 0. 01 ITMLST_INFO_ADDRESS PIC 9(9) COMP VALUE 0. 01 ITMLST_PTR PIC 9(9) COMP. 01 LIB$_INVARG PIC 9(9) COMP VALUE EXTERNAL LIB$_INVARG. 01 RETOUR PIC S9(9) COMP. 01 DUMMY1 PIC 9(4) COMP. 01 DUMMY2 PIC 9(9) COMP. 01 COMPARAISON PIC 9(4) COMP. 01 TAILLE_BUFFER PIC 9(9) COMP. 01 TAILLE_ATRBLK PIC 9(9) COMP. 01 NBR_ITEMS PIC 9(9) COMP. 01 DESCR1. 02 D1_LEN PIC 9(4) COMP. * CLASSE 1, TYPE 14 (CLASS_S,DTYPE_T) 02 PIC 9(4) COMP VALUE 270. 02 D1_PTR PIC 9(9) COMP. 01 DESCR2. 02 D2_LEN PIC 9(4) COMP. * CLASSE 1, TYPE 14 (CLASS_S,DTYPE_T) 02 PIC 9(4) COMP VALUE 270. 02 D2_PTR PIC 9(9) COMP. 01 BUF_NUM1 PIC 9(18) COMP. 01 BUF_NUM2 PIC 9(18) COMP. 01 ITMLST_MASK. 02 BUFLEN PIC 9(4) COMP. 02 ITM_CODE PIC 9(4) COMP. 02 BUF_ADDRESS PIC 9(9) COMP. 02 ITM_FLAGS PIC 9(4) COMP. 02 ITM_FLAG_OR PIC 9(4) COMP. 02 NXT_ITM PIC 9(9) COMP. 01 OR_TABLE1. 02 OR_TABLE OCCURS 20 TIMES INDEXED BY OR_CODE_INDEX. 03 OR_CODE PIC 9(4) COMP. 03 OR_VALUE PIC 9(4) COMP. LINKAGE SECTION. 01 ITMLST PIC 9(9) COMP. 01 ITMLST_INFO PIC 9(9) COMP. 01 D_FILESPEC PIC 9(18) COMP. 01 D_RFILESPEC PIC 9(18) COMP. 01 D_DFILESPEC PIC 9(18) COMP. 01 RETCODE PIC 9(9) COMP. PROCEDURE DIVISION USING ITMLST ITMLST_INFO D_FILESPEC D_RFILESPEC D_DFILESPEC RETCODE. DEBUT. * On retrouve l'adresse de l'Item Liste CALL "LIB$ANALYZE_SDESC" USING BY DESCRIPTOR ITMLST BY REFERENCE DUMMY1 ITMLST_ADDRESS. * Item list omise IF ITMLST_ADDRESS = 0 THEN GO TO BOUCLE. * Remise à ZERO des contextes et libération de la mémoire... IF ITMLST = 0 THEN IF FAB_ADDRESS NOT = 0 THEN CALL "LIB$FIND_FILE_END" USING FAB_ADDRESS MOVE 0 TO FAB_ADDRESS END-IF IF BUFFER_ADDRESS NOT = 0 THEN CALL "LIB$FREE_VM" USING TAILLE_BUFFER BY REFERENCE BUFFER_ADDRESS MOVE 0 TO BUFFER_ADDRESS END-IF IF ATRBLK_ADDRESS NOT = 0 THEN CALL "LIB$FREE_VM" USING TAILLE_ATRBLK BY REFERENCE ATRBLK_ADDRESS MOVE 0 TO ATRBLK_ADDRESS NBR_ITEMS END-IF GO TO FIN END-IF. * On scanne une première fois l'ITEM LISTE pour obtenir : * o - Le nombre d'items * o - La taille des buffers à réserver. * si cela n'a pas été fait dans un appel précédent... IF FAB_ADDRESS NOT = 0 THEN GO TO BOUCLE. MOVE 0 TO TAILLE_BUFFER NBR_ITEMS. * On retrouve l'adresse de l'Item Liste CALL "LIB$ANALYZE_SDESC" USING BY DESCRIPTOR ITMLST BY REFERENCE DUMMY1 ITMLST_ADDRESS. * Item list omise IF ITMLST_ADDRESS = 0 THEN GO TO BOUCLE. MOVE 16 TO DUMMY1. MOVE ITMLST_ADDRESS TO ITMLST_PTR. SCAN_ITM_1. CALL "LIB$MOVC3" USING DUMMY1 BY VALUE ITMLST_PTR BY REFERENCE ITMLST_MASK. ADD 1 TO NBR_ITEMS. ADD BUFLEN TO TAILLE_BUFFER. ADD 12 TO ITMLST_PTR. IF NXT_ITM NOT = 0 THEN GO TO SCAN_ITM_1. * On réserve : * o - La place pour l'attributes block * (item list passée à RETURN_FILE_ATTRIBUTYES) * o - La place pour la zone mémoire dans laquelle seront stockés les * données renvoyées par RETURN_FILE_ATTRIBUTES. * Taille du BUFFER... CALL "LIB$GET_VM" USING TAILLE_BUFFER BY REFERENCE BUFFER_ADDRESS GIVING RETCODE. IF RETCODE IS FAILURE THEN GO TO FIN. * Attributes BLOCK : NBR_ITEMS * 8 + 4 MULTIPLY 8 BY NBR_ITEMS GIVING TAILLE_ATRBLK. ADD 4 TO TAILLE_ATRBLK. CALL "LIB$GET_VM" USING TAILLE_ATRBLK BY REFERENCE ATRBLK_ADDRESS GIVING RETCODE. IF RETCODE IS FAILURE THEN GO TO FIN. * On scanne une deuxième fois l'ITEM LISTE pour construire l'Attributes BLOCK MOVE BUFFER_ADDRESS TO BUFFER_PTR. MOVE ITMLST_ADDRESS TO ITMLST_PTR. MOVE ATRBLK_ADDRESS TO ATRBLK_PTR. MOVE 1 TO DUMMY2. MOVE 4 TO DUMMY1. PERFORM UNTIL DUMMY2 > NBR_ITEMS * On recopie le code et le buflen dans l'attributes block CALL "LIB$MOVC3" USING DUMMY1 BY VALUE ITMLST_PTR ATRBLK_PTR * On recopie ces mêmes informations dans le masque pour obtenir la taille * de l'item... CALL "LIB$MOVC3" USING DUMMY1 BY VALUE ITMLST_PTR BY REFERENCE ITMLST_MASK * On met à jour l'adresse de l'item de l'attributes block ADD 4 TO ATRBLK_PTR CALL "LIB$MOVC3" USING DUMMY1 BUFFER_PTR BY VALUE ATRBLK_PTR * On avance le pointer dans le buffer... ADD BUFLEN TO BUFFER_PTR ADD 12 TO ITMLST_PTR ADD 4 TO ATRBLK_PTR ADD 1 TO DUMMY2 END-PERFORM. * On termine l'Attributes BLOCK par un LONG à 0. MOVE 0 TO DUMMY2. CALL "LIB$MOVC3" USING DUMMY1 DUMMY2 BY VALUE ATRBLK_PTR. BOUCLE. CALL "LIB$FIND_FILE" USING D_FILESPEC D_RFILESPEC FAB_ADDRESS D_DFILESPEC GIVING RETCODE. IF RETCODE IS FAILURE THEN GO TO FIN. CALL "RETURN_FILE_ATTRIBUTES" USING FAB_ADDRESS BY VALUE ATRBLK_ADDRESS BY REFERENCE RETCODE. IF RETCODE IS FAILURE THEN GO TO FIN. INITIALIZE OR_TABLE1. * On scanne l'ITM_LIST pour faire les test. MOVE BUFFER_ADDRESS TO BUFFER_PTR. MOVE ITMLST_ADDRESS TO ITMLST_PTR. MOVE 1 TO DUMMY2. MOVE 12 TO DUMMY1. PERFORM UNTIL DUMMY2 > NBR_ITEMS CALL "LIB$MOVC3" USING DUMMY1 BY VALUE ITMLST_PTR BY REFERENCE ITMLST_MASK ADD DUMMY1 TO ITMLST_PTR ADD 1 TO DUMMY2 * Comparaison de type STRING... IF ITM_FLAGS > 20 THEN * On construit deux descripteurs type STRING sur les données pour les comparer MOVE BUFLEN TO D1_LEN D2_LEN MOVE BUFFER_PTR TO D1_PTR MOVE BUF_ADDRESS TO D2_PTR ADD BUFLEN TO BUFFER_PTR * Comparaison... CALL "STR$COMPARE" USING DESCR1 DESCR2 GIVING RETOUR SUBTRACT 20 FROM ITM_FLAGS ELSE * Comparaison de type numérique... MOVE 0 TO BUF_NUM1 BUF_NUM2 IF BUFLEN <= 8 THEN CALL "LIB$MOVC3" USING BUFLEN BY VALUE BUFFER_PTR BY REFERENCE BUF_NUM1 CALL "LIB$MOVC3" USING BUFLEN BY VALUE BUF_ADDRESS BY REFERENCE BUF_NUM2 MOVE 0 TO RETOUR IF BUF_NUM1 > BUF_NUM2 THEN MOVE 1 TO RETOUR ELSE IF BUF_NUM1 < BUF_NUM2 THEN MOVE -1 TO RETOUR END-IF END-IF SUBTRACT 10 FROM ITM_FLAGS ELSE MOVE LIB$_INVARG TO RETCODE GO TO FIN END-IF END-IF ADD BUFLEN TO BUFFER_PTR MOVE 0 TO COMPARAISON EVALUATE ITM_FLAGS WHEN 0 IF RETOUR = 0 THEN MOVE 1 TO COMPARAISON END-IF WHEN 1 IF RETOUR NOT = 0 THEN MOVE 1 TO COMPARAISON END-IF WHEN 2 IF RETOUR = 1 THEN MOVE 1 TO COMPARAISON END-IF WHEN 3 IF RETOUR >= 0 THEN MOVE 1 TO COMPARAISON END-IF WHEN 4 IF RETOUR = -1 THEN MOVE 1 TO COMPARAISON END-IF WHEN 5 IF RETOUR <= 0 THEN MOVE 1 TO COMPARAISON END-IF WHEN OTHER MOVE LIB$_INVARG TO RETCODE GO TO FIN END-EVALUATE SET OR_CODE_INDEX TO 1 SEARCH OR_TABLE AT END * Le code n'est pas présent dans la table : Il n'y avait pas de précédent ITEM * avec le OR FLAG EVALUATE COMPARAISON ITM_FLAG_OR IS SUCCESS * ---> L'item courant a le OR flag : On le stocke dans la table WHEN ANY, TRUE SET OR_CODE_INDEX TO 1 SEARCH OR_TABLE AT END MOVE LIB$_INVARG TO RETCODE WHEN OR_CODE(OR_CODE_INDEX) = 0 MOVE ITM_CODE TO OR_CODE(OR_CODE_INDEX) MOVE COMPARAISON TO OR_VALUE(OR_CODE_INDEX) END-SEARCH * ---> L'item courant n'a pas le OR flag et la comparaison a échoué : Le fichier * courant n'est pas retenu WHEN 0, ANY GO TO BOUCLE END-EVALUATE WHEN OR_CODE(OR_CODE_INDEX) = ITM_CODE * Il y avait un item avec le or flag... EVALUATE COMPARAISON, OR_VALUE(OR_CODE_INDEX), ITM_FLAG_OR IS SUCCESS * ---> Toutes les comparaisons précédentes ainsi que le courante ont échouées * et l'item courant n'a pas le OR flag : le fichier courant n'est pas * retenu... WHEN 0, 0, FALSE GO TO BOUCLE * ---> une des comparaisons a réussi. On retient a priori le fichier courant. * L'item courant n'ayant pas le OR flag, on supprime le code du tableau WHEN ANY, ANY, FALSE MOVE 0 TO OR_CODE(OR_CODE_INDEX) * ---> L'item courant a le OR flag : On met à jour le tableau... WHEN ANY, ANY, TRUE CALL "MTH$IIOR" USING COMPARAISON OR_VALUE(OR_CODE_INDEX) GIVING OR_VALUE(OR_CODE_INDEX) END-EVALUATE END-SEARCH END-PERFORM. * D'après les tests ci-dessus, les cas qui rejettent le fichier concernent * uniquement les items qui ne contiennent pas le OR flag. On scanne donc le * tableau (Cas où un item portant le or flag ne serait pas suivi par un autre) SET OR_CODE_INDEX TO 1. SEARCH OR_TABLE WHEN OR_CODE(OR_CODE_INDEX) NOT = 0 IF OR_VALUE(OR_CODE_INDEX) = 0 THEN GO TO BOUCLE END-IF END-SEARCH. * Récupération de l'info... * On retrouve l'adresse de l'Item Liste CALL "LIB$ANALYZE_SDESC" USING BY DESCRIPTOR ITMLST_INFO BY REFERENCE DUMMY1 ITMLST_INFO_ADDRESS. * Item list omise... IF ITMLST_INFO_ADDRESS = 0 THEN GO TO FIN. * Recherche des attributs CALL "RETURN_FILE_ATTRIBUTES" USING FAB_ADDRESS BY VALUE ITMLST_INFO_ADDRESS BY REFERENCE RETCODE. FIN. EXIT PROGRAM. END PROGRAM FIND_FILE_WITH_SELECTION. ******************************************************************************