[Back to ARCHIVES SWAG index]  [Back to Main SWAG index]  [Original]

{
  This code may be used as long as the resulting product is FREE.

  See the end of the file (after end.) for the zipfile data structure

  Written by Zak Smith

       I am reachable the following ways..
             sysop Sirius Cybernetics 414-966-3552
             Zak Smith @ 1:154/736 fido-land
             zak.smith@mixcom.com
}


{$M 32768,0,65520}
Program ZipComment;  { by Zak, mahahaha }
Uses Dos,Crt;
Type FindZipType = record
    id : longint;
    dn : array[1..2] of byte;
    sd : array[1..2] of byte;
    cd : array[1..2] of byte;
    tcd: array[1..2] of byte;
    scd: array[1..4] of byte;
    sdn: array[1..4] of byte;
    cl : word;
   end;
var total    : longint;
    starttime: longint;
type commentfiletype = record
      len : word;
      data : array[1..5120] of byte;
      end;

function SecondsSinceMidnight(h,m,s:word):longint;
  begin
  SecondsSinceMidnight := (h*3600)+(m*60)+s
  end;

procedure CurTime(var h:word; var m: word;var s:word);
 Var Hour,Min,Sec,Sec100:word;
 begin
 GetTime(Hour,Min,Sec,Sec100);
 h:=hour;
 m:=min;
 s:=sec;
 end;

function nowsecondssincemidnight: longint;
 var h,m,s: word;
 begin
 curtime(h,m,s);
 nowsecondssincemidnight:=secondssincemidnight(h,m,s);
 end;

(********* The following search engine routines are sneakly swiped *********)
(********* from Turbo Technix v1n6.  See there for further details *********)

type
  ProcType=             procedure(var S: SearchRec; P: PathStr);
var
  EngineMask:           PathStr;
  EngineAttr:           byte;
  EngineProc:           ProcType;
  EngineCode:           byte;

function ValidExtention(var S: SearchRec): boolean;
var
  Junk1: dirstr                ;
  junk2: namestr;
  E:                    ExtStr;
begin
  if S.Attr and Directory=Directory then
  begin
    ValidExtention := true;
    exit;
  end;
  FSplit(S.Name,Junk1,Junk2,E);

  if (E='.ZIP') then

  ValidExtention := true else ValidExtention := false;
end;

procedure SearchEngine(M: dirstr; Attr: byte; Proc: ProcType;
                       var ErrorCode: byte);
var
  S:                    SearchRec;
  P:                    dirStr;
  Ext:                  ExtStr;
  Mask:                 Namestr;
begin
  FSplit(M, P, Mask, Ext);
  Mask := Mask+Ext;
  FindFirst(P+Mask,Attr,S);
  if DosError<>0 then
  begin
    ErrorCode := DosError;
    exit;
  end;
  while DosError=0 do
  begin
    if ValidExtention(S) then Proc(S, P);
    FindNext(S);
  end;
  if DosError=18 then ErrorCode := 0
  else ErrorCode := DosError;
end;

function GoodDirectory(S: SearchRec): boolean;
begin
  GoodDirectory := (S.name<>'.') and (S.Name<>'..') and
  (S.Attr and Directory=Directory);
end;

procedure SearchOneDir(var S: SearchRec; P: PathStr); far;
begin
  if GoodDirectory(S) then
  begin
    P := P+S.Name;
    SearchEngine(P+'\'+EngineMask,EngineAttr,EngineProc,EngineCode);
    SearchEngine(P+'\*.*',Directory or Archive, SearchOneDir ,EngineCode);
  end;
end;

procedure SearchEngineAll(Path: PathStr; Mask: pathStr; Attr: byte;
                          Proc: ProcType; var ErrorCode: byte);
begin
  EngineMask := Mask;
  EngineProc := Proc;
  EngineAttr := Attr;
  SearchEngine(Path+Mask,Attr,Proc,ErrorCode);
  SearchEngine(Path+'*.*',Directory or Archive,SearchOneDir,ErrorCode);
  ErrorCode := EngineCode;
end;

(************** Thus ends the sneakly swiped code *************)
(**** We now return you to our regularly scheduled program ****)

procedure status(p,f:string);
 var tt:longint;
 begin
 gotoxy(1,wherey);
 textcolor(cyan);
 write('File: ');
 textcolor(lightcyan);
 write(p,f);
 gotoxy(50,wherey);
 textcolor(lightgray);
 write('Time: ');
 textcolor(white);
 tt:=(NowSecondsSinceMidnight-StartTime);
 write(tt:5);
 textcolor(lightgray);
 write(' / ');
 write(total:5);
 end;

var c:^commentfiletype;

procedure AddComment(var s:searchrec; p:pathstr); far;
  type bffrtype = array[1..1500] of byte;
  var f :file;
      b :^bffrtype;
      ofs: longint;
      tv : longint;
      zd : findziptype;
  function inray:word;
   var i:word;
   begin
    inray:=0;
    for i:= 1 to tv do
    begin
    move(b^[i],zd,sizeof(zd));
    if zd.id= $06054b50 then
      begin
      inray:=i;
      exit;
      end;
    end;
   end;

  begin
  assign(f,p+s.name);
  {$I-}
  reset(f,1);
  if ioresult<>0 then exit;
  {$I+}
  new (b);
  fillchar(b^,sizeof(b^),#0);
  tv:=filesize(f);
  if tv>sizeof(b^) then tv:=sizeof(b^);
  seek(f,filesize(f)-tv);
  blockread(f,b^,tv);
  ofs:=inray;
  if not (ofs=0) then
    begin
    zd.cl:=c^.len;
    seek(f,filesize(f)-1-tv+ofs);
    blockwrite(f,zd,sizeof(zd));
    blockwrite(f,c^.data,c^.len);
    end;
  close(f);
  dispose(b);
  inc(total);
  status(p,s.name);
  end;

procedure loadcommentfile;
var f:file;
 begin
 assign(f,getenv('ZIPCOMNT'));
 reset(f,1);
 blockread(f,c^.data,filesize(f));
 c^.len:=filesize(f);
 close(f);
 end;


var err:byte;
begin
total:=0;
StartTime:=NowSecondsSinceMidnight;
writeln;
writeln('ZipC - Zak''s semiPersonal Hyper-Speed Zipfile Commenter');
writeln;
directvideo:=true;
new(c);
loadcommentfile;
SearchEngineAll (
  fExpand('.\'),
  '*.ZIP',
  anyfile,
  AddComment,
  err);

writeln;
writeln;
writeln('ZipC Done.');
dispose(c);
end.

 Specific ZIP data struct. used here..

        end of central dir signature    4 bytes  (0x06054b50)
        number of this disk             2 bytes
        number of the disk with the
        start of the central directory  2 bytes
        total number of entries in
        the central dir on this disk    2 bytes
        total number of entries in
        the central dir                 2 bytes
        size of the central directory   4 bytes
        offset of start of central
        directory with respect to
        the starting disk number        4 bytes
        zipfile comment length          2 bytes
        zipfile comment (variable size)

[Back to ARCHIVES SWAG index]  [Back to Main SWAG index]  [Original]