execute ibeblock ExtractProcedures (
    CodeDir varchar(1000) = 'E:\IBEBlocks\' comment 'Path to necessary IBEBlocks',
    CreateAlter varchar(6) = 'CREATE',
    Dialect smallint = 3,
    EmptyBody Boolean = FALSE,
    FileStrm variant)
 as
 begin
    CRLF = ibec_CRLF;
    WriteDDLBlock =
       'execute ibeblock (sName variant, sDDL variant, sInParams variant, sOutParams variant, sSrc variant, FS variant)
    as
       CRLF = ibec_CRLF();
       if (sInParams <> '''') then
          sDDL = sDDL || '' ('' || CRLF || '' '' || ibec_Trim(sInParams) || '')'';  
       if (sOutParams <> '''') then
          sDDL = sDDL || CRLF || ''RETURNS ('' || CRLF || '' '' || ibec_Trim(sOutParams) || '')'';
       sDDL = sDDL || CRLF || ''AS'' || CRLF;
       sDDL = sDDL || sSrc || ''^'';
       ibec_progress(''Writing procedure '' || sName);
       ibec_fs_Writeln(FS, sDDL); ibec_fs_Writeln(FS, ''''); ibec_fs_Writeln(FS, '''');
    end';

    RdbPrecisionExists = TRUE;
    FldTypeFunc = ibec_LoadFromFile(CodeDir || 'FldType.ibeblock');

    sName = ''; sDDL = ''; sInParams = ''; sOutParams = ''; sParam = ''; iPrec = 0;
    if (FileStrm is not null) then
       FS = FileStrm;
    else
       FS = ibec_fs_OpenFile('E:\BlockScript.sql', __fmCreate);

    Stmt = ibec_Concat(
    'select pr.rdb$procedure_name,    ', CRLF,  -- 0
    '       pp.rdb$parameter_name,    ', CRLF,  -- 1
    '       pp.rdb$parameter_type,    ', CRLF,  -- 2
    '       fs.rdb$field_name,        ', CRLF,  -- 3
    '       fs.rdb$field_type,        ', CRLF,  -- 4
    '       fs.rdb$field_length,      ', CRLF,  -- 5
    '       fs.rdb$field_scale,       ', CRLF,  -- 6
    '       fs.rdb$field_sub_type,    ', CRLF,  -- 7
    '       fs.rdb$segment_length,    ', CRLF,  -- 8
    '       fs.rdb$dimensions,        ', CRLF,  -- 9
    '       cr.rdb$character_set_name,', CRLF,  -- 10
    '       co.rdb$collation_name,    ', CRLF,  -- 11
    '       pp.rdb$parameter_number,  ', CRLF,  -- 12
    '       fs.rdb$character_length,  ', CRLF,  -- 13
    '       fs.rdb$default_source     ', CRLF); -- 14

    if (not EmptyBody) then
       Stmt = ibec_Trim(Stmt) || ',' || CRLF || ' pr.rdb$procedure_source' || CRLF;
    else
       sSrc = 'BEGIN' || CRLF || ' EXIT;' || CRLF || 'END';

    if (RdbPrecisionExists) then
       Stmt = ibec_Trim(Stmt) || ',' || CRLF ||
              '        fs.rdb$field_precision' || CRLF;
    Stmt = Stmt ||
    'from rdb$procedures pr'              || CRLF ||
    'left join rdb$procedure_parameters pp on pp.rdb$procedure_name = pr.rdb$procedure_name' || CRLF ||
    'left join rdb$fields fs on fs.rdb$field_name = pp.rdb$field_source'                     || CRLF ||
    'left join rdb$character_sets cr on fs.rdb$character_set_id = cr.rdb$character_set_id'   || CRLF ||
    'left join rdb$collations co on ((fs.rdb$collation_id = co.rdb$collation_id) and'        || CRLF ||
    '                                (fs.rdb$character_set_id = co.rdb$character_set_id))'   || CRLF ||
    'order by pr.rdb$procedure_name, pp.rdb$parameter_type, pp.rdb$parameter_number';

    SetTermWritten = FALSE;

    for execute statement :Stmt into :SPProps
    do
    begin
       if (SetTermWritten = FALSE) then
       begin
          ibec_fs_Writeln(FS, 'SET TERM ^ ;' || CRLF);
          SetTermWritten = TRUE;
       end;
       if (RdbPrecisionExists = TRUE) then
          iPrec = ibec_IIF(EmptyBody = 1, SPProps[15], SPProps[16]);

       SPName = ibec_Trim(SPProps[0]);
       if (sName <> SPName) then
       begin
          if (sDDL <> '') then
             execute ibeblock WriteDDLBlock(sName, sDDL, sInParams, sOutParams, sSrc, FS);

          sName = SPName;
          if (not EmptyBody) then
             sSrc = ibec_Trim(SPProps[15]);
          sDDL = CreateAlter || ' PROCEDURE ' || SPName;
          sInParams = ''; sOutParams = ''; sParam = '';
       end
       if (SPProps[1] is not null) then
       begin
          execute ibeblock FldTypeFunc(SPProps[4], SPProps[7], SPProps[5], SPProps[6], SPProps[8],
                                       SPProps[13], SPProps[16], Dialect)
                  returning_values :sParam;
          sParam = ibec_Trim(SPProps[1]) || ' ' || sParam;
          -- Character Set
          if ((SPProps[4] in (14, 37, 261)) and (SPProps[10] is not null)) then
             sParam = sParam || ' CHARACTER SET ' || ibec_trim(SPProps[10]);
          -- Default Value
          if ((SPProps[14] is not null) and (SPProps[14] <> '')) then
             sParam = sParam || ' DEFAULT ' || ibec_trim(SPProps[14]);
          if (SPProps[2] = 0) then
          begin
             if (sInParams <> '') then
                sInParams = sInParams || ',' || CRLF || ' ';
             sInParams = sInParams || sParam;
          end
          else if (SPProps[2] = 1) then
          begin
             if (sOutParams <> '') then
                sOutParams = sOutParams || ',' || CRLF || ' ';
             sOutParams = sOutParams || sParam;
          end
       end
    end
    if (sDDL <> '') then
       execute ibeblock WriteDDLBlock(sName, sDDL, sInParams, sOutParams, sSrc, FS);

    if (SetTermWritten) then
       ibec_fs_Writeln(FS, 'SET TERM ; ^' || CRLF);

    if (FileStrm is null) then
       ibec_fs_CloseFile(FS);
 end

back to top of page
<< GensExtract.ibeblock | IBEBlock | RunMe.ibeblock >>