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

   1 (* SimpleCipher.mod implements a pegalogical caesar cipher.
   2
   3 Copyright (C) 2008-2023 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 SimpleCipher ;
  28
  29
  30 FROM SYSTEM IMPORT ADDRESS, ADR, CARDINAL8, LOC ;
  31 FROM RTio IMPORT GetDeviceId ;
  32 FROM RTdata IMPORT ModuleId, MakeModuleId, InitData, GetData, KillData ;
  33 FROM IOLink IMPORT DeviceId, DeviceTable, DeviceTablePtr, DeviceTablePtrValue, AllocateDeviceId, RAISEdevException ;
  34 FROM IOChan IMPORT ChanExceptions ;
  35 FROM IOConsts IMPORT ReadResults ;
  36 FROM Storage IMPORT ALLOCATE, DEALLOCATE ;
  37 FROM ASCII IMPORT nul, lf ;
  38 FROM Strings IMPORT Insert, Append ;
  39 FROM CharClass IMPORT IsLower, IsUpper, IsNumeric ;
  40
  41
  42 TYPE
  43    PtrToLoc   = POINTER TO LOC ;
  44    PtrToChar  = POINTER TO CHAR ;
  45    CipherInfo = POINTER TO RECORD
  46                               key  : INTEGER ;
  47                               lower: DeviceTable ;
  48                            END ;
  49
  50
  51 VAR
  52    mid: ModuleId ;
  53
  54
  55 (*
  56    RotateChar -
  57 *)
  58
  59 PROCEDURE RotateChar (ch, lower, upper: CHAR; key: INTEGER) : CHAR ;
  60 VAR
  61    r: INTEGER ;
  62 BEGIN
  63    r := VAL(INTEGER, ORD(upper)-ORD(lower))+1 ;
  64    IF key<0
  65    THEN
  66       RETURN( RotateChar(ch, lower, upper, r-key) )
  67    ELSE
  68       IF key>r
  69       THEN
  70          key := key MOD r
  71       END ;
  72       (* key is now positive and within a sensible range *)
  73       IF ORD(ch)+VAL(CARDINAL, key)>ORD(upper)
  74       THEN
  75          RETURN( CHR((ORD(ch)+VAL(CARDINAL, key))-VAL(CARDINAL, r)) )
  76       ELSE
  77          RETURN( CHR(ORD(ch)+VAL(CARDINAL, key)) )
  78       END
  79    END
  80 END RotateChar ;
  81
  82
  83 (*
  84    encryptChar - encrypts, ch, using Caesar cipher.  Only
  85                  characters [A-Z][a-z][0-9] are encrypted.
  86                  Also these character ranges are only rotated
  87                  around their own range.
  88 *)
  89
  90 PROCEDURE encryptChar (ch: CHAR; key: INTEGER) : CHAR ;
  91 BEGIN
  92    IF IsLower(ch)
  93    THEN
  94       RETURN( RotateChar(ch, 'a', 'z', key) )
  95    ELSIF IsUpper(ch)
  96    THEN
  97       RETURN( RotateChar(ch, 'A', 'Z', key) )
  98    ELSIF IsNumeric(ch)
  99    THEN
 100       RETURN( RotateChar(ch, '0', '9', key) )
 101    ELSE
 102       RETURN( ch )
 103    END
 104 END encryptChar ;
 105
 106
 107 (*
 108    decryptChar - decrypts, ch, using Caesar cipher.  Only
 109                  characters [A-Z][a-z][0-9] are decrypted.
 110                  Also these character ranges are only rotated
 111                  around their own range.
 112 *)
 113
 114 PROCEDURE decryptChar (ch: CHAR; key: INTEGER) : CHAR ;
 115 BEGIN
 116    RETURN( encryptChar(ch, -key) )
 117 END decryptChar ;
 118
 119
 120 (*
 121    RotateLoc -
 122 *)
 123
 124 PROCEDURE RotateLoc (cid: ChanId;
 125                      did: DeviceId;
 126                      l: LOC; key: INTEGER) : LOC ;
 127 VAR
 128    i, u: INTEGER ;
 129    c: CARDINAL8 ;
 130 BEGIN
 131    IF SIZE(l)#SIZE(c)
 132    THEN
 133       RAISEdevException(cid, did, notAvailable, 'SimpleCipher: unable to cipher LOCs of this size')
 134    ELSE
 135       IF key<0
 136       THEN
 137          RETURN( RotateLoc(cid, did, l, -key+VAL(INTEGER, MAX(CARDINAL8))) )
 138       ELSE
 139          IF key>VAL(INTEGER, MAX(CARDINAL8))
 140          THEN
 141             key := key MOD (VAL(INTEGER, MAX(CARDINAL8))+1)
 142          END ;
 143          c := VAL(CARDINAL8, l) ;
 144          u := VAL(INTEGER, MAX(CARDINAL8))+1 ;
 145          IF u-VAL(INTEGER, c)>key
 146          THEN
 147             INC(c, key)
 148          ELSE
 149             c := key-(u-VAL(INTEGER, c))
 150          END ;
 151          RETURN( VAL(LOC, c) )
 152       END
 153    END
 154 END RotateLoc ;
 155
 156
 157 (*
 158    encryptLoc - encrypts, l, by, key.
 159 *)
 160
 161 PROCEDURE encryptLoc (cid: ChanId; did: DeviceId; l: LOC; key: INTEGER) : LOC ;
 162 BEGIN
 163    RETURN( RotateLoc(cid, did, l, key) )
 164 END encryptLoc ;
 165
 166
 167 (*
 168    decryptLoc - decrypts, l, by, key.
 169 *)
 170
 171 PROCEDURE decryptLoc (cid: ChanId; did: DeviceId; l: LOC; key: INTEGER) : LOC ;
 172 BEGIN
 173    RETURN( RotateLoc(cid, did, l, -key) )
 174 END decryptLoc ;
 175
 176
 177 PROCEDURE dolook (d: DeviceTablePtr;
 178                   VAR ch: CHAR; VAR r: ReadResults) ;
 179 VAR
 180    c: CipherInfo ;
 181 BEGIN
 182    c := GetData(d, mid) ;
 183    WITH c^ DO
 184       lower.doLook(d, ch, r) ;
 185       IF (r=allRight) OR (r=endOfLine)
 186       THEN
 187          ch := decryptChar(ch, key)
 188       END
 189    END
 190 END dolook ;
 191
 192
 193 PROCEDURE doskip (d: DeviceTablePtr) ;
 194 VAR
 195    c: CipherInfo ;
 196 BEGIN
 197    c := GetData(d, mid) ;
 198    WITH c^ DO
 199       lower.doSkip(d)
 200    END
 201 END doskip ;
 202
 203
 204 PROCEDURE doskiplook (d: DeviceTablePtr;
 205                       VAR ch: CHAR; VAR r: ReadResults) ;
 206 VAR
 207    c: CipherInfo ;
 208 BEGIN
 209    c := GetData(d, mid) ;
 210    WITH c^ DO
 211       lower.doSkipLook(d, ch, r) ;
 212       IF (r=allRight) OR (r=endOfLine)
 213       THEN
 214          ch := decryptChar(ch, key)
 215       END
 216    END
 217 END doskiplook ;
 218
 219
 220 PROCEDURE dowriteln (d: DeviceTablePtr) ;
 221 VAR
 222    ch: CHAR ;
 223 BEGIN
 224    ch := lf ;
 225    dotextwrite(d, ADR(ch), 1)
 226 END dowriteln ;
 227
 228
 229 PROCEDURE dotextread (d: DeviceTablePtr;
 230                       to: ADDRESS;
 231                       maxChars: CARDINAL;
 232                       VAR charsRead: CARDINAL) ;
 233 VAR
 234    c : CipherInfo ;
 235    i : CARDINAL ;
 236    ch: CHAR ;
 237    p : PtrToChar ;
 238 BEGIN
 239    c := GetData(d, mid) ;
 240    WITH c^ DO
 241       charsRead := 0 ;
 242       p := to ;
 243       WHILE charsRead<maxChars DO
 244          c^.lower.doTextRead(d, ADR(ch), SIZE(ch), i) ;
 245          IF i>0
 246          THEN
 247             p^ := decryptChar(ch, key) ;
 248             INC(p, SIZE(ch)) ;
 249             INC(charsRead, i)
 250          ELSE
 251             RETURN
 252          END
 253       END
 254    END
 255 END dotextread ;
 256
 257
 258 PROCEDURE dotextwrite (d: DeviceTablePtr;
 259                        from: ADDRESS;
 260                        charsToWrite: CARDINAL);
 261 VAR
 262    c : CipherInfo ;
 263    i : CARDINAL ;
 264    ch: CHAR ;
 265    p : PtrToChar ;
 266 BEGIN
 267    c := GetData(d, mid) ;
 268    WITH c^ DO
 269       p := from ;
 270       i := 0 ;
 271       WHILE i<charsToWrite DO
 272          ch := encryptChar(p^, key) ;
 273          c^.lower.doTextWrite(d, ADR(ch), SIZE(ch)) ;
 274          INC(p, SIZE(ch)) ;
 275          INC(i)
 276       END
 277    END
 278 END dotextwrite ;
 279
 280
 281 PROCEDURE dorawread (d: DeviceTablePtr;
 282                      to: ADDRESS;
 283                      maxLocs: CARDINAL;
 284                      VAR locsRead: CARDINAL) ;
 285 VAR
 286    c: CipherInfo ;
 287    i: CARDINAL ;
 288    p: PtrToLoc ;
 289    l: LOC ;
 290 BEGIN
 291    c := GetData(d, mid) ;
 292    WITH c^ DO
 293       locsRead := 0 ;
 294       p := to ;
 295       WHILE locsRead<maxLocs DO
 296          lower.doRawRead(d, ADR(l), SIZE(l), i) ;
 297          IF i>0
 298          THEN
 299             p^ := decryptLoc(d^.cid, d^.did, l, key) ;
 300             INC(p) ;
 301             INC(locsRead, i)
 302          ELSE
 303             RETURN
 304          END
 305       END
 306    END
 307 END dorawread ;
 308
 309
 310 PROCEDURE dorawwrite (d: DeviceTablePtr;
 311                       from: ADDRESS;
 312                       locsToWrite: CARDINAL) ;
 313 VAR
 314    c: CipherInfo ;
 315    i: CARDINAL ;
 316    l: LOC ;
 317    p: PtrToLoc ;
 318 BEGIN
 319    c := GetData(d, mid) ;
 320    WITH c^ DO
 321       p := from ;
 322       i := 0 ;
 323       WHILE i<locsToWrite DO
 324          l := encryptLoc(d^.cid, d^.did, p^, key) ;
 325          lower.doRawWrite(d, ADR(l), SIZE(l)) ;
 326          INC(p) ;
 327          INC(i)
 328       END
 329    END
 330 END dorawwrite ;
 331
 332
 333 PROCEDURE dogetname (d: DeviceTablePtr;
 334                      VAR a: ARRAY OF CHAR) ;
 335 VAR
 336    c: CipherInfo ;
 337 BEGIN
 338    c := GetData(d, mid) ;
 339    WITH c^ DO
 340       lower.doGetName(d, a) ;
 341       Insert('SimpleCipher (', 0, a) ;
 342       Append(')', a)
 343    END
 344 END dogetname ;
 345
 346
 347 (*
 348    freeData - disposes of, c.
 349 *)
 350
 351 PROCEDURE freeData (c: CipherInfo) ;
 352 BEGIN
 353    DISPOSE(c)
 354 END freeData ;
 355
 356
 357 (*
 358    dofree - replace original methods and then delete data pertaining
 359             to, mid.  The idea is that our new methods will call the
 360             old methods and then decrypt data when reading and visa
 361             versa for writing.  We write CHARs and LOCs at a time so
 362             ensure no plaintext data is ever passed outside this
 363             module.
 364 *)
 365
 366 PROCEDURE dofree (d: DeviceTablePtr) ;
 367 VAR
 368    c: CipherInfo ;
 369 BEGIN
 370    c := GetData(d, mid) ;
 371    WITH d^ DO
 372       doLook := c^.lower.doLook ;
 373       doLook := c^.lower.doLook ;
 374       doSkip := c^.lower.doSkip ;
 375       doSkipLook := c^.lower.doSkipLook ;
 376       doLnWrite := c^.lower.doLnWrite ;
 377       doTextRead := c^.lower.doTextRead ;
 378       doTextRead := c^.lower.doTextRead ;
 379       doRawRead := c^.lower.doRawRead ;
 380       doRawWrite := c^.lower.doRawWrite ;
 381       doGetName := c^.lower.doGetName ;
 382       doReset := c^.lower.doReset ;
 383       doFlush := c^.lower.doFlush ;
 384       doFree := c^.lower.doFree
 385    END
 386 END dofree ;
 387
 388
 389 (*
 390    InsertCipherLayer - inserts a Caesar cipher below channel, cid.
 391                        The encryption, key, is specified.
 392 *)
 393
 394 PROCEDURE InsertCipherLayer (cid: ChanId; key: INTEGER) ;
 395 VAR
 396    did: DeviceId ;
 397    d  : DeviceTablePtr ;
 398    c  : CipherInfo ;
 399 BEGIN
 400    did := GetDeviceId(cid) ;
 401    d := DeviceTablePtrValue(cid, did) ;
 402    IF GetData(d, mid)=NIL
 403    THEN
 404       NEW(c) ;
 405       c^.key := key ;
 406       c^.lower := d^ ;
 407       InitData(d, mid, c, freeData) ;
 408       WITH d^ DO
 409          doLook := dolook ;
 410          doSkip := doskip ;
 411          doSkipLook := doskiplook ;
 412          doLnWrite := dowriteln ;
 413          doTextRead := dotextread ;
 414          doTextWrite := dotextwrite ;
 415          doRawRead := dorawread ;
 416          doRawWrite := dorawwrite ;
 417          doGetName := dogetname ;
 418          (* doReset := doreset ; no need for either of these *)
 419          (* doFlush := doflush ; *)
 420          doFree := dofree
 421       END
 422    ELSE
 423       RAISEdevException(cid, did, notAvailable,
 424                         'SimpleCipher: unable to insert multiple cipher layers from the same module under a channel')
 425    END
 426 END InsertCipherLayer ;
 427
 428
 429 (*
 430    RemoveCipherLayer - removes a Caesar cipher below channel, cid.
 431 *)
 432
 433 PROCEDURE RemoveCipherLayer (cid: ChanId) ;
 434 VAR
 435    did: DeviceId ;
 436    d  : DeviceTablePtr ;
 437 BEGIN
 438    did := GetDeviceId(cid) ;
 439    d := DeviceTablePtrValue(cid, did) ;
 440    IF GetData(d, mid)=NIL
 441    THEN
 442       RAISEdevException(cid, did, notAvailable,
 443                         'SimpleCipher: no cipher layer to remove from this channel')
 444    ELSE
 445       KillData(d, mid)
 446    END
 447 END RemoveCipherLayer ;
 448
 449
 450 BEGIN
 451    MakeModuleId(mid)
 452 END SimpleCipher.