home *** CD-ROM | disk | FTP | other *** search
/ Over 1,000 Windows 95 Programs / Over 1000 Windows 95 Programs (Microforum) (Disc 1).iso / 1261 / samples / xpxmp06.pl_ / xpxmp06.pl
Encoding:
Text File  |  1996-06-20  |  6.0 KB  |  135 lines
  1.  /* Generated by EasyCODE(SPX) V6.0 at 21.06.1996 09:44:27
  2.     with V:\E\V60\SAMPLES\SPX-PL1\PL1.CFG */
  3.  
  4.  /* XPXMP06 - Translate strings */
  5.  
  6.   PROCESS MACRO;
  7.  
  8.  /*===================================================================*/
  9.  /* Date creatd:  06.04.92 / 17:20:00  by Fischer                     */
  10.  /* Version    :                                                      */
  11.  /*===================================================================*/
  12.  /*                             History                               */
  13.  /* Date                        Name                          Level   */
  14.  /*-------------------------------------------------------------------*/
  15.  /*                                                                   */
  16.  /*===================================================================*/
  17.  /*===================================================================*/
  18.  /*                                                                   */
  19.  /* PROGRAM DESCRIPTION:                                              */
  20.  /*                                                                   */
  21.  /*   Translate strings                                               */
  22.  /*                                                                   */
  23.  /*      If Funct = 0 translate:                                      */
  24.  /*       - lower case to upper case,                                 */
  25.  /*       - special german characters to international characters     */
  26.  /*                                                                   */
  27.  /* RETURN CODES:                                                     */
  28.  /*                                                                   */
  29.  /*   0 ... OK                                                        */
  30.  /*   4 ... Invalid call                                              */
  31.  /*   8 ... Buffer too small                                          */
  32.  /*                                                                   */
  33.  /*===================================================================*/
  34.  XPXMP06:
  35.   PROC(PFUNCT, PSUARG, PRETF) REORDER;
  36.  DEFAULT RANGE (A:Z) STATIC;
  37.  /*===========================================*/
  38.  /*       Definition parameters               */
  39.  /*===========================================*/
  40.  %INCLUDE XPXMI06⌡;
  41.  /* Data definitions */
  42.  /*********************************************************************/
  43.  /*       Furhter definitions                                         */
  44.  /*********************************************************************/
  45.  DCL      (I, J)    BIN FIXED(15);                          /* Indexes*/
  46.  DCL      E_ACT_LEN BIN FIXED(15);   /* Actual length of source buffer*/
  47.  DCL      H_CHTAB(256) CHAR  BASED(ADDR(I_CHTAB));  /* Character table*/
  48.  DCL  1  I_CHTAB,             /* Internal structure - Char. Tab. Init.*/
  49.   3 CH1 CHAR(64) INIT(
  50.  /* 0                1               2               3                */
  51.  /* 0123456789ABCDEF0123456789ABCDEF0123456789ABCDEF0123456789ABCDEF  */
  52.    '                                                                '),
  53.   3 CH2 CHAR(64) INIT(
  54.  /* 4                5               6               7                */
  55.  /* 0123456789ABCDEF0123456789ABCDEF0123456789ABCDEF0123456789ABCDEF  */
  56.    '          U               U               U                     '),
  57.   3 CH3 CHAR(64) INIT(
  58.  /* 8                9               A               B                */
  59.  /* 0123456789ABCDEF0123456789ABCDEF0123456789ABCDEF0123456789ABCDEF  */
  60.    ' KKKKKKKKK       KKKKKKKKK       UKKKKKKKK                      '),
  61.   3 CH4 CHAR(64) INIT(
  62.  /* C                D               E               F                */
  63.  /* 0123456789ABCDEF0123456789ABCDEF0123456789ABCDEF0123456789ABCDEF  */
  64.    'U               U               U                               ');
  65.  DCL      H_LWCASE    CHAR(26)  INIT ('abcdefghijklmnopqrstuvwxyz');
  66.  DCL      H_UPCASE    CHAR(26)  INIT ('ABCDEFGHIJKLMNOPQRSTUVWXYZ');
  67.                   /* Lower and upper case letters for translation     */
  68.  DCL      E_STR     CHAR(10000) BASED(P_IN);             /* Source b. */
  69.  DCL      A_STR     CHAR(10000) BASED(P_OUT);            /* Dest. b.  */
  70.  DCL      (ADDR, UNSPEC, SUBSTR, TRANSLATE) BUILTIN;
  71.  /* Processing */
  72.  IF FUNCT ^= 0
  73.  THEN DO;
  74.     /* Invalid function */
  75.     RETF.RC=4;
  76.     RETURN;
  77.  END;
  78.  E_ACT_LEN = SUARG.EIN_LENGTH;
  79.  DO WHILE (  (SUBSTR(E_STR, E_ACT_LEN, 1) = ' ')
  80.            & (E_ACT_LEN > 0));
  81.     E_ACT_LEN = E_ACT_LEN - 1;
  82.  END;
  83.  J = 0;                               /* J Index of dest. buffer */
  84.  DO I = 1 TO E_ACT_LEN              /* I Index of source buffer */;
  85.     J = J + 1;
  86.     IF J > SUARG.OUT_LENGTH
  87.     THEN DO;
  88.        RETF.RC = 8;
  89.        RETURN;
  90.     END;
  91.     SELECT H_CHTAB(UNSPEC(SUBSTR(E_STR, I, 1)) + 1);
  92.        WHEN (' ' /* No lower cas letters or special characters */) DO;
  93.           SUBSTR(A_STR, J, 1) = SUBSTR(E_STR, I, 1);
  94.        END;
  95.        WHEN ('K' /* Lower case letters */) DO;
  96.           SUBSTR(A_STR, J, 1) =
  97.            TRANSLATE(SUBSTR(E_STR, I, 1), H_UPCASE, H_LWCASE);
  98.        END;
  99.        WHEN ('U' /* Special characters */) DO;
  100.           J = J + 1;
  101.           IF J > SUARG.OUT_LENGTH 
  102.           THEN DO;
  103.              RETF.RC = 8;
  104.              RETURN;
  105.           END;
  106.           SUBSTR(A_STR, J, 1) = 'E';
  107.           SELECT SUBSTR(E_STR, I, 1);
  108.              WHEN ('ö', 'Ö') DO;
  109.                  SUBSTR(A_STR, J - 1, 1) = 'O';
  110.              END;
  111.              WHEN ('ü', 'Ü') DO;
  112.                 SUBSTR(A_STR, J - 1, 1) = 'U';
  113.              END;
  114.              WHEN ('ä', 'Ä') DO;
  115.                 SUBSTR(A_STR, J - 1, 1) = 'A';
  116.              END;
  117.              WHEN ('ß') DO;
  118.                 SUBSTR(A_STR, J - 1, 1) = 'S';
  119.                 SUBSTR(A_STR, J, 1)     = 'S';
  120.              END;
  121.              OTHERWISE DO;
  122.              END;
  123.           END;
  124.        END;
  125.        OTHERWISE DO;
  126.        END;
  127.     END;
  128.  END;
  129.  DO J = J + 1 TO OUT_LENGTH /* Fill rest of dest. buffer with ' ' */;
  130.     SUBSTR(A_STR,  J, 1) = ' ';
  131.  END;
  132.   RETF.RC = 0;
  133.  END; /* End Procedure */
  134.  
  135.