gcc/m2/gm2-libs-iso/RndFile.mod

   1 (* RndFile.mod implement the ISO RndFile specification.
   2
   3 Copyright (C) 2008-2024 Free Software Foundation, Inc.
   4 Contributed by Gaius Mulley <gaius.mulley@southwales.ac.uk>.
   5
   6 This file is part of GNU Modula-2.
   7
   8 GNU Modula-2 is free software; you can redistribute it and/or modify
   9 it under the terms of the GNU General Public License as published by
  10 the Free Software Foundation; either version 3, or (at your option)
  11 any later version.
  12
  13 GNU Modula-2 is distributed in the hope that it will be useful, but
  14 WITHOUT ANY WARRANTY; without even the implied warranty of
  15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  16 General Public License for more details.
  17
  18 Under Section 7 of GPL version 3, you are granted additional
  19 permissions described in the GCC Runtime Library Exception, version
  20 3.1, as published by the Free Software Foundation.
  21
  22 You should have received a copy of the GNU General Public License and
  23 a copy of the GCC Runtime Library Exception along with this program;
  24 see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
  25 <http://www.gnu.org/licenses/>.  *)
  26
  27 IMPLEMENTATION MODULE RndFile ;
  28
  29
  30 FROM RTgen IMPORT ChanDev, DeviceType,
  31                   InitChanDev, doLook, doSkip, doSkipLook, doWriteLn,
  32                   doReadText, doWriteText, doReadLocs, doWriteLocs,
  33                   checkErrno ;
  34
  35 FROM RTfio IMPORT doreadchar, dounreadchar, dogeterrno, dorbytes,
  36                   dowbytes, dowriteln, iseof, iseoln, iserror ;
  37
  38 FROM IOLink IMPORT DeviceId, DeviceTablePtr, IsDevice, MakeChan, UnMakeChan,
  39                    DeviceTablePtrValue, RAISEdevException, AllocateDeviceId,
  40                    ResetProc ;
  41
  42 FROM Storage IMPORT ALLOCATE, DEALLOCATE ;
  43 FROM RTgenif IMPORT GenDevIF, InitGenDevIF ;
  44 FROM FIO IMPORT File ;
  45 FROM libc IMPORT memcpy ;
  46 FROM errno IMPORT geterrno ;
  47 FROM IOConsts IMPORT ReadResults ;
  48 FROM ChanConsts IMPORT readFlag, writeFlag ;
  49
  50 FROM EXCEPTIONS IMPORT ExceptionNumber, RAISE,
  51                        AllocateSource, ExceptionSource, IsCurrentSource,
  52                        IsExceptionalExecution ;
  53
  54 IMPORT FIO, RTio, errno, ErrnoCategory ;
  55
  56
  57 VAR
  58    dev             : ChanDev ;
  59    did             : DeviceId ;
  60    rndfileException: ExceptionSource ;
  61
  62
  63 PROCEDURE look (d: DeviceTablePtr;
  64                 VAR ch: CHAR; VAR r: ReadResults) ;
  65 BEGIN
  66    checkRW(FALSE, d) ;
  67    doLook(dev, d, ch, r)
  68 END look ;
  69
  70
  71 PROCEDURE skip (d: DeviceTablePtr) ;
  72 BEGIN
  73    doSkip(dev, d)
  74 END skip ;
  75
  76
  77 PROCEDURE skiplook (d: DeviceTablePtr;
  78                     VAR ch: CHAR; VAR r: ReadResults) ;
  79 BEGIN
  80    checkRW(FALSE, d) ;
  81    doSkipLook(dev, d, ch, r)
  82 END skiplook ;
  83
  84
  85 PROCEDURE lnwrite (d: DeviceTablePtr) ;
  86 BEGIN
  87    checkRW(TRUE, d) ;
  88    doWriteLn(dev, d)
  89 END lnwrite ;
  90
  91
  92 PROCEDURE textread (d: DeviceTablePtr;
  93                     to: SYSTEM.ADDRESS;
  94                     maxChars: CARDINAL;
  95                     VAR charsRead: CARDINAL) ;
  96 BEGIN
  97    checkRW(FALSE, d) ;
  98    doReadText(dev, d, to, maxChars, charsRead)
  99 END textread ;
 100
 101
 102 PROCEDURE textwrite (d: DeviceTablePtr;
 103                      from: SYSTEM.ADDRESS;
 104                      charsToWrite: CARDINAL);
 105 BEGIN
 106    checkRW(TRUE, d) ;
 107    doWriteText(dev, d, from, charsToWrite)
 108 END textwrite ;
 109
 110
 111 PROCEDURE rawread (d: DeviceTablePtr;
 112                    to: SYSTEM.ADDRESS;
 113                    maxLocs: CARDINAL;
 114                    VAR locsRead: CARDINAL) ;
 115 BEGIN
 116    checkRW(FALSE, d) ;
 117    doReadLocs(dev, d, to, maxLocs, locsRead)
 118 END rawread ;
 119
 120
 121 PROCEDURE rawwrite (d: DeviceTablePtr;
 122                     from: SYSTEM.ADDRESS;
 123                     locsToWrite: CARDINAL) ;
 124 BEGIN
 125    checkRW(TRUE, d) ;
 126    doWriteLocs(dev, d, from, locsToWrite)
 127 END rawwrite ;
 128
 129
 130 PROCEDURE getname (d: DeviceTablePtr;
 131                    VAR a: ARRAY OF CHAR) ;
 132 BEGIN
 133    FIO.GetFileName(RTio.GetFile(d^.cid), a)
 134 END getname ;
 135
 136
 137 PROCEDURE flush (d: DeviceTablePtr) ;
 138 BEGIN
 139    FIO.FlushBuffer(RTio.GetFile(d^.cid))
 140 END flush ;
 141
 142
 143 (*
 144    checkOpenErrno - assigns, e, and, res, depending upon file result of opening,
 145                     file.
 146 *)
 147
 148 PROCEDURE checkOpenErrno (file: FIO.File; VAR e: INTEGER; VAR res: OpenResults) ;
 149 BEGIN
 150    IF FIO.IsNoError(file)
 151    THEN
 152       e := 0 ;
 153    ELSE
 154       e := errno.geterrno()
 155    END ;
 156    res := ErrnoCategory.GetOpenResults(e)
 157 END checkOpenErrno ;
 158
 159
 160 (*
 161    checkRW - ensures that the file attached to, p, has been opened, towrite.
 162 *)
 163
 164 PROCEDURE checkRW (towrite: BOOLEAN; p: DeviceTablePtr) ;
 165 VAR
 166    pb      : POINTER TO BOOLEAN ;
 167    fp      : FilePos ;
 168    file    : File ;
 169    name    : SYSTEM.ADDRESS ;
 170    size    : CARDINAL ;
 171    contents: SYSTEM.ADDRESS ;
 172 BEGIN
 173    pb := p^.cd ;
 174    IF pb^#towrite
 175    THEN
 176       WITH p^ DO
 177          pb^ := towrite ;
 178          fp := CurrentPos(cid) ;
 179          file := RTio.GetFile(RTio.ChanId(cid)) ;
 180          name := FIO.getFileName(file) ;
 181          size := FIO.getFileNameLength(file) ;
 182          ALLOCATE(contents, size+1) ;
 183          contents := memcpy(contents, name, size) ;
 184          FIO.Close(file) ;
 185          file := FIO.openForRandom(contents, size, towrite, FALSE) ;
 186          RTio.SetFile(cid, file) ;
 187          SetPos(cid, fp) ;
 188          DEALLOCATE(contents, size+1)
 189       END
 190    END
 191 END checkRW ;
 192
 193
 194 (*
 195    newCid - returns a ChanId which represents the opened file, name.
 196             res is set appropriately on return.
 197 *)
 198
 199 PROCEDURE newCid (fname: ARRAY OF CHAR;
 200                   f: FlagSet;
 201                   VAR res: OpenResults;
 202                   toWrite, newfile: BOOLEAN;
 203                   whichreset: ResetProc) : ChanId ;
 204 VAR
 205    c   : RTio.ChanId ;
 206    file: FIO.File ;
 207    e   : INTEGER ;
 208    p   : DeviceTablePtr ;
 209    pb  : POINTER TO BOOLEAN ;
 210 BEGIN
 211    file := FIO.OpenForRandom(fname, toWrite, newfile) ;
 212    checkOpenErrno(file, e, res) ;
 213
 214    IF FIO.IsNoError(file)
 215    THEN
 216       NEW(pb) ;
 217       pb^ := toWrite ;
 218       MakeChan(did, c) ;
 219       RTio.SetFile(c, file) ;
 220       p := DeviceTablePtrValue(c, did) ;
 221       WITH p^ DO
 222          cd := pb ;
 223          flags := f ;
 224          errNum := e ;
 225          doLook := look ;
 226          doSkip := skip ;
 227          doSkipLook := skiplook ;
 228          doLnWrite := lnwrite ;
 229          doTextRead := textread ;
 230          doTextWrite := textwrite ;
 231          doRawRead := rawread ;
 232          doRawWrite := rawwrite ;
 233          doGetName := getname ;
 234          doReset := whichreset ;
 235          doFlush := flush ;
 236          doFree := handlefree
 237       END ;
 238       RETURN( c )
 239    ELSE
 240       RETURN( IOChan.InvalidChan() )
 241    END
 242 END newCid ;
 243
 244
 245 (*
 246    handlefree -
 247 *)
 248
 249 PROCEDURE handlefree (d: DeviceTablePtr) ;
 250 VAR
 251    f : File ;
 252    pb: POINTER TO BOOLEAN ;
 253 BEGIN
 254    WITH d^ DO
 255       doFlush(d) ;
 256       checkErrno(dev, d) ;
 257       f := RTio.GetFile(RTio.ChanId(cid)) ;
 258       IF FIO.IsNoError(f)
 259       THEN
 260          FIO.Close(f) ;
 261       END ;
 262       checkErrno(dev, d) ;
 263       pb := cd ;
 264       DISPOSE(pb) ;
 265       cd := NIL
 266    END
 267 END handlefree ;
 268
 269
 270 PROCEDURE resetRandom (d: DeviceTablePtr) ;
 271 BEGIN
 272    WITH d^ DO
 273       IF IsRndFile(cid)
 274       THEN
 275          (* --fixme --, finish this *)
 276       ELSE
 277          RAISEdevException(cid, did, IOChan.wrongDevice,
 278                            'RndFile.' + __FUNCTION__ +
 279                            ': channel is not a random file')
 280       END
 281    END
 282 END resetRandom ;
 283
 284
 285 PROCEDURE OpenOld (VAR cid: ChanId; name: ARRAY OF CHAR; flags: FlagSet;
 286                    VAR res: OpenResults);
 287   (* Attempts to obtain and open a channel connected to a stored random
 288      access file of the given name.
 289      The old flag is implied; without the write flag, read is implied;
 290      without the text flag, raw is implied.
 291      If successful, assigns to cid the identity of the opened channel,
 292      assigns the value opened to res, and sets the read/write position
 293      to the start of the file.
 294      If a channel cannot be opened as required, the value of res indicates
 295      the reason, and cid identifies the invalid channel.
 296   *)
 297 BEGIN
 298    INCL(flags, ChanConsts.oldFlag) ;
 299    IF NOT (ChanConsts.writeFlag IN flags)
 300    THEN
 301       INCL(flags, ChanConsts.readFlag)
 302    END ;
 303    IF NOT (ChanConsts.textFlag IN flags)
 304    THEN
 305       INCL(flags, ChanConsts.rawFlag)
 306    END ;
 307    cid := newCid(name, flags, res, FALSE, FALSE, resetRandom)
 308 END OpenOld ;
 309
 310
 311 PROCEDURE OpenClean (VAR cid: ChanId; name: ARRAY OF CHAR; flags: FlagSet;
 312                      VAR res: OpenResults);
 313   (* Attempts to obtain and open a channel connected to a stored random
 314      access file of the given name.
 315      The write flag is implied; without the text flag, raw is implied.
 316      If successful, assigns to cid the identity of the opened channel,
 317      assigns the value opened to res, and truncates the file to zero length.
 318      If a channel cannot be opened as required, the value of res indicates
 319      the reason, and cid identifies the invalid channel.
 320   *)
 321 BEGIN
 322    INCL(flags, ChanConsts.writeFlag) ;
 323    IF NOT (ChanConsts.textFlag IN flags)
 324    THEN
 325       INCL(flags, ChanConsts.rawFlag)
 326    END ;
 327    cid := newCid(name, flags, res, TRUE, TRUE, resetRandom)
 328 END OpenClean ;
 329
 330
 331 PROCEDURE IsRndFile (cid: ChanId): BOOLEAN;
 332   (* Tests if the channel identified by cid is open to a random access file. *)
 333 BEGIN
 334    RETURN( (cid # NIL) AND (IOChan.InvalidChan() # cid) AND
 335            (IsDevice(cid, did)) AND
 336            ((ChanConsts.readFlag IN IOChan.CurrentFlags(cid)) OR
 337             (ChanConsts.writeFlag IN IOChan.CurrentFlags(cid))) )
 338 END IsRndFile ;
 339
 340
 341 PROCEDURE IsRndFileException (): BOOLEAN;
 342   (* Returns TRUE if the current coroutine is in the exceptional execution
 343      state because of the raising of a RndFile exception; otherwise returns
 344      FALSE.
 345   *)
 346 BEGIN
 347    RETURN( IsCurrentSource (rndfileException) )
 348 END IsRndFileException ;
 349
 350
 351
 352 PROCEDURE StartPos (cid: ChanId): FilePos;
 353   (* If the channel identified by cid is not open to a random access file,
 354      the exception wrongDevice is raised; otherwise returns the position of
 355      the start of the file.
 356   *)
 357 VAR
 358    d: DeviceTablePtr ;
 359 BEGIN
 360    IF IsRndFile(cid)
 361    THEN
 362       d := DeviceTablePtrValue(cid, did) ;
 363       RETURN( 0 )
 364    ELSE
 365       RAISEdevException(cid, did, IOChan.wrongDevice,
 366                         'RndFile.' + __FUNCTION__ +
 367                         ': channel is not a random file')
 368    END
 369 END StartPos ;
 370
 371
 372 PROCEDURE CurrentPos (cid: ChanId): FilePos;
 373   (* If the channel identified by cid is not open to a random access file,
 374      the exception wrongDevice is raised; otherwise returns the position
 375      of the current read/write position.
 376   *)
 377 VAR
 378    d: DeviceTablePtr ;
 379 BEGIN
 380    IF IsRndFile(cid)
 381    THEN
 382       d := DeviceTablePtrValue(cid, did) ;
 383       WITH d^ DO
 384          RETURN( FIO.FindPosition(RTio.GetFile(cid)) )
 385       END
 386    ELSE
 387       RAISEdevException(cid, did, IOChan.wrongDevice,
 388                         'RndFile.' + __FUNCTION__ +
 389                         ': channel is not a random file')
 390    END
 391 END CurrentPos ;
 392
 393
 394 PROCEDURE EndPos (cid: ChanId): FilePos;
 395   (* If the channel identified by cid is not open to a random access file,
 396      the exception wrongDevice is raised; otherwise returns the first
 397      position after which there have been no writes.
 398   *)
 399 VAR
 400    d  : DeviceTablePtr ;
 401    end,
 402    old: FilePos ;
 403 BEGIN
 404    IF IsRndFile(cid)
 405    THEN
 406       d := DeviceTablePtrValue(cid, did) ;
 407       old := CurrentPos(cid) ;
 408       WITH d^ DO
 409          old := CurrentPos(cid) ;
 410          FIO.SetPositionFromEnd(RTio.GetFile(cid), 0) ;
 411          checkErrno(dev, d) ;
 412          end := CurrentPos(cid) ;
 413          FIO.SetPositionFromBeginning(RTio.GetFile(cid), old) ;
 414          RETURN( end )
 415       END
 416    ELSE
 417       RAISEdevException(cid, did, IOChan.wrongDevice,
 418                         'RndFile.' + __FUNCTION__ +
 419                         ': channel is not a random file')
 420    END
 421 END EndPos ;
 422
 423
 424 PROCEDURE NewPos (cid: ChanId; chunks: INTEGER; chunkSize: CARDINAL;
 425                   from: FilePos): FilePos;
 426   (* If the channel identified by cid is not open to a random access file,
 427      the exception wrongDevice is raised; otherwise returns the position
 428      (chunks * chunkSize) relative to the position given by from, or
 429      raises the exception posRange if the required position cannot be
 430      represented as a value of type FilePos.
 431   *)
 432 VAR
 433    d: DeviceTablePtr ;
 434 BEGIN
 435    IF IsRndFile(cid)
 436    THEN
 437       d := DeviceTablePtrValue(cid, did) ;
 438       WITH d^ DO
 439          RETURN( from+VAL(FilePos, chunks*VAL(INTEGER, chunkSize))-
 440                  CurrentPos(cid) )
 441       END
 442    ELSE
 443       RAISEdevException(cid, did, IOChan.wrongDevice,
 444                         'RndFile.' + __FUNCTION__ +
 445                         ': channel is not a random file')
 446    END
 447 END NewPos ;
 448
 449
 450 PROCEDURE SetPos (cid: ChanId; pos: FilePos);
 451   (* If the channel identified by cid is not open to a random access file,
 452      the exception wrongDevice is raised; otherwise sets the read/write
 453      position to the value given by pos.
 454   *)
 455 VAR
 456    d: DeviceTablePtr ;
 457 BEGIN
 458    IF IsRndFile(cid)
 459    THEN
 460       d := DeviceTablePtrValue(cid, did) ;
 461       WITH d^ DO
 462          FIO.SetPositionFromBeginning(RTio.GetFile(cid), pos) ;
 463          checkErrno(dev, d)
 464       END
 465    ELSE
 466       RAISEdevException(cid, did, IOChan.wrongDevice,
 467                         'RndFile.' + __FUNCTION__ +
 468                         ': channel is not a random file')
 469    END
 470 END SetPos ;
 471
 472
 473 PROCEDURE Close (VAR cid: ChanId);
 474   (* If the channel identified by cid is not open to a random access file,
 475      the exception wrongDevice is raised; otherwise closes the channel,
 476      and assigns the value identifying the invalid channel to cid.
 477   *)
 478 BEGIN
 479    IF IsRndFile(cid)
 480    THEN
 481       UnMakeChan(did, cid) ;
 482       cid := IOChan.InvalidChan()
 483    ELSE
 484       RAISEdevException(cid, did, IOChan.wrongDevice,
 485                         'RndFile.' + __FUNCTION__ +
 486                         ': channel is not a random file')
 487    END
 488 END Close ;
 489
 490
 491 (*
 492    Init -
 493 *)
 494
 495 PROCEDURE Init ;
 496 VAR
 497    gen: GenDevIF ;
 498 BEGIN
 499    AllocateDeviceId(did) ;
 500    gen := InitGenDevIF(did, doreadchar, dounreadchar,
 501                        dogeterrno, dorbytes, dowbytes,
 502                        dowriteln,
 503                        iseof, iseoln, iserror) ;
 504    dev := InitChanDev(streamfile, did, gen) ;
 505    AllocateSource (rndfileException)
 506 END Init ;
 507
 508
 509 BEGIN
 510    Init
 511 END RndFile.