/compiler/utils/ppumove.pp

  1{
  2    Copyright (c) 1999-2002 by the FPC Development Team
  3
  4    Add multiple FPC units into a static/shared library
  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{$ifndef TP}
 22  {$H+}
 23{$endif}
 24Program ppumove;
 25uses
 26
 27{$IFDEF MACOS}
 28{$DEFINE USE_FAKE_SYSUTILS}
 29{$ENDIF MACOS}
 30
 31{$IFNDEF USE_FAKE_SYSUTILS}
 32  sysutils,
 33{$ELSE}
 34  fksysutl,
 35{$ENDIF}
 36
 37{$ifdef unix}
 38  Baseunix,Unix, Dos,
 39{$else unix}
 40  dos,
 41{$endif unix}
 42  cutils,ppu,systems,
 43  getopts;
 44
 45const
 46  Version   = 'Version 2.1.1';
 47  Title     = 'PPU-Mover';
 48  Copyright = 'Copyright (c) 1998-2007 by the Free Pascal Development Team';
 49
 50  ShortOpts = 'o:e:d:i:qhsvb';
 51  BufSize = 4096;
 52  PPUExt = 'ppu';
 53  ObjExt = 'o';
 54  StaticLibExt ='a';
 55{$ifdef unix}
 56  SharedLibExt ='so';
 57  BatchExt     ='.sh';
 58{$else}
 59  SharedLibExt ='dll';
 60  BatchExt     ='.bat';
 61{$endif unix}
 62
 63  { link options }
 64  link_none    = $0;
 65  link_always  = $1;
 66  link_static  = $2;
 67  link_smart   = $4;
 68  link_shared  = $8;
 69
 70Type
 71  PLinkOEnt = ^TLinkOEnt;
 72  TLinkOEnt = record
 73    Name : string;
 74    Next : PLinkOEnt;
 75  end;
 76
 77Var
 78  ArBin,LDBin,StripBin,
 79  OutputFileForPPU,
 80  OutputFile,
 81  OutputFileForLink,  { the name of the output file needed when linking }
 82  InputPath,
 83  DestPath,
 84  PPLExt,
 85  LibExt      : string;
 86  DoStrip,
 87  Batch,
 88  Quiet,
 89  MakeStatic  : boolean;
 90  Buffer      : Pointer;
 91  ObjFiles    : PLinkOEnt;
 92  BatchFile   : Text;
 93  Libs        : ansistring;
 94
 95{*****************************************************************************
 96                                 Helpers
 97*****************************************************************************}
 98
 99Procedure Error(const s:string;stop:boolean);
100{
101  Write an error message to stderr
102}
103begin
104  writeln(stderr,s);
105  if stop then
106   halt(1);
107end;
108
109
110function Shell(const s:string):longint;
111{
112  Run a shell commnad and return the exitcode
113}
114begin
115  if Batch then
116   begin
117     Writeln(BatchFile,s);
118     Shell:=0;
119     exit;
120   end;
121{$ifdef unix}
122  Shell:=unix.fpsystem(s);
123{$else}
124  exec(getenv('COMSPEC'),'/C '+s);
125  Shell:=DosExitCode;
126{$endif}
127end;
128
129
130Function FileExists (Const F : String) : Boolean;
131{
132  Returns True if the file exists, False if not.
133}
134Var
135{$ifdef unix}
136  info : Stat;
137{$else}
138  info : searchrec;
139{$endif}
140begin
141{$ifdef unix}
142  FileExists:=FpStat(F,Info)=0;
143{$else}
144  FindFirst (F,anyfile,Info);
145  FileExists:=DosError=0;
146{$endif}
147end;
148
149
150Function ChangeFileExt(Const HStr,ext:String):String;
151{
152  Return a filename which will have extension ext added if no
153  extension is found
154}
155var
156  j : longint;
157begin
158  j:=length(Hstr);
159  while (j>0) and (Hstr[j]<>'.') do
160   dec(j);
161  if j=0 then
162   ChangeFileExt:=Hstr+'.'+Ext
163  else
164   ChangeFileExt:=HStr;
165end;
166
167
168Function ForceExtension(Const HStr,ext:String):String;
169{
170  Return a filename which certainly has the extension ext
171}
172var
173  j : longint;
174begin
175  j:=length(Hstr);
176  while (j>0) and (Hstr[j]<>'.') do
177   dec(j);
178  if j=0 then
179   j:=255;
180  ForceExtension:=Copy(Hstr,1,j-1)+'.'+Ext;
181end;
182
183
184Procedure AddToLinkFiles(const S : String);
185{
186  Adds a filename to a list of object files to link to.
187  No duplicates allowed.
188}
189Var
190  P : PLinKOEnt;
191begin
192  P:=ObjFiles;
193  { Don't add files twice }
194  While (P<>nil) and (p^.name<>s) do
195    p:=p^.next;
196  if p=nil then
197   begin
198     new(p);
199     p^.next:=ObjFiles;
200     p^.name:=s;
201     ObjFiles:=P;
202   end;
203end;
204
205
206Function ExtractLib(const libfn:string):string;
207{
208  Extract a static library libfn and return the files with a
209  wildcard
210}
211var
212  n : namestr;
213  d : dirstr;
214  e : extstr;
215begin
216{ create the temp dir first }
217  fsplit(libfn,d,n,e);
218  {$push}{$I-}
219   mkdir(n+'.sl');
220  {$pop}
221  if ioresult<>0 then;
222{ Extract }
223  if Shell(arbin+' x '+libfn)<>0 then
224   Error('Fatal: Error running '+arbin,true);
225{ Remove the lib file, it's extracted so it can be created with ease }
226  if PPLExt=PPUExt then
227   Shell('rm '+libfn);
228{$ifdef unix}
229  ExtractLib:=n+'.sl/*';
230{$else}
231  ExtractLib:=n+'.sl\*';
232{$endif}
233end;
234
235
236Function DoPPU(const PPUFn,PPLFn:String):Boolean;
237{
238  Convert one file (in Filename) to library format.
239  Return true if successful, false otherwise.
240}
241Var
242  inppu,
243  outppu : tppufile;
244  b,
245  untilb : byte;
246  l,m    : longint;
247  f      : file;
248  ext,
249  s      : string;
250  ppuversion : dword;
251begin
252  DoPPU:=false;
253  If Not Quiet then
254   Write ('Processing ',PPUFn,'...');
255  inppu:=tppufile.create(PPUFn);
256  if not inppu.openfile then
257   begin
258     inppu.free;
259     Error('Error: Could not open : '+PPUFn,false);
260     Exit;
261   end;
262{ Check the ppufile }
263  if not inppu.CheckPPUId then
264   begin
265     inppu.free;
266     Error('Error: Not a PPU File : '+PPUFn,false);
267     Exit;
268   end;
269  ppuversion:=inppu.GetPPUVersion;
270  if ppuversion<CurrentPPUVersion then
271   begin
272     inppu.free;
273     Error('Error: Wrong PPU Version '+tostr(ppuversion)+' in '+PPUFn,false);
274     Exit;
275   end;
276{ No .o file generated for this ppu, just skip }
277  if (inppu.header.flags and uf_no_link)<>0 then
278   begin
279     inppu.free;
280     If Not Quiet then
281      Writeln (' No files.');
282     DoPPU:=true;
283     Exit;
284   end;
285{ Already a lib? }
286  if (inppu.header.flags and uf_in_library)<>0 then
287   begin
288     inppu.free;
289     Error('Error: PPU is already in a library : '+PPUFn,false);
290     Exit;
291   end;
292{ We need a static linked unit }
293  if (inppu.header.flags and uf_static_linked)=0 then
294   begin
295     inppu.free;
296     Error('Error: PPU is not static linked : '+PPUFn,false);
297     Exit;
298   end;
299{ Check if shared is allowed }
300  if tsystem(inppu.header.target) in [system_i386_go32v2] then
301   begin
302     Writeln('Warning: shared library not supported for ppu target, switching to static library');
303     MakeStatic:=true;
304   end;
305{ Create the new ppu }
306  if PPUFn=PPLFn then
307   outppu:=tppufile.create('ppumove.$$$')
308  else
309   outppu:=tppufile.create(PPLFn);
310  outppu.createfile;
311{ Create new header, with the new flags }
312  outppu.header:=inppu.header;
313  outppu.header.flags:=outppu.header.flags or uf_in_library;
314  if MakeStatic then
315   outppu.header.flags:=outppu.header.flags or uf_static_linked
316  else
317   outppu.header.flags:=outppu.header.flags or uf_shared_linked;
318{ read until the object files are found }
319  untilb:=iblinkunitofiles;
320  repeat
321    b:=inppu.readentry;
322    if b in [ibendinterface,ibend] then
323     begin
324       inppu.free;
325       outppu.free;
326       Error('Error: No files to be linked found : '+PPUFn,false);
327       Exit;
328     end;
329    if b<>untilb then
330     begin
331       repeat
332         inppu.getdatabuf(buffer^,bufsize,l);
333         outppu.putdata(buffer^,l);
334       until l<bufsize;
335       outppu.writeentry(b);
336     end;
337  until (b=untilb);
338{ we have now reached the section for the files which need to be added,
339  now add them to the list }
340  case b of
341    iblinkunitofiles :
342      begin
343        { add all o files, and save the entry when not creating a static
344          library to keep staticlinking possible }
345        while not inppu.endofentry do
346         begin
347           s:=inppu.getstring;
348           m:=inppu.getlongint;
349           if not MakeStatic then
350            begin
351              outppu.putstring(s);
352              outppu.putlongint(m);
353            end;
354           AddToLinkFiles(s);
355         end;
356        if not MakeStatic then
357         outppu.writeentry(b);
358      end;
359{    iblinkunitstaticlibs :
360      begin
361        AddToLinkFiles(ExtractLib(inppu.getstring));
362        if not inppu.endofentry then
363         begin
364           repeat
365             inppu.getdatabuf(buffer^,bufsize,l);
366             outppu.putdata(buffer^,l);
367           until l<bufsize;
368           outppu.writeentry(b);
369         end;
370       end; }
371  end;
372{ just add a new entry with the new lib }
373  if MakeStatic then
374   begin
375     outppu.putstring(OutputfileForPPU);
376     outppu.putlongint(link_static);
377     outppu.writeentry(iblinkunitstaticlibs)
378   end
379  else
380   begin
381     outppu.putstring(OutputfileForPPU);
382     outppu.putlongint(link_shared);
383     outppu.writeentry(iblinkunitsharedlibs);
384   end;
385{ read all entries until the end and write them also to the new ppu }
386  repeat
387    b:=inppu.readentry;
388  { don't write ibend, that's written automatically }
389    if b<>ibend then
390     begin
391       if b=iblinkothersharedlibs then
392         begin
393           while not inppu.endofentry do
394             begin
395               s:=inppu.getstring;
396               m:=inppu.getlongint;
397
398               outppu.putstring(s);
399
400               { strip lib prefix }
401               if copy(s,1,3)='lib' then
402                 delete(s,1,3);
403
404               { strip lib prefix }
405               if copy(s,1,3)='lib' then
406                 delete(s,1,3);
407               ext:=ExtractFileExt(s);
408               if ext<>'' then
409                 delete(s,length(s)-length(ext)+1,length(ext));
410
411               libs:=libs+' -l'+s;
412
413               outppu.putlongint(m);
414             end;
415         end
416       else
417         repeat
418           inppu.getdatabuf(buffer^,bufsize,l);
419           outppu.putdata(buffer^,l);
420         until l<bufsize;
421       outppu.writeentry(b);
422     end;
423  until b=ibend;
424{ write the last stuff and close }
425  outppu.flush;
426  outppu.writeheader;
427  outppu.free;
428  inppu.free;
429{ rename }
430  if PPUFn=PPLFn then
431   begin
432     {$push}{$I-}
433      assign(f,PPUFn);
434      erase(f);
435      assign(f,'ppumove.$$$');
436      rename(f,PPUFn);
437     {$pop}
438     if ioresult<>0 then;
439   end;
440{ the end }
441  If Not Quiet then
442   Writeln (' Done.');
443  DoPPU:=True;
444end;
445
446
447Function DoFile(const FileName:String):Boolean;
448{
449  Process a file, mainly here for wildcard support under Dos
450}
451{$ifndef unix}
452var
453  dir : searchrec;
454{$endif}
455begin
456{$ifdef unix}
457  DoFile:=DoPPU(InputPath+FileName,InputPath+ForceExtension(FileName,PPLExt));
458{$else}
459  DoFile:=false;
460  findfirst(filename,$20,dir);
461  while doserror=0 do
462   begin
463     if not DoPPU(InputPath+Dir.Name,InputPath+ForceExtension(Dir.Name,PPLExt)) then
464      exit;
465     findnext(dir);
466   end;
467  findclose(dir);
468  DoFile:=true;
469{$endif}
470end;
471
472
473Procedure DoLink;
474{
475  Link the object files together to form a (shared) library
476}
477Var
478  Names : ansistring;
479  f     : file;
480  Err   : boolean;
481  P     : PLinkOEnt;
482begin
483  if not Quiet then
484   Write ('Linking ');
485  P:=ObjFiles;
486  names:='';
487  While p<>nil do
488   begin
489     if Names<>'' then
490      Names:=Names+' '+InputPath+P^.name
491     else
492      Names:=InputPath+p^.Name;
493     p:=p^.next;
494   end;
495  if Names='' then
496   begin
497     If not Quiet then
498      Writeln('Error: no files found to be linked');
499     exit;
500   end;
501  If not Quiet then
502    WriteLn(names+Libs);
503{ Run ar or ld to create the lib }
504  If MakeStatic then
505   Err:=Shell(arbin+' rs '+outputfile+' '+names)<>0
506  else
507   begin
508     Err:=Shell(ldbin+' -shared -E -o '+OutputFile+' '+names+' '+libs)<>0;
509     if (not Err) and dostrip then
510      Shell(stripbin+' --strip-unneeded '+OutputFile);
511   end;
512  If Err then
513   Error('Fatal: Library building stage failed.',true);
514{ fix permission to 644, so it's not 755 }
515{$ifdef unix}
516  FPChmod(OutputFile,420);
517{$endif}
518{ Rename to the destpath }
519  if DestPath<>'' then
520   begin
521     Assign(F, OutputFile);
522     Rename(F,DestPath+DirectorySeparator+OutputFile);
523   end;
524end;
525
526
527Procedure usage;
528{
529  Print usage and exit.
530}
531begin
532  Writeln(paramstr(0),': [-qhvbsS] [-e ext] [-o name] [-d path] file [file ...]');
533  Halt(0);
534end;
535
536
537
538Procedure processopts;
539{
540  Process command line opions, and checks if command line options OK.
541}
542var
543  C : char;
544begin
545  if paramcount=0 then
546   usage;
547{ Reset }
548  ObjFiles:=Nil;
549  Quiet:=False;
550  Batch:=False;
551  DoStrip:=False;
552  OutputFile:='';
553  PPLExt:='ppu';
554  ArBin:='ar';
555  LdBin:='ld';
556  StripBin:='strip';
557  repeat
558    c:=Getopt (ShortOpts);
559    Case C of
560      EndOfOptions : break;
561      'S' : MakeStatic:=True;
562      'o' : OutputFile:=OptArg;
563      'd' : DestPath:=OptArg;
564      'i' : begin
565              InputPath:=OptArg;
566              if InputPath[length(InputPath)]<>DirectorySeparator then
567                InputPath:=InputPath+DirectorySeparator;
568            end;
569      'e' : PPLext:=OptArg;
570      'q' : Quiet:=True;
571      'b' : Batch:=true;
572      's' : DoStrip:=true;
573      '?' : Usage;
574      'h' : Usage;
575    end;
576  until false;
577{ Test filenames on the commandline }
578  if (OptInd>Paramcount) then
579   Error('Error: no input files',true);
580  if (OptInd<ParamCount) and (OutputFile='') then
581   Error('Error: when moving multiple units, specify an output name.',true);
582{ alloc a buffer }
583  GetMem (Buffer,Bufsize);
584  If Buffer=Nil then
585   Error('Error: could not allocate memory for buffer.',true);
586end;
587
588
589var
590  i : longint;
591begin
592  Libs:='';
593  ProcessOpts;
594{ Write Header }
595  if not Quiet then
596   begin
597     Writeln(Title+' '+Version);
598     Writeln(Copyright);
599     Writeln;
600   end;
601{ fix the libext and outputfilename }
602  if Makestatic then
603   LibExt:=StaticLibExt
604  else
605   LibExt:=SharedLibExt;
606  if OutputFile='' then
607   OutputFile:=Paramstr(OptInd);
608  OutputFileForPPU:=OutputFile;
609{ fix filename }
610{$ifdef unix}
611  if Copy(OutputFile,1,3)<>'lib' then
612   OutputFile:='lib'+OutputFile;
613  { For unix skip replacing the extension if a full .so.X.X if specified }
614  i:=pos('.so.',Outputfile);
615  if i<>0 then
616   OutputFileForLink:=Copy(Outputfile,4,i-4)
617  else
618   begin
619     OutputFile:=ForceExtension(OutputFile,LibExt);
620     OutputFileForLink:=Copy(Outputfile,4,length(Outputfile)-length(LibExt)-4);
621   end;
622{$else}
623  OutputFile:=ForceExtension(OutputFile,LibExt);
624  OutputFileForLink:=OutputFile;
625{$endif}
626{ Open BatchFile }
627  if Batch then
628   begin
629     Assign(BatchFile,'pmove'+BatchExt);
630     Rewrite(BatchFile);
631   end;
632{ Process Files }
633  i:=OptInd;
634  While (i<=ParamCount) and Dofile(ChangeFileExt(Paramstr(i),PPUExt)) do
635   Inc(i);
636{ Do Linking stage }
637  DoLink;
638{ Close BatchFile }
639  if Batch then
640   begin
641     if Not Quiet then
642      Writeln('Writing pmove'+BatchExt);
643     Close(BatchFile);
644{$ifdef unix}
645  FPChmod('pmove'+BatchExt,493);
646{$endif}
647   end;
648{ The End }
649  if Not Quiet then
650   Writeln('Done.');
651end.