アナクロなコンピューターエンジニアのつぶやき

書庫の内容を書き出すextrac()、ファイルを削除するdelete()、 ファイルを更新するreplac()を紹介します。

extrac()は、書庫を開き、書庫内の各ファイルについて、引数のファイルと一致する ならば、ファイルを取り出します。

extrac()のRATFOR版は以下の通り。

# extrac.r -- extract files from archive
      subroutine extrac(aname,cmd)
      integer*1 aname(NAMESIZE),cmd

      integer*1 ename(NAMESIZE),in(MAXLINE)
      integer fcreate,filarg,gethdr,fopen,fc
      integer afd,efd,size

      include carch.fi
      
      if (fopen(afd,aname,READ) == ERR)
          call cant(aname)

      if (cmd == PRINT)
          efd = STDOUT
      else
          efd = ERR
      while (gethdr(afd,in,ename,size) != EOF)
          if (filarg(ename) == NO)
              call fskip(afd,size)
          else {
              if(efd != STDOUT)
                  efd = fcreate(ename)
              if (efd == ERR) {
                  call putlin(ename,STDOUT)
                  call remark(': can not create.')
                  errcnt = errcnt + 1
                  call fskip(afd,size)
                  }
              else {
                  call acopy(afd,efd,size)
                  if (efd != STDOUT)
                      call fclose(efd)
                  }
              }
      call notfnd
      return
      end

WATCOM fortran77版は、以下の通り。

c extrac -- extract files from archive
      subroutine extrac(aname,cmd)
      integer*1 aname(81),cmd           ! NAMESIZE(81)
      integer*1 ename(81),in(81)        ! NAMESIZE(81) MAXLINE(81)
      integer fcreate,filarg,gethdr,fopen
      integer afd,efd,size

      include carch.fi
      
      if (fopen(afd,aname,82) .eq. -1) then ! READ(LETR) ERR(-1)
          call cant(aname)
      end if

      if (cmd .eq. 112) then            ! PRINT(LETP)
          efd = 6                       ! STDOUT(6)
      else
          efd = -1                      ! ERR(-1)
      end if

      while (gethdr(afd,in,ename,size) .ne. -1) do ! EOF(-1)
          if (filarg(ename) .eq. 0) then ! NO(0)
              call fskip(afd,size)
          else
              if(efd .ne. 6) then       ! STDOUT(6)
                  if (fcreate(ename) .eq. -1) then ! ERR(-1)
                      call putlin(ename,6)         ! STDOUT(6)
                      call remark(': can not create.')
                      errcnt = errcnt + 1
                      call fskip(afd,size)
                  else
                      efd = fopen(efd,ename,87) ! WRITE(LETW)
                  end if
              end if
              call acopy(afd,efd,size)
              if (efd .ne. 6) then      ! STDOUT(6)
                  call fclose(efd)
              end if
          end if
      end while
      call notfnd
      return
      end

acopy()は、size文字分、fdiからfdoに書き出します。

RATFOR版は下記の通り。

# acopy.r4 -- copy size characters from fdi to fdo
      subroutine acopy(fdi,fdo,size)
      integer fdi,fdo,size
      
      integer*1 fgetc,c
      integer i
      
      for (i = 1; i <= size; i = i + 1) {
          if (fgetc(fdi,c) == EOF)
              break
          call fputc(fdo,c)
          }
      return
      end

WATCOM Fortran77版は下記の通り。

c acopy.for -- copy size characters from fdi to fdo
      subroutine acopy(fdi,fdo,size)
      integer fdi,fdo,size
      integer*1 fgetc,c
      integer i

      i = 1
      while (i .le. size) do
          if (fgetc(fdi,c) .eq. -1) then ! EOF(-1)
              exit
          end if
          call fputc(fdo,c)
          i = i + 1
      end while
      return
      end

書庫からファイルを削除するdelete()は、ファイルの指定がなかった場合、 警告を出し実行を打ち切ります。

RATFOR版は下記の通り。

# delete.r -- delete files from archive
      subroutine delete(aname)
      character aname(ARB)
      integer fcreate,fopen,afd,tfd

      include carch.ri

      string tname "archtemp"

      if (nfiles < 0 ) then             # protect innocents
          call error('delete by name only.')
      end if
      
      if (fopen(afd,aname,READWRITE) == ERR)
          call cant(aname)
      if (fcreate(tname) == ERR)
          call cant(tname)
      if (fopen(tfd,tname,READWRITE) == ERR)
          call cant(tname)
      
      call replace(afd,tfd,DEL,errcnt)
      call notfnd
      call fclose(afd)
      call fclose(tfd)
      if (errcnt = 0) then
          call amove(tname,aname)
      else
          call remark('fatal errors -- archive not altered.')
      end if
      call fremove(tname)
      return
      end

WATCOM Fortran77版は下記の通り。

c delete.f -- delete files from archive
      subroutine delete(aname)
      integer*1 aname(81)               ! NAMESIZE(81)
      integer fcreate,fopen,afd,tfd

      include carch.fi

      integer*1 tname(9)
      data tname/'a','r','c','h','t','e','m','p',-2/

      if (nfiles .le. 0 ) then          ! protect innocents
          call error('delete by name only.')
      end if
      if (fopen(afd,aname,66) .eq. -1) then ! READWRITE(LETB) ERR(-1)
          call cant(aname)
      end if
      if (fcreate(tname) .eq. -1) then  ! ERR(-1)
          call cant(tname)
      endif
      if (fopen(tfd,tname,66) .eq. -1) then ! READWRITE(LETB) ERR(-1)
          call cant(tname)
      end if
      call replac(afd,tfd,100,errcnt) ! DEL(LETD)
      call notfnd
      call fclose(afd)
      call fclose(tfd)
      if (errcnt .eq. 0) then
          call amove(tname,aname)
      else
          call remark('fatal errors -- archive not altered.')
      end if
      call fremove(tname)
      return
      end

最後にreplac()は、ファイルの更新、または、削除をします。

RATFOR版は下記の通り。

# replac.r4 -- replace or delete files
      subroutine replace(afd,tfd,cmd,errcnt)
      integer afd,tfd,errcnt
      character cmd

      character in(MAXLINE),uname(NAMESIZE)
      integer size,filarg,gethdr

      while (gethdr(afd,in,uname,size) != EOF)
          if (filarg(uname) == YES) {
              if (cmd .eq. UPD)
                  call addfil(uname,tfd,errcnt)
              call fskip(afd,size)
              }
          else {
              call putlin(in,tfd)
              call acopy(afd,tfd,size)
              }
      return
      end

WATCOM Fortran77版は下記の通り。

c replac.for -- replace or delete files
      subroutine replac(afd,tfd,cmd,errcnt)
      integer afd,tfd,errcnt
      integer*1 cmd
      integer*1 in(81),uname(81)        ! MAXLINE(81) NAMESIZE(81)
      integer size
      integer filarg,gethdr

      while (gethdr(afd,in,uname,size) .ne. -1) do ! EOF(-1)
          if (filarg(uname) .eq. 1) then ! YES(1)
              if (cmd .eq. 117) then    ! UPD(LETU)
                  call addfil(uname,tfd,errcnt)
              end if
              call fskip(afd,size)
          else
              call putlin(in,tfd)
              call acopy(afd,tfd,size)
          end if
      end while
      return
      end