identification division.
program-id. sibase64.
*
* CALL "sibase64" USING fichero fichero-dest
*
* llamado desde windows por sivisors, en linux existe comando
* ( jcantero )
environment division.
configuration section.
source-computer. rmcobol-85.
object-computer. rmcobol-85.
special-names.
decimal-point is comma.
*
input-output section.
file-control.
*
select atr01 assign to random, nombre-atr01
organization sequential
access mode is sequential
file status is fs-atr01.
select atr01j assign to random, nombre-atr01j
organization sequential
access mode is sequential
file status is fs-atr01j.
data division.
file section.
*
fd atr01.
01 reg-atr01.
02 atr-cabecera pic x(3).
fd atr01j.
01 reg-atr01j.
02 atr-cabeceraj pic x(4).
working-storage section.
01 nombre-atr01 pic x(80).
01 nombre-atr01j pic x(80).
01 nombre-atr01jx pic x(80).
01 mensaje pic x(200).
01 fs-atr01 pic xx.
88 esta-atr01 value '00' '02'.
88 n-esta-atr01 value '23'.
88 fin-atr01 value '46' '10'.
88 bloqueado-atr01 value '99'.
88 f-bloqueado-atr01 value '38' '93'.
88 f-noexiste-atr01 value '35'.
01 fs-atr01j pic xx.
88 esta-atr01j value '00' '02'.
88 n-esta-atr01j value '23'.
88 fin-atr01j value '46' '10'.
88 bloqueado-atr01j value '99'.
88 f-bloqueado-atr01j value '38' '93'.
88 f-noexiste-atr01j value '35'.
01 binary(2).
02 i pic 9(4).
02 j pic 9(4).
02 k pic 9(4).
01 message-length pic 9(6) binary.
01 base64-message-length pic 9(6) binary.
01 triplet-count pic 9(6) binary.
01 trailing-count pic 9(6) binary.
01 Base64-Alphabet pic x(64) value
"ABCDEFGHIJKLMNOPQRSTUVWXYZ" &
"abcdefghijklmnopqrstuvwxyz" &
"0123456789" &
"+/".
01 b64-triplet.
05 b64-4octets.
07 pic x.
07 b64-3octets.
09 pic x.
09 b64-2octets.
11 pic x.
11 b64-1octet pic x.
01 redefines b64-triplet.
05 b64-octet pic 999 binary(1) occurs 4.
01 ARGUMENT-DESCRIPTION BINARY(2).
02 ARGUMENT-TYPE PIC 9(2).
02 ARGUMENT-LENGTH PIC 9(8) BINARY(4).
02 ARGUMENT-DIGIT-COUNT PIC 9(2).
02 ARGUMENT-SCALE PIC S9(2).
01 C-CARG-SUCCESS PIC X.
88 IS-C-CARG-SUCCESS VALUE "Y".
01 carg usage binary.
04 tipo pic 9(2).
04 longitudx pic 9(8) .
04 digitos pic 9(2).
04 escala pic s9(2).
01 narg pic 9(3) binary.
01 es-tipo pic x VALUE 'N'.
88 es-tipo-ascii value 'y' 'Y'.
88 es-tipo-num value 'n' 'N'.
linkage section.
01 lk-par1 pic x.
01 lk-par1xx redefines lk-par1.
03 lk-par1x pic x occurs 100.
01 lk-par2 pic x.
01 lk-par2xx redefines lk-par2.
03 lk-par2x pic x occurs 100.
01 lk-par3 pic x.
01 lk-par3xx redefines lk-par3.
03 lk-par3x pic x occurs 100.
01 lk-par4 pic x.
01 lk-par4xx redefines lk-par4.
03 lk-par4x pic x occurs 100.
------*
PROCEDURE DIVISION using
lk-par1 lk-par2 lk-par3 lk-par4.
------*
declaratives.
errores section.
use after standard error procedure on atr01 atr01j.
end declaratives.
programa section.
programa-prin.
initialize nombre-atr01 nombre-atr01j nombre-atr01jx
call 'c$narg' using narg
end-call.
if narg < 2 then go fin-p.
d accept narg update
call "c$carg" using es-tipo lk-par1 carg
end-call
d accept longitudx update
if longitudx > 80 move 80 to longitudx end-if
perform varying i from longitudx by -1 until i = 0
move lk-par1x(i) to nombre-atr01(i:1)
end-perform
call "c$carg" using es-tipo lk-par2 carg
end-call
perform varying i from longitudx by -1 until i = 0
move lk-par2x(i) to nombre-atr01jx(i:1)
end-perform.
b.
string nombre-atr01jx delimited by ' '
'x' delimited by size into nombre-atr01j
d display nombre-atr01 line 1.
d display nombre-atr01j line 2
d accept nombre-atr01jx line 3 update.
open input atr01
if not esta-atr01 then
go fin-p
end-if.
initialize i
open output atr01j.
c.
if not esta-atr01j then
display 'error ' line 1 position 1
accept fs-atr01j update
open output atr01j
close atr01j
open extend atr01j
end-if
if not esta-atr01j then
go fin-p
end-if.
initialize reg-atr01j reg-atr01j
read atr01 next record end-read
perform until fin-atr01
move all x"00" to b64-4octets
move reg-atr01 to b64-3octets
call "C$LogicalShiftLeft" using b64-4octets, 6
call "C$LogicalShiftRight" using b64-3octets, 2
call "C$LogicalShiftRight" using b64-2octets, 2
call "C$LogicalShiftRight" using b64-1octet, 2
perform varying j from 1 by 1
until j > count of b64-octet
add b64-octet (j), 1 giving k
move Base64-Alphabet (k:1)
to b64-octet (j) (1:1)
end-perform
move b64-4octets to reg-atr01j
write reg-atr01j end-write
initialize reg-atr01 reg-atr01j
read atr01 next record end-read
end-perform.
fin-p.
close atr01 atr01j.
initialize mensaje
string 'cmd /c type ' delimited by size
nombre-atr01j delimited by ' '
' >> ' delimited by size
nombre-atr01jx delimited by ' '
into mensaje.
call 'ejecuta' using mensaje.
delete file atr01j.
exit program.