* CPYR     TXT      5/03/10 23:38:56
PROCEDURE CPYR_NODE
RESET MSGCTL 2 SUB 5
Begin
$SetG('FILE', 'QAWORK')
End
CREATE (NOFORMAT) ?&FILE
END
OPENC ?&FILE
*
IN ?&FILE INITIALIZE
IN ?&FILE DEFINE FIELD FOO
IN ?&FILE Begin
*-----------------------------------------------------------------------*
* Accumulate multiple records in one XmlDoc                             *
*-----------------------------------------------------------------------*
%doc Object XmlDoc
%nod Object XmlNode
%r Float
Store Record
   FOO = 'Info from first record'
End Store
%r = $CurRec
FRN %r
   %doc = %doc:NewFromRecord
   %nod = %doc:SelectSingleNode('*')
End For
Print '----- XmlDoc after load from first record: -----'
%doc:Print(, 'BothCompact')
Print ''
Store Record
   FOO = 'Info from second record'
End Store
%r = $CurRec
FRN %r
   %nod:LoadFromRecord
End For
Print '----- XmlDoc after load from second record: -----'
%doc:Print(, 'BothCompact')
Print ''
Store Record
End Store
%r = $CurRec
FRN %r
   %doc:AddToRecord
   Print '-----  Record ' And $CurRec And '------'
   PAI
End For
End
* Result is:
* -----  Record  2 ------
* FOO = Info from first record
* FOO = Info from second record
CLOSE ?&FILE
END PROC
********************************
PROCEDURE CPYR_ALTER1
RESET MSGCTL 2 SUB 5
Begin
$SetG('FILE', 'QAWORK')
End
CREATE (NOFORMAT) ?&FILE
END
*
OPENC ?&FILE
IN ?&FILE INITIALIZE
IN ?&FILE DEFINE FIELD SELECT
IN ?&FILE DEFINE FIELD FLD1
IN ?&FILE DEFINE FIELD FLD2
IN ?&FILE Begin
*-----------------------------------------------------------------------*
* De-select field occurrences to copy                                   *
*-----------------------------------------------------------------------*
%nlis Object XmlNodelist
%del Object XmlNodelist
%doc Object XmlDoc
%i Float
%rn Float
%doc = New
Store Record
   SELECT = 'true'
   FLD1 = 'selValue1'
   FLD2 = 'selValue2'
   SELECT = 'false'
   FLD1 = 'skipValue1'
   FLD2 = 'skipValue2'
End Store
%rn = $CurRec
FRN %rn
   %doc = %doc:NewFromRecord
End For
%nlis = %doc:SelectNodes(-
   '*/field[@name = "SELECT"]')
%del = New(%doc)
For %i From 1 To %nlis:Count
   If %nlis(%i):Value NE 'true' Then
      %del = %del:UnionSelected(%nlis(%i))
      %del = %del:UnionSelected(%doc, '*/field[@name = "FLD1"][' -
         With %i With ']')
      %del = %del:UnionSelected(%doc, '*/field[@name = "FLD2"][' -
         With %i With ']')
   End If
End For
For %i From 1 To %del:Count
   %del(%i):DeleteSubtree
End For
Store Record
End Store
%rn = $CurRec
FRN %rn
   %doc:AddToRecord
   Print '-----  Record ' And $CurRec And '------'
   PAI
End For
End
* Result is:
* -----  Record  1 ------
* SELECT = true
* FLD1 = selValue1
* FLD2 = selValue2
CLOSE ?&FILE
END PROC
********************************
PROCEDURE CPYR_ALTER2
RESET MSGCTL 2 SUB 5
Begin
$SetG('FILE1', 'QAWORK')
$SetG('FILE2', 'QAWORK2')
End
CREATE (NOFORMAT) ?&FILE1
END
*
OPENC ?&FILE1
IN ?&FILE1 INITIALIZE
IN ?&FILE1 DEFINE FIELD CITY
IN ?&FILE1 DEFINE FIELD STATE
CREATE (NOFORMAT) ?&FILE2
END
*
OPENC ?&FILE2
IN ?&FILE2 INITIALIZE
IN ?&FILE2 DEFINE FIELD CITY
IN ?&FILE2 DEFINE FIELD STATE
IN ?&FILE2 DEFINE FIELD CITY.STATE WITH ORDERED INVISIBLE
Begin
*-----------------------------------------------------------------------*
* Create concatenated invisible key                                     *
*-----------------------------------------------------------------------*
%recs Collection Arraylist of Object XmlDoc
%recNode Object XmlNode
%node Object XmlNode
%recs = New
%i Float
%rn Float
%citySt Unicode
IN ?&FILE1 Store Record
   CITY = 'Springfield'
   STATE = 'MA'
End Store
%rn = $CurRec
IN ?&FILE1 FRN %rn
   %recs:Add(%(XmlDoc):NewFromRecord)
End For
IN ?&FILE1 Store Record
   CITY = 'Springfield'
   STATE = 'MO'
End Store
%rn = $CurRec
IN ?&FILE1 FRN %rn
   %recs:Add(%(XmlDoc):NewFromRecord)
End For

For %i From 1 To %recs:Count
   %recNode = %recs(%i):SelectSingleNode('Record')

   %citySt = %recNode:Value('field[@name="CITY"]') With ',' -
      With %recNode:Value('field[@name="STATE"]')

      * Strictly speaking, previous two lines a little better as:
   *  %recNode:Value('field[@name="CITY"]'):UnicodeWith(',':U) -
   *  :UnicodeWith(%recNode:Value('field[@name="STATE"]'))

   %node = %recNode:AddElement('field':U, %citySt)
   %node:AddAttribute('name', 'CITY.STATE')
   IN ?&FILE2 Store Record
   End Store
   %rn = $CurRec
   IN ?&FILE2 FRN %rn
      %recs(%i):AddToRecord
      IN ?&FILE2 FR Where CITY.STATE EQ %citySt
         Print 'Record' And *Record With ':'
         PAI
      End For
   End For
End For
End
* Result is:
* Record 0:
* CITY = Springfield
* STATE = MA
* Record 1:
* CITY = Springfield
* STATE = MO
CLOSE ?&FILE1
CLOSE ?&FILE2
END PROC
********************************
PROCEDURE CPYR_TRANS3
RESET MSGCTL 2 SUB 5
Begin
$SetG('FILE', 'QAWORK')
End
CREATE (NOFORMAT) ?&FILE
END
OPENC ?&FILE
*
IN ?&FILE INITIALIZE
IN ?&FILE DEFINE FIELD FOO
*
* For example only ... UNICODE Table command should only be in CCAIN:
UNICODE Table Standard Base Codepage 0037
UNICODE Table Standard Trans E=AD To U=005B
IN ?&FILE Begin
*-----------------------------------------------------------------------*
* Show a pitfall of building XmlDoc by hand                             *
*-----------------------------------------------------------------------*
%doc Object XmlDoc
%rec Object XmlNode
%fgrp Object XmlNode
%fld Object XmlNode
%rn Float
%doc = New
%rec = %doc:AddElement('Record')
%i Float
%s String Len 1 Initial('AD':X)
%fld = %rec:AddElement('field', %s)
%fld:AddAttribute('name', 'FOO')
Store Record
End Store
%rn = $CurRec
FRN %rn
   %doc:AddToRecord
   Print '-----  Record ' And $CurRec And '------'
   PrintText Expecting {$C2X(%s)}: {$C2X(FOO(1))}
End For
End
* Result is:
* -----  Record  0 ------
* Expecting AD: BA
CLOSE ?&FILE
UNICODE Table Standard Base Codepage 1047
END PROC
********************************
PROCEDURE CPYR_BASE64
RESET MSGCTL 2 SUB 5
Begin
$SetG('FILE', 'QAWORK')
End
CREATE (NOFORMAT) ?&FILE
END
OPENC ?&FILE
*
IN ?&FILE INITIALIZE
IN ?&FILE DEFINE FIELD FOO
IN ?&FILE Begin
%doc Object XmlDoc
%doc = New
%u Unicode
%rn Float
Try %u = '08':X:EbcdicToUnicode
Catch CharacterTranslationException
   Print 'EBCDIC X''08'' is not translatable to Unicode'
End Try
%s Longstring Initial('08':x)
Store Record
   FOO = %s
End Store
%rn = $CurRec
FRN %rn
   %doc:NewFromRecord:Print
End For
End
* Result is:
* EBCDIC X'08' is not translatable to Unicode
* <Record version="1" file="QAWORK" number="0">
*    <field name="FOO" encoding="base64">
*       CA==
*    </field>
* </Record>
CLOSE ?&FILE
END PROC
********************************
PROCEDURE CPYR_CONSTR
R MSGCTL 2
UTABLE LPDLST 12000
Begin
$SetG('FILE', 'QAWORK')
End
CREATE (NOFORMAT) ?&FILE
PARAMETER FILEORG X'100'
END
OPENC ?&FILE
*
IN ?&FILE INITIALIZE
IN ?&FILE DEFINE FIELD DTM WITH DATETIME
IN ?&FILE Begin
Store Record
   DTM = 20090927
Then Continue
   Print 'Original record:'
   PAI
End Store
End
IN ?&FILE REDEFINE FIELD DTM WITH DATETIME-LE 18900101
IN ?&FILE Begin
%doc Object XmlDoc
Print ' - - - Now REDEFINE FIELD DTM WITH DATETIME-LE 18900101 - - -'
Print 'Copying record "into itself" with DisableFieldConstraints=True:'
FR
   %doc = %doc:NewFromRecord
   %doc:AddToRecord(DisableFieldConstraints=True)
   PAI
End For
Print 'DisableFieldConstraints=False (default):'
On Error
   $Close('QAWORK')
End On
FR
   %doc:AddToRecord
   PAI
End For
End
* Result is:
* Original record:
* DTM = 20090927000000000000
*  - - - Now REDEFINE FIELD DTM WITH DATETIME-LE 18900101 - - -
* Copying record "into itself" with DisableFieldConstraints=True:
* DTM = 20090927000000000000
* DTM = 20090927000000000000
* DisableFieldConstraints=False (default):
* ***  1  CANCELLING REQUEST: M204.2874: ATTEMPT TO ADD A VALUE
* THAT'S AFTER THE MAXIMUM DATETIME: DTM = 20090927000000000000
CLOSE ?&FILE
END PROC
********************************
PROCEDURE CPYR_COPY
RESET MSGCTL 2 SUB 5
Begin
$SetG('FILE', 'QAWORK')
End
CREATE (NOFORMAT) ?&FILE
PARAMETER ESIZE=30
END
OPENC ?&FILE
*
IN ?&FILE INITIALIZE
IN ?&FILE DEFINE FIELD FOO
IN ?&FILE DEFINE FIELD LOB WITH BLOB
IN ?&FILE Begin
%doc Object XmlDoc
%rn Float
%doc = New
$Lstr_Set_UserBuffer('Value of LOB field, obviously can be very much longer' -
   :Left(500))
Store Record
   FOO = 'Value of FOO'
   LOB = Buffer, 1, 500
End Store
%rn = $CurRec
FRN %rn
   %doc:LoadFromRecord
   %doc:Print
End For
Store Record
End Store
%rn = $CurRec
FRN %rn
   %doc:AddToRecord
   PAI
End For
End
* Result is:
* <Record version="1" file="QAWORK" number="0">
*    <field name="FOO">
*       Value of FOO
*    </field>
*    <field name="LOB">
*       Value of LOB field, obviously could be much longer
*    </field>
* </Record>
* FOO = Value of FOO
* LOB = ?      ? ?                 ?   g
* Value of LOB field, obviously could be much longer
CLOSE ?&FILE
END PROC
********************************
PROCEDURE CPYR_DEBUG_DATA
RESET MSGCTL 2 SUB 5
Begin
$SetG('FILE', 'QAWORK')
End
CREATE (NOFORMAT) ?&FILE
END
OPENC ?&FILE
*
IN ?&FILE INITIALIZE
IN ?&FILE DEFINE FIELD JUNK
IN ?&FILE DEFINE FIELD JEWEL1
IN ?&FILE DEFINE FIELD JEWEL2
IN ?&FILE Begin
%doc Object XmlDoc
%doc = New
%i Float
%r Float
%s Longstring
Store Record
End Store
%r = $CurRec
FRN %r
   For %i From 1 To 100
      ADD JUNK = 'All work and no play makes Jack a dull boy'
      If %i:Mod(7) EQ 0 Then
         %s = 'Jewel one number ' With %i
         ADD JEWEL1 = %s
      End If
      If %i:Mod(11) EQ 0 Then
         %s = 'Jewel two number ' With %i
         ADD JEWEL2 = %s
      End If
   End For
   If $Upcase(%(System):Arguments:Unspace) NE 'NOPAI' Then
      PAI
   End If
   Print ''
   Print 'Displaying selected fields:'
   Print ''
   %doc:LoadFromRecord
   %nl Object XmlNodelist
   %nl = %doc:SelectNodes('*/*')
   For %i From 1 To %nl:Count
      If %nl(%i):Value('@name') NE 'JUNK' Then
         %nl(%i):Print(, 'BothCompact')
      End If
   End For
End For
End
* Result is:
* JUNK = All work and no play makes Jack a dull boy
* JUNK = All work and no play makes Jack a dull boy
* JUNK = All work and no play makes Jack a dull boy
* JUNK = All work and no play makes Jack a dull boy
* JUNK = All work and no play makes Jack a dull boy
* JUNK = All work and no play makes Jack a dull boy
* JUNK = All work and no play makes Jack a dull boy
* JEWEL1 = Jewel one number 7
* JUNK = All work and no play makes Jack a dull boy
* JUNK = All work and no play makes Jack a dull boy
* JUNK = All work and no play makes Jack a dull boy
* JUNK = All work and no play makes Jack a dull boy
* JEWEL2 = Jewel two number 11
* ...
* JEWEL2 = Jewel two number 99
* JUNK = All work and no play makes Jack a dull boy
* Displaying selected fields:
* <field name="JEWEL1">Jewel one number 7</field>
* <field name="JEWEL2">Jewel two number 11</field>
* <field name="JEWEL1">Jewel one number 14</field>
* <field name="JEWEL1">Jewel one number 21</field>
* <field name="JEWEL2">Jewel two number 22</field>
* <field name="JEWEL1">Jewel one number 28</field>
* <field name="JEWEL2">Jewel two number 33</field>
* <field name="JEWEL1">Jewel one number 35</field>
* <field name="JEWEL1">Jewel one number 42</field>
* <field name="JEWEL2">Jewel two number 44</field>
* <field name="JEWEL1">Jewel one number 49</field>
* <field name="JEWEL2">Jewel two number 55</field>
* <field name="JEWEL1">Jewel one number 56</field>
* <field name="JEWEL1">Jewel one number 63</field>
* <field name="JEWEL2">Jewel two number 66</field>
* <field name="JEWEL1">Jewel one number 70</field>
* <field name="JEWEL1">Jewel one number 77</field>
* <field name="JEWEL2">Jewel two number 77</field>
* <field name="JEWEL1">Jewel one number 84</field>
* <field name="JEWEL2">Jewel two number 88</field>
* <field name="JEWEL1">Jewel one number 91</field>
* <field name="JEWEL1">Jewel one number 98</field>
* <field name="JEWEL2">Jewel two number 99</field>
CLOSE ?&FILE
END PROC
********************************
PROCEDURE CPYR_TRANS
Begin
%i Float
%d Object XmlDoc
%c String Len 1
%ok Float
%u Unicode
* For %i From 0 To 255
For %i From 5 To 5
   %c = $D2C(%i)
   %d = New
   %d:AllowNull = True
   %ok = 1
   Try %u =  %c:EbcdicToUnicode
   Catch CharacterTranslationException
      PrintText X'{$D2X(%i, 2)}' untranslatable to Unicode
      %ok = 0
   End Try
   If %ok Then
      %d:AddElement('c', %c):AddAttribute('hex', $D2X(%i, 2))
      %d:Print(, 'BothCompact')
   *  Print '--' %c '--'
   End If
   Print ''
End For
End
* Result is:
* <c hex="05">&#x9;</c>
END PROC