1 { 2 Copyright (c) 1998-2002 by Florian Klaempfl 3 4 This unit implements an extended file management 5 6 This program is free software; you can redistribute it and/or modify 7 it under the terms of the GNU General Public License as published by 8 the Free Software Foundation; either version 2 of the License, or 9 (at your option) any later version. 10 11 This program is distributed in the hope that it will be useful, 12 but WITHOUT ANY WARRANTY; without even the implied warranty of 13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 GNU General Public License for more details. 15 16 You should have received a copy of the GNU General Public License 17 along with this program; if not, write to the Free Software 18 Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. 19 20 **************************************************************************** 21 } 22 unit finput; 23 24 {$i fpcdefs.inc} 25 26 interface 27 28 uses 29 cutils,globtype,cclasses,cstreams; 30 31 const 32 InputFileBufSize=32*1024+1; 33 linebufincrease=512; 34 35 type 36 tlongintarr = array[0..1000000] of longint; 37 plongintarr = ^tlongintarr; 38 39 tinputfile = class 40 path,name : TPathStr; { path and filename } 41 inc_path : TPathStr; { path if file was included with $I directive } 42 next : tinputfile; { next file for reading } 43 44 is_macro, 45 endoffile, { still bytes left to read } 46 closed : boolean; { is the file closed } 47 48 buf : pchar; { buffer } 49 bufstart, { buffer start position in the file } 50 bufsize, { amount of bytes in the buffer } 51 maxbufsize : longint; { size in memory for the buffer } 52 53 saveinputpointer : pchar; { save fields for scanner variables } 54 savelastlinepos, 55 saveline_no : longint; 56 57 linebuf : plongintarr; { line buffer to retrieve lines } 58 maxlinebuf : longint; 59 60 ref_index : longint; 61 ref_next : tinputfile; 62 63 constructor create(const fn:TPathStr); 64 destructor destroy;override; 65 procedure setpos(l:longint); 66 procedure seekbuf(fpos:longint); 67 procedure readbuf; opennull68 function open:boolean; 69 procedure close; 70 procedure tempclose; tempopennull71 function tempopen:boolean; 72 procedure setmacro(p:pchar;len:longint); 73 procedure setline(line,linepos:longint); getlinestrnull74 function getlinestr(l:longint):string; getfiletimenull75 function getfiletime:longint; 76 protected 77 filetime : longint; fileopennull78 function fileopen(const filename: TPathStr): boolean; virtual; abstract; fileseeknull79 function fileseek(pos: longint): boolean; virtual; abstract; filereadnull80 function fileread(var databuf; maxsize: longint): longint; virtual; abstract; fileeofnull81 function fileeof: boolean; virtual; abstract; fileclosenull82 function fileclose: boolean; virtual; abstract; 83 procedure filegettime; virtual; abstract; 84 end; 85 86 tdosinputfile = class(tinputfile) 87 protected fileopennull88 function fileopen(const filename: TPathStr): boolean; override; fileseeknull89 function fileseek(pos: longint): boolean; override; filereadnull90 function fileread(var databuf; maxsize: longint): longint; override; fileeofnull91 function fileeof: boolean; override; fileclosenull92 function fileclose: boolean; override; 93 procedure filegettime; override; 94 private 95 f : TCCustomFileStream; { current file handle } 96 end; 97 98 tinputfilemanager = class 99 files : tinputfile; 100 last_ref_index : longint; 101 cacheindex : longint; 102 cacheinputfile : tinputfile; 103 constructor create; 104 destructor destroy;override; 105 procedure register_file(f : tinputfile); get_filenull106 function get_file(l:longint) : tinputfile; get_file_namenull107 function get_file_name(l :longint):TPathStr; get_file_pathnull108 function get_file_path(l :longint):TPathStr; 109 end; 110 111 {**************************************************************************** 112 TModuleBase 113 ****************************************************************************} 114 115 type 116 tmodulestate = (ms_unknown, 117 ms_registered, 118 ms_load,ms_compile, 119 ms_second_load,ms_second_compile, 120 ms_compiled 121 ); 122 const 123 ModuleStateStr : array[TModuleState] of string[20] = ( 124 'Unknown', 125 'Registered', 126 'Load','Compile', 127 'Second_Load','Second_Compile', 128 'Compiled' 129 ); 130 131 type 132 tmodulebase = class(TLinkedListItem) 133 { index } 134 unit_index : longint; { global counter for browser } 135 { status } 136 state : tmodulestate; 137 { sources } 138 sourcefiles : tinputfilemanager; 139 { paths and filenames } 140 paramallowoutput : boolean; { original allowoutput parameter } 141 modulename, { name of the module in uppercase } 142 realmodulename: pshortstring; { name of the module in the orignal case } 143 paramfn, { original filename } 144 mainsource, { name of the main sourcefile } 145 objfilename, { fullname of the objectfile } 146 asmfilename, { fullname of the assemblerfile } 147 ppufilename, { fullname of the ppufile } 148 importlibfilename, { fullname of the import libraryfile } 149 staticlibfilename, { fullname of the static libraryfile } 150 sharedlibfilename, { fullname of the shared libraryfile } 151 exportfilename, { fullname of the export file } 152 mapfilename, { fullname of the mapfile } 153 exefilename, { fullname of the exefile } 154 dbgfilename, { fullname of the debug info file } 155 path, { path where the module is find/created } 156 outputpath : TPathStr; { path where the .s / .o / exe are created } 157 constructor create(const s:string); 158 destructor destroy;override; 159 procedure setfilename(const fn:TPathStr;allowoutput:boolean); 160 end; 161 162 GetNamedFileTimenull163 Function GetNamedFileTime (Const F : TPathStr) : Longint; 164 165 166 implementation 167 168 uses 169 SysUtils, 170 Comphook, 171 {$ifndef GENERIC_CPU} 172 {$ifdef heaptrc} 173 fmodule, 174 ppheap, 175 {$endif heaptrc} 176 {$endif not GENERIC_CPU} 177 cfileutl, 178 Globals,Systems 179 ; 180 181 182 {**************************************************************************** 183 Utils 184 ****************************************************************************} 185 GetNamedFileTimenull186 Function GetNamedFileTime (Const F : TPathStr) : Longint; 187 begin 188 GetNamedFileTime:=do_getnamedfiletime(F); 189 end; 190 191 192 {**************************************************************************** 193 TINPUTFILE 194 ****************************************************************************} 195 196 constructor tinputfile.create(const fn:TPathStr); 197 begin 198 name:=ExtractFileName(fn); 199 path:=ExtractFilePath(fn); 200 inc_path:=''; 201 next:=nil; 202 filetime:=-1; 203 { file info } 204 is_macro:=false; 205 endoffile:=false; 206 closed:=true; 207 buf:=nil; 208 bufstart:=0; 209 bufsize:=0; 210 maxbufsize:=InputFileBufSize; 211 { save fields } 212 saveinputpointer:=nil; 213 saveline_no:=0; 214 savelastlinepos:=0; 215 { indexing refs } 216 ref_next:=nil; 217 ref_index:=0; 218 { line buffer } 219 linebuf:=nil; 220 maxlinebuf:=0; 221 end; 222 223 224 destructor tinputfile.destroy; 225 begin 226 if not closed then 227 close; 228 { free memory } 229 if assigned(linebuf) then 230 freemem(linebuf,maxlinebuf*sizeof(linebuf^[0])); 231 end; 232 233 234 procedure tinputfile.setpos(l:longint); 235 begin 236 bufstart:=l; 237 end; 238 239 240 procedure tinputfile.seekbuf(fpos:longint); 241 begin 242 if closed then 243 exit; 244 fileseek(fpos); 245 bufstart:=fpos; 246 bufsize:=0; 247 end; 248 249 250 procedure tinputfile.readbuf; 251 begin 252 if is_macro then 253 endoffile:=true; 254 if closed then 255 exit; 256 inc(bufstart,bufsize); 257 bufsize:=fileread(buf^,maxbufsize-1); 258 buf[bufsize]:=#0; 259 endoffile:=fileeof; 260 end; 261 262 tinputfile.opennull263 function tinputfile.open:boolean; 264 begin 265 open:=false; 266 if not closed then 267 Close; 268 if not fileopen(path+name) then 269 exit; 270 { file } 271 endoffile:=false; 272 closed:=false; 273 Getmem(buf,MaxBufsize); 274 buf[0]:=#0; 275 bufstart:=0; 276 bufsize:=0; 277 open:=true; 278 end; 279 280 281 procedure tinputfile.close; 282 begin 283 if is_macro then 284 begin 285 if assigned(buf) then 286 begin 287 Freemem(buf,maxbufsize); 288 buf:=nil; 289 end; 290 name:=''; 291 path:=''; 292 closed:=true; 293 exit; 294 end; 295 if not closed then 296 begin 297 fileclose; 298 closed:=true; 299 end; 300 if assigned(buf) then 301 begin 302 Freemem(buf,maxbufsize); 303 buf:=nil; 304 end; 305 bufstart:=0; 306 end; 307 308 309 procedure tinputfile.tempclose; 310 begin 311 if is_macro then 312 exit; 313 if not closed then 314 begin 315 fileclose; 316 if assigned(buf) then 317 begin 318 Freemem(buf,maxbufsize); 319 buf:=nil; 320 end; 321 closed:=true; 322 end; 323 end; 324 325 tinputfile.tempopennull326 function tinputfile.tempopen:boolean; 327 begin 328 tempopen:=false; 329 if is_macro then 330 begin 331 { seek buffer postion to bufstart } 332 if bufstart>0 then 333 begin 334 move(buf[bufstart],buf[0],bufsize-bufstart+1); 335 bufstart:=0; 336 end; 337 tempopen:=true; 338 exit; 339 end; 340 if not closed then 341 exit; 342 if not fileopen(path+name) then 343 exit; 344 closed:=false; 345 { get new mem } 346 Getmem(buf,maxbufsize); 347 { restore state } 348 fileseek(BufStart); 349 bufsize:=0; 350 readbuf; 351 tempopen:=true; 352 end; 353 354 355 procedure tinputfile.setmacro(p:pchar;len:longint); 356 begin 357 { create new buffer } 358 getmem(buf,len+1); 359 move(p^,buf^,len); 360 buf[len]:=#0; 361 { reset } 362 bufstart:=0; 363 bufsize:=len; 364 maxbufsize:=len+1; 365 is_macro:=true; 366 endoffile:=true; 367 closed:=true; 368 end; 369 370 371 procedure tinputfile.setline(line,linepos:longint); 372 begin 373 if line<1 then 374 exit; 375 while (line>=maxlinebuf) do 376 begin 377 { create new linebuf and move old info } 378 linebuf:=reallocmem(linebuf,(maxlinebuf+linebufincrease)*sizeof(linebuf^[0])); 379 fillchar(linebuf^[maxlinebuf],linebufincrease*sizeof(linebuf^[0]),0); 380 inc(maxlinebuf,linebufincrease); 381 end; 382 linebuf^[line]:=linepos; 383 end; 384 385 tinputfile.getlinestrnull386 function tinputfile.getlinestr(l:longint):string; 387 var 388 c : char; 389 i, 390 fpos : longint; 391 p : pchar; 392 begin 393 getlinestr:=''; 394 if l<maxlinebuf then 395 begin 396 fpos:=linebuf^[l]; 397 { fpos is set negativ if the line was already written } 398 { but we still know the correct value } 399 if fpos<0 then 400 fpos:=-fpos+1; 401 if closed then 402 open; 403 { in current buf ? } 404 if (fpos<bufstart) or (fpos>bufstart+bufsize) then 405 begin 406 seekbuf(fpos); 407 readbuf; 408 end; 409 { the begin is in the buf now simply read until #13,#10 } 410 i:=0; 411 p:=@buf[fpos-bufstart]; 412 repeat 413 c:=p^; 414 if c=#0 then 415 begin 416 if endoffile then 417 break; 418 readbuf; 419 p:=buf; 420 c:=p^; 421 end; 422 if c in [#10,#13] then 423 break; 424 inc(i); 425 getlinestr[i]:=c; 426 inc(p); 427 until (i=255); 428 getlinestr[0]:=chr(i); 429 end; 430 end; 431 432 tinputfile.getfiletimenull433 function tinputfile.getfiletime:longint; 434 begin 435 if filetime=-1 then 436 filegettime; 437 getfiletime:=filetime; 438 end; 439 440 441 {**************************************************************************** 442 TDOSINPUTFILE 443 ****************************************************************************} 444 tdosinputfile.fileopennull445 function tdosinputfile.fileopen(const filename: TPathStr): boolean; 446 begin 447 { Check if file exists, this will also check if it is 448 a real file and not a directory } 449 if not fileexists(filename,false) then 450 begin 451 result:=false; 452 exit; 453 end; 454 { Open file } 455 fileopen:=false; 456 try 457 f:=CFileStreamClass.Create(filename,fmOpenRead); 458 fileopen:=CStreamError=0; 459 except 460 end; 461 end; 462 463 tdosinputfile.fileseeknull464 function tdosinputfile.fileseek(pos: longint): boolean; 465 begin 466 fileseek:=false; 467 try 468 f.position:=Pos; 469 fileseek:=true; 470 except 471 end; 472 end; 473 474 tdosinputfile.filereadnull475 function tdosinputfile.fileread(var databuf; maxsize: longint): longint; 476 begin 477 fileread:=f.Read(databuf,maxsize); 478 end; 479 480 tdosinputfile.fileeofnull481 function tdosinputfile.fileeof: boolean; 482 begin 483 fileeof:=f.eof(); 484 end; 485 486 tdosinputfile.fileclosenull487 function tdosinputfile.fileclose: boolean; 488 begin 489 fileclose:=false; 490 try 491 f.Free; 492 fileclose:=true; 493 except 494 end; 495 end; 496 497 498 procedure tdosinputfile.filegettime; 499 begin 500 filetime:=getnamedfiletime(path+name); 501 end; 502 503 504 {**************************************************************************** 505 Tinputfilemanager 506 ****************************************************************************} 507 508 constructor tinputfilemanager.create; 509 begin 510 files:=nil; 511 last_ref_index:=0; 512 cacheindex:=0; 513 cacheinputfile:=nil; 514 end; 515 516 517 destructor tinputfilemanager.destroy; 518 var 519 hp : tinputfile; 520 begin 521 hp:=files; 522 while assigned(hp) do 523 begin 524 files:=files.ref_next; 525 hp.free; 526 hp:=files; 527 end; 528 last_ref_index:=0; 529 end; 530 531 532 procedure tinputfilemanager.register_file(f : tinputfile); 533 begin 534 { don't register macro's } 535 if f.is_macro then 536 exit; 537 inc(last_ref_index); 538 f.ref_next:=files; 539 f.ref_index:=last_ref_index; 540 files:=f; 541 { update cache } 542 cacheindex:=last_ref_index; 543 cacheinputfile:=f; 544 {$ifndef GENERIC_CPU} 545 {$ifdef heaptrc} 546 ppheap_register_file(f.path+f.name,current_module.unit_index*100000+f.ref_index); 547 {$endif heaptrc} 548 {$endif not GENERIC_CPU} 549 end; 550 551 tinputfilemanager.get_filenull552 function tinputfilemanager.get_file(l :longint) : tinputfile; 553 var 554 ff : tinputfile; 555 begin 556 { check cache } 557 if (l=cacheindex) and assigned(cacheinputfile) then 558 begin 559 get_file:=cacheinputfile; 560 exit; 561 end; 562 ff:=files; 563 while assigned(ff) and (ff.ref_index<>l) do 564 ff:=ff.ref_next; 565 if assigned(ff) then 566 begin 567 cacheindex:=ff.ref_index; 568 cacheinputfile:=ff; 569 end; 570 get_file:=ff; 571 end; 572 573 tinputfilemanager.get_file_namenull574 function tinputfilemanager.get_file_name(l :longint):TPathStr; 575 var 576 hp : tinputfile; 577 begin 578 hp:=get_file(l); 579 if assigned(hp) then 580 get_file_name:=hp.name 581 else 582 get_file_name:=''; 583 end; 584 585 tinputfilemanager.get_file_pathnull586 function tinputfilemanager.get_file_path(l :longint):TPathStr; 587 var 588 hp : tinputfile; 589 begin 590 hp:=get_file(l); 591 if assigned(hp) then 592 get_file_path:=hp.path 593 else 594 get_file_path:=''; 595 end; 596 597 598 {**************************************************************************** 599 TModuleBase 600 ****************************************************************************} 601 602 procedure tmodulebase.setfilename(const fn:TPathStr;allowoutput:boolean); 603 var 604 p, n, 605 prefix, 606 suffix : TPathStr; 607 begin 608 { Create names } 609 paramfn := fn; 610 paramallowoutput := allowoutput; 611 p := FixPath(ExtractFilePath(fn),false); 612 n := FixFileName(ChangeFileExt(ExtractFileName(fn),'')); 613 { set path } 614 path:=p; 615 { obj,asm,ppu names } 616 if AllowOutput then 617 begin 618 if (OutputUnitDir<>'') then 619 p:=OutputUnitDir 620 else 621 if (OutputExeDir<>'') then 622 p:=OutputExeDir; 623 end; 624 outputpath:=p; 625 asmfilename:=p+n+target_info.asmext; 626 objfilename:=p+n+target_info.objext; 627 ppufilename:=p+n+target_info.unitext; 628 importlibfilename:=p+target_info.importlibprefix+n+target_info.importlibext; 629 staticlibfilename:=p+target_info.staticlibprefix+n+target_info.staticlibext; 630 exportfilename:=p+'exp'+n+target_info.objext; 631 632 { output dir of exe can be specified separatly } 633 if AllowOutput and (OutputExeDir<>'') then 634 p:=OutputExeDir 635 else 636 p:=path; 637 638 { lib and exe could be loaded with a file specified with -o } 639 if AllowOutput and 640 (compile_level=1) and 641 (OutputFileName<>'')then 642 begin 643 exefilename:=p+OutputFileName; 644 sharedlibfilename:=p+OutputFileName; 645 n:=ChangeFileExt(OutputFileName,''); { for mapfilename and dbgfilename } 646 end 647 else 648 begin 649 exefilename:=p+n+target_info.exeext; 650 if Assigned(OutputPrefix) then 651 prefix := OutputPrefix^ 652 else 653 prefix := target_info.sharedlibprefix; 654 if Assigned(OutputSuffix) then 655 suffix := OutputSuffix^ 656 else 657 suffix := ''; 658 sharedlibfilename:=p+prefix+n+suffix+target_info.sharedlibext; 659 end; 660 mapfilename:=p+n+'.map'; 661 dbgfilename:=p+n+'.dbg'; 662 end; 663 664 665 constructor tmodulebase.create(const s:string); 666 begin 667 modulename:=stringdup(Upper(s)); 668 realmodulename:=stringdup(s); 669 mainsource:=''; 670 ppufilename:=''; 671 objfilename:=''; 672 asmfilename:=''; 673 importlibfilename:=''; 674 staticlibfilename:=''; 675 sharedlibfilename:=''; 676 exefilename:=''; 677 dbgfilename:=''; 678 mapfilename:=''; 679 outputpath:=''; 680 paramfn:=''; 681 path:=''; 682 { status } 683 state:=ms_registered; 684 { unit index } 685 inc(global_unit_count); 686 unit_index:=global_unit_count; 687 { sources } 688 sourcefiles:=TInputFileManager.Create; 689 end; 690 691 692 destructor tmodulebase.destroy; 693 begin 694 if assigned(sourcefiles) then 695 sourcefiles.free; 696 sourcefiles:=nil; 697 stringdispose(modulename); 698 stringdispose(realmodulename); 699 inherited destroy; 700 end; 701 702 end. 703