doc/nguide/ngdump/ngdump.pas

   1 {$R+,I+,V-}\r
   2 \r
   3 program ngdump;\r
   4 \r
   5 uses crt, dos,\r
   6      BufIO;\r
   7 \r
   8 const progname = 'NGDUMP';\r
   9       version  = 'V1.0';\r
  10       copyright = 'Copyright 1989 J.P.Pedersen, 1990 E.v.Asperen';\r
  11 \r
  12       MaxNameLen = 40;\r
  13       MaxLineLen = 160;\r
  14 \r
  15 type gentry = record                    {General entry type}\r
  16                 filptr:longint;\r
  17                 name:string[MaxNameLen];\r
  18               end;\r
  19      line   = string[MaxLineLen];\r
  20 \r
  21 var\r
  22      mennu:array[0..3,0..8] of gentry;  {Buffer to hold variable part of guide menu structure}\r
  23      itemlist:array[0..3] of byte;               {Menu structure info}\r
  24      errorinfo:array[3..6] of string[14];        {Buffer for error messages}\r
  25      f:file;                                                                                    {The guide file}\r
  26      propath,homedir,streng:string;              {String variables, mostly for path and file use}\r
  27      erro,\r
  28         seealsonum,\r
  29         menuantal,\r
  30         menunr : byte;                           {Byte variables}\r
  31      entrytype : (et_misc, et_short, et_long);\r
  32      guidename : line;\r
  33 \r
  34 const MaxLevel = 10;\r
  35       OutBufSize   = 4096;\r
  36 \r
  37 type FileBuffer = array [1..OutBufSize] of byte;\r
  38 \r
  39 var  outf    : array [1..MaxLevel] of text;\r
  40      flevel  : 1..MaxLevel;\r
  41      OutBuf  : array [1..MaxLevel] of ^FileBuffer;\r
  42      Nfiles  : word;\r
  43      numentries : longint;\r
  44 \r
  45 \r
  46 \r
  47 procedure threenitvars;                 {Initialize variables}\r
  48 begin\r
  49     menunr := 0;\r
  50 end;\r
  51 \r
  52 procedure twonitvars;                   {Initialize variables}\r
  53 begin\r
  54     threenitvars;\r
  55 end;\r
  56 \r
  57 procedure initvars;                     {Initialize variables}\r
  58 var str5:string;\r
  59 begin\r
  60     twonitvars;\r
  61     errorinfo[3] := 'File not found';\r
  62     errorinfo[4] := 'Not an NG file';\r
  63     errorinfo[5] := 'Unexpected EOF';\r
  64     errorinfo[6] := 'Corrupted file';\r
  65     str5 := '';propath := paramstr(0);\r
  66     while (pos('\',propath) > 0) do begin\r
  67         str5 := str5+copy(propath,1,pos('\',propath));\r
  68         propath := copy(propath,pos('\',propath)+1,length(propath)-(pos('\',propath)+1));\r
  69     end;\r
  70     propath := str5;\r
  71 end;\r
  72 \r
  73 var attr, startattr : byte;\r
  74 \r
  75 procedure WriteNgString(var outf:text; s:string);\r
  76 var i,j:byte;\r
  77     c:char;\r
  78 begin\r
  79     i := 1;\r
  80     attr := startattr;\r
  81     while (i <= length(s)) do begin\r
  82         c := s[i];\r
  83         if c = #255 then begin\r
  84             {Expand spaces}\r
  85             inc(i);\r
  86             c := s[i];\r
  87             for j := 1 to ord(c) do begin\r
  88                 write(outf, ' ');\r
  89             end;\r
  90         end\r
  91         else begin\r
  92             if (c = '!') and (i = 1) then write(outf, c);\r
  93             write(outf, c);\r
  94         end;\r
  95         inc(i);\r
  96     end;\r
  97 \r
  98     writeln(outf);\r
  99 end;\r
 100 \r
 101 procedure WriteString(s:string);\r
 102 begin\r
 103   WriteNgString(outf[flevel], s);\r
 104 end;\r
 105 \r
 106 const Fx = 10; Fy = 2;\r
 107       Gx = 10; Gy = 3;\r
 108       Mx = 10; My = 5;\r
 109       Cx = 10; Cy = 7;\r
 110       Lx = 10; Ly = 8;\r
 111       Sx = 10; Sy = 10;\r
 112 \r
 113 \r
 114 procedure ShowShort(s:string);\r
 115 begin\r
 116   gotoxy(Sx, Sy);  ClrEol;\r
 117   gotoxy(1, Sy+1); ClrEol;\r
 118   gotoxy(Sx, Sy);  WriteNgString(Output, s);\r
 119 end;\r
 120 \r
 121 procedure ShowLong(n:longint);\r
 122 begin\r
 123   gotoxy(Lx, Ly); write(n:7);\r
 124 end;\r
 125 \r
 126 procedure ShowEndLong;\r
 127 begin\r
 128   gotoxy(Lx, Ly); ClrEol;\r
 129 end;\r
 130 \r
 131 procedure ShowFile(s:string);\r
 132 begin\r
 133   gotoxy(Fx, Fy); ClrEol; write(s);\r
 134 end;\r
 135 \r
 136 procedure ShowGuide(s:string);\r
 137 begin\r
 138   gotoxy(Gx, Gy); ClrEol; write(s);\r
 139 end;\r
 140 \r
 141 procedure ShowCount(n:longint);\r
 142 begin\r
 143   gotoxy(Cx, Cy); write(n:7);\r
 144 end;\r
 145 \r
 146 procedure ShowMenu(s:string);\r
 147 begin\r
 148   gotoxy(Mx, My); ClrEol; WriteNgString(output, s);\r
 149 end;\r
 150 \r
 151 procedure ScreenInit;\r
 152 begin\r
 153   ClrScr;\r
 154   gotoxy(Fx-8, Fy); write(' file:');\r
 155   gotoxy(Gx-8, Gy); write('guide:');\r
 156   gotoxy(Mx-8, My); write(' menu:');\r
 157   gotoxy(Cx-8, Cy); write('count:');\r
 158   gotoxy(Lx-8, Ly); write('lines:');\r
 159   gotoxy(Sx-8, Sy); write('entry:');\r
 160 end;\r
 161 \r
 162 procedure ScreenExit;\r
 163 begin\r
 164   gotoxy(1, Sy+3); ClrScr;\r
 165 end;\r
 166 \r
 167 procedure Usage;                        {Write usage info}\r
 168 begin\r
 169   writeln;\r
 170   writeln('usage:        ngdump filename');\r
 171   writeln;\r
 172   Halt(1);\r
 173 end;\r
 174 \r
 175 procedure slutlort(b:byte);  {Exit on error and display relevant error message}\r
 176 begin\r
 177   if b > 3 then close(f);\r
 178   if b > 2 then begin\r
 179      writeln('NGDUMP ERROR #', b, ': '+errorinfo[b]+', cannot proceed');\r
 180   end;\r
 181   if b < 3 then usage;\r
 182   halt(0);\r
 183 end;\r
 184 \r
 185 procedure sllut(b:byte); {Error handler without exit, just indicating the error type}\r
 186 var sl:byte;\r
 187 begin\r
 188   sl := 0;\r
 189   if b > 3 then close(f);\r
 190   writeln(' ',errorinfo[b],' - Press any key');\r
 191   erro := 1;\r
 192 end;\r
 193 \r
 194 function decrypt(b:byte):byte;          {Decrypt byte from NG format}\r
 195 begin\r
 196 (*\r
 197   if ((b mod 32)>=16) then b := b-16 else b := b+16;\r
 198   if ((b mod 16)>=8) then b := b-8 else b := b+8;\r
 199   if ((b mod 4)>=2) then b := b-2 else b := b+2;\r
 200   decrypt := b;\r
 201 *)\r
 202   decrypt := b xor (16+8+2);   { this is somewhat more efficient... EVAS}\r
 203 end;\r
 204 \r
 205 function read_byte:byte;                {Read and decrypt byte}\r
 206 var tb:byte;\r
 207     numread:word;\r
 208 begin\r
 209   bread(f, tb, 1, numread);\r
 210   read_byte := tb xor 26;\r
 211 end;\r
 212 \r
 213 function read_word:word;                {Read and decrypt word}\r
 214 var tb:byte;\r
 215 begin\r
 216   tb := read_byte;\r
 217   read_word := word(tb) or (word(read_byte) shl 8);\r
 218 end;\r
 219 \r
 220 function read_long:longint;             {Read and decrypt longint}\r
 221 var tw:word;\r
 222 begin\r
 223   tw := read_word;\r
 224   read_long := longint(tw) or (longint(read_word) shl 16);\r
 225 end;\r
 226 \r
 227 type BigStr = string[255];\r
 228 \r
 229 procedure read_string(maxlen:byte; var s:BigStr);\r
 230 var c,j:byte;\r
 231 begin\r
 232   j := 0;\r
 233   repeat\r
 234     c := read_byte;\r
 235     inc(j);\r
 236     s[j] := chr(c);\r
 237   until (c = 0) or (j = maxlen);\r
 238   s[0] := chr(j-1);\r
 239 end;\r
 240 \r
 241 procedure read_menu;             {Read a menu structure into the menu buffer}\r
 242 var items,i,j:word;\r
 243 begin\r
 244   mennu[menunr,0].filptr := bpos(f)-2;\r
 245   bskip(f, 2);\r
 246   items := read_word;\r
 247   itemlist[menunr] := items;\r
 248   bskip(f, 20);\r
 249   for i := 1 to items-1 do begin\r
 250     mennu[menunr,i].filptr := read_long;\r
 251   end;\r
 252   bskip(f, items * 8);\r
 253   for i := 0 to items-1 do begin\r
 254      with mennu[menunr, i] do begin\r
 255         read_string( 40, name );\r
 256      end;\r
 257   end;\r
 258   bskip(f, 1);\r
 259 end;\r
 260 \r
 261 procedure skip_short_long;       {Skip procedure for the initial menu bseek}\r
 262 var length:word;\r
 263 begin\r
 264   length := read_word;\r
 265   bskip(f, length + 22);\r
 266 end;\r
 267 \r
 268 procedure read_header(modf:byte); {Read NG file header and enter the guide name in the screen template}\r
 269 var buf       : array[0..377] of byte;\r
 270     i,numread : word;\r
 271 begin\r
 272   bread(f, buf, sizeof(buf), numread);\r
 273   if ((buf[0]<>ord('N')) or (buf[1]<>ord('G'))) then begin\r
 274      {If the two first characters in the file are not 'NG', the file is no guide}\r
 275      if modf = 0\r
 276       then slutlort(4)\r
 277       else sllut(4);\r
 278   end;\r
 279 \r
 280   menuantal := buf[6];\r
 281   i := 0;\r
 282   repeat\r
 283     guidename[i+1] := chr(buf[i+8]);\r
 284     inc(i);\r
 285   until (buf[i+8] = 0);\r
 286   guidename[0] := chr(i);\r
 287 \r
 288   ShowGuide( guidename );\r
 289   bseek(f, 378);\r
 290 end;\r
 291 \r
 292 procedure read_menus(modf:boolean);  {Initial menu bseek, indexing the whole file}\r
 293 var id : word;\r
 294 begin\r
 295   repeat\r
 296     id := read_word;\r
 297     if (id < 2) then begin\r
 298        skip_short_long\r
 299     end\r
 300     else if (id = 2) then begin\r
 301        read_menu;\r
 302        inc(menunr);\r
 303     end\r
 304     else if (id <> 5) then begin\r
 305        if (filesize(f) <> bpos(f)) then begin\r
 306           if (not modf)\r
 307            then slutlort(5)\r
 308            else sllut(5);        {NG file error}\r
 309        end\r
 310        else id := 5;\r
 311     end;\r
 312   until (id = 5);\r
 313 \r
 314   if (menunr <> menuantal) then begin\r
 315      if (not modf)\r
 316       then slutlort(6)\r
 317       else sllut(6);                {Incomplete file}\r
 318   end;\r
 319 end;\r
 320 \r
 321 function MakeName:Dos.PathStr;\r
 322 var fname:Dos.PathStr;\r
 323 begin\r
 324   inc(Nfiles);\r
 325   str(Nfiles, fname);\r
 326   MakeName := fname;\r
 327 end;\r
 328 \r
 329 procedure OpenOutFile(n:word; s:Dos.PathStr);\r
 330 begin\r
 331   assign(outf[n], s); rewrite(outf[n]);\r
 332   SetTextBuf(outf[n], OutBuf[n]^, OutBufSize);\r
 333 end;\r
 334 \r
 335 procedure read_entry(level:byte; fp:longint); forward;\r
 336 \r
 337 procedure read_short_entry(level:byte);\r
 338 {Read short entry from file and wring some information out of it}\r
 339 var i, items: word;\r
 340     subject : line;\r
 341     entrypos, subj_pos, p0, p   : longint;\r
 342 begin\r
 343   bskip(f, 2);\r
 344   items := read_word;\r
 345   bskip(f, 20);\r
 346   p0 := bpos(f);\r
 347   subj_pos := p0 + longint(items) * 6;\r
 348   for i := 1 to items do begin\r
 349     bskip(f, 2);\r
 350     entrypos := read_long;\r
 351     p := bpos(f);\r
 352     bseek(f, subj_pos);\r
 353     read_string( MaxLineLen, subject );\r
 354     subj_pos := bpos(f);\r
 355     write(outf[flevel], '!short:'); WriteString(subject);\r
 356 {}  ShowShort(subject);\r
 357     read_entry(level+1, entrypos);\r
 358     bseek(f, p);\r
 359   end;\r
 360 end;\r
 361 \r
 362 procedure read_long_entry;\r
 363 {Read long entry information}\r
 364 const MaxSeeAlso = 20;\r
 365 var i, linens, dlength, seealso_num : word;\r
 366     s : line;\r
 367 begin\r
 368   bskip(f, 2);\r
 369   linens := read_word;\r
 370   dlength := read_word;\r
 371 {} ShowLong(linens);\r
 372   bskip(f, 18);       { 10 + links to prev/next entry (long's) }\r
 373   for i := 1 to linens do begin\r
 374     read_string( MaxLineLen, s );\r
 375     WriteString(s);\r
 376   end;\r
 377 \r
 378   if dlength <> 0 then begin            {If there are seealso entries, read them}\r
 379      seealso_num := read_word;\r
 380      { skip the offsets for the SeeAlso-items; }\r
 381      bskip(f, seealso_num * 4);\r
 382      { read the items; }\r
 383      for i := 1 to seealso_num do begin\r
 384         if i <= MaxSeeAlso then begin\r
 385            read_string( MaxLineLen, s );\r
 386            writeln(outf[flevel], '!seealso: "', s, '"');\r
 387         end;\r
 388      end;\r
 389   end;\r
 390 {} ShowEndLong;\r
 391 end;\r
 392 \r
 393 procedure read_entry(level:byte; fp:longint); {Read some kind of file entry}\r
 394 var id:word; fname:dos.pathstr;\r
 395 begin\r
 396   inc(numentries); ShowCount(numentries);\r
 397   bseek(f, fp);\r
 398   id := read_word;\r
 399   case id of\r
 400    0: begin\r
 401         if (level > 0) then begin\r
 402            fname := MakeName;\r
 403            writeln(outf[flevel], '!file: ',fname+'.NGO');\r
 404            inc(flevel);\r
 405 {$ifdef Debug}\r
 406            assign(outf[flevel], 'CON'); rewrite(outf[flevel]);\r
 407 {$else}\r
 408            OpenOutFile(flevel, fname+'.DAT');\r
 409 {$endif}\r
 410            read_short_entry(level);\r
 411            close(outf[flevel]);\r
 412            dec(flevel);\r
 413         end\r
 414         else begin\r
 415            read_short_entry(level);\r
 416         end;\r
 417       end;\r
 418    1: begin\r
 419 (*\r
 420         if (level > 0) and (not odd(level)) then begin\r
 421            fname := MakeName;\r
 422            writeln(outf[flevel], '!long: ',fname+'.NGO');\r
 423            inc(flevel);\r
 424 {$ifdef Debug}\r
 425            assign(outf[flevel], 'CON'); rewrite(outf[flevel]);\r
 426 {$else}\r
 427            OpenOutFile(flevel, fname+'.DAT');\r
 428 {$endif}\r
 429            read_long_entry;\r
 430            close(outf[flevel]);\r
 431            dec(flevel);\r
 432         end\r
 433         else begin\r
 434            read_long_entry;\r
 435         end;\r
 436 *)\r
 437         read_long_entry;\r
 438       end;\r
 439   end;\r
 440 end;\r
 441 \r
 442 \r
 443 procedure Main;\r
 444 label Next;\r
 445 var i,j,k:word;\r
 446     linkf : text;\r
 447     fname : Dos.PathStr;\r
 448 begin\r
 449   numentries := 0;\r
 450 \r
 451   { create Menu Link Control File; }\r
 452   assign(linkf, 'GUIDE.LCF'); rewrite(linkf);\r
 453   writeln(linkf, '!name:'^i, guidename);\r
 454   writeln(linkf);\r
 455 \r
 456   for i := 0 to menuantal-1 do begin\r
 457      writeln(linkf, '!menu:'^i, mennu[i,0].name);\r
 458      ShowMenu(mennu[i,0].name);\r
 459      for j := 1 to itemlist[i]-1 do begin\r
 460         close(outf[flevel]);\r
 461         fname := MakeName;\r
 462         OpenOutFile(flevel, fname+'.dat');\r
 463         ShowMenu(mennu[i,j].name);\r
 464         writeln(linkf, ^i, mennu[i,j].name, ^i, fname+'.ngo');\r
 465         read_entry( 0, mennu[i,j].filptr );\r
 466 Next:\r
 467      end;\r
 468   end;\r
 469 \r
 470   close(linkf);\r
 471 \r
 472   { write a makefile; }\r
 473   assign(linkf, 'MAKEGUID'); rewrite(linkf);\r
 474   writeln(linkf, '.dat.ngo:');\r
 475   writeln(linkf, ^i'ngc $<');\r
 476   writeln(linkf);\r
 477   write(linkf, 'OBJECTS=');\r
 478   j := 0;\r
 479   for i := 1 to Nfiles do begin\r
 480      str(i, fname);\r
 481      fname := fname + '.ngo ';\r
 482      write(linkf, fname);\r
 483      inc(j, length(fname));\r
 484      if (j > 65) then begin\r
 485         write(linkf, '\'^m^j^i);\r
 486         j := 0;\r
 487      end;\r
 488   end;\r
 489   writeln(linkf);\r
 490   writeln(linkf);\r
 491   writeln(linkf, 'guide.ng:     $(OBJECTS)');\r
 492   writeln(linkf, ^i'ngml guide.lcf');\r
 493   close(linkf);\r
 494 end;\r
 495 \r
 496 var i:byte;\r
 497 begin                        {Main loop and command-line parser}\r
 498   flevel := 1;\r
 499   Nfiles := 0;\r
 500   for i := 1 to MaxLevel do begin\r
 501     new(OutBuf[i]);\r
 502   end;\r
 503 \r
 504 {$ifndef Debug}\r
 505   assign(outf[flevel], 'CON');\r
 506 {$else}\r
 507   assign(outf[flevel], 'GUIDE.DAT');\r
 508 {$endif}\r
 509   rewrite(outf[flevel]);\r
 510   SetTextBuf(outf[flevel], OutBuf[flevel]^, OutBufSize);\r
 511 \r
 512   writeln(progname,' ',version,'. ',copyright,'.');\r
 513   initvars; {Initialize global variables}\r
 514 \r
 515   if ((paramstr(1)='/?') or (paramstr(1)='/h') or (paramstr(1)='/H')) then begin\r
 516      Usage;\r
 517   end;\r
 518 \r
 519   if (ParamCount <> 1) then begin\r
 520      Usage;\r
 521   end;\r
 522 \r
 523   streng := paramstr(1);\r
 524 \r
 525   if pos('.',streng)=0\r
 526    then streng := streng+'.NG';        {Expand file name}\r
 527 \r
 528   assign(f, streng);\r
 529 {$I-}\r
 530   reset(f, 1);\r
 531   if ioresult<>0 then slutlort(3);   {If file does not exist, terminate and write cause of death}\r
 532 {$I+}\r
 533 \r
 534   ScreenInit;\r
 535   ShowFile(streng);\r
 536   ShowMenu('reading menu-info...');\r
 537   read_header(0);\r
 538   read_menus(False);\r
 539   Main;\r
 540 \r
 541   close(f);\r
 542   close(outf[flevel]);\r
 543   ScreenExit;\r
 544 end.\r
 545 \1a