You must be logged in to use the copy button.

        
**Free
ctl-opt
   copyright('Copyright JAS, Inc. 2024')
   nomain debug
   option(*srcstmt : *nodebugio ) ccsid(*char:*jobrun)
   decedit(*jobrun) alwnull(*usrctl);

//***********************************************************************************
//  PURPOSE: This application will check IFS object existence, read, write or execute
// **********************************************************************************
//  COMPILE Module: CRTRPGMOD MODULE(*CURLIB/JSIFSTOOL) SRCFILE(*CURLIB/QRPGLESRC)
//                  SRCMBR(JSIFSTOOL) DBGVIEW(*SOURCE) REPLACE(*YES)
//  COMPILE SrvPgm: CRTSRVPGM SRVPGM(*CURLIB/JSIFSTOOL) EXPORT(*ALL) ACTGRP(*CALLER)
//  Bindding Dir:   ADDBNDDIRE BNDDIR(JASTOOL) OBJ((JSIFSTOOL))
// **********************************************************************************
dcl-pr ifs_FileUnLink int(10) extProc('unlink');
  p_Path       pointer value options(*string);
end-pr;

dcl-pr ifs_FileWrite int(10) extProc('write');
   p_Handle             int(10) value;
   p_Buffer             pointer value;
   p_FileSize           int(10) value;
end-pr;

//*****************************************************************************
/define ifs_Create_File_PR
/copy qProtosrc,JSIFSTOOL

/define ifs_Write_File_PR
/copy qProtosrc,JSIFSTOOL
//*****************************************************************************
dcl-proc ifs_Create_File export;
/define ifs_Create_File_PI
/copy qProtosrc,JSIFSTOOL

  dcl-c O_WRONLY   const(2);        // Write only
  dcl-c O_CREAT    const(8);        // Create File if needed
  dcl-c O_CODEPAGE const(8388608);  // Assign a code page
  dcl-c O_TEXTDATA const(16777216); // Open in text-mode

  dcl-c S_IRUSR    const(256);      // owner authority
  dcl-c S_IWUSR    const(128);      // owner authority
  dcl-c S_IRGRP    const(32);       // group authority
  dcl-c S_IROTH    const(4);        // other people

  dcl-s w_FileHandle int(10)      inz(0);
  dcl-s w_Flags      int(10)      inz(0);
  dcl-s w_Mode       int(10)      inz(0);
  dcl-s w_File       like(P_FILE) inz;

  w_File  = %trim(p_Directory) + '/' + %trim(P_FILE);

  // remove the file if exist
  callp(e) ifs_FileUnLink(%trim(w_File));

  w_Flags = O_WRONLY + O_CREAT + O_CODEPAGE;
  w_Mode  = S_IRUSR + S_IWUSR + S_IRGRP + S_IROTH;

  w_FileHandle  = ifs_FileOpen(%trim(w_File) :w_Flags: w_Mode :819);
  callp ifs_FileClose(w_FileHandle);

  // re-Open since Code is 819. This allow iSeries to deal with it
  // This avoids extra coding for ASCII format
  w_FileHandle  = ifs_FileOpen(%trim(w_File) :O_WRONLY+O_TEXTDATA);

  return w_FileHandle;
end-proc;

//****************************************************************************
dcl-proc ifs_Write_File export;
/define ifs_Write_File_PI
/copy qProtosrc,JSIFSTOOL

   dcl-c cCRLF const(x'0d25');
   dcl-c cTab  const(x'05');

   dcl-s w_data      like(p_Data)      inz;
   dcl-s w_Delimiter like(p_Delimiter) inz(',');
   dcl-s w_cnt       zoned(3)          inz;
   dcl-s w_Rtn       ind               inz(*off);
   dcl-s w_EOL       char(2)           inz;

   if p_FileHandle >= 0;
     if %parms >= 3 and %addr(p_Delimiter) <> *null
                    and %trim(p_Delimiter) <> *blanks;
       w_Delimiter = %trim(p_Delimiter);
     endIf;

     w_Cnt = %len(%trim(w_Delimiter));
     w_Data = %trim(p_Data);

     // if there is a tab char on the end remove it
     if %len(%trim(p_Data)) <= w_Cnt;
       w_Cnt = 0;
     endif;

     if %subst(w_Data: %len(%trimr(p_Data))-w_Cnt :1) = cTab;
       w_Data = %subst(w_Data: 1 :%len(%trimr(p_Data))-w_Cnt); // remove the last tab
     endIf;

     callp(e) ifs_FileWrite(p_FileHandle :%addr(w_Data)
                                         :%Len(%trim(w_Data)) );
     if not %Error;
       w_Rtn = *on;
     endif;

     // Return if not End of Line is specified
     if %parms >= %parmnum(P_NOEOL) and P_NOEOL = *on;
       return w_Rtn;
     endif;

     w_EOL = cCRLF;           // Write the end-of-line chars
     callp(e) ifs_FileWrite(p_FileHandle :%addr(w_EOL) :2 );
   endif;

   return w_Rtn;
end-proc;