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

簡単な、ファイル書庫archiveを紹介します。

archive [dptux] archive-file file ...
   d-delete fileを削除する
   p-print fileを標準出力に書き出す
   t-table archive-fileの一覧を書き出す
   u-update fileを更新または追加する
   x-extract fileを取り出す

ファイル書庫の形式は以下のとおり。

file1 header
file1
file2 header
file2
 .
 .
 .

file headerは、ファイル名、ファイル書庫内のファイル長さです(ファイルの実際の長さでないことに注意)。

archive本体から紹介します。

RATFOR版は下記の通り。

# archive.r4 -- file nameger
      character aname(NAMESIZE)
      integer getarg
      character comand(2)
      
      call initfile()

      if ((getarg(1,comand,2) == EOF)
     1    | (getarg(2,aname,NAMESIZE) == EOF))
         call help
      call getfns()
      
      if (comand(1) == UPD)
          call update(aname)
      else if (comand(1) == TBL)
          call table(aname)
      else if ((comand(1) == EXTR | (comand(1) == PRINT)
          call extrac(aname,comand(1))
      else if (comand(1) == DEL)
          call delete(aname)
      else
          call help()
      end if
      stop
      end

何か間違いがあれば、helpテキストを表示します。 WATCOM Fortran77版は、下記の通り。

c archive -- file nameger
      program archive
      integer*1 aname(81)               ! NAMESIZE(81)
      integer getarg
      integer*1 comand(2)
      
      call initfile()
      if ((getarg(1,comand,2) .eq. -1)  ! ERR(-1)
     1    .or. (getarg(2,aname,81) .eq. -1)) then ! NAMESIZE(81) ERR(-1)
         call help()
      end if
      call getfns()
      if (comand(1) .eq. 117) then      ! UPD(LETU)
          call update(aname)
      else if (comand(1) .eq. 116) then ! TBL(LETT)
          call table(aname)
      else if ((comand(1) .eq. 120)     ! EXTR(LETE)
     1  .or.   (comand(1) .eq. 112)) then ! PRINT(LETP)
          call extrac(aname,comand(1))
      else if (comand(1) .eq. 100) then ! DEL(LETD)
          call delete(aname)
      else
          call help()
      end if
      stop
      end

ヘルプを書き出すhelp()サブルーチンは下記の通り。

RATFOR版。

# help.r4 -- diagnostic printout
      subroutine help

      call error('usage: archive { dptux } archname [files].')
      return
      end

WATCOM Fortran77版。

c help.for -- diagnostic printout
      subroutine help

      call error('usage: archive { dptux } archname [files].')
      return
      end

コマンドラインの引数のうちfile名を処理するgetfns()サブルーチンを示します。このサブルーチンは、引数にあるファイル名を取り出し、重複がないか確認し、処理フラグをリセットします。

RATFOR版は次の通り。

# getfns.r -- get file names into fname, check for duplicates
      subroutine getfns
      integer equal,getarg
      integer i,j
      integer*1 junk(2)

      include carch.ri

      errcnt = 0
      for (i = 1; i <= MAXFILES; i = i + 1)
          if (getarg(i+2,fname(1,i),NAMESIZE) == EOF)
              break
      nfiles = i - 1

      if (i > MAXFILES)
          if (getarg(i+2,junk,2) != EOF)
              call error('too many files.')
      for (i = 1; i <= nfiles; i = i + 1)
          fstat(i) = NO
      for (i = 1, i < nfiles; i = i + 1)
          for (j = i+1; j <= nfiles; j = j + 1)
              if (equal(fname(1,i),fname(1,j)) == YES) {
                  call putlin(fname(1,i),ERROUT)
                  call error(': duplicate file name.')
                  }
      return
      end

WATCOMM Fortran77版は下記の通り。

c getfns.f -- get file names into fname, check for duplicates
      subroutine getfns
      integer equal,getarg
      integer i,j
      integer*1 junk(2)

      include carch.fi

      errcnt = 0
      i = 1
      while ( i .le. 20 ) do            ! MAXFILES(20)
          if (getarg(i+2,fname(1,i),81) .eq. -1) then ! NAMESIZE(81) ERR(-1)
              exit
          end if
          i = i + 1
      end while
      nfiles = i - 1
      if (i .gt. 20) then               ! MAXFILES(20)
          if (getarg(i+2,junk,2) .ne. -1) then ! ERR(-1)
              call error('too many files.')
          end if
      end if
      i = 1
      while (i .le. nfiles) do
          fstat(i) = 0                 ! NO(0)
          i = i + 1
      end while
      i = 1
      while (i .lt. nfiles) do
          j = i + 1
          while (j .le. nfiles) do
              if (equal(fname(1,i),fname(1,j)) .eq. 1) then ! YES(1)
                  call putlin(fname(1,i),6) ! ERROUT(6)
                  call error(': duplicate file name.')
              end if
              j = j + 1
          end while
          i = i + 1
      end while
      return
      end

いずれの版でも、commonファイルをインクルードします。ファイルのインクルードには、先に作ったincludeを使います。インクルードされるファイルは以下の通り。

RATFOR版。

# carch.ri -- common definiton of archive
      common /carch/fname(NAMESIZE,MAXFILES),fstat(MAXFILES),nfiles,errcnt
      character fname    ! file arguments
      integer fstat      ! YES if touched, NO otherwise; init = NO
      integer nfiles     ! number of file arguments
      integer errcnt     ! error count; init = 0

WATCOM Fortran77版。

c carch.fi -- common definiton of archive
      common /carch/fname(81,20),fstat(20),nfiles,errcnt
      integer*1 fname    ! file arguments
      integer fstat      ! YES if touched, NO otherwise; init = NO
      integer nfiles     ! number of file arguments
      integer errcnt     ! error count; init = 0

その他の下請けルーチンについては次回説明します。