Acessar Database via:
Comandos nativos Cobol. Comandos SQL.
Links
Microfocus Cobol. Fujitsu Cobol MariaDB Oracle Mysql.
Serviços
Franco Stringari Pudler Serviços de consultoria, e desenvolvimento de software. Conversão e modernização de sistemas, migração para banco de dados.
Aplicativos
IMEDIATA Inform.Empres.Ltda E.R.P., NFe, NF3e. Folha de pagamento. Sped, Ecf, Ecd, eSocial. Ativo imobilizado. Cooperativas, distribuiçõo energia. Aneel Resolução Normativa 815. Georeferenciamento redes elétricas.

Cobol & Mysql - Arquivos cobol migrando para Sql.

Download.

EXTMYSQL. Rotina gerada para COBOL 32 Micro Focus.
Conteúdo:

MYSQLDEM.EXE - Programa demo acessando tanto arquivos MF como Mysql.
COBOL.DIR - Parametros, diretivas de compilação.
EXTASC.EXE - Rotina que registra release em uso. (Uso facultativo)
EXTMYSQL.DLL - Rotina que substitui EXTFH do cobol gerenciando acessos a arquivos.
LIBMYSQL.DLL - Conector MYSQL para programas "C/C++".
MFRTS32.DLL - Runtime COBOL Micro Focus 32.
MFSCREEN.DLL - Runtime COBOL Micro Focus 32.
MYSQLDEM.CBL - Programa fonte do demo para estudo e evolução
TSMYSQL1.CBL - Programa fonte demo.
TSMYSQL4.CBL - Programa fonte demo.
TSMYSQL9.CBL - Programa fonte demo.
TSMYSQLk.CBL - Programa fonte demo.

Para executar:

Descompacte o arquivo CobolMysql.rar que voce baixou, em uma pasta de seu computador.
Instale servidor MYSQL. Certifique-se de que esta configurado corretamente, para isso voce pode usar o HeidiSQL.
O programa MYSQLDEM.EXE esta configurado para acessar um servidor instalado na maquina local IP 127.0.0.1, porta 3306, usuario "root" sem pasword. A tabela deve estar instalada no DB "imediata", com o nome "arqtst".
@127.0.0.1@3306@root@@imediata@arqtst
Veja em A DLL como definir o label de um arquivo numa tabela MYSQL.
Ex.: "@IP@PORTA@USER@PASW@DB@TABEL"
Na pasta local ira criar o arquivo "arqtst" e "arqtst.idx" quando for acessado o arquivo MF ISAM.
Use o script SQL que voce vai encontrar dentro do fonte MYSQLDEM.CBL, para criar a tabela usada pelo programa, correspondendo a FD do mesmo.
Execute MYSQLDEM.EXE, siga o que for solicitado e acompanhe no banco de dados o que esta sendo feito pelo programa.

Execute mysqldem.exe

EXTMYSQL. Para NetExpress. Arquivos necessários para gerar o EXTMYSQL no NetExpress.
Conteúdo:

EXTMYSQL.BAT - Rotina para gerar o EXTMYSQL.DLL e EXTASC.EXE.
EXTMYSQL.OBJ - OBJ do programa EXTMYSQL.
DIFTMP.OBJ - OBJ complemento EXTMYSQL.
GERALOG.OBJ - OBJ complemento EXTMYSQL.
EXTVAL.OBJ - OBJ complemento EXTMYSQL.
EXTASC.OBJ - OBJ para gerar o EXTASC.EXE.

Gerar EXTMYSQL.DLL e EXTASC.EXE para NetExpress.

Descompacte NetExtMysql.rar numa pasta de seu computador.
Abra uma janela "DOS" do NetExpress, de forma que vc consiga compilar seus programas via comando tipo "COBOL SEUPROG;".
Execute "EXTMYSQL.BAT"
Ou crie um projeto, de forma a gerar EXTMYSQL.DLL e EXTASC.EXE conforme descrito no EXTMYSQL.BAT.

Leitura de um registro com bloqueio.

TSMYSQL1.CBL

$set callfh"extmysql"
      ***********************************************************
      *  IMEDIATA INFORMATICA EMPRESARIAL LTDA                  *
      *  PROGRAMA - Testa chave composta                        *
      ***********************************************************
       IDENTIFICATION DIVISION.
       PROGRAM-ID.    TSMYSQL1.
       ENVIRONMENT    DIVISION.
       CONFIGURATION  SECTION.
       SPECIAL-NAMES.
       INPUT-OUTPUT   SECTION.
       FILE-CONTROL.

SELECT TSTLOCK ASSIGN TO DYNAMIC W-ARQUIVOS
                  ORGANIZATION IS INDEXED
                  ACCESS MODE  IS DYNAMIC
                  RECORD KEY   IS LK-CHA = LK-CMP1 LK-CMP2 LK-CMP3
                  FILE STATUS  IS ESTADO.

DATA DIVISION.
       FILE SECTION.

FD TSTLOCK.

01  LK-REG.
           03 LK-CMP1          PIC S9(07)      COMP-3.
           03 LK-CMP2          PIC S9(11)      COMP-3.
           03 LK-CMP3          PIC  X(02).
           03 LK-DES           PIC  X(50).

*>CREATE TABLE `tstlock` (
      *>	`Cmp1` DECIMAL(7,0) NOT NULL,
      *>	`cmp2` DECIMAL(11,0) NOT NULL,
      *>	`Cmp3` CHAR(2) NOT NULL,
      *>	`Des` CHAR(50) NOT NULL,
      *>	PRIMARY KEY (`Cmp1`, `cmp2`, `Cmp3`)
      *>)
      *>COMMENT='Teste tratamento bloqueio de registros'
      *>COLLATE='latin1_swedish_ci'
      *>ENGINE=InnoDB;

WORKING-STORAGE SECTION.
       77  W-CMD       PIC X(64000) VALUE SPACES.
       77  W-CONT1     PIC 9(05) COMP-5.
       77  W-CT1        PIC 9(07) COMP-5.
       77  W-CT2        PIC 9(07) COMP-5.
       77  W-CT3        PIC 9(07) COMP-5.
       77  W-CY4        PIC 9(05) COMP.
       77  W-LIN        PIC X(79).
       77  W-QRTM       PIC 9(09) COMP-5.
       77  W-DVS        PIC X(20)   VALUE SPACES.
       77  W-BUF        PIC X(64000).

77  W-TMDIV      PIC S9(9)  COMP-5.   *> Ocorrencia onde esta definido o campo.

01  W-HDLOCK          USAGE POINTER. *> Pointer registro bloqueado

77  W-ARQUIVOS  PIC X(128) VALUE
           Z"@127.0.0.1@3306@root@@test@tstlock".
      *>@www.imediata.com.br@3306@usuario@12345678@baseteste@tstlock
       01  ESTADO      PIC X(02).
       88  STAT-ERRO            VALUE X"3100" THRU X"3943"
                                      X"3945" THRU X"39EE".
       88  DUPLICADO            VALUE "22".
       88  CRIAR-ARQUIVO        VALUE X"3335" X"3913".
       88  JA-ABERTO            VALUE "41" X"398D".
       88  REINDEXAR            VALUE X"3929" X"3912".
       88  ESTA-ABERTO          VALUE "12".
       88  FOI-CRIADO           VALUE "05".
       88  NAO-ENCONTRADO       VALUE "23".
       88  FINAL-ARQUIVO        VALUE "10".
       88  CHAVE-DUPLICADA      VALUE "02".

01  RESTADO REDEFINES ESTADO.
           02 ST-K01 PIC X(01).
           02 ST-K02 PIC X(01).
           02 RST-K02 REDEFINES ST-K02.
            03 ST-ERR PIC 9(02) COMP-X.

01  DATA-DIA.
           02 TM-DATE        PIC 9(08).
           02 FILLER REDEFINES TM-DATE.
            03 AA-DIA        pic 9999.
            03 MM-DIA        pic 99.
            03 DD-DIA        pic 99.
           02 TM-HORARIO.
            03 TM-TIME       PIC 9(06).
            03 FILLER REDEFINES TM-TIME.
             05 TM-HOR       PIC 9(04).
             05 FILLER       PIC X(02).
            03 FILLER REDEFINES TM-TIME.
             05 time-hr      pic 99.
             05 time-min     pic 99.
             05 time-sec     pic 99.
            03 time-hun      pic 99.
            03 gmt-flag      pic x.
            03 gmt-diff-hr   pic 99.
            03 gmt-diff-min  pic 99.
           02 FILLER REDEFINES TM-HORARIO.
            03 TM-LBL        PIC X(08).
            03 FILLER        PIC X(05).

01  W-EDTA.
           02 W-ANOE         PIC 9(04).
           02 FILLER         PIC X(01).
           02 W-MESE         PIC 9(02).
           02 FILLER         PIC X(01).
           02 W-DIAE         PIC 9(02).
           02 FILLER         PIC X(01).
           02 W-HORE         PIC 9(02).
           02 FILLER         PIC X(01).
           02 W-MINE         PIC 9(02).
           02 FILLER         PIC X(01).
           02 W-SEGE         PIC 9(02).
           02 FILLER         PIC X(01).
           02 W-THRE         PIC X(11).

PROCEDURE DIVISION.
       PRINCIPAL.
           DISPLAY ERASE.

OPEN I-O TSTLOCK.
           IF ESTADO > "09"
              DISPLAY "Abrindo TABTST " ESTADO
              GO TO STATUS-ERRO.

MOVE  1            TO LK-CMP1 LK-CMP2.
           MOVE  "A"          TO LK-CMP3.

READ TSTLOCK WITH LOCK.

CALL "SalvaCmd".

IF STAT-ERRO
              DISPLAY "Registro não encontrado"
           ELSE
              MOVE  "123"        TO LK-DES
              REWRITE LK-REG.

CLOSE TSTLOCK.

STOP RUN.
           
       RET-NOW.
              MOVE  1         TO W-QRTM.         *> Confere idade do bloqueio
              STRING "SELECT NOW()"
                     X"00"    DELIMITED BY SIZE INTO W-CMD
                         WITH POINTER W-QRTM
              CALL "MysqlQuery" USING W-CMD
                                      W-HDLOCK
                                      W-QRTM.
              IF W-HDLOCK = NULL                     *> A thread não existe mais
                 MOVE  FUNCTION CURRENT-DATE TO DATA-DIA
              ELSE
                 MOVE  LOW-VALUES    TO W-CMD
                 MOVE  1             TO W-TMDIV
                 MOVE  " "           TO W-DVS
                 MOVE  Z" "          TO W-BUF
                 CALL "RetResult" USING W-HDLOCK   *> Handle do query ao qual se busca o resultado
                                        W-QRTM     *> Tamanho do buffer sendo retornado
                                        ESTADO     *> Status de retorno
                                        W-DVS      *> Divisor do campo, terminado em X"00"
                                        W-TMDIV    *> Tamanho do divisor
                                        W-CMD      *> Buffer contendo o resultado sendo retornado. Ter cuidado no programa
                                                   *> chamador para reservar espaço suficiente, para caber o retorno
                 CALL "FreeResultado" USING W-HDLOCK
                 MOVE  W-CMD         TO W-EDTA
                 MOVE  W-ANOE        TO AA-DIA
                 MOVE  W-MESE        TO MM-DIA
                 MOVE  W-DIAE        TO DD-DIA
                 MOVE  W-HORE        TO TIME-HR
                 MOVE  W-MINE        TO TIME-MIN
                 MOVE  W-SEGE        TO TIME-SEC
              END-IF
           EXIT PROGRAM.

STATUS-ERRO.
           CALL "GetLstMsgErr" USING W-CMD.   *> Demonstra como monitorar o erro

MOVE  ZEROS        TO W-CONT1.
           INSPECT W-CMD TALLYING W-CONT1 FOR CHARACTERS BEFORE X"00".
           IF W-CONT1 > ZEROS
              IF W-CMD (1:W-CONT1) NOT = SPACES
                 PERFORM VARYING W-CT1 FROM 1 BY 80
                           UNTIL W-CT1 > W-CONT1
                    MOVE  W-CMD (W-CT1:W-CONT1) TO W-LIN
                    IF W-LIN NOT = SPACES
                       DISPLAY W-LIN
                    ELSE
                       MOVE  W-CONT1 TO W-CT1
                       ADD   1       TO W-CT1
                    END-IF
                 END-PERFORM
              END-IF
           END-IF.

IF ST-K01 = "9"
              EVALUATE ST-ERR
                WHEN 27
                   DISPLAY "Access denied for DB/user"
                WHEN 48
                   DISPLAY "Heap access failure - out of buffer"
                WHEN 49
                   DISPLAY "Heap deallocated while program inactive"
                WHEN 50
                   DISPLAY "Backing-file failure: too many files"
                WHEN 51
                   DISPLAY "Backing-file failure: file access denied"
                WHEN 52
                   DISPLAY "Backing-file failure: I/O failure"
                WHEN 04
                   DISPLAY "Nao encontrou no DB tabela procurada - Illeg
      -                    "al file name."
                WHEN 200
                   DISPLAY "Erro com a execucao de comando da LIBMYSQL c
      -                    "onfira sgamysql.log"
                WHEN 201
                   DISPLAY "Conexao com servidor perdida."
              END-EVALUATE
           ELSE
              EVALUATE ESTADO
                WHEN "51"
                   DISPLAY "Erro na conexao com o banco de dados atravez
      -                    " da LIBMYSQL"
                WHEN "53"
                   DISPLAY "Nao foi possivel interpretar campos na tabel
      -                    "a e montar correspondencia."
                WHEN "91"
                   DISPLAY "Erro na montagem da estrutura da FD,falha mo
      -                    "ntando campos."
              END-EVALUATE
           END-IF.
           
           STOP RUN.

TSMYSQL.CBL

Demonstra relacão entre campos da FD e do Mysql.

$set defaultbyte"00" linkcount"1350" oldindex copy "WINDOWS.cpy". $set sourceformat"FIXED" $set callfh"extmysql" ASSIGN"EXTERNAL" *********************************************************** * IMEDIATA INFORMATICA EMPRESARIAL LTDA * * PROGRAMA - * *********************************************************** IDENTIFICATION DIVISION. PROGRAM-ID. TSMYSQL. ENVIRONMENT DIVISION. CONFIGURATION SECTION. SPECIAL-NAMES. call-convention 66 is WINAPI. INPUT-OUTPUT SECTION. FILE-CONTROL. $set fcdreg SELECT MYSQLTST ASSIGN TO DYNAMIC W-ARQUIVOS ORGANIZATION IS INDEXED ACCESS MODE IS DYNAMIC RECORD KEY IS MY-CHA ALTERNATE RECORD KEY IS MY-LNCDT = MY-CHA MY-DATA WITH DUPLICATES LOCK MODE IS MANUAL FILE STATUS IS ESTADO. DATA DIVISION. FILE SECTION. FD MYSQLTST. 01 MY-REG. 03 MY-SIT PIC X(01). 03 MY-CHA PIC S9(05) COMP-3. 03 MY-LIMPA. 05 MY-DATA PIC 9(09) COMP-3. 05 MY-CMPX01N PIC 9(01) COMP-X. 05 MY-CMPX02N PIC 9(02) COMP-X. 05 MY-CMPX03N PIC 9(03) COMP-X. 05 MY-CMPX04N PIC 9(04) COMP-X. 05 MY-CMPX05N PIC 9(05) COMP-X. 05 MY-CMPX06N PIC 9(06) COMP-X. 05 MY-CMPX07N PIC 9(07) COMP-X. 05 MY-CMPX08N PIC 9(08) COMP-X. 05 MY-CMPX09N PIC 9(09) COMP-X. 05 MY-CMPX10N PIC 9(10) COMP-X. 05 MY-CMPX11N PIC 9(11) COMP-X. 05 MY-CMPX12N PIC 9(12) COMP-X. 05 MY-CMPX13N PIC 9(13) COMP-X. 05 MY-CMPX14N PIC 9(14) COMP-X. 05 MY-CMPX15N PIC 9(15) COMP-X. 05 MY-CMPX16N PIC 9(16) COMP-X. 05 MY-CMPX17N PIC 9(17) COMP-X. 05 MY-CMPX18N PIC 9(18) COMP-X. 05 MY-CMP301N PIC 9(01) COMP-3. 05 MY-CMP302N PIC 9(02) COMP-3. 05 MY-CMP303N PIC 9(03) COMP-3. 05 MY-CMP304N PIC 9(04) COMP-3. 05 MY-CMP305N PIC 9(05) COMP-3. 05 MY-CMP306N PIC 9(06) COMP-3. 05 MY-CMP307N PIC 9(07) COMP-3. 05 MY-CMP308N PIC 9(08) COMP-3. 05 MY-CMP309N PIC 9(09) COMP-3. 05 MY-CMP310N PIC 9(10) COMP-3. 05 MY-CMP311N PIC 9(11) COMP-3. 05 MY-CMP312N PIC 9(12) COMP-3. 05 MY-CMP313N PIC 9(13) COMP-3. 05 MY-CMP314N PIC 9(14) COMP-3. 05 MY-CMP315N PIC 9(15) COMP-3. 05 MY-CMP316N PIC 9(16) COMP-3. 05 MY-CMP317N PIC 9(17) COMP-3. 05 MY-CMP318N PIC 9(18) COMP-3. 05 MY-CMP301S PIC S9(01) COMP-3. 05 MY-CMP302S PIC S9(02) COMP-3. 05 MY-CMP303S PIC S9(03) COMP-3. 05 MY-CMP304S PIC S9(04) COMP-3. 05 MY-CMP305S PIC S9(05) COMP-3. 05 MY-CMP306S PIC S9(06) COMP-3. 05 MY-CMP307S PIC S9(07) COMP-3. 05 MY-CMP308S PIC S9(08) COMP-3. 05 MY-CMP309S PIC S9(09) COMP-3. 05 MY-CMP310S PIC S9(10) COMP-3. 05 MY-CMP311S PIC S9(11) COMP-3. 05 MY-CMP312S PIC S9(12) COMP-3. 05 MY-CMP313S PIC S9(13) COMP-3. 05 MY-CMP314S PIC S9(14) COMP-3. 05 MY-CMP315S PIC S9(15) COMP-3. 05 MY-CMP316S PIC S9(16) COMP-3. 05 MY-CMP317S PIC S9(17) COMP-3. 05 MY-CMP318S PIC S9(18) COMP-3. 05 MY-CMP501N PIC 9(01) COMP-5. 05 MY-CMP502N PIC 9(02) COMP-5. 05 MY-CMP503N PIC 9(03) COMP-5. 05 MY-CMP504N PIC 9(04) COMP-5. 05 MY-CMP505N PIC 9(05) COMP-5. 05 MY-CMP506N PIC 9(06) COMP-5. 05 MY-CMP507N PIC 9(07) COMP-5. 05 MY-CMP508N PIC 9(08) COMP-5. 05 MY-CMP509N PIC 9(09) COMP-5. 05 MY-CMP510N PIC 9(10) COMP-5. 05 MY-CMP511N PIC 9(11) COMP-5. 05 MY-CMP512N PIC 9(12) COMP-5. 05 MY-CMP513N PIC 9(13) COMP-5. 05 MY-CMP514N PIC 9(14) COMP-5. 05 MY-CMP515N PIC 9(15) COMP-5. 05 MY-CMP516N PIC 9(16) COMP-5. 05 MY-CMP517N PIC 9(17) COMP-5. 05 MY-CMP518N PIC 9(18) COMP-5. 05 MY-CMP501S PIC S9(01) COMP-5. 05 MY-CMP502S PIC S9(02) COMP-5. 05 MY-CMP503S PIC S9(03) COMP-5. 05 MY-CMP504S PIC S9(04) COMP-5. 05 MY-CMP505S PIC S9(05) COMP-5. 05 MY-CMP506S PIC S9(06) COMP-5. 05 MY-CMP507S PIC S9(07) COMP-5. 05 MY-CMP508S PIC S9(08) COMP-5. 05 MY-CMP509S PIC S9(09) COMP-5. 05 MY-CMP510S PIC S9(10) COMP-5. 05 MY-CMP511S PIC S9(11) COMP-5. 05 MY-CMP512S PIC S9(12) COMP-5. 05 MY-CMP513S PIC S9(13) COMP-5. 05 MY-CMP514S PIC S9(14) COMP-5. 05 MY-CMP515S PIC S9(15) COMP-5. 05 MY-CMP516S PIC S9(16) COMP-5. 05 MY-CMP517S PIC S9(17) COMP-5. 05 MY-CMP518S PIC S9(18) COMP-5. 05 MY-DISP01S PIC S9(01). 05 MY-DISP02S PIC S9(02). 05 MY-DISP03S PIC S9(03). 05 MY-DISP04S PIC S9(04). 05 MY-DISP05S PIC S9(05). 05 MY-DISP06S PIC S9(06). 05 MY-DISP07S PIC S9(07). 05 MY-DISP08S PIC S9(08). 05 MY-DISP09S PIC S9(09). 05 MY-DISP10S PIC S9(10). 05 MY-DISP11S PIC S9(11). 05 MY-DISP12S PIC S9(12). 05 MY-DISP13S PIC S9(13). 05 MY-DISP14S PIC S9(14). 05 MY-DISP15S PIC S9(15). 05 MY-DISP16S PIC S9(16). 05 MY-DISP17S PIC S9(17). 05 MY-DISP18S PIC S9(18). 05 MY-DISD01S PIC S9(01)V9(17). 05 MY-DISD02S PIC S9(02)V9(16). 05 MY-DISD03S PIC S9(03)V9(15). 05 MY-DISD04S PIC S9(04)V9(14). 05 MY-DISD05S PIC S9(05)V9(13). 05 MY-DISD06S PIC S9(06)V9(12). 05 MY-DISD07S PIC S9(07)V9(11). 05 MY-DISD08S PIC S9(08)V9(10). 05 MY-DISD09S PIC S9(09)V9(09). 05 MY-DISD10S PIC S9(10)V9(08). 05 MY-DISD11S PIC S9(11)V9(07). 05 MY-DISD12S PIC S9(12)V9(06). 05 MY-DISD13S PIC S9(13)V9(05). 05 MY-DISD14S PIC S9(14)V9(04). 05 MY-DISD15S PIC S9(15)V9(03). 05 MY-DISD16S PIC S9(16)V9(02). 05 MY-DISD17S PIC S9(17)V9(01). 05 MY-DISD18S PIC S9(18). 05 MY-DISD01 PIC 9(01)V9(17). 05 MY-DISD02 PIC 9(02)V9(16). 05 MY-DISD03 PIC 9(03)V9(15). 05 MY-DISD04 PIC 9(04)V9(14). 05 MY-DISD05 PIC 9(05)V9(13). 05 MY-DISD06 PIC 9(06)V9(12). 05 MY-DISD07 PIC 9(07)V9(11). 05 MY-DISD08 PIC 9(08)V9(10). 05 MY-DISD09 PIC 9(09)V9(09). 05 MY-DISD10 PIC 9(10)V9(08). 05 MY-DISD11 PIC 9(11)V9(07). 05 MY-DISD12 PIC 9(12)V9(06). 05 MY-DISD13 PIC 9(13)V9(05). 05 MY-DISD14 PIC 9(14)V9(04). 05 MY-DISD15 PIC 9(15)V9(03). 05 MY-DISD16 PIC 9(16)V9(02). 05 MY-DISD17 PIC 9(17)V9(01). 05 MY-DISD18 PIC 9(18). *>-- -------------------------------------------------------- *>-- Servidor: 127.0.0.1 *>-- VersÃ£o do servidor: 5.5.24-log - MySQL Community Server (GPL) *>-- OS do Servidor: Win64 *>-- HeidiSQL VersÃ£o: 8.1.0.4545 *>-- -------------------------------------------------------- *> *>/*!40101 SET @OLD_CHARACTER_SET_CLIENT=@@CHARACTER_SET_CLIENT */; *>/*!40101 SET NAMES utf8 */; *>/*!40014 SET @OLD_FOREIGN_KEY_CHECKS=@@FOREIGN_KEY_CHECKS, FOREIGN_KEY_CHECKS=0 */; *>/*!40101 SET @OLD_SQL_MODE=@@SQL_MODE, SQL_MODE='NO_AUTO_VALUE_ON_ZERO' */; *> *>-- Copiando estrutura do banco de dados para test *>CREATE DATABASE IF NOT EXISTS `test` /*!40100 DEFAULT CHARACTER SET latin1 */; *>USE `test`; *> *> *>-- Copiando estrutura para tabela test.mysqltst *>CREATE TABLE IF NOT EXISTS `mysqltst` ( *> `MY_SIT` varchar(1) NOT NULL DEFAULT ' ', *> `MY_CHA` decimal(5,0) NOT NULL DEFAULT '0', *> `MY_DATA` decimal(9,0) unsigned NOT NULL DEFAULT '0', *> `MY_CMPX01N` int(1) unsigned NOT NULL DEFAULT '0', *> `MY_CMPX02N` int(2) unsigned NOT NULL DEFAULT '0', *> `MY_CMPX03N` int(3) unsigned NOT NULL DEFAULT '0', *> `MY_CMPX04N` int(4) unsigned NOT NULL DEFAULT '0', *> `MY_CMPX05N` bigint(5) unsigned NOT NULL DEFAULT '0', *> `MY_CMPX06N` bigint(6) unsigned NOT NULL DEFAULT '0', *> `MY_CMPX07N` bigint(7) unsigned NOT NULL DEFAULT '0', *> `MY_CMPX08N` bigint(8) unsigned NOT NULL DEFAULT '0', *> `MY_CMPX09N` bigint(9) unsigned NOT NULL DEFAULT '0', *> `MY_CMPX10N` bigint(10) unsigned NOT NULL DEFAULT '0', *> `MY_CMPX11N` bigint(11) unsigned NOT NULL DEFAULT '0', *> `MY_CMPX12N` bigint(12) unsigned NOT NULL DEFAULT '0', *> `MY_CMPX13N` bigint(13) unsigned NOT NULL DEFAULT '0', *> `MY_CMPX14N` bigint(14) unsigned NOT NULL DEFAULT '0', *> `MY_CMPX15N` bigint(15) unsigned NOT NULL DEFAULT '0', *> `MY_CMPX16N` bigint(16) unsigned NOT NULL DEFAULT '0', *> `MY_CMPX17N` bigint(17) unsigned NOT NULL DEFAULT '0', *> `MY_CMPX18N` bigint(18) unsigned NOT NULL DEFAULT '0', *> `MY_CMP301N` decimal(1,0) unsigned NOT NULL DEFAULT '0', *> `MY_CMP302N` decimal(2,0) unsigned NOT NULL DEFAULT '0', *> `MY_CMP303N` decimal(3,0) unsigned NOT NULL DEFAULT '0', *> `MY_CMP304N` decimal(4,0) unsigned NOT NULL DEFAULT '0', *> `MY_CMP305N` decimal(5,0) unsigned NOT NULL DEFAULT '0', *> `MY_CMP306N` decimal(6,0) unsigned NOT NULL DEFAULT '0', *> `MY_CMP307N` decimal(7,0) unsigned NOT NULL DEFAULT '0', *> `MY_CMP308N` decimal(8,0) unsigned NOT NULL DEFAULT '0', *> `MY_CMP309N` decimal(9,0) unsigned NOT NULL DEFAULT '0', *> `MY_CMP310N` decimal(10,0) unsigned NOT NULL DEFAULT '0', *> `MY_CMP311N` decimal(11,0) unsigned NOT NULL DEFAULT '0', *> `MY_CMP312N` decimal(12,0) unsigned NOT NULL DEFAULT '0', *> `MY_CMP313N` decimal(13,0) unsigned NOT NULL DEFAULT '0', *> `MY_CMP314N` decimal(14,0) unsigned NOT NULL DEFAULT '0', *> `MY_CMP315N` decimal(15,0) unsigned NOT NULL DEFAULT '0', *> `MY_CMP316N` decimal(16,0) unsigned NOT NULL DEFAULT '0', *> `MY_CMP317N` decimal(17,0) unsigned NOT NULL DEFAULT '0', *> `MY_CMP318N` decimal(18,0) unsigned NOT NULL DEFAULT '0', *> `MY_CMP301S` decimal(1,0) NOT NULL DEFAULT '0', *> `MY_CMP302S` decimal(2,0) NOT NULL DEFAULT '0', *> `MY_CMP303S` decimal(3,0) NOT NULL DEFAULT '0', *> `MY_CMP304S` decimal(4,0) NOT NULL DEFAULT '0', *> `MY_CMP305S` decimal(5,0) NOT NULL DEFAULT '0', *> `MY_CMP306S` decimal(6,0) NOT NULL DEFAULT '0', *> `MY_CMP307S` decimal(7,0) NOT NULL DEFAULT '0', *> `MY_CMP308S` decimal(8,0) NOT NULL DEFAULT '0', *> `MY_CMP309S` decimal(9,0) NOT NULL DEFAULT '0', *> `MY_CMP310S` decimal(10,0) NOT NULL DEFAULT '0', *> `MY_CMP311S` decimal(11,0) NOT NULL DEFAULT '0', *> `MY_CMP312S` decimal(12,0) NOT NULL DEFAULT '0', *> `MY_CMP313S` decimal(13,0) NOT NULL DEFAULT '0', *> `MY_CMP314S` decimal(14,0) NOT NULL DEFAULT '0', *> `MY_CMP315S` decimal(15,0) NOT NULL DEFAULT '0', *> `MY_CMP316S` decimal(16,0) NOT NULL DEFAULT '0', *> `MY_CMP317S` decimal(17,0) NOT NULL DEFAULT '0', *> `MY_CMP318S` decimal(18,0) NOT NULL DEFAULT '0', *> `MY_CMP501N` int(1) NOT NULL DEFAULT '0', *> `MY_CMP502N` int(2) NOT NULL DEFAULT '0', *> `MY_CMP503N` int(3) NOT NULL DEFAULT '0', *> `MY_CMP504N` int(4) NOT NULL DEFAULT '0', *> `MY_CMP505N` int(5) NOT NULL DEFAULT '0', *> `MY_CMP506N` int(6) NOT NULL DEFAULT '0', *> `MY_CMP507N` int(7) NOT NULL DEFAULT '0', *> `MY_CMP508N` int(8) NOT NULL DEFAULT '0', *> `MY_CMP509N` int(9) NOT NULL DEFAULT '0', *> `MY_CMP510N` bigint(10) NOT NULL DEFAULT '0', *> `MY_CMP511N` bigint(11) NOT NULL DEFAULT '0', *> `MY_CMP512N` bigint(12) NOT NULL DEFAULT '0', *> `MY_CMP513N` bigint(13) NOT NULL DEFAULT '0', *> `MY_CMP514N` bigint(14) NOT NULL DEFAULT '0', *> `MY_CMP515N` bigint(15) NOT NULL DEFAULT '0', *> `MY_CMP516N` bigint(16) NOT NULL DEFAULT '0', *> `MY_CMP517N` bigint(17) NOT NULL DEFAULT '0', *> `MY_CMP518N` bigint(18) NOT NULL DEFAULT '0', *> `MY_CMP501S` int(1) NOT NULL DEFAULT '0', *> `MY_CMP502S` int(2) NOT NULL DEFAULT '0', *> `MY_CMP503S` int(3) NOT NULL DEFAULT '0', *> `MY_CMP504S` int(4) NOT NULL DEFAULT '0', *> `MY_CMP505S` int(5) NOT NULL DEFAULT '0', *> `MY_CMP506S` int(6) NOT NULL DEFAULT '0', *> `MY_CMP507S` int(7) NOT NULL DEFAULT '0', *> `MY_CMP508S` int(8) NOT NULL DEFAULT '0', *> `MY_CMP509S` int(9) NOT NULL DEFAULT '0', *> `MY_CMP510S` bigint(10) NOT NULL DEFAULT '0', *> `MY_CMP511S` bigint(11) NOT NULL DEFAULT '0', *> `MY_CMP512S` bigint(12) NOT NULL DEFAULT '0', *> `MY_CMP513S` bigint(13) NOT NULL DEFAULT '0', *> `MY_CMP514S` bigint(14) NOT NULL DEFAULT '0', *> `MY_CMP515S` bigint(15) NOT NULL DEFAULT '0', *> `MY_CMP516S` bigint(16) NOT NULL DEFAULT '0', *> `MY_CMP517S` bigint(17) NOT NULL DEFAULT '0', *> `MY_CMP518S` bigint(18) NOT NULL DEFAULT '0', *> `MY_DISP01S` decimal(1,0) NOT NULL DEFAULT '0' COMMENT 'PND', *> `MY_DISP02S` decimal(2,0) NOT NULL DEFAULT '0' COMMENT 'PND', *> `MY_DISP03S` decimal(3,0) NOT NULL DEFAULT '0' COMMENT 'PND', *> `MY_DISP04S` decimal(4,0) NOT NULL DEFAULT '0' COMMENT 'PND', *> `MY_DISP05S` decimal(5,0) NOT NULL DEFAULT '0' COMMENT 'PND', *> `MY_DISP06S` decimal(6,0) NOT NULL DEFAULT '0' COMMENT 'PND', *> `MY_DISP07S` decimal(7,0) NOT NULL DEFAULT '0' COMMENT 'PND', *> `MY_DISP08S` decimal(8,0) NOT NULL DEFAULT '0' COMMENT 'PND', *> `MY_DISP09S` decimal(9,0) NOT NULL DEFAULT '0' COMMENT 'PND', *> `MY_DISP10S` decimal(10,0) NOT NULL DEFAULT '0' COMMENT 'PND', *> `MY_DISP11S` decimal(11,0) NOT NULL DEFAULT '0' COMMENT 'PND', *> `MY_DISP12S` decimal(12,0) NOT NULL DEFAULT '0' COMMENT 'PND', *> `MY_DISP13S` decimal(13,0) NOT NULL DEFAULT '0' COMMENT 'PND', *> `MY_DISP14S` decimal(14,0) NOT NULL DEFAULT '0' COMMENT 'PND', *> `MY_DISP15S` decimal(15,0) NOT NULL DEFAULT '0' COMMENT 'PND', *> `MY_DISP16S` decimal(16,0) NOT NULL DEFAULT '0' COMMENT 'PND', *> `MY_DISP17S` decimal(17,0) NOT NULL DEFAULT '0' COMMENT 'PND', *> `MY_DISP18S` decimal(18,0) NOT NULL DEFAULT '0' COMMENT 'PND', *> `MY_DISD01S` decimal(18,17) NOT NULL COMMENT 'PND', *> `MY_DISD02S` decimal(18,16) NOT NULL COMMENT 'PND', *> `MY_DISD03S` decimal(18,15) NOT NULL COMMENT 'PND', *> `MY_DISD04S` decimal(18,14) NOT NULL COMMENT 'PND', *> `MY_DISD05S` decimal(18,13) NOT NULL COMMENT 'PND', *> `MY_DISD06S` decimal(18,12) NOT NULL COMMENT 'PND', *> `MY_DISD07S` decimal(18,11) NOT NULL COMMENT 'PND', *> `MY_DISD08S` decimal(18,10) NOT NULL COMMENT 'PND', *> `MY_DISD09S` decimal(18,9) NOT NULL COMMENT 'PND', *> `MY_DISD10S` decimal(18,8) NOT NULL COMMENT 'PND', *> `MY_DISD11S` decimal(18,7) NOT NULL COMMENT 'PND', *> `MY_DISD12S` decimal(18,6) NOT NULL COMMENT 'PND', *> `MY_DISD13S` decimal(18,5) NOT NULL COMMENT 'PND', *> `MY_DISD14S` decimal(18,4) NOT NULL COMMENT 'PND', *> `MY_DISD15S` decimal(18,3) NOT NULL COMMENT 'PND', *> `MY_DISD16S` decimal(18,2) NOT NULL COMMENT 'PND', *> `MY_DISD17S` decimal(18,1) NOT NULL COMMENT 'PND', *> `MY_DISD18S` decimal(18,0) NOT NULL COMMENT 'PND', *> `MY_DISD01` decimal(18,17) NOT NULL COMMENT 'PND', *> `MY_DISD02` decimal(18,16) NOT NULL COMMENT 'PND', *> `MY_DISD03` decimal(18,15) NOT NULL COMMENT 'PND', *> `MY_DISD04` decimal(18,14) NOT NULL COMMENT 'PND', *> `MY_DISD05` decimal(18,13) NOT NULL COMMENT 'PND', *> `MY_DISD06` decimal(18,12) NOT NULL COMMENT 'PND', *> `MY_DISD07` decimal(18,11) NOT NULL COMMENT 'PND', *> `MY_DISD08` decimal(18,10) NOT NULL COMMENT 'PND', *> `MY_DISD09` decimal(18,9) NOT NULL COMMENT 'PND', *> `MY_DISD10` decimal(18,8) NOT NULL COMMENT 'PND', *> `MY_DISD11` decimal(18,7) NOT NULL COMMENT 'PND', *> `MY_DISD12` decimal(18,6) NOT NULL COMMENT 'PND', *> `MY_DISD13` decimal(18,5) NOT NULL COMMENT 'PND', *> `MY_DISD14` decimal(18,4) NOT NULL COMMENT 'PND', *> `MY_DISD15` decimal(18,3) NOT NULL COMMENT 'PND', *> `MY_DISD16` decimal(18,2) NOT NULL COMMENT 'PND', *> `MY_DISD17` decimal(18,1) NOT NULL COMMENT 'PND', *> `MY_DISD18` decimal(18,0) NOT NULL COMMENT 'PND', *> PRIMARY KEY (`MY_CHA`), *> KEY `MY_CHA` (`MY_CHA`,`MY_DATA`) *>) ENGINE=InnoDB DEFAULT CHARSET=latin1; *> WORKING-STORAGE SECTION. 77 W-CMD PIC X(64000) VALUE SPACES. 77 W-CONT1 PIC 9(05) COMP-5. 77 W-CT1 PIC 9(07) COMP-5. 77 W-CT2 PIC 9(07) COMP-5. 77 W-CT3 PIC 9(07) COMP-5. 77 W-CY4 PIC 9(05) COMP. 77 W-LIN PIC X(79). 78 REG-LEN VALUE LENGTH OF MY-REG. 77 W-RGS PIC X(REG-LEN). 77 W-INT USAGE INT. 77 W-ARQUIVOS PIC X(128) VALUE *> Z"@10.0.0.8@3306@root@@imed@estcad". Z"@127.0.0.1@3306@root@@test@mysqltst". 01 ESTADO PIC X(02). 88 STAT-ERRO VALUE X"3100" THRU X"3943" X"3945" THRU X"39EE". 88 DUPLICADO VALUE "22". 88 CRIAR-ARQUIVO VALUE X"3335" X"3913". 88 JA-ABERTO VALUE "41" X"398D". 88 REINDEXAR VALUE X"3929" X"3912". 88 ESTA-ABERTO VALUE "12". 88 FOI-CRIADO VALUE "05". 88 NAO-ENCONTRADO VALUE "23". 88 FINAL-ARQUIVO VALUE "10". 88 CHAVE-DUPLICADA VALUE "02". 01 RESTADO REDEFINES ESTADO. 02 ST-K01 PIC X(01). 02 ST-K02 PIC X(01). 02 RST-K02 REDEFINES ST-K02. 03 ST-ERR PIC 9(02) COMP-X. 01 MEM-ADDR USAGE LPVOID. 01 MEM-SIZE USAGE DWORD. 01 MEM-TYPE USAGE DWORD. 01 MEM-PROT USAGE DWORD. 01 MEM-RET USAGE POINTER. 01 UNI-FLAG USAGE UINT. 01 DLG-HAN USAGE HWND. 01 DLG-PTF USAGE LPTSTR. 01 DLG-STP USAGE dword. 01 KERNEL32-POINTER procedure-pointer. LINKAGE SECTION. 01 LK-MEMORY PIC X(01). PROCEDURE DIVISION. PRINCIPAL. DISPLAY ERASE. set KERNEL32-POINTER to entry "KERNEL32". *> MOVE 1024 TO MEM-SIZE. *> MOVE MEM-RESERVE TO MEM-TYPE. *> MOVE PAGE-READWRITE TO MEM-PROT. *> SET MEM-ADDR TO NULL. *> *> CALL WINAPI "VirtualAlloc" USING BY VALUE MEM-ADDR *> BY VALUE MEM-SIZE *> BY VALUE MEM-TYPE *> BY VALUE MEM-PROT *> RETURNING MEM-RET. *> MOVE 1024 TO MEM-SIZE. *> MOVE MEM-COMMIT TO MEM-TYPE. *> MOVE PAGE-READWRITE TO MEM-PROT. *> SET MEM-ADDR TO NULL. *> *> CALL WINAPI "VirtualAlloc" USING BY VALUE MEM-ADDR *> BY VALUE MEM-SIZE *> BY VALUE MEM-TYPE *> BY VALUE MEM-PROT *> RETURNING MEM-RET. *> CALL WINAPI "DlgDirListComboBox" USING MOVE 1024 TO MEM-SIZE. MOVE GMEM-FIXED TO UNI-FLAG. SET MEM-ADDR TO NULL. CALL WINAPI "GlobalAlloc" USING BY VALUE UNI-FLAG MEM-SIZE RETURNING MEM-RET. IF MEM-RET NOT = NULL SET ADDRESS OF LK-MEMORY TO MEM-RET CALL "TSMEM" USING MEM-SIZE LK-MEMORY MOVE MEM-DECOMMIT TO MEM-TYPE CALL WINAPI "GlobalFree" USING BY VALUE MEM-RET RETURNING MEM-RET. OPEN I-O MYSQLTST IF ESTADO > "09" DISPLAY "Abrindo TABTST " ESTADO GO TO STATUS-ERRO. PERFORM INICIALIZA-REG. MOVE 999 TO MY-CHA. REWRITE MY-REG INVALID KEY DISPLAY "INVALID-KEY.". MOVE 1 TO MY-CHA. READ MYSQLTST. INITIALIZE MY-LIMPA. MOVE ZEROS TO MY-DATA. WRITE MY-REG. READ MYSQLTST. PERFORM INICIALIZA-REG. MOVE MY-REG TO W-RGS. REWRITE MY-REG. MOVE 1 TO MY-CHA. READ MYSQLTST. IF MY-REG NOT = W-RGS DISPLAY "Tem erro na rotina" STOP " Tecle return " ELSE DISPLAY "Exatamente iguais, funcionou perfeitamente" END-IF. MOVE 20131231 TO MY-DATA. REWRITE MY-REG. MOVE ZEROS TO MY-DATA. CLOSE MYSQLTST. STOP RUN. INICIALIZA-REG. MOVE ZEROS TO MY-DATA. MOVE 9 TO MY-CMP301N MOVE 91 TO MY-CMP302N MOVE 919 TO MY-CMP303N MOVE 9199 TO MY-CMP304N MOVE 91999 TO MY-CMP305N MOVE 919999 TO MY-CMP306N MOVE 9199999 TO MY-CMP307N MOVE 91999999 TO MY-CMP308N MOVE 919999999 TO MY-CMP309N MOVE 9199999999 TO MY-CMP310N MOVE 91999999999 TO MY-CMP311N MOVE 919999999999 TO MY-CMP312N MOVE 9199999999999 TO MY-CMP313N MOVE 91999999999999 TO MY-CMP314N MOVE 919999999999999 TO MY-CMP315N MOVE 9199999999999999 TO MY-CMP316N MOVE 91999999999999999 TO MY-CMP317N MOVE 919999999999999999 TO MY-CMP318N MOVE -9 TO MY-CMP301S MOVE -91 TO MY-CMP302S MOVE -919 TO MY-CMP303S MOVE -9199 TO MY-CMP304S MOVE -91999 TO MY-CMP305S MOVE -919999 TO MY-CMP306S MOVE -9199999 TO MY-CMP307S MOVE -91999999 TO MY-CMP308S MOVE -919999999 TO MY-CMP309S MOVE -9199999999 TO MY-CMP310S MOVE -91999999999 TO MY-CMP311S MOVE -919999999999 TO MY-CMP312S MOVE -9199999999999 TO MY-CMP313S MOVE -91999999999999 TO MY-CMP314S MOVE -919999999999999 TO MY-CMP315S MOVE -9199999999999999 TO MY-CMP316S MOVE -91999999999999999 TO MY-CMP317S MOVE -919999999999999999 TO MY-CMP318S MOVE 9 TO MY-CMP501N MOVE 91 TO MY-CMP502N MOVE 919 TO MY-CMP503N MOVE 9199 TO MY-CMP504N MOVE 91999 TO MY-CMP505N MOVE 919999 TO MY-CMP506N MOVE 9199999 TO MY-CMP507N MOVE 91999999 TO MY-CMP508N MOVE 991999999 TO MY-CMP509N MOVE 9199999999 TO MY-CMP510N MOVE 91999999999 TO MY-CMP511N MOVE 919999999999 TO MY-CMP512N MOVE 9199999999999 TO MY-CMP513N MOVE 91999999999999 TO MY-CMP514N MOVE 919999999999999 TO MY-CMP515N MOVE 9199999999999999 TO MY-CMP516N MOVE 91999999999999999 TO MY-CMP517N MOVE 919999999999999999 TO MY-CMP518N MOVE -9 TO MY-CMP501S MOVE -91 TO MY-CMP502S MOVE -919 TO MY-CMP503S MOVE -9199 TO MY-CMP504S MOVE -91999 TO MY-CMP505S MOVE -919999 TO MY-CMP506S MOVE -9199999 TO MY-CMP507S MOVE -91999999 TO MY-CMP508S MOVE -919999999 TO MY-CMP509S MOVE -9199999999 TO MY-CMP510S MOVE -91999999999 TO MY-CMP511S MOVE -919999999999 TO MY-CMP512S MOVE -9199999999999 TO MY-CMP513S MOVE -91999999999999 TO MY-CMP514S MOVE -919999999999999 TO MY-CMP515S MOVE -9199999999999999 TO MY-CMP516S MOVE -91999999999999999 TO MY-CMP517S MOVE -919999999999999999 TO MY-CMP518S MOVE 9 TO MY-CMPX01N MOVE 91 TO MY-CMPX02N MOVE 919 TO MY-CMPX03N MOVE 9199 TO MY-CMPX04N MOVE 91999 TO MY-CMPX05N MOVE 919999 TO MY-CMPX06N MOVE 9199999 TO MY-CMPX07N MOVE 91999999 TO MY-CMPX08N MOVE 919999999 TO MY-CMPX09N MOVE 9199999999 TO MY-CMPX10N MOVE 91999999999 TO MY-CMPX11N MOVE 919999999999 TO MY-CMPX12N MOVE 9199999999999 TO MY-CMPX13N MOVE 91999999999999 TO MY-CMPX14N MOVE 919999999999999 TO MY-CMPX15N MOVE 9199999999999999 TO MY-CMPX16N MOVE 91999999999999999 TO MY-CMPX17N MOVE 919999999999999999 TO MY-CMPX18N. MOVE -9 TO MY-DISP01S MOVE -91 TO MY-DISP02S MOVE -919 TO MY-DISP03S MOVE -9199 TO MY-DISP04S MOVE -91999 TO MY-DISP05S MOVE -919999 TO MY-DISP06S MOVE -9199999 TO MY-DISP07S MOVE -91999999 TO MY-DISP08S MOVE -919999999 TO MY-DISP09S MOVE -9199999999 TO MY-DISP10S MOVE -91999999999 TO MY-DISP11S MOVE -919999999999 TO MY-DISP12S MOVE -9199999999999 TO MY-DISP13S MOVE -91999999999999 TO MY-DISP14S MOVE -919999999999999 TO MY-DISP15S MOVE -9199999999999999 TO MY-DISP16S MOVE -91999999999999999 TO MY-DISP17S MOVE -919999999999999999 TO MY-DISP18S. MOVE -9.99999999999999999 TO MY-DISD01S MOVE -91.9999999999999999 TO MY-DISD02S MOVE -919.999999999999999 TO MY-DISD03S MOVE -9199.99999999999999 TO MY-DISD04S MOVE -91999.9999999999999 TO MY-DISD05S MOVE -919999.999999999999 TO MY-DISD06S MOVE -9199999.99999999999 TO MY-DISD07S MOVE -91999999.9999999999 TO MY-DISD08S MOVE -919999999.999999999 TO MY-DISD09S MOVE -9199999999.99999999 TO MY-DISD10S MOVE -91999999999.9999999 TO MY-DISD11S MOVE -919999999999.999999 TO MY-DISD12S MOVE -9199999999999.99999 TO MY-DISD13S MOVE -91999999999999.9999 TO MY-DISD14S MOVE -919999999999999.999 TO MY-DISD15S MOVE -9199999999999999.99 TO MY-DISD16S MOVE -91999999999999999.9 TO MY-DISD17S MOVE -919999999999999999 TO MY-DISD18S. MOVE 9.99999999999999999 TO MY-DISD01 MOVE 91.9999999999999999 TO MY-DISD02 MOVE 919.999999999999999 TO MY-DISD03 MOVE 9199.99999999999999 TO MY-DISD04 MOVE 91999.9999999999999 TO MY-DISD05 MOVE 919999.999999999999 TO MY-DISD06 MOVE 9199999.99999999999 TO MY-DISD07 MOVE 91999999.9999999999 TO MY-DISD08 MOVE 919999999.999999999 TO MY-DISD09 MOVE 9199999999.99999999 TO MY-DISD10 MOVE 91999999999.9999999 TO MY-DISD11 MOVE 919999999999.999999 TO MY-DISD12 MOVE -9199999999999.99999 TO MY-DISD13 MOVE -91999999999999.9999 TO MY-DISD14 MOVE -919999999999999.999 TO MY-DISD15 MOVE -9199999999999999.99 TO MY-DISD16 MOVE -91999999999999999.9 TO MY-DISD17 MOVE -919999999999999999 TO MY-DISD18. STATUS-ERRO. CALL "GetLstMsgErr" USING W-CMD. *> Demonstra como monitorar o erro MOVE ZEROS TO W-CONT1. INSPECT W-CMD TALLYING W-CONT1 FOR CHARACTERS BEFORE X"00". IF W-CONT1 > ZEROS IF W-CMD (1:W-CONT1) NOT = SPACES PERFORM VARYING W-CT1 FROM 1 BY 80 UNTIL W-CT1 > W-CONT1 MOVE W-CMD (W-CT1:W-CONT1) TO W-LIN IF W-LIN NOT = SPACES DISPLAY W-LIN ELSE MOVE W-CONT1 TO W-CT1 ADD 1 TO W-CT1 END-IF END-PERFORM END-IF END-IF. IF ST-K01 = "9" EVALUATE ST-ERR WHEN 27 DISPLAY "Access denied for DB/user" WHEN 48 DISPLAY "Heap access failure - out of buffer" WHEN 49 DISPLAY "Heap deallocated while program inactive" WHEN 50 DISPLAY "Backing-file failure: too many files" WHEN 51 DISPLAY "Backing-file failure: file access denied" WHEN 52 DISPLAY "Backing-file failure: I/O failure" WHEN 04 DISPLAY "Nao encontrou no DB tabela procurada - Illeg - "al file name." WHEN 200 DISPLAY "Erro com a execucao de comando da LIBMYSQL c - "onfira sgamysql.log" WHEN 201 DISPLAY "Conexao com servidor perdida." END-EVALUATE ELSE EVALUATE ESTADO WHEN "51" DISPLAY "Erro na conexao com o banco de dados atravez - " da LIBMYSQL" WHEN "53" DISPLAY "Nao foi possivel interpretar campos na tabel - "a e montar correspondencia." WHEN "91" DISPLAY "Erro na montagem da estrutura da FD,falha mo - "ntando campos." END-EVALUATE END-IF. STOP RUN.

TSMYSQL9.CBL

Demonstra acesso ao Mysql via comando SQL.

IDENTIFICATION DIVISION. PROGRAM-ID. TSMYSQL9. *-----------------------------------------------------------* * Objetivo: * *-----------------------------------------------------------* ENVIRONMENT DIVISION. CONFIGURATION SECTION. SPECIAL-NAMES. call-convention 66 is WINAPI DECIMAL-POINT IS COMMA. INPUT-OUTPUT SECTION. FILE-CONTROL. DATA DIVISION. FILE SECTION. WORKING-STORAGE SECTION. 77 W-ARQUIVOS PIC X(64) VALUE "@127.0.0.1@3306@root@@test@cadcep". 77 W-PRIM PIC 9(01) VALUE ZEROS. 77 W-NREG PIC 9(02) COMP-5 VALUE ZEROS. 77 W-QRTM PIC 9(09) COMP-5. 77 W-CMD PIC X(64000). 77 W-SINAL PIC S9(05)V99 VALUE -1234,33. 01 ESTADO PIC X(02). 88 STAT-ERRO VALUE X"3100" THRU X"3943" X"3945" THRU X"39EE". 88 DUPLICADO VALUE "22". 88 CRIAR-ARQUIVO VALUE X"3335" X"3913". 88 JA-ABERTO VALUE "41" X"398D". 88 REINDEXAR VALUE X"3929" X"3912". 88 ESTA-ABERTO VALUE "12". 88 FOI-CRIADO VALUE "05". 88 NAO-ENCONTRADO VALUE "23". 88 FINAL-ARQUIVO VALUE "10". 88 CHAVE-DUPLICADA VALUE "02". 01 RESTADO REDEFINES ESTADO. 02 ST-K01 PIC X(01). 02 ST-K02 PIC X(01). 02 RST-K02 REDEFINES ST-K02. 03 ST-ERR PIC 9(02) COMP-X. 01 W-CONEXAO USAGE POINTER. 01 W-CURSOR USAGE POINTER. 01 EXTMYSQL procedure-pointer. 01 WS-REG. 02 WS-LAN PIC S9(10). 02 WS-CL1 PIC S9(07). 02 WS-CL2 PIC S9(06). 02 WS-CL3 PIC S9(07)V99. 02 WS-CL4 PIC S9(05). 02 WS-CL5 PIC S9(05)V9999. 02 WS-CH1 PIC X(10). 02 WS-CH2 PIC X(50). PROCEDURE DIVISION. INICIO. SET EXTMYSQL TO ENTRY "EXTMYSQL". MOVE "@127.0.0.1@3306@root@@test@cadtst" TO W-ARQUIVOS. *>MOVE "@127.0.0.1@3306@root@1234@rosul@estcad" *> TO W-ARQUIVOS. CALL "MysqlConecta" USING W-ARQUIVOS *> Variavel com os parametros para estabelecer a conexão W-CONEXAO *> Retorna handle para encontrar a FCD-AREA da conexão ESTADO. *> Status de retorno PERFORM SETA-VARIAVEL MOVE 1 TO W-QRTM. STRING "SELECT cadtst.tstlan, cadtst.tstvl1, cadtst.tstvl2, " "cadtst.tstvl3, cadtst.tstvl4, cadtst.tstvl5, " "cadtst.tstch1, cadtst.tstch2 FROM cadtst" DELIMITED BY SIZE INTO W-CMD WITH POINTER W-QRTM. CALL "MysqlComando" USING W-CONEXAO *> Handle para recuperar FCD-AREA W-CMD *> Comando a ser executado W-CURSOR *> Handle do retorno do comando W-QRTM *> Tamanho do comando a ser executado ESTADO. *> Status de retorno IF W-CURSOR NOT = NULL PERFORM UNTIL STAT-ERRO MOVE ZEROS TO W-QRTM CALL "MysqlRetorna" USING W-CONEXAO *> Handle para recuperar FCD-AREA W-CURSOR *> Endereço estrutura do retorno (cursor) W-QRTM *> Tamanho do buffer sendo retornado ESTADO *> Status de retorno W-CMD *> Buffer contendo o resultado sendo retornado. Ter cuidado no programa MOVE W-CMD TO WS-REG END-PERFORM END-IF CALL "MysqlLiberaCursor" USING W-CONEXAO W-CURSOR. *> Handle para encontrar a FCD-AREA desta conexão CALL "MysqlDesConecta" USING W-CONEXAO *> Handle para encontrar a FCD-AREA desta conexão W-CURSOR *> Handle das definições para o cursor, pode não vir informado ESTADO. STOP RUN. SETA-VARIAVEL. MOVE "SET @teste = 2;" TO W-CMD MOVE 15 TO W-QRTM. CALL "MysqlComando" USING W-CONEXAO *> Handle para recuperar FCD-AREA W-CMD *> Comando a ser executado W-CURSOR *> Handle do retorno do comando W-QRTM *> Tamanho do comando a ser executado ESTADO. *> Status de retorno MOVE "SELECT @teste;" TO W-CMD MOVE 14 TO W-QRTM. CALL "MysqlComando" USING W-CONEXAO *> Handle para recuperar FCD-AREA W-CMD *> Comando a ser executado W-CURSOR *> Handle do retorno do comando W-QRTM *> Tamanho do comando a ser executado ESTADO. *> Status de retorno IF W-CURSOR NOT = NULL PERFORM UNTIL STAT-ERRO MOVE ZEROS TO W-QRTM CALL "MysqlRetorna" USING W-CONEXAO *> Handle para recuperar FCD-AREA W-CURSOR *> Endereço estrutura do retorno (cursor) W-QRTM *> Tamanho do buffer sendo retornado ESTADO *> Status de retorno W-CMD *> Buffer contendo o resultado sendo retornado. Ter cuidado no programa MOVE W-CMD TO WS-REG END-PERFORM END-IF.

BIB2SQL.CBL

Cria script definição tabela.

Programa inacabado, que a partir de uma Bib informada contendo a FD de um arquivo COBOL, cria script de uma tabela Mysql compatível a FD informada.

$SET NORETRYLOCK MS"2" *********************************************************** * IMEDIATA INFORMATICA EMPRESARIAL LTDA * * PROGRAMA - BIB2SQL - Converte BIB para tabela MYSQL * *********************************************************** *> ========================================================= *> |Tipo |T|S| Menor valor| Maior Valor| *> ========================================================= *> |TINYINT |1|S| -128| 127| *> | | |U| 0| 255| *> |SMALLINT |2|S| -32768| 32767| *> | | |U| 0| 65535| *> |MEDIUMINT|3|S| -8388608| 8388607| *> | | |U| 0| 16777215| *> |INT |4|S| -2147483648| 2147483647| *> | | |U| 0| 4294967295| *> |BIGINT |8|S|-9223372036854775808| 9223372036854775807| *> | | |U| 0|18446744073709551615| *> ========================================================= *> Tipo - Tipo de variavel no MYSQL *> T - Tamanho ocupado em bites *> S - Signed ou Unsigned *> Menor valor - Menor valor suportado pela variável *> Maior valor - Maior valor suportado pela variável *> ========================================================= *> Correlação entre MYSQL e Cobol *> ============================== *> COMP-3 (Signed e Unsigned respectivamente) *> Decimal - Unsigned *> Decimal - Signed *> COMP-0, COMP-X até 9(09) *> INT - Unsigned *> COMP-0, COMP-X acima de 9(09) *> BIGINT - Unsigned *> COMP-5 até 9(09) *> INT - Signed *> COMP-5 acima de 9(09) *> BIGINT - Signed *> Vide www.mercosoft.com.br IDENTIFICATION DIVISION. PROGRAM-ID. BIB2SQL. ENVIRONMENT DIVISION. CONFIGURATION SECTION. SPECIAL-NAMES. DECIMAL-POINT IS COMMA. INPUT-OUTPUT SECTION. FILE-CONTROL. SELECT ARQBIB ASSIGN TO DYNAMIC W-ARQBIB ORGANIZATION IS LINE SEQUENTIAL FILE STATUS IS ESTADO. SELECT ARQSQL ASSIGN TO DYNAMIC W-ARQSQL ORGANIZATION IS LINE SEQUENTIAL FILE STATUS IS ESTADO. DATA DIVISION. FILE SECTION. FD ARQBIB. 01 BB-REG PIC X(1024). FD ARQSQL. 01 SQ-REG PIC X(1024). WORKING-STORAGE SECTION. 77 W-DBG PIC 9(01) VALUE ZEROS. 88 DEBUGAR VALUE 1. 77 W-ARQBIB PIC X(60) VALUE SPACES. 77 W-ARQSQL PIC X(60) VALUE SPACES. 77 W-TABELA PIC X(60) VALUE SPACES. 77 W-DBASE PIC X(60) VALUE SPACES. 77 W-COMMAND PIC X(1024) VALUE SPACES. 77 W-STR PIC X(01). 88 BRANCO VALUE SPACES. 88 NULO VALUE X"00". 77 W-LIN PIC X(79) VALUE SPACES. 77 W-STR1 PIC X(128) VALUE SPACES. 77 W-STR2 PIC X(128) VALUE SPACES. 77 W-STRING PIC X(1024) VALUE SPACES. 77 W-TIPOARQ PIC X(04) VALUE SPACES. 88 TIPO-CERTO VALUE "BIB" "CPY" "FD". 77 W-PALAVRA PIC X(30) VALUE SPACES. 77 W-INI PIC X(02) VALUE ZEROS COMP-X. 77 W-FIM PIC X(02) VALUE ZEROS COMP-X. 77 W-OK PIC 9(01) VALUE ZEROS. 77 W-NUM PIC 9(01) VALUE ZEROS. 88 UNSIGNED VALUE 1. *> Numero sem sinal 88 SIGNED VALUE 2. *> Numero com sinal 88 NUMERICO VALUE 1 2. *> Numero 88 ALFA VALUE 4. *> Alfa numerico (Caractere) 88 SIGALFA VALUE 5. *> Numero alfa 77 W-PND PIC 9(01). 88 PND VALUE 1. *> Decimal "PND" 77 W-TERMINOU PIC 9(01) VALUE ZEROS. 88 TERMINOU VALUE 1. 77 W-DBCOMENT PIC X(80) VALUE SPACES. 77 W-SQLREG PIC X(1024) VALUE SPACES. 77 W-SQLSGN PIC X(64) VALUE SPACES. *> Define se tem ou não sinal 77 W-ST1 PIC X(30). 77 W-ST2 PIC X(30). 77 W-ST3 PIC X(30). 77 W-ST4 PIC X(30). 77 W-TMT PIC X(02) VALUE ZEROS COMP-X. 77 W-CMP PIC X(30) VALUE SPACES. 77 W-COMAUX PIC X(128) VALUE SPACES. 77 W-COMENT PIC X(128) VALUE SPACES. 77 W-BOL PIC 9(01) VALUE ZEROS. 88 FALSO VALUE 0. 88 VERDADEIRO VALUE 1. 77 W-CO1 PIC 9(06) VALUE ZEROS. 77 W-CO2 PIC 9(06) VALUE ZEROS. 77 W-CO3 PIC 9(06) VALUE ZEROS. 77 W-CO4 PIC 9(06) VALUE ZEROS. 77 W-COA PIC 9(06) VALUE ZEROS. 77 W-POS PIC 9(05) VALUE 1 COMP-0. 77 W-TMN PIC X(04) VALUE ZEROS COMP-X. 77 COMANDO PIC X(80) VALUE SPACES. 01 ESTADO PIC X(02). 88 REG-BLOQ VALUE X"3944" X"3941". 88 STAT-ERRO VALUE X"3100" THRU X"3943" X"3945" THRU X"39EE". 88 DUPLICADO VALUE "22". 88 CRIAR-ARQUIVO VALUE X"3335" X"3913". 88 JA-ABERTO VALUE "41" X"398D". 88 REINDEXAR VALUE X"3929" X"3912". 88 ESTA-ABERTO VALUE "12". 88 FOI-CRIADO VALUE "05". 88 NAO-ENCONTRADO VALUE "23". 88 FINAL-ARQUIVO VALUE "10". 88 CHAVE-DUPLICADA VALUE "02". 01 RESTADO REDEFINES ESTADO. 02 ST-K01 PIC X(01). 02 ST-K02 PIC X(01). 02 RST-K02 REDEFINES ST-K02. 03 ST-ERR PIC 9(02) COMP-X. 01 SB-DET. 02 SB-SIZE PIC X(08) COMP-X. 02 SB-DTA. 03 SB-DAY PIC 9(02) COMP-X. 03 SB-MON PIC 9(02) COMP-X. 03 SB-YEA PIC 9(04) COMP-X. 02 SB-TIM. 03 SB-HOR PIC 9(02) COMP-X. 03 SB-MIN PIC 9(02) COMP-X. 03 SB-SEC PIC 9(02) COMP-X. 02 SB-HUN PIC 9(02) COMP-X. 01 LINHA-BIB. 02 W-NIVEL PIC 9(05) VALUE ZEROS. 02 W-CAMPO PIC X(30) VALUE SPACES. 02 W-PICTURE PIC X(03) VALUE SPACES. 02 W-TPIC PIC X(30) VALUE SPACES. 02 FILLER REDEFINES W-TPIC. 03 W-PPIC PIC X(01). 03 FILLER PIC X(01). 02 W-REDEF PIC 9(01) VALUE ZEROS. 02 W-OCCURS PIC 9(01) VALUE ZEROS. 02 W-PONTO PIC 9(01) VALUE ZEROS. 02 W-TAMANHO PIC 9(05) VALUE ZEROS. 02 W-TAMDEC PIC 9(05) VALUE ZEROS. 02 W-TCAMPO PIC X(20) VALUE SPACES. 88 CAMPO-INT VALUE "COMP" "COMP-X" "COMP-0". 88 CAMPO-CMP VALUE "COMP-5". 88 CAMPO-DECIMAL VALUE "COMP-3". 02 W-DECIMAL PIC X(30) VALUE SPACES. 02 FILLER REDEFINES W-DECIMAL. 03 W-PDEC PIC X(01). 88 E-DECIMAL VALUE "V". 03 W-TDEC PIC X(01). 88 E-DECPIC VALUE "(". 03 W-TAMPIC PIC X(04). 02 W-COMP PIC X(30). 88 DISPL VALUE "DISPLAY" " ". 88 COMPU VALUE "COMP" "COMPUTATIONAL". 88 COMP0 VALUE "COMP-0" "COMPUTATIONAL-0". 88 COMPX VALUE "COMP-X" "COMPUTATIONAL-X". 88 COMP3 VALUE "COMP-3" "COMPUTATIONAL-3". 88 COMP5 VALUE "COMP-5" "COMPUTATIONAL-5". 02 W-SQLTIP PIC X(60). 02 W-SQLDEC PIC X(60). 02 W-NOCR PIC 9(05). *> 88 TP-DISP VALUE 0. *> Display (X, 9, A, Z) Não compactado *> 88 TP-COMP VALUE 1. *> Compactado (COMP, COMP-X, COMP-0) *> 88 TP-DECM VALUE 2. *> Decimal (COMP-3) *> 88 TP-DECS VALUE 3. *> Decimal (COMP-3) com sinal *> 88 TP-COMS VALUE 4. *> Compactado (COMP-5) com sinal PROCEDURE DIVISION. INICIO. DISPLAY (1, 1) ERASE "Gerando comandos para converter bib em" - "MYSql.". DISPLAY "." IF W-DBG = 1 MOVE "arqdemo.bib@arqdemo@demo" TO W-COMMAND ELSE ACCEPT W-COMMAND FROM COMMAND-LINE. UNSTRING W-COMMAND DELIMITED BY "@" INTO W-ARQBIB W-TABELA W-DBASE. MOVE FUNCTION UPPER-CASE (W-TABELA) TO W-TABELA. MOVE FUNCTION UPPER-CASE (W-ARQBIB) TO W-STRING. MOVE W-STRING TO W-ARQBIB. MOVE SPACES TO W-LIN. STRING "Parametros " W-COMMAND DELIMITED BY SIZE INTO W-LIN. MOVE SPACES TO W-LIN. STRING "Converte " W-ARQBIB DELIMITED BY SIZE INTO W-LIN. DISPLAY W-LIN. MOVE SPACES TO W-LIN STRING "Tabela " W-TABELA DELIMITED BY SIZE INTO W-LIN. DISPLAY W-LIN. MOVE SPACES TO W-LIN STRING "Dbase " W-DBASE DELIMITED BY SIZE INTO W-LIN. DISPLAY W-LIN. IF W-ARQBIB = SPACES DISPLAY "Informe nome da biblioteca." GO TO MOSTRA-SINTAX. IF W-TABELA = SPACES DISPLAY "Informe nome da tabela." GO TO MOSTRA-SINTAX. *>IF W-DBASE = SPACES *> DISPLAY "Informe nome da DBASE." *> GO TO MOSTRA-SINTAX. CALL "CBL_CHECK_FILE_EXIST" USING W-ARQBIB SB-DET IF RETURN-CODE NOT = ZEROS MOVE SPACES TO W-LIN STRING "Arquivo " W-STR1 " não encontrado" DELIMITED BY X"00" INTO W-LIN DISPLAY W-LIN DISPLAY "Use a sintax abaixo:" GO TO MOSTRA-SINTAX. MOVE LENGTH OF W-ARQBIB TO W-TMN PERFORM VARYING W-TMN FROM W-TMN BY -1 UNTIL W-TMN < 1 OR (W-ARQBIB (W-TMN : 1) NOT = SPACES AND W-ARQBIB (W-TMN : 1) NOT = LOW-VALUES) MOVE SPACES TO W-ARQBIB (W-TMN : 1). PERFORM VARYING W-POS FROM W-TMN BY -1 UNTIL W-POS < 1 OR W-ARQBIB (W-POS : 1) = "." MOVE W-ARQBIB (W-POS : W-TMN - W-POS + 1) TO W-TIPOARQ. IF NOT TIPO-CERTO DISPLAY "Converte apenas arquivos do tipo (BIB) OU (CPY)," - " " W-TIPOARQ "." GO TO MOSTRA-SINTAX. MOVE W-ARQBIB TO W-ARQSQL. MOVE "SQL" TO W-ARQSQL (W-POS + 1:3). * CALL "CBL_CHECK_FILE_EXIST" USING W-ARQSQL SB-DET * IF RETURN-CODE = ZEROS * DISPLAY "Arquivo " W-ARQSQL " já existe" * DISPLAY "Use a sintax abaixo:" * GO TO MOSTRA-SINTAX. OPEN INPUT ARQBIB. OPEN OUTPUT ARQSQL. MOVE SPACES TO SQ-REG. MOVE W-DBASE TO W-STRING. MOVE LENGTH OF W-TABELA TO W-TMN. SET NULO TO TRUE. PERFORM MOVE-STRFIM. MOVE W-STRING TO W-DBASE. MOVE W-TABELA TO W-STRING. MOVE LENGTH OF W-TABELA TO W-TMN. SET NULO TO TRUE. PERFORM MOVE-STRFIM. MOVE W-STRING TO W-TABELA. MOVE W-TMN TO W-TMT. MOVE SPACES TO W-SQLREG. MOVE 1 TO W-POS. STRING "CREATE TABLE IF NOT EXISTS " DELIMITED BY X"00" INTO W-SQLREG WITH POINTER W-POS. IF W-DBASE(1:1) NOT = X"00" STRING "`" W-DBASE "`." DELIMITED BY X"00" INTO W-SQLREG WITH POINTER W-POS END-IF STRING "`" W-TABELA "` (" DELIMITED BY X"00" INTO W-SQLREG WITH POINTER W-POS. PERFORM GRAVA-SQL. PERFORM UNTIL STAT-ERRO READ ARQBIB NEXT RECORD AT END PERFORM VARYING W-POS FROM LENGTH OF SQ-REG BY -1 UNTIL W-POS < 2 IF SQ-REG (W-POS:1) = "," MOVE " " TO SQ-REG (W-POS:1) MOVE 1 TO W-POS END-IF END-PERFORM NOT AT END MOVE SPACES TO W-SQLREG MOVE SPACES TO W-STR1 W-STR2 MOVE LOW-VALUES TO W-COMENT UNSTRING BB-REG DELIMITED BY "*>" INTO W-STR1 W-STR2 IF W-STR2 NOT = SPACES MOVE W-STR2 TO W-STRING MOVE LENGTH OF W-STR2 TO W-TMN SET NULO TO TRUE PERFORM MOVE-STRFIM STRING W-STRING "'" DELIMITED BY X"00" X"00" DELIMITED BY SIZE INTO W-COMENT END-IF MOVE W-STR1 TO BB-REG MOVE FUNCTION UPPER-CASE(BB-REG) TO W-SQLREG MOVE W-SQLREG TO BB-REG MOVE SPACES TO W-SQLREG PERFORM INICIALIZA-VAR IF BB-REG (7 : 1) = "*" IF W-TMT > ZEROS PERFORM VARYING W-POS FROM 8 BY 1 UNTIL W-POS > 80 IF BB-REG (W-POS : W-TMT) = FUNCTION UPPER-CASE (W-TABELA (1 : W-TMT)) COMPUTE W-TMN = 80 - W-POS MOVE BB-REG (W-POS : W-TMN) TO W-COMENT MOVE LENGTH OF W-COMENT TO W-TMN PERFORM VARYING W-TMN FROM W-TMN BY -1 UNTIL W-TMN < 1 IF W-COMENT (W-TMN : 1) = " " OR = "*" OR = X"00" MOVE X"00" TO W-COMENT (W-TMN : 1) ELSE MOVE 1 TO W-TMN END-IF END-PERFORM MOVE LOW-VALUES TO W-DBCOMENT STRING W-COMENT "'" DELIMITED BY X"00" INTO W-DBCOMENT END-IF END-PERFORM END-IF ELSE PERFORM TRATA-LINHA IF W-PICTURE = SPACES *> Não tem picture IF W-PONTO NOT = ZEROS PERFORM INICIALIZA-VAR END-IF ELSE IF W-NIVEL = ZEROS OR W-REDEF > ZEROS PERFORM INICIALIZA-VAR *> Não possui nivel válido ELSE IF W-OCCURS > ZEROS MOVE W-NOCR TO W-CO2 PERFORM INICIALIZA-VAR ELSE IF W-PONTO > ZEROS IF W-TAMANHO NOT = ZEROS PERFORM CONCLUI-CAMPO ELSE PERFORM INICIALIZA-VAR END-IF END-IF END-IF END-IF END-IF END-IF END-READ END-PERFORM. MOVE W-DBCOMENT TO W-STRING. MOVE LENGTH OF W-TABELA TO W-TMN. SET NULO TO TRUE. PERFORM MOVE-STRFIM. MOVE W-STRING TO W-COMENT. MOVE SPACES TO W-SQLREG. MOVE "# PRIMARY KEY `NOME_CHAVE`(`CAMPO_CHAVE`)," TO W-SQLREG. PERFORM GRAVA-SQL MOVE SPACES TO W-SQLREG. MOVE "# INDEX `NOME_CHAVE` (`CAMPO_CHAVE`)," TO W-SQLREG. PERFORM GRAVA-SQL MOVE SPACES TO W-SQLREG. STRING " )" W-DBCOMENT DELIMITED BY X"00" INTO W-SQLREG. PERFORM GRAVA-SQL MOVE " ENGINE=InnoDB;" TO W-SQLREG. PERFORM GRAVA-SQL. *> Sempre garava um registro atrazado PERFORM GRAVA-SQL. *> Grava o ultimo registro CLOSE ARQBIB ARQSQL. DISPLAY "Criado " W-ARQSQL. STOP RUN. CONCLUI-CAMPO. PERFORM LINHA-SQL PERFORM GRAVA-SQL. PERFORM INICIALIZA-VAR. INICIALIZA-VAR. MOVE ZEROS TO W-REDEF. MOVE ZEROS TO W-OCCURS. MOVE ZEROS TO W-PONTO. MOVE ZEROS TO W-NIVEL. MOVE LOW-VALUES TO W-CAMPO. MOVE SPACES TO W-PICTURE. MOVE SPACES TO W-TPIC. MOVE ZEROS TO W-TAMANHO. MOVE SPACES TO W-TCAMPO. MOVE SPACES TO W-DECIMAL. MOVE SPACES TO W-COMP. MOVE ZEROS TO W-TAMDEC. MOVE ZEROS TO W-NOCR. MOVE ZEROS TO W-PND. MOVE ZEROS TO W-NUM. TRATA-LINHA. SET NULO TO TRUE. PERFORM PROCURA-REDEFINES PERFORM PROCURA-OCCURS. IF W-OCCURS > ZEROS AND W-NOCR = ZEROS PERFORM PROCURA-NOCR. PERFORM PROCURA-PONTO PERFORM PROCURA-NIVEL PERFORM PROCURA-CAMPO PERFORM PROCURA-PICTURE PERFORM PROCURA-TPIC PERFORM PROCURA-COMP. PROCURA-REDEFINES. MOVE ZEROS TO W-REDEF. INSPECT BB-REG TALLYING W-REDEF FOR ALL "REDEFINES" REPLACING ALL "REDEFINES" BY " ". PROCURA-OCCURS. MOVE ZEROS TO W-OCCURS. INSPECT BB-REG TALLYING W-OCCURS FOR ALL "OCCURS" W-CO2 FOR CHARACTERS BEFORE "OCCURS" REPLACING ALL "OCCURS" BY " ". PROCURA-NOCR. IF W-OCCURS NOT = ZEROS MOVE W-CO2 TO W-POS PERFORM PROCURA-PALAVRA MOVE W-PALAVRA (1 : W-FIM) TO COMANDO MOVE FUNCTION NUMVAL (COMANDO) TO W-NOCR. MOVE 1 TO W-CO2. PROCURA-PONTO. MOVE ZEROS TO W-PONTO. INSPECT BB-REG TALLYING W-PONTO FOR ALL "." REPLACING ALL "." BY " ". PROCURA-NIVEL. IF W-NIVEL = SPACES OR ZEROS MOVE 01 TO W-POS PERFORM PROCURA-PALAVRA MOVE W-PALAVRA (1 : W-FIM) TO COMANDO MOVE FUNCTION NUMVAL (COMANDO) TO W-NIVEL. PROCURA-CAMPO. IF W-CAMPO = LOW-VALUES PERFORM PROCURA-PALAVRA MOVE W-PALAVRA (1 : W-FIM) TO W-CAMPO INSPECT W-CAMPO REPLACING ALL "-" BY "_". PROCURA-PICTURE. IF W-PICTURE = SPACES PERFORM PROCURA-PALAVRA MOVE W-PALAVRA (1 : W-FIM) TO W-PICTURE. PROCURA-TPIC. IF W-TPIC = SPACES PERFORM PROCURA-PALAVRA MOVE ZEROS TO W-CO1 MOVE W-PALAVRA (1 : W-FIM) TO W-TPIC IF W-TPIC NOT = SPACES PERFORM TRATA-TPIC. PROCURA-TAMANHO. IF W-TAMANHO = SPACES OR ZEROS PERFORM PROCURA-PALAVRA MOVE W-PALAVRA (1 : W-FIM) TO COMANDO MOVE FUNCTION NUMVAL (COMANDO) TO W-TAMANHO. PROCURA-TCAMPO. IF W-TCAMPO = SPACES PERFORM PROCURA-PALAVRA MOVE W-PALAVRA (1 : W-FIM) TO W-TCAMPO. PROCURA-DECIMAL. IF W-DECIMAL = SPACES PERFORM PROCURA-PALAVRA MOVE W-PALAVRA (1 : W-FIM) TO W-DECIMAL. PROCURA-COMP. IF W-COMP = SPACES SET BRANCO TO TRUE PERFORM PROCURA-PALAVRA MOVE W-PALAVRA (1 : W-FIM) TO W-COMP. PROCURA-PALAVRA. *> Procura inicio da palavra e monta em W-PALAVRA MOVE ZEROS TO W-OK. MOVE ZEROS TO W-FIM. PERFORM VARYING W-POS FROM W-POS BY 1 UNTIL W-POS > 80 OR W-OK = 1 IF BB-REG (W-POS : 1) NOT = SPACES *> Quando encontra monta a palavra MOVE SPACES TO W-PALAVRA MOVE 1 TO W-OK *> Sinalisa que encontrou a palavra MOVE 1 TO W-FIM PERFORM VARYING W-POS FROM W-POS BY 1 UNTIL W-POS > 80 OR BB-REG (W-POS : 1) = SPACES OR BB-REG (W-POS : 1) = "." MOVE BB-REG (W-POS : 1) TO W-PALAVRA (W-FIM : 1) ADD 1 TO W-FIM MOVE W-STR TO W-PALAVRA (W-FIM : 1). *> Garante que variavel termine com X"00" TRATA-TPIC. EVALUATE W-TPIC (1 : 1) *> Verifica tipo de picture WHEN "9" SET UNSIGNED TO TRUE WHEN "S" SET SIGNED TO TRUE WHEN "X" SET ALFA TO TRUE WHEN "A" SET ALFA TO TRUE WHEN "Z" SET ALFA TO TRUE END-EVALUATE. IF COMPU SET ALFA TO TRUE. MOVE ZEROS TO W-CO1. *> Verifica se tamanho esta definido entre parenteses INSPECT W-TPIC TALLYING W-CO1 FOR ALL "(". IF W-CO1 > ZEROS *> Tamanho da picture definida entre parenteses MOVE W-TPIC (3 : 26) TO COMANDO MOVE COMANDO TO W-TPIC IF NUMERICO *> Campo definido como numerico 9 ou S MOVE SPACES TO W-STR1 W-STR2 UNSTRING W-TPIC DELIMITED BY "V" *> Verifica se tem casas decimais INTO W-STR1 W-STR2 *> Se W-STR2 # brancos, tem casas decimais MOVE FUNCTION NUMVAL (W-STR1) *> Recupera tamanho do campo TO W-TAMANHO MOVE ZEROS TO W-CO1 INSPECT W-STR2 TALLYING W-CO1 FOR ALL "(" *> Verifica se casas decimais esta definida entre parenteses IF W-CO1 > ZEROS MOVE W-STR2 (3 : 26) TO COMANDO MOVE FUNCTION NUMVAL (COMANDO) TO W-TAMDEC ELSE MOVE ZEROS TO W-TAMDEC INSPECT W-STR2 TALLYING W-TAMDEC FOR ALL "9" END-IF ELSE MOVE FUNCTION NUMVAL (W-TPIC) TO W-TAMANHO END-IF ELSE INSPECT W-TPIC TALLYING W-TAMANHO FOR ALL "X" W-TAMANHO FOR ALL "9" BEFORE "V" W-TAMDEC FOR ALL "9" AFTER "V". GRAVA-SQL. IF SQ-REG NOT = SPACES MOVE SQ-REG TO W-LIN DISPLAY W-LIN WRITE SQ-REG. MOVE W-SQLREG TO SQ-REG. MOVE SPACES TO W-SQLREG. LINHA-SQL. *> Monta a linha de criação do campo no MYSQL MOVE SPACES TO W-SQLREG. MOVE LOW-VALUES TO W-SQLDEC. MOVE LOW-VALUES TO W-SQLSGN. IF DISPL AND UNSIGNED OR DISPL AND SIGNED SET PND TO TRUE SET COMP3 TO TRUE. IF ALFA OR SIGALFA MOVE "VARCHAR(" & X"00" TO W-SQLTIP IF ALFA IF W-TAMANHO > 255 MOVE "VARCHAR(" & X"00" TO W-SQLTIP END-IF END-IF STRING ") NOT NULL DEFAULT ' '" X"00" DELIMITED BY SIZE INTO W-SQLDEC ELSE IF SIGNED MOVE ") NOT NULL DEFAULT '0'" & X"00" TO W-STR1 ELSE MOVE ") UNSIGNED NOT NULL DEFAULT '0'" & X"00" TO W-STR1 END-IF IF W-TAMDEC > ZEROS OR COMP3 MOVE "DECIMAL(" & X"00" TO W-SQLTIP ELSE IF W-TAMANHO > 9 MOVE "BIGINT(" & X"00" TO W-SQLTIP ELSE MOVE "INT(" & X"00" TO W-SQLTIP END-IF IF COMPX MOVE " UNSIGNED" & X"00" TO W-SQLSGN ELSE MOVE X"00" TO W-SQLSGN END-IF END-IF IF W-TAMDEC > ZEROS STRING "," W-TAMDEC W-STR1 DELIMITED BY SIZE INTO W-SQLDEC ELSE STRING W-STR1 DELIMITED BY SIZE INTO W-SQLDEC END-IF END-IF. IF PND IF W-COMENT (1:1) NOT = X"00" MOVE W-COMENT TO W-COMAUX ELSE MOVE Z"'" TO W-COMAUX END-IF MOVE ALL X"00" TO W-COMENT STRING " COMMENT 'PND " W-COMAUX DELIMITED BY SIZE INTO W-COMENT ELSE IF W-COMENT (1:1) NOT = X"00" MOVE W-COMENT TO W-COMAUX MOVE ALL X"00" TO W-COMENT STRING " COMMENT '" W-COMAUX DELIMITED BY SIZE INTO W-COMENT. ADD W-TAMDEC TO W-TAMANHO. *> Tamanho inclui casas decimais no MYSQL STRING " `" W-CAMPO "` " W-SQLTIP W-TAMANHO W-SQLDEC W-SQLSGN W-COMENT "," DELIMITED BY X"00" INTO W-SQLREG. PROCURA-TAMANHO. PERFORM PROCURA-PALAVRA MOVE W-PALAVRA (1 : W-FIM) TO COMANDO MOVE FUNCTION NUMVAL (COMANDO) TO W-TAMANHO. MOVE-STRFIM. PERFORM VARYING W-TMN FROM W-TMN BY -1 UNTIL W-TMN < 1 OR W-STRING (W-TMN : 1) NOT = SPACES MOVE W-STR TO W-STRING (W-TMN : 1). MOSTRA-SINTAX. DISPLAY "Ex.: BIB2SQL nomearqBib@nomeTabela@nomeDB" DISPLAY " Sera usado nomearqBib para acessar a biblioteca - " em Cobol" DISPLAY " para criar arquivo contendo comandos para criar - " banco de dados em SQL". DISPLAY " Sera usado nomeTabela para definir a tabela no - "banco de dados a ser criada.". STOP RUN.

TSMYSQLB.CBL

Demo usando MONTAORDER.

Programa demo para uso do recurso MontaOrder.

$set callfh"EXTMYSQL" *********************************************************** * IMEDIATA INFORMATICA EMPRESARIAL LTDA * * PROGRAMA - * *********************************************************** IDENTIFICATION DIVISION. PROGRAM-ID. TSMYSQLB. ENVIRONMENT DIVISION. CONFIGURATION SECTION. SOURCE-COMPUTER. IBM-PC WITH DEBUGGING MODE. SPECIAL-NAMES. call-convention 66 is WINAPI DECIMAL-POINT IS COMMA. INPUT-OUTPUT SECTION. FILE-CONTROL. $SET OPTIONAL-FILE SELECT CADCEP ASSIGN TO DYNAMIC W-ARQCEP ORGANIZATION IS INDEXED ACCESS MODE IS DYNAMIC LOCK MODE IS MANUAL FILE STATUS IS ESTADO RECORD KEY IS CEP-ID ALTERNATE RECORD KEY IS UFCCDLOG = CEP-UF CEP-CCD CEP-LOG WITH DUPLICATES ALTERNATE RECORD KEY IS CEP-CEP WITH DUPLICATES ALTERNATE RECORD KEY IS CEP-UFC WITH DUPLICATES. DATA DIVISION. FILE SECTION. FD CADCEP. 01 CEP-REG. 02 CEP-ID PIC S9(07) COMP-3. *> Código do registro 02 CEP-UF PIC X(02). *> Código da UF 02 CEP-CCD PIC S9(05) COMP-3. *> Código da cidade 02 CEP-LOG PIC X(64). *> Logradouro 02 CEP-BAI PIC X(25). *> Bairro 02 CEP-TLG PIC X(15). *> Tipo de logradouro 02 CEP-CEP PIC X(09). *> C.E.P. 02 CEP-UFC PIC S9(05) COMP-3. *> Código da UF. *>CREATE TABLE `cadcep` ( *> `id` DECIMAL(7,0) NOT NULL, *> `uf` VARCHAR(2) NOT NULL, *> `cidade_id` DECIMAL(5,0) NOT NULL, *> `nomeclog` VARCHAR(64) NOT NULL, *> `bairro_id` VARCHAR(25) NOT NULL, *> `logradouro` VARCHAR(15) NOT NULL, *> `cep` VARCHAR(9) NOT NULL, *> `uf_cod` DECIMAL(5) NOT NULL, *> PRIMARY KEY (`id`), *> INDEX `uf` (`uf`, `cidade_id`, `nomeclog`), *> INDEX `cep` (`cep`), *> INDEX `uf_cod` (`uf_cod`) *>) *>COLLATE='latin1_swedish_ci' *>ENGINE=InnoDB; WORKING-STORAGE SECTION. 77 W-CT1 PIC 9(07). 77 W-CT2 PIC 9(07). 77 W-CT3 PIC 9(07) COMP-5. 77 W-TMP1 PIC 99.99.99. 77 W-TMP2 PIC 99.99.99. 77 W-TMP3 PIC 99.99.99. 77 W-NUEXEC2 PIC 9(02) COMP-5. 77 W-NUEXEC PIC 9(03) COMP-5. 77 W-PACK PIC X(01) COMP-X. 77 W-IGKEY PIC X(01) COMP-X. 77 W-CMD PIC X(64000). 77 W-QRTM PIC 9(09) COMP-5. 77 W-LNG pic 9(9) comp-5. 77 W-TMDIV PIC 9(9) comp-5 VALUE 1. 77 W-TMBUF PIC 9(9) comp-5 VALUE ZEROS. 77 W-DIV PIC X(05) VALUE "|". 77 W-TSTOPEN PIC 9(01) VALUE ZEROS. 88 TESTA-OPEN VALUE 1. 77 W-LIN PIC X(79). 77 W-ARQCEP PIC X(128) VALUE SPACES. 77 W-ARQUIVOS PIC X(256) VALUE SPACES. 01 ESTADO PIC X(02). 88 STAT-ERRO VALUE X"3100" THRU X"3943" X"3945" THRU X"39EE". 88 DUPLICADO VALUE "22". 88 CRIAR-ARQUIVO VALUE X"3335" X"3913". 88 JA-ABERTO VALUE "41" X"398D". 88 REINDEXAR VALUE X"3929" X"3912". 88 ESTA-ABERTO VALUE "12". 88 FOI-CRIADO VALUE "05". 88 NAO-ENCONTRADO VALUE "23". 88 FINAL-ARQUIVO VALUE "10". 88 CHAVE-DUPLICADA VALUE "02". 01 RESTADO REDEFINES ESTADO. 02 ST-K01 PIC X(01). 02 ST-K02 PIC X(01). 02 RST-K02 REDEFINES ST-K02. 03 ST-ERR PIC 9(02) COMP-X. 01 ASS-REG. 02 ASS-ID PIC S9(07). *> Código do registro 02 ASS-UF PIC X(02). *> Código da UF 02 ASS-CCD PIC S9(05). *> Código da cidade 02 ASS-LOG PIC X(64). *> Logradouro 02 ASS-BAI PIC X(25). *> Bairro 02 ASS-TLG PIC X(15). *> Tipo de logradouro 02 ASS-CEP PIC X(09). *> C.E.P. 02 ASS-UFC PIC S9(05). *> Código da UF. 01 W-CONEXAO USAGE POINTER. 01 W-CURSOR USAGE POINTER. LOCAL-STORAGE SECTION. LINKAGE SECTION. PROCEDURE DIVISION. PRINCIPAL. *> READY TRACE. DISPLAY ERASE. DISPLAY "Vou abrir arquivos". MOVE Z"@127.0.0.1@3306@root@@test@cadcep" TO W-ARQCEP. OPEN I-O CADCEP. IF ESTADO > "09" DISPLAY "Erro abrindo CADCEP" DISPLAY ESTADO STOP RUN. MOVE 1 TO CEP-ID. READ CADCEP. MOVE ZEROS TO CEP-ID. START CADCEP KEY IS NOT LESS THAN CEP-ID. PERFORM LISTA-CEP. DISPLAY W-CT2. MOVE 1 TO W-QRTM. STRING " ORDER BY `id`" X"00" DELIMITED BY SIZE INTO W-CMD WITH POINTER W-QRTM. CALL "MontaOrder" USING W-CMD. MOVE ZEROS TO CEP-ID. START CADCEP KEY IS NOT LESS THAN CEP-ID. PERFORM LISTA-CEP. DISPLAY W-CT2. DISPLAY "Final -----------------------------------------". CLOSE CADCEP. PERFORM CRIA-ACESSO. PERFORM START-ACESSO. PERFORM LE-ACESSO UNTIL STAT-ERRO. PERFORM FECHA-ACESSO. STOP RUN. LISTA-CEP. MOVE ZEROS TO W-CT2. PERFORM UNTIL ESTADO NOT = ZEROS READ CADCEP NEXT RECORD WITH IGNORE LOCK AT END MOVE "10" TO ESTADO NOT AT END DISPLAY CEP-LOG ADD 1 TO W-CT2 END-READ END-PERFORM. CRIA-ACESSO. MOVE "@127.0.0.1@3306@root@@test@cadcep" TO W-ARQUIVOS. CALL "MysqlConecta" USING W-ARQUIVOS *> Variavel com os parametros para estabelecer a conexão W-CONEXAO *> Retorna handle para encontrar a FCD-AREA da conexão ESTADO. *> Status de retorno START-ACESSO. MOVE 1 TO W-QRTM. STRING "SELECT * FROM cadcep" DELIMITED BY SIZE INTO W-CMD WITH POINTER W-QRTM. CALL "MysqlComando" USING W-CONEXAO *> Handle para recuperar FCD-AREA W-CMD *> Comando a ser executado W-CURSOR *> Handle do retorno do comando W-QRTM *> Tamanho do comando a ser executado ESTADO. *> Status de retorno LE-ACESSO. MOVE ZEROS TO W-QRTM CALL "MysqlRetorna" USING W-CONEXAO *> Handle para recuperar FCD-AREA W-CURSOR *> Endereço estrutura do retorno (cursor) W-QRTM *> Tamanho do buffer sendo retornado ESTADO *> Status de retorno W-CMD *> Buffer contendo o resultado sendo retornado. Ter cuidado no programa MOVE W-CMD TO ASS-REG. DISPLAY ASS-LOG. FECHA-ACESSO. CALL "MysqlLiberaCursor" USING W-CONEXAO W-CURSOR. *> Handle para encontrar a FCD-AREA desta conexão CALL "MysqlDesConecta" USING W-CONEXAO *> Handle para encontrar a FCD-AREA desta conexão W-CURSOR *> Handle das definições para o cursor, pode não vir informado ESTADO.

CADCEP.RAR.

Demo com programas para uso dos recursos basicos do EXTMYSQL.

Instale o MYSQL.

Voce vai encontrar tanto os programas para baixar como as instruções no site Mysql Download.

Fabricante Cobol, Micro Focus :Micro Focus Cobol.

Franco Stringari Pudler, email franco@imediata.com.br