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

archiveのファイルの追加、更新を受け持つupdatre()を紹介します。

update()は、replac()で書庫の内容を一時ファイルに書き写し、その後、 指定されたファイルすべてについて、addfil()でファイルを追加します。 最後に、一連の処理でエラーがなければ、amove()で書庫を一時ファイルで上書きします。

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

# update.f -- update existing files, add new ones at end
      subroutine update(aname)
      character aname(NAMESIZE)
      integer fcreate,fopen
      integer afd,i,tfd
      include carch.ri
      string tname "archtemp"

      if (fopen(afd,aname,READWRITE) == ERR)
          if (fcreate(aname) == ERR)
              call cant(aname)
          afd = fopen(afd,aname,READWRITE)
      if (fcreate(tname) == ERR)
          call cant(tname)
      if (fopen(tfd,tname,READWRITE) == ERR)
          call cant(tname)
      call replac(afd,tfd,UPD,errcnt)
      for (i = 1; i <= nfiles; i = i + 1)
          if (fstat(i) == NO) {
              call addfil(fname(1,i),tfd,errcnt)
              fstat(i) = YES
              }
      call fclose(afd)
      call fclose(tfd)
      if (errcnt == 0) then
          call amove(tname,aname)
      else
          call remark('fatal errors - archive not altered.')
      call fremove(tname)
      return
      end

WATCOM fortran77版は、以下の通り。

c update.f -- update existing files, add new ones at end
      subroutine update(aname)
      integer*1 aname(81)               ! NAMESIZE(81)
      integer fcreate,fopen
      integer afd,i,tfd
      
      include carch.fi

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

      if (fopen(afd,aname,66) .eq. -1) then ! READWRITE(LETB) ERR(-1)
                                        ! maybe it's new one
          if (fcreate(aname) .eq. -1) then ! ERR(-1)
              call cant(aname)
          endif
          afd = fopen(afd,aname,66)     ! READWRITE(LETB)
      endif
      if (fcreate(tname) .eq. -1) then  ! ERR(-1)
          call cant(tname)
      else if (fopen(tfd,tname,66) .eq. -1) then ! READWRITE(LETB) ERR(-1)
          call cant(tname)
      end if
      call replac(afd,tfd,117,errcnt)   ! UPD(LETU)
      i = 1
      while (i .le. nfiles) do
          if (fstat(i) .eq. 0) then     ! NO(0)
              call addfil(fname(1,i),tfd,errcnt)
              fstat(i) = 1              ! YES(1)
          end if
          i = i + 1
      end while
      call fclose(afd)
      call fclose(tfd)
      if (errcnt .eq. 0) then
          call amove(tname,aname)
      else
          call remark('fatal errors - archive not altered.')
      endif
      call fremove(tname)
      return
      end

update()の中で、fremove()はfcreate()の逆で、ファイルを削除します。 fremove()は下記の通り。

c fremove.for -- remove a file, file must be open once as read mode
      subroutine fremove(fn)
      integer*1 fn(81)                  ! NAMESIZE(81)
      integer uid
      integer fopen

      uid = fopen(uid,fn,82)            ! READ(LETR)
      close(unit=uid,status='delete')
      return
      end

amove()のRATFOR版は下記の通り。

# amove.r4 -- move name1 to name2
      subroutine amove(name1,name2)
      character name1(ARB),name2(ARB)
      integer fd1,fd2
      integer fopen,fcreate

      if (fopen(fd1,name1,READ) == ERR)
          call cant(name1)
      if (fcreate(name2) == ERR)
          call cant(name2)
      if (fopen(fd2,name2,WRITE) == ERR)
          call cant(name2)
      call fcopy(fd1,fd2)
      call fclose(fd1)
      call fclose(fd2)
      return
      end

WATCOM fortran77版は下記の通り。

c amove.for -- move name1 to name2
      subroutine amove(name1,name2)
      integer*1 name1(*),name2(*)       ! ARB(*)
      integer fd1,fd2
      integer fopen,fcreate

      if (fopen(fd1,name1,82) .eq. -1) then ! READ(LETR) ERR(-1)
          call cant(name1)
      end if
      if (fcreate(name2) .eq. -1) then  ! ERR(-1)
          call cant(name2)
      end if
      if (fopen(fd2,name2,87) .eq. -1) then ! WRITE(LETW) ERR(-1)
          call cant(name2)
      end if
      call fcopy(fd1,fd2)
      call fclose(fd1)
      call fclose(fd2)
      return
      end

addfil()は、指定されたファイルを開け、ヘッダーを作り、一時ファイルに 追加します。

RATFOR版は下記の通り。

# addfil.r4 -- add file name to erchive
      subroutine addfil(name,fd,errcnt)
      character name(ARB)
      integer fd,errcnt
      character head(MAXLINE)
      integer fopen,nfd

      if (fopen(nfd,name,READ) {
          call putlin(nale,ERROUT)
          call remark(': can not add.')
          errcnt = errcnt + 1
          }
      if (errcnt == 0) {
          call makhdr(name,head)
          call putlin(head,fd)
          call fcopy(nfd,fd)
          call fclose(nfd)
          }
      return
      end

WATCOM Fortran77版は下記の通り。

c addfil.for -- add file name to erchive
      subroutine addfil(name,fd,errcnt)
      integer*1 name(*)                 ! ARB(*)
      integer fd,errcnt
      integer*1 head(81)                ! MAXLINE(81)
      integer fopen,nfd

      if (fopen(nfd,name,82) .eq. -1) then ! READ(LETR) ERR(-1)
          call putlin(name,6)           ! ERROUT(6)
          call remark(': can not add.')
          errcnt = errcnt + 1
      end if
      if (errcnt .eq. 0) then
          call makhdr(name,head)
          call putlin(head,fd)
          call fcopy(nfd,fd)
          call fclose(nfd)
      end if
      return
      end

ヘッダーを作るのは、makhdr()が行います。

RATFOR版は下記の通り。

# makhdr.r4 -- make header line for archive member
      subroutine makhdr(name,head)
      character name(NAMESIZE),head(MAXLINE)
      integer fsize,itoc,length
      integer i
      string hdr "-h-"
      
      call scopy(hdr,1,head,1)
      i = length(hdr) + 1
      head(i) = BLANK
      call scopy(name,1,head,i+1)
      i = length(head) + 1
      head(i) = BLANK
      i = i + 1  + itoc(fsize(name),head(i+1),MAXCHARS)
      head(i) = NEWLINE
      head(i+1) = EOS
      return
      end

WATCOM Fortran77版は下記の通り。

c makhdr.for -- make header line for archive member
      subroutine makhdr(name,head)
      integer*1 name(81),head(81+1)     ! NAMESIZE(81) MAXLINE(81)
      integer fsize,itoc,length
      integer i
      integer*1 hdr(4)
      data hdr/'-','h','-',-2/
      
      call scopy(hdr,1,head,1)
      i = length(hdr) + 1
      head(i) = 32                      ! BLANK(32)
      call scopy(name,1,head,i+1)
      i = length(head) + 1
      head(i) = 32                      ! BLANK(32)
      i = i + 1  + itoc(fsize(name),head(i+1),81) ! MAXCHARS(81)
      head(i) = 10                      ! NEWLINE(10)
      head(i+1) = -2                    ! EOS(-2)
      return
      end

scopy()は、文字列をコピーします。

RATFOR版は、下記の通り。

# scopy.r4 -- copy string at from(i) to to(j)
      subroutine scopy(from,i,to,j)
      character from(ARB),to(ARB)
      integer i,j
      integer k1,k2

      k2 = j
      for (k1 = i; from(k1) != EOS; k1 = k1 +1) {
          to(k2) = from(k1)
          k2 = k2 + 1
          }
      to(k2) = EOS
      return
      end

WATCOM Fortran77版は、下記の通り。

c scopy.for -- copy string at from(i) to to(j)
      subroutine scopy(from,i,to,j)
      integer*1 from(*),to(*)           ! ARB(*)
      integer i,j
      integer k1,k2

      k2 = j
      k1 = i
      while (from(k1) .ne. -2) do       ! EOF(-2)
          to(k2) = from(k1)
          k2 = k2 + 1
          k1 = k1 + 1
      end while
      to(k2) = -2                       ! EOS(-2)
      return
      end

fsize()はファイルの文字数(ファイルのサイズではないことに注意)を 計算します。

RATFOR版は下記の通り。

# fsize.r4 -- size of file in characters
      integer function fsize(name)
      character name(ARB)
      character fgetc,c
      integer fd,fopen

      if (fopen(fd,name,READ) == ERR)
          fsize = ERR
      else {
          fsize = 0
          while (fgetc(fd,c) != EOF)
              fsize = fsize + 1
          call fclose(fd)
          }
      return
      end

WATCOM Fortran77版は下記の通り。

c fsize.for -- size of file in characters
      integer function fsize(name)
      integer*1 name(*)                 ! ARB(*)
      integer*1 fgetc,c
      integer fd,fopen

      if (fopen(fd,name,82) .eq. -1) then ! READ(LETR) ERR(-1)
          fsize = -1                    ! ERR(-1)
      else
          fsize = 0
          while (fgetc(fd,c) .ne. -1) do ! EOF(-1)
              fsize = fsize + 1
          end while
          call fclose(fd)
      end if
      return
      end

次回は、ほかの機能について説明します。