.ad 8
.bm 8
.fm 4
.bt $Copyright by SAP AG, 2002$$Page %$
.tm 12
.hm 6
.hs 3
.TT 1 $SQL$Project Distributed Database System$VAK76$
.tt 2 $$$
.TT 3 $$AK_string_columns$1998-12-30$
***********************************************************
.nf
 
 
    ========== licence begin  GPL
    Copyright (C) 2000 SAP AG
 
    This program is free software; you can redistribute it and/or
    modify it under the terms of the GNU General Public License
    as published by the Free Software Foundation; either version 2
    of the License, or (at your option) any later version.
 
    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.
 
    You should have received a copy of the GNU General Public License
    along with this program; if not, write to the Free Software
    Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
    ========== licence end
 
.fo
.nf
.sp
MODULE  : execute_string_opns
=========
.sp
Purpose : semantics analysis for string column opns in
          executing only mode
.CM *-END-* purpose -------------------------------------
.sp
.cp 3
Define  :
 
        PROCEDURE
              a76ex_string_opns (VAR acv : tak_all_command_glob;
                    VAR dmli : tak_dml_info);
 
.CM *-END-* define --------------------------------------
.sp;.cp 3
Use     :
 
&       ifdef TRACE
        FROM
              Test_Procedures : VTA01;
 
        PROCEDURE
              t01int4 (debug : tgg00_Debug;
                    nam      : tsp00_Sname;
                    int      : tsp00_Int4);
 
        PROCEDURE
              t01sname (schicht : tgg00_Debug; nam : tsp00_Sname);
 
        PROCEDURE
              t01buf  (schicht : tgg00_Debug;
                    VAR buf : tak_systembuffer;
                    pos_anf : integer;
                    pos_end : integer);
 
        PROCEDURE
              t01messblock (debug : tgg00_Debug;
                    nam           : tsp00_Sname;
                    VAR m         : tgg00_MessBlock);
 
        PROCEDURE
              t01mess2type (schicht : tgg00_Debug;
                    nam        : tsp00_Sname;
                    mess_type  : tgg00_MessType2);
&       endif
 
      ------------------------------ 
 
        FROM
              AK_universal_semantic_tools : VAK06;
 
        PROCEDURE
              a06rsend_mess_buf (VAR acv : tak_all_command_glob;
                    VAR mblock  : tgg_mess_block;
                    return_req  : boolean;
                    VAR b_err   : tgg_basis_error);
 
      ------------------------------ 
 
        FROM
              AK_error_handling : VAK07;
 
        PROCEDURE
              a07_b_put_error (VAR acv : tak_all_command_glob;
                    b_err   : tgg_basis_error;
                    err_code : tsp_int4);
 
      ------------------------------ 
 
        FROM
              Executing_values : VAK506;
 
        PROCEDURE
              a506fieldvalues (VAR acv : tak_all_command_glob;
                    VAR dmli      : tak_dml_info;
                    VAR frec      : tak_fill_rec;
                    viewkeybuf    : tak_sysbufferaddress;
                    VAR result    : tsp_moveobj;
                    resultBufSize : tsp00_Int4); (* PTS 1115085 *)
 
      ------------------------------ 
 
        FROM
              AK_Lock_Commit_Rollback : VAK52;
 
        PROCEDURE
              a52internal_subtrans (VAR acv : tak_all_command_glob);
 
      ------------------------------ 
 
        FROM
              AK_string_columns : VAK77;
 
        PROCEDURE
              a77convert (VAR acv : tak_all_command_glob;
                    VAR buffer  : tsp_moveobj;
                    column_code : tsp_code_type;
                    pos         : tsp_int4;
                    len         : tsp_int4;
                    is_input    : boolean);
 
        PROCEDURE
              a77efread_epilog (VAR acv : tak_all_command_glob;
                    VAR sysp_arr : tak_syspointerarr);
 
        PROCEDURE
              a77eopen_epilog (VAR acv : tak_all_command_glob;
                    VAR sysp_arr : tak_syspointerarr;
                    m2type       : tgg_message2_type);
 
        PROCEDURE
              a77get_and_close_descr (VAR acv : tak_all_command_glob);
 
        PROCEDURE
              a77eread_epilog (VAR acv : tak_all_command_glob;
                    VAR sysp_arr : tak_syspointerarr;
                    column_code  : tsp_code_type);
 
        PROCEDURE
              a77elength_epilog (VAR acv : tak_all_command_glob;
                    called_by_copy : boolean;
                    column_code    : tsp_code_type;
                    VAR sysp_arr   : tak_syspointerarr);
 
        PROCEDURE
              a77esearch_epilog (VAR acv : tak_all_command_glob;
                    VAR sysp_arr : tak_syspointerarr);
 
        PROCEDURE
              a77replace_descr (VAR acv : tak_all_command_glob;
                    VAR cfd        : tgg_string_filedescr;
                    VAR coldesc_id : tgg_surrogate;
                    cpy_source     : boolean;
                    pos            : tsp_int4);
 
        PROCEDURE
              a77test_and_change_coldesc (VAR acv : tak_all_command_glob;
                    VAR coldesc_id : tgg_surrogate;
                    use_dest_col   : boolean;
                    m2type         : tgg_message2_type);
 
        PROCEDURE
              a77bget_buffer (VAR acv: tak_all_command_glob;
                    colcode : tsp_code_type;
                    pos     : tsp_int4);
 
        PROCEDURE
              a77pget_pattern (VAR acv : tak_all_command_glob;
                    VAR cfd    : tgg_string_filedescr;
                    VAR  vppos : tsp_int4;
                    is_pattern : boolean);
 
        PROCEDURE
              a77get_int4 (VAR acv    : tak_all_command_glob;
                    VAR val4     : tsp_int4;
                    var_part_pos : tsp_int4;
                    len          : tsp_int2);
 
        PROCEDURE
              a77lget_colpos (VAR acv: tak_all_command_glob;
                    var_part_pos : tsp_int4;
                    len          : tsp_int2;
                    cfd          : tgg_string_filedescr;
                    qual         : tak_fs_value_qual);
 
        PROCEDURE
              a77sget_length (VAR acv : tak_all_command_glob;
                    column_code  : tsp_code_type;
                    var_part_pos : tsp_int4;
                    len          : tsp_int2);
 
      ------------------------------ 
 
        FROM
              Codetransformation_and_Coding : VGG02;
 
        VAR
              g02codetables : tgg_code_tables;
 
      ------------------------------ 
 
        FROM
              Kernel_move_and_fill : VGG10;
 
        PROCEDURE
              g10mv  (mod_id      : tsp_c6;
                    mod_intern_num : tsp_int4;
                    source_upb     : tsp_int4;    destin_upb : tsp_int4;
                    VAR source     : tsp_moveobj; source_pos : tsp_int4;
                    VAR destin     : tsp_moveobj; destin_pos : tsp_int4;
                    length         : tsp_int4;
                    VAR e          : tgg_basis_error);
 
      ------------------------------ 
 
        FROM
              RTE-Extension-30: VSP30;
 
        PROCEDURE
              s30map (VAR code_t : tsp_ctable;
                    VAR source   : tsp_moveobj;
                    source_pos   : tsp_int4;
                    VAR destin   : tsp_moveobj;
                    destin_pos   : tsp_int4;
                    length       : tsp_int4);
 
.CM *-END-* use -----------------------------------------
.sp;.cp 3
Synonym :
 
        PROCEDURE
              t01buf;
 
              tsp00_Buf tak_systembuffer
 
.CM *-END-* synonym -------------------------------------
.sp;.cp 3
Author  :
.sp
.cp 3
Created : 1986-07-23
.sp
.cp 3
Version : 2002-03-27
.sp
.cp 3
Release :      Date : 1998-12-30
.sp
***********************************************************
.sp
.cp 10
.fo
.oc _/1
Specification:
 
 
.CM *-END-* specification -------------------------------
.sp 2
***********************************************************
.sp
.cp 10
.fo
.oc _/1
Description:
 
 
.CM *-END-* description ---------------------------------
.sp 2
***********************************************************
.sp
.cp 10
.nf
.oc _/1
Structure:
 
.CM *-END-* structure -----------------------------------
.sp 2
**********************************************************
.sp
.cp 10
.nf
.oc _/1
.CM -lll-
Code    :
 
 
CONST
      c_is_input         = true (* a77convert *);
      c_cpy_source       = true (* a77replace_descr *);
 
 
(*------------------------------*) 
 
PROCEDURE
      a76ex_string_opns (VAR acv : tak_all_command_glob;
            VAR dmli : tak_dml_info);
 
CONST
      c_use_dest_col = true;
 
VAR
      b_err       : tgg_basis_error;
      with_epilog : boolean;
      src_code    : tsp_code_type;
      dst_code    : tsp_code_type;
      old_m2_type : tgg_message2_type;
      rest_len    : tsp_int2;
      column_code : tsp_code_type;
      coldesc_id  : tgg_surrogate;
      coldesc2_id : tgg_surrogate;
      pmbp        : tgg_mess_block_ptr;
      pdbp        : tgg_datapart_ptr;
 
BEGIN
old_m2_type := mm_nil;
b_err       := e_ok;
IF  NOT (acv.a_mblock.mb_type2 in [ mm_read, mm_search,
    mm_length ])
THEN
    a52internal_subtrans (acv);
(*ENDIF*) 
WITH acv DO
    BEGIN
    IF  a_mblock.mb_type = m_column
    THEN
        BEGIN
        CASE a_mblock.mb_type2 OF
            mm_open, mm_fread, mm_fwrite, mm_fnull :
                BEGIN
                CASE a_mblock.mb_type2 OF
                    mm_open :
                        ak76ex_open_col (acv, dmli);
                    mm_fread :
                        ak76ex_fread_col (acv, dmli);
                    mm_fwrite :
                        ak76ex_fwrite_col (acv, dmli);
                    mm_fnull :
                        ak76ex_fnull_col (acv, dmli, with_epilog);
                    END;
                (*ENDCASE*) 
                IF   a_mblock.mb_type2 <> mm_fwrite
                THEN
                    BEGIN
                    WITH a_mblock, mb_data^ DO
                        BEGIN
                        pmbp := @dmli.d_sparr.px[ dmli.d_sparr.pcount ]^.
                              smessblock.mbr_mess_block;
                        pdbp := pmbp^.mb_data;
&                       IFDEF TRACE
                        t01int4 (ak_sem, 'pos_in_parsb', dmli.d_pos_in_parsbuf);
                        t01int4 (ak_sem, 'datalen     ', mb_data_len);
                        t01int4 (ak_sem, 'keylen      ', mbp_keylen);
&                       ENDIF
                        IF  pmbp^.mb_data_len >= dmli.d_pos_in_parsbuf
                        THEN
                            BEGIN
                            rest_len := pmbp^.mb_data_len -
                                  dmli.d_pos_in_parsbuf + 1;
&                           IFDEF TRACE
                            t01int4 (ak_sem, 'pos_in_parsb',
                                  dmli.d_pos_in_parsbuf);
                            t01int4 (ak_sem, 'length      ', rest_len);
                            t01int4 (ak_sem, 'datalen     ', mb_data_len);
                            t01int4 (ak_sem, 'keylen      ', mbp_keylen);
&                           ENDIF
                            g10mv ('VAK76 ',   1,    
                                  pmbp^.mb_data_size, a_mblock.mb_data_size,
                                  pdbp^.mbp_buf, dmli.d_pos_in_parsbuf,
                                  a_mblock.mb_data^.mbp_buf,
                                  mb_data_len + 1, rest_len,
                                  a_return_segm^.sp1r_returncode);
                            mb_data_len  := mb_data_len + rest_len;
                            dmli.d_pos_in_parsbuf := dmli.d_pos_in_parsbuf +
                                  rest_len;
                            END
                        (*ENDIF*) 
                        END;
                    (*ENDWITH*) 
&                   ifdef TRACE
                    t01int4 (ak_sem, 'm.data_len  ',
                          a_mblock.mb_data_len );
&                   endif
                    END;
                (*ENDIF*) 
                END;
            mm_close :
                ak76ex_close_col (acv);
            mm_read, mm_write :
                ak76ex_readwrite_col (acv, dmli.d_sparr,
                      column_code, coldesc_id);
            mm_trunc, mm_length :
                ak76ex_trunclength_col (acv, dmli.d_sparr,
                      column_code, coldesc_id);
            mm_search :
                ak76ex_search_col (acv, dmli.d_sparr,
                      coldesc_id);
            mm_expand :
                ak76ex_expand_col (acv, dmli.d_sparr,
                      coldesc_id);
            mm_copy :
                BEGIN
                ak76ex_copy_col (acv, dmli.d_sparr,
                      src_code, dst_code, coldesc_id, coldesc2_id);
                column_code := dst_code;
                END;
            OTHERWISE
                a07_b_put_error (acv, e_invalid_command, 1);
            END;
        (*ENDCASE*) 
        IF  (a_return_segm^.sp1r_returncode = 0) AND
            (a_mblock.mb_type2 <> mm_close)
        THEN
            BEGIN
            old_m2_type         := a_mblock.mb_type2;
            a_mblock.mb_trns    := @acv.a_transinf.tri_trans;
            IF  (a_mblock.mb_type2 = mm_copy)
                AND (src_code <> dst_code)
            THEN
                BEGIN
                b_err := e_not_implemented
                END
            ELSE
                a06rsend_mess_buf (acv, a_mblock,
                      cak_return_req, b_err);
            (*ENDIF*) 
            END;
        (*ENDIF*) 
        IF  (b_err = e_ok) AND
            (a_return_segm^.sp1r_returncode = 0)
        THEN
            BEGIN
            CASE old_m2_type OF
                mm_fread :
                    a77efread_epilog (acv, dmli.d_sparr);
                mm_fwrite :
                    a77eopen_epilog (acv, dmli.d_sparr, mm_fwrite);
                mm_fnull :
                    BEGIN
                    END;
                mm_open :
                    a77eopen_epilog (acv, dmli.d_sparr, mm_open);
                mm_close :
                    a77get_and_close_descr (acv);
                mm_read :
                    a77eread_epilog (acv, dmli.d_sparr, column_code);
                mm_write, mm_expand, mm_trunc :
                    BEGIN
                    END;
                mm_length, mm_copy :
                    a77elength_epilog (acv, old_m2_type = mm_copy,
                          column_code, dmli.d_sparr);
                mm_search :
                    a77esearch_epilog (acv, dmli.d_sparr);
                OTHERWISE
                    BEGIN
&                   ifdef TRACE
                    t01mess2type (ak_sem, 'mess2_type  ',old_m2_type);
&                   endif
                    END;
                END;
            (*ENDCASE*) 
            (*====== update if column status has changed ===========*)
            IF  acv.a_return_segm^.sp1r_returncode = 0
            THEN
                a77test_and_change_coldesc (acv, coldesc_id,
                      NOT c_use_dest_col, old_m2_type);
            (*ENDIF*) 
            IF  (acv.a_return_segm^.sp1r_returncode = 0) AND
                (old_m2_type = mm_copy)
            THEN
                a77test_and_change_coldesc (acv, coldesc2_id,
                      c_use_dest_col, old_m2_type)
            (*ENDIF*) 
            END
        ELSE
            a07_b_put_error (acv, b_err, 1);
        (*ENDIF*) 
        a_return_segm^.sp1r_function_code := csp1_string_command_fc
        END
    (*ENDIF*) 
    END
(*ENDWITH*) 
END;
 
(*------------------------------*) 
 
PROCEDURE
      ak76ex_fread_col (VAR acv : tak_all_command_glob;
            VAR dmli : tak_dml_info);
 
BEGIN
ak76ex_open_col (acv, dmli);
END;
 
(*------------------------------*) 
 
PROCEDURE
      ak76ex_fwrite_col (VAR acv : tak_all_command_glob;
            VAR dmli      : tak_dml_info);
 
VAR
      column_code : tsp_code_type;
      vppos       : tsp_int4;
      act_p_inf   : integer;
      pmbp        : tgg_mess_block_ptr;
      pdbp        : tgg_datapart_ptr;
 
BEGIN
WITH dmli.d_sparr.px[ 1 ]^.sparsinfo DO
    BEGIN
    p_cnt_infos := p_cnt_infos - 2;
    ak76ex_open_col (acv, dmli);
    CASE (ord (acv.a_mblock.mb_st^[ 1 ].ecol_tab [ 1 ]))
          OF
        0:
            column_code := csp_ebcdic;
        1:
            column_code := csp_ascii;
        2:
            column_code := csp_codeneutral;
        4:
            column_code := csp_unicode;
        OTHERWISE
            column_code := csp_codeneutral;
        END;
    (*ENDCASE*) 
    IF  acv.a_return_segm^.sp1r_returncode = 0
    THEN
        WITH dmli.d_sparr.px [ 1 ]^.sparsinfo DO
            BEGIN
            act_p_inf   := p_cnt_infos + 1;
            p_cnt_infos := p_cnt_infos + 2;
&           ifdef TRACE
            t01int4 (ak_sem, 'act_p_inf   ', act_p_inf);
            t01int4 (ak_sem, 'p_cnt_infos ', p_cnt_infos);
&           endif
            vppos := p_pars_infos [ act_p_inf ].fp_frompos_v1;
            IF  acv.a_return_segm^.sp1r_returncode = 0
            THEN
                BEGIN
                IF  p_pars_infos [ act_p_inf ].fp_movebefore_v1 > 0
                THEN
                    BEGIN
                    pmbp := @dmli.d_sparr.px[ dmli.d_sparr.pcount ]^.
                          smessblock.mbr_mess_block;
                    pdbp := pmbp^.mb_data;
                    g10mv ('VAK76 ',   2,    
                          pmbp^.mb_data_size, acv.a_mblock.mb_data_size,
                          pdbp^.mbp_buf, dmli.d_pos_in_parsbuf,
                          acv.a_mblock.mb_data^.mbp_buf, cgg_rec_key_offset + 1,
                          p_pars_infos [ act_p_inf ].fp_movebefore_v1,
                          acv.a_return_segm^.sp1r_returncode);
                    dmli.d_pos_in_parsbuf := dmli.d_pos_in_parsbuf +
                          p_pars_infos [ act_p_inf ].fp_movebefore_v1;
                    acv.a_mblock.mb_data_len :=
                          acv.a_mblock.mb_data_len +
                          p_pars_infos [ act_p_inf ].fp_movebefore_v1;
                    END;
                (*ENDIF*) 
                a77sget_length (acv, column_code, vppos, 5);
                END;
            (*ENDIF*) 
            WITH dmli.d_sparr.px [ 1 ]^.sparsinfo DO
                vppos := vppos + p_pars_infos[ act_p_inf ].fp_inoutlen_v1;
            (*ENDWITH*) 
            IF  acv.a_return_segm^.sp1r_returncode = 0
            THEN
                a77bget_buffer (acv, column_code, vppos);
            (*ENDIF*) 
            END
        (*ENDWITH*) 
    (*ENDIF*) 
    END
(*ENDWITH*) 
END;
 
(*------------------------------*) 
 
PROCEDURE
      ak76ex_fnull_col (VAR acv : tak_all_command_glob;
            VAR dmli        : tak_dml_info;
            VAR with_epilog : boolean);
 
BEGIN
ak76ex_open_col (acv, dmli);
with_epilog := acv.a_mblock.mb_qual^.mbool;
&ifdef TRACE
t01int4 (ak_sem, 'with epilog ', ord (with_epilog));
&endif
END;
 
(*------------------------------*) 
 
PROCEDURE
      ak76ex_open_col (VAR acv  : tak_all_command_glob;
            VAR dmli        : tak_dml_info);
 
VAR
      dummy_ptr  : tak_sysbufferaddress;
      fillrec    : tak_fill_rec;
 
BEGIN
dummy_ptr := NIL;
WITH acv, fillrec, a_mblock  DO
    BEGIN
    fr_f_no         := 1;
    fr_last_fno     := dmli.d_sparr.px [ 1 ]^.sparsinfo.p_cnt_infos;
    fr_total_leng   := 0;
    fr_leng         := 0;
&   ifdef TRACE
    t01int4 (ak_sem, 'p_cnt_infos ',
          dmli.d_sparr.px [ 1 ]^.sparsinfo.p_cnt_infos);
&   endif
    a506fieldvalues (acv, dmli, fillrec, dummy_ptr,
          mb_data^.mbp_buf, mb_data_size);
&   ifdef TRACE
    mb_qual^.ml_long_qual.lq_data_offset := mb_data_len;
    t01messblock (ak_sem, 'MBLOCK 76ex_', a_mblock);
    t01buf (ak_sem, dmli.d_sparr.px[ dmli.d_sparr.pcount ]^,
          cak_sysbufferoffset + dmli.d_pos_in_parsbuf,
          cak_sysbufferoffset + dmli.d_pos_in_parsbuf + mxsp_c60);
&   endif
    END;
(*ENDWITH*) 
END;
 
(*------------------------------*) 
 
PROCEDURE
      ak76ex_close_col (VAR acv : tak_all_command_glob);
 
BEGIN
a77get_and_close_descr (acv)
END;
 
(*------------------------------*) 
 
PROCEDURE
      ak76ex_readwrite_col (VAR acv : tak_all_command_glob;
            VAR sysp_arr    : tak_syspointerarr;
            VAR column_code : tsp_code_type;
            VAR coldesc_id  : tgg_surrogate);
 
VAR
      vppos : tsp_int4;
      cfd   : tgg_string_filedescr;
 
BEGIN
WITH acv DO
    BEGIN
    vppos := 1;
    a77replace_descr (acv, cfd, coldesc_id,
          NOT c_cpy_source, vppos);
    IF  a_return_segm^.sp1r_returncode = 0
    THEN
        column_code := cfd.codespec;
    (*ENDIF*) 
    vppos := sysp_arr.px[ 1 ]^.sparsinfo.p_pars_infos[ 2 ].fp_frompos_v1;
    IF  a_return_segm^.sp1r_returncode = 0
    THEN
        a77lget_colpos (acv, vppos, 10, cfd, c_startpos);
    (*ENDIF*) 
    vppos := sysp_arr.px[ 1 ]^.sparsinfo.p_pars_infos[ 3 ].fp_frompos_v1;
    IF  a_return_segm^.sp1r_returncode = 0
    THEN
        a77sget_length (acv, cfd.codespec, vppos, 5);
    (*ENDIF*) 
    vppos := vppos + sysp_arr.px[ 1 ]^.sparsinfo.
          p_pars_infos[ 3 ].fp_inoutlen_v1;
    IF  a_return_segm^.sp1r_returncode = 0
    THEN
        IF  a_mblock.mb_type2 = mm_write
        THEN
            a77bget_buffer (acv, cfd.codespec, vppos);
        (*ENDIF*) 
    (*ENDIF*) 
    END
(*ENDWITH*) 
END;
 
(*------------------------------*) 
 
PROCEDURE
      ak76ex_trunclength_col (VAR acv : tak_all_command_glob;
            VAR sysp_arr    : tak_syspointerarr;
            VAR column_code : tsp_code_type;
            VAR coldesc_id  : tgg_surrogate);
 
VAR
      vppos : tsp_int4;
      cfd   : tgg_string_filedescr;
 
BEGIN
WITH acv, a_mblock DO
    BEGIN
    vppos := 1;
    a77replace_descr (acv, cfd, coldesc_id,
          NOT c_cpy_source, vppos);
    IF  a_return_segm^.sp1r_returncode = 0
    THEN
        column_code := cfd.codespec;
    (*ENDIF*) 
    vppos := sysp_arr.px[ 1 ]^.sparsinfo.p_pars_infos[ 2 ].fp_frompos_v1;
    IF  (a_return_segm^.sp1r_returncode = 0)
        AND (mb_type2 = mm_trunc)
    THEN
        BEGIN
        a77lget_colpos (acv, vppos, 10, cfd, c_length4);
        vppos := sysp_arr.px[ 1 ]^.sparsinfo.
              p_pars_infos[ 3 ].fp_frompos_v1;
        WITH a_mblock, mb_qual^.ml_long_qual DO
            lq_data_offset := mb_data_len
        (*ENDWITH*) 
        END
    ELSE
        mb_qual^.ml_long_qual.lq_long_in_file :=
              cfd.str_treeid.fileTfn_gg00 <> tfnShortScol_egg00;
    (*ENDIF*) 
    END
(*ENDWITH*) 
END;
 
(*------------------------------*) 
 
PROCEDURE
      ak76ex_search_col (VAR acv : tak_all_command_glob;
            VAR sysp_arr   : tak_syspointerarr;
            VAR coldesc_id : tgg_surrogate);
 
VAR
      vppos      : tsp_int4;
      is_pattern : boolean;
      cfd        : tgg_string_filedescr;
 
BEGIN
is_pattern := false;
WITH acv, a_mblock DO
    BEGIN
    vppos := 1;
    a77replace_descr (acv, cfd, coldesc_id,
          NOT c_cpy_source, vppos);
    vppos := sysp_arr.px[ 1 ]^.sparsinfo.p_pars_infos[ 2 ].fp_frompos_v1;
    IF  a_return_segm^.sp1r_returncode = 0
    THEN
        a77lget_colpos (acv, vppos, 10, cfd, c_startpos);
    (*ENDIF*) 
    vppos := sysp_arr.px[ 1 ]^.sparsinfo.p_pars_infos[ 3 ].fp_frompos_v1;
    IF  a_return_segm^.sp1r_returncode = 0
    THEN
        a77lget_colpos (acv, vppos, 10, cfd, c_endpos);
    (*ENDIF*) 
    vppos := sysp_arr.px[ 1 ]^.sparsinfo.p_pars_infos[ 4 ].fp_frompos_v1;
    IF  a_return_segm^.sp1r_returncode = 0
    THEN
        BEGIN
        IF  fp_like in
            sysp_arr.px[ 1 ]^.sparsinfo.p_pars_infos [ 4 ].fp_colset
        THEN
            BEGIN
&           ifdef TRACE
            t01sname (ak_sem, 'fclike on   ');
&           endif
            mb_qual^.ml_long_qual.lq_is_pattern := true
            END
        ELSE
            BEGIN
&           ifdef TRACE
            t01sname (ak_sem, 'fclike off  ');
&           endif
            END;
        (*ENDIF*) 
        a77pget_pattern (acv, cfd, vppos,
              mb_qual^.ml_long_qual.lq_is_pattern)
        END;
    (* part2_len is assigned by a77pget_pattern *)
    (*ENDIF*) 
    END
(*ENDWITH*) 
END;
 
(*------------------------------*) 
 
PROCEDURE
      ak76ex_expand_col (VAR acv : tak_all_command_glob;
            VAR sysp_arr   : tak_syspointerarr;
            VAR coldesc_id : tgg_surrogate);
 
VAR
      vppos       : tsp_int4;
      cfd         : tgg_string_filedescr;
      exp_pos     : integer;
      mark_pos    : integer;
 
BEGIN
WITH acv, a_mblock, mb_qual^, ml_long_qual DO
    BEGIN
    vppos := 1;
    a77replace_descr (acv, cfd, coldesc_id,
          NOT c_cpy_source, vppos);
    vppos := sysp_arr.px[ 1 ]^.sparsinfo.p_pars_infos[ 2 ].fp_frompos_v1;
    IF  a_return_segm^.sp1r_returncode = 0
    THEN
        BEGIN
        lq_long_in_file := cfd.str_treeid.fileTfn_gg00 <> tfnShortScol_egg00;
        a77get_int4 (acv, lq_long_size, vppos, 10);
        IF  lq_long_size < 1
        THEN
            a07_b_put_error (acv, e_st_invalid_length, 1)
        (*ENDIF*) 
        END;
    (*ENDIF*) 
    vppos := sysp_arr.px[ 1 ]^.sparsinfo.p_pars_infos[ 3 ].fp_frompos_v1;
    IF  a_return_segm^.sp1r_returncode = 0
    THEN
        BEGIN
        IF  cfd.codespec = csp_unicode
        THEN
            a07_b_put_error (acv, e_not_implemented, 1)
        ELSE
            IF  (cfd.codespec in [ csp_ascii, csp_ebcdic ])
                AND (a_out_packet^.sp1_header.sp1h_mess_code in
                [csp_unicode, csp_unicode_swap])
            THEN
                BEGIN
                IF  (a_out_packet^.sp1_header.sp1h_mess_code
                    = csp_unicode)
                THEN
                    BEGIN
                    mark_pos := vppos + 1;
                    exp_pos  := vppos + 2;
                    END
                ELSE
                    BEGIN
                    mark_pos := vppos + 2;
                    exp_pos  := vppos + 1;
                    END;
                (*ENDIF*) 
                IF  a_data_ptr^ [mark_pos] <> csp_unicode_mark
                THEN
                    a07_b_put_error (acv, e_not_implemented, 1)
                ELSE
                    BEGIN
                    IF  cfd.codespec = csp_ebcdic
                    THEN
                        s30map (g02codetables.tables[ cgg_to_ebcdic ],
                              a_data_ptr^, exp_pos,
                              a_data_ptr^, exp_pos, 1);
                    (*ENDIF*) 
                    mb_qual^.ml_long_qual.lq_expand_char [1] :=
                          a_data_ptr^ [exp_pos];
                    END;
                (*ENDIF*) 
                END
            ELSE
                BEGIN
                a77convert (acv, a_data_ptr^, cfd.codespec,
                      vppos + 1, 1, c_is_input);
                mb_qual^.ml_long_qual.lq_expand_char [1] :=
                      a_data_ptr^ [vppos + 1];
                END;
            (*ENDIF*) 
        (*ENDIF*) 
        END
    (*ENDIF*) 
    END
(*ENDWITH*) 
END;
 
(*------------------------------*) 
 
PROCEDURE
      ak76ex_copy_col (VAR acv : tak_all_command_glob;
            VAR sysp_arr    : tak_syspointerarr;
            VAR src_code    : tsp_code_type;
            VAR dst_code    : tsp_code_type;
            VAR coldesc_id  : tgg_surrogate;
            VAR coldesc2_id : tgg_surrogate);
 
VAR
      vppos   : tsp_int4;
      src_cfd : tgg_string_filedescr;
      dst_cfd : tgg_string_filedescr;
 
BEGIN
WITH acv, a_mblock, mb_qual^, mcl_copy_long DO
    BEGIN
    dst_code := csp_ascii;
    vppos    := 1;
    a77replace_descr (acv, src_cfd, coldesc_id,
          c_cpy_source, vppos);
    IF  a_return_segm^.sp1r_returncode = 0
    THEN
        BEGIN
        src_code := src_cfd.codespec;
        mcl_copy_long.lcq_src_tabid := mtree.fileTabId_gg00;
        END;
    (*ENDIF*) 
    vppos := sysp_arr.px[ 1 ]^.sparsinfo.p_pars_infos[ 2 ].fp_frompos_v1;
    IF  a_return_segm^.sp1r_returncode = 0
    THEN
        BEGIN
        a77replace_descr (acv, dst_cfd, coldesc2_id,
              NOT c_cpy_source, vppos);
        IF  a_return_segm^.sp1r_returncode = 0
        THEN
            dst_code := dst_cfd.codespec;
        (*ENDIF*) 
        vppos := sysp_arr.px[ 1 ]^.sparsinfo.p_pars_infos[ 3 ].fp_frompos_v1;
        END;
    (*ENDIF*) 
    IF  a_return_segm^.sp1r_returncode = 0
    THEN
        BEGIN
        lcq_src_long_in_file := src_cfd.str_treeid.fileTfn_gg00
              <> tfnShortScol_egg00;
        a77get_int4 (acv, lcq_src_pos, vppos, 10);
        IF  src_code = csp_unicode
        THEN
            lcq_src_pos := (lcq_src_pos * 2) - 1;
        (*ENDIF*) 
        IF  lcq_src_pos <= 0
        THEN
            a07_b_put_error (acv, e_st_invalid_startpos, 1)
        (*ENDIF*) 
        END;
    (*ENDIF*) 
    vppos := sysp_arr.px[ 1 ]^.sparsinfo.p_pars_infos[ 4 ].fp_frompos_v1;
    IF  a_return_segm^.sp1r_returncode = 0
    THEN
        BEGIN
        lcq_dest_long_in_file := dst_cfd.str_treeid.fileTfn_gg00 <> tfnShortScol_egg00;
        a77get_int4 (acv, lcq_dest_pos, vppos, 10);
        IF  dst_code = csp_unicode
        THEN
            lcq_dest_pos := (lcq_dest_pos * 2) - 1;
        (*ENDIF*) 
        IF  lcq_dest_pos < (-1)
        THEN
            a07_b_put_error (acv, e_st_invalid_destpos, 1)
        (*ENDIF*) 
        END;
    (*ENDIF*) 
    vppos := sysp_arr.px[ 1 ]^.sparsinfo.p_pars_infos[ 5 ].fp_frompos_v1;
    IF  a_return_segm^.sp1r_returncode = 0
    THEN
        BEGIN
        a77get_int4 (acv, lcq_len, vppos, 10);
        IF  src_code = csp_unicode
        THEN
            lcq_len := lcq_len * 2;
        (*ENDIF*) 
        IF  lcq_len < (-1)
        THEN
            a07_b_put_error (acv, e_st_invalid_length, 1)
        (*ENDIF*) 
        END;
    (*ENDIF*) 
    END
(*ENDWITH*) 
END;
 
.CM *-END-* code ----------------------------------------
.SP 2 
***********************************************************
*-PRETTY-*  statements    :        208
*-PRETTY-*  lines of code :        674        PRETTYX 3.10 
*-PRETTY-*  lines in file :        984         1997-12-10 
.PA 
