diff --git a/packages/extra/bzip2/LICENSE b/packages/extra/bzip2/LICENSE new file mode 100644 index 0000000000..43865575d1 --- /dev/null +++ b/packages/extra/bzip2/LICENSE @@ -0,0 +1,40 @@ +This Pascal unit "bzip2.pas" is +copyright (C) 2002 by Daniel Mantione + +It is inspired by "bzip2" and associated library "libbzip2", +copyright (C) 1996-2002 by Julian R Seward. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. The origin of this software must not be misrepresented; you must + not claim that you wrote the original software. If you use this + software in a product, an acknowledgment in the product + documentation would be appreciated but is not required. + +3. Altered source versions must be plainly marked as such, and must + not be misrepresented as being the original software. + +4. The name of the author may not be used to endorse or promote + products derived from this software without specific prior written + permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS +OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +Daniel Mantione, Delft, the Netherlans +daniel.mantione@freepascal.org +Pascal bzip2 unit, version 0.0.1 of 10 October 2002 diff --git a/packages/extra/bzip2/bzip2.pas b/packages/extra/bzip2/bzip2.pas new file mode 100644 index 0000000000..f0e375af32 --- /dev/null +++ b/packages/extra/bzip2/bzip2.pas @@ -0,0 +1,733 @@ +unit bzip2; +{**************************************************************************** + + BZIP2 decompression unit + + Copyright (C) 2002 by Daniel Mantione + +This unit provides a decompression stream to decode .bz2 files. It is +inpired by Julian R. Seward's libbzip2 library and therefore you should +send credits to him and bug reports to me :) + +This code is licensed under the same terms as the original libbz2 library, +which is decsribed in the file LICENSE. If you don't have this file, look +at http://www.freepascal.org for this bzip2 unit, the LICENSE file will +be included. In case of problems, contact the author. + +E-mail addresses: + +Daniel Mantione +Julian R. Seward + +Please do not contact Julian about this Pascal library, he didn't wrote it. + +****************************************************************************} +interface + +uses objects; + +const max_groups=6; + max_alpha_size=258; + max_code_len=23; + group_size=50; + iter_count=4; + max_selectors=2+(900000 div group_size); + +const mtfa_size=4096; + mtfl_size=16; + +type Tcardinal_array=array [0..899999] of cardinal; + Pcardinal_array=^Tcardinal_array; + + Pcardinal=^cardinal; + Thuffarray=array[0..max_alpha_size] of cardinal; + Phuffarray=^Thuffarray; + + Tbzip2_decode_stream=object(Tstream) + short:cardinal; + readstream:Pstream; + block_randomized:boolean; + blocksize:byte; + tt:Pcardinal_array; + tt_count:cardinal; + rle_run_left,rle_run_data:byte; + nextrle:Pbyte; + decode_available:cardinal; + block_origin:cardinal; + current_block:cardinal; + read_data,bits_available:byte; + inuse16:set of 0..15; + inuse:set of 0..255; + inuse_count:cardinal; + seq_to_unseq:array[0..255] of byte; + alphasize:cardinal; + group_count,group_pos,gsel,gminlen:byte; + group_no:cardinal; + glimit,gperm,gbase:Phuffarray; + selector_count:cardinal; + selector,selector_mtf:array[0..max_selectors] of byte; + len:array[0..max_groups,0..max_alpha_size] of byte; + limit:array[0..max_groups,0..max_alpha_size] of cardinal; + base:array[0..max_groups,0..max_alpha_size] of cardinal; + perm:array[0..max_groups,0..max_alpha_size] of cardinal; + minlens:array[0..max_groups] of byte; + cftab:array[0..257] of cardinal; + mtfbase:array[0..256 div mtfl_size-1] of cardinal; + mtfa:array[0..mtfa_size-1] of byte; + constructor init(Areadstream:Pstream); + function get_bits(n:byte):byte; + function get_boolean:boolean; + function get_byte:byte; + function get_cardinal24:cardinal; + function get_cardinal:cardinal; + procedure receive_mapping_table; + procedure receive_selectors; + procedure undo_mtf_values; + procedure receive_coding_tables; + procedure make_hufftab; + procedure init_mtf; + function get_mtf_value:cardinal; + procedure move_mtf_block; + procedure receive_mtf_values; + procedure detransform; + function decode_block:boolean; + procedure read(var buf;count:sw_word);virtual; + procedure new_block; + procedure consume_rle;inline; + procedure rle_read(bufptr:Pbyte;var count:sw_word); + destructor done;virtual; + end; + +{A bzip2 stream starts with this:} +const bzip2_stream_magic='BZh'; + +{Error codes for stream errorinfo.} +const bzip2_bad_header_magic =1; + bzip2_bad_block_magic =2; + bzip2_endoffile =3; + bzip2_data_error =4; + +implementation + +{$ifdef i386} + {$i bzip2i386.inc} +{$endif} + +procedure hb_create_decode_tables(var limit,base,perm:array of cardinal; + var length:array of byte; + minlen,maxlen:byte;alphasize:cardinal); + +var pp,i,j,vec:cardinal; + +begin + pp:=0; + for i:=minlen to maxlen do + for j:=0 to alphasize-1 do + if length[j]=i then + begin + perm[pp]:=j; + inc(pp); + end; + for i:=0 to max_code_len-1 do + begin + base[i]:=0; + limit[i]:=0; + end; + for i:=0 to alphasize-1 do + inc(base[length[i]+1]); + for i:=1 to max_code_len-1 do + inc(base[i],base[i-1]); + vec:=0; + for i:=minlen to maxlen do + begin + inc(vec,base[i+1]-base[i]); + limit[i]:=vec-1; + vec:=vec shl 1; + end; + for i:=minlen+1 to maxlen do + base[i]:=((limit[i-1]+1) shl 1)-base[i]; +end; + +{***************************************************************************** + Tbzip2_decode_stream +*****************************************************************************} + +constructor Tbzip2_decode_stream.init(Areadstream:Pstream); + +var magic:array[1..3] of char; + c:char; + +begin + readstream:=Areadstream; + {Read the magic.} + readstream^.read(magic,sizeof(magic)); + if magic<>bzip2_stream_magic then + begin + error(stiniterror,bzip2_bad_header_magic); + exit; + end; + {Read the block size and allocate the working array.} + readstream^.read(c,1); + blocksize:=byte(c)-byte('0'); + getmem(tt,blocksize*100000*sizeof(cardinal)); + decode_available:=high(decode_available); +end; + +function Tbzip2_decode_stream.get_bits(n:byte):byte; + +var data:byte; + +begin + if n>bits_available then + begin + readstream^.read(data,1); + get_bits:=(read_data shr (8-n)) or data shr (8-(n-bits_available)); + read_data:=data shl (n-bits_available); + inc(bits_available,8); + end + else + begin + get_bits:=read_data shr (8-n); + read_data:=read_data shl n; + end; + dec(bits_available,n); +end; + +function Tbzip2_decode_stream.get_boolean:boolean; + +begin + get_boolean:=boolean(get_bits(1)); +end; + +function Tbzip2_decode_stream.get_byte:byte; + +begin + get_byte:=get_bits(8); +end; + +function Tbzip2_decode_stream.get_cardinal24:cardinal; + +begin + get_cardinal24:=get_bits(8) shl 16 or get_bits(8) shl 8 or get_bits(8); +end; + + +function Tbzip2_decode_stream.get_cardinal:cardinal; + +begin + get_cardinal:=get_bits(8) shl 24 or get_bits(8) shl 16 or get_bits(8) shl 8 or + get_bits(8); +end; + +procedure Tbzip2_decode_stream.receive_mapping_table; + +{Receive the mapping table. To save space, the inuse set is stored in pieces + of 16 bits. First 16 bits are stored which pieces of 16 bits are used, then + the pieces follow.} + +var i,j:byte; + +begin + inuse16:=[]; + {Receive the first 16 bits which tell which pieces are stored.} + for i:=0 to 15 do + if get_boolean then + include(inuse16,i); + + {Receive the used pieces.} + inuse:=[]; + inuse_count:=0; + for i:=0 to 15 do + if i in inuse16 then + for j:=0 to 15 do + if get_boolean then + begin + include(inuse,16*i+j); + seq_to_unseq[inuse_count]:=16*i+j; + inc(inuse_count); + end; +{ system.write('Mapping table: '); + for i:=0 to 255 do + if i in inuse then + system.write(i,' '); + writeln;} +end; + +procedure Tbzip2_decode_stream.receive_selectors; + +{Receives the selectors.} + +var i:cardinal; + j:byte; + +begin + group_count:=get_bits(3); + selector_count:=get_bits(8) shl 7 or get_bits(7); + for i:=0 to selector_count-1 do + begin + j:=0; + while get_boolean do + begin + inc(j); + if j>5 then + error(streaderror,bzip2_data_error); + end; + selector_mtf[i]:=j; + end; +{ system.write('Selector_mtf: '); + for i:=0 to selector_count-1 do + system.write(selector_mtf[i],' '); + writeln;} +end; + +procedure Tbzip2_decode_stream.undo_mtf_values; + +{Undo the MTF values for the selectors.} + +var pos:array[0..max_groups] of byte; + i:cardinal; + v,tmp:byte; + +begin + for v:=0 to group_count-1 do + pos[v]:=v; + for i:=0 to selector_count-1 do + begin + v:=selector_mtf[i]; + tmp:=pos[v]; + while v<>0 do + begin + pos[v]:=pos[v-1]; + dec(v); + end; + pos[0]:=tmp; + selector[i]:=tmp; + end; +end; + +procedure Tbzip2_decode_stream.receive_coding_tables; + +var t,curr:byte; + i:cardinal; + +begin + for t:=0 to group_count-1 do + begin + curr:=get_bits(5); + for i:=0 to alphasize-1 do + begin + repeat + if not(curr in [1..20]) then + begin + error(streaderror,bzip2_data_error); + exit; + end; + if not get_boolean then + break; + if get_boolean then + dec(curr) + else + inc(curr); + until false; + len[t,i]:=curr; + end; + end; +{ writeln('Coding tables:'); + for t:=0 to group_count-1 do + begin + for i:=0 to alphasize-1 do + system.write(len[t,i],' '); + writeln; + end;} +end; + +procedure Tbzip2_decode_stream.make_hufftab; + +{Builds the Huffman tables.} + +var i:cardinal; + t,minlen,maxlen:byte; + +begin + for t:=0 to group_count-1 do + begin + minlen:=32; + maxlen:=0; + for i:=0 to alphasize-1 do + begin + if len[t,i]>maxlen then + maxlen:=len[t,i]; + if len[t,i]glimit^[zn] do + begin + inc(zn); + zvec:=zvec shl 1 or byte(get_boolean); + end; + get_mtf_value:=gperm^[zvec-gbase^[zn]]; +end; + +procedure Tbzip2_decode_stream.move_mtf_block; + +var i:byte; + j,k:cardinal; + +begin + k:=MTFA_SIZE; + for i:=256 div MTFL_SIZE-1 downto 0 do + begin + j:=mtfbase[i]; + Pcardinal(@mtfa[k- 4])^:=Pcardinal(@mtfa[j+12])^; + Pcardinal(@mtfa[k- 8])^:=Pcardinal(@mtfa[j+ 8])^; + Pcardinal(@mtfa[k-12])^:=Pcardinal(@mtfa[j+ 4])^; + dec(k,16); + Pcardinal(@mtfa[k ])^:=Pcardinal(@mtfa[j ])^; + mtfbase[i]:=k; + end; +end; + +procedure Tbzip2_decode_stream.receive_mtf_values; + +const run_a=0; + run_b=1; + +var t,next_sym:cardinal; + es:cardinal; + n:byte; + nn,i:cardinal; + p,q:Pbyte; + u,v:Pcardinal; + lno,off:cardinal; + +begin + group_no:=high(group_no); + group_pos:=0; + t:=0; + for i:=0 to 257 do + cftab[i]:=0; + init_mtf; + next_sym:=get_mtf_value; + while next_sym<>inuse_count+1 do + begin +{ writeln(t,' ',next_sym); + if t=22296 then + t:=t; } + if next_sym<=run_b then + begin + es:=0; + n:=0; + repeat + inc(es,(next_sym+1) shl n); + inc(n); + next_sym:=get_mtf_value; + until next_sym>run_b; + n:=seq_to_unseq[mtfa[mtfbase[0]]]; + inc(cftab[n],es); + if t+es>100000*blocksize then + begin + error(streaderror,bzip2_data_error); + exit; + end; + while es>0 do + begin + tt^[t]:=n; + dec(es); + inc(t); + end; + end + else + begin + nn:=next_sym-1; + if nnp) do + begin + q^:=(q-1)^; + dec(q); + end; + u:=@mtfbase; + v:=u+lno; + repeat + mtfa[v^]:=mtfa[(v-1)^+MTFL_SIZE-1]; + dec(v); + dec(v^); + until v=u; + mtfa[v^]:=n; + if v^=0 then + move_mtf_block; + end; + inc(cftab[seq_to_unseq[n]]); + tt^[t]:=cardinal(seq_to_unseq[n]); + inc(t); + if t>100000*blocksize then + begin + error(streaderror,bzip2_data_error); + exit; + end; + next_sym:=get_mtf_value; + end; + end; + tt_count:=t; + {Setup cftab to facilitate generation of T^(-1).} + t:=0; + for i:=0 to 256 do + begin + nn:=cftab[i]; + cftab[i]:=t; +{ writeln(i,' ',t);} + inc(t,nn); + end; +end; + +{$ifndef HAVE_DETRANSFORM} + +procedure Tbzip2_decode_stream.detransform; + +var a:cardinal; + p,q,r:Pcardinal; + +begin + a:=0; + p:=@tt^[0]; + q:=p+tt_count; + while p<>q do + begin + r:=@tt^[cftab[p^ and $ff]]; + inc(cftab[p^ and $ff]); + r^:=r^ or a; + inc(a,256); + inc(p); + end; +end; + +{$endif} + +function Tbzip2_decode_stream.decode_block:boolean; + +{Decode a new compressed block.} + +var magic:array[1..6] of char; + stored_blockcrc:cardinal; + i:byte; + +begin + for i:=1 to 6 do + magic[i]:=char(get_byte); + if magic='1AY&SY' then + begin + inc(current_block); +{ writeln('Block ',current_block,': Header ok');} + stored_blockcrc:=get_cardinal; + block_randomized:=get_boolean; + block_origin:=get_cardinal24; + + {Receive the mapping table.} + receive_mapping_table; + alphasize:=cardinal(inuse_count)+2; +{ writeln('Mapping table ok.');} + + {Receive the selectors.} + receive_selectors; + if status<>0 then + exit; +{ writeln('Selectors ok.');} + {Undo the MTF values for the selectors.} + undo_mtf_values; +{ writeln('Undo mtf ok.');} + {Receive the coding tables.} + receive_coding_tables; + if status<>0 then + exit; +{ writeln('Coding tables ok');} + {Build the Huffman tables.} + make_hufftab; +{ writeln('Huffman ok.');} + {Receive the MTF values.} + receive_mtf_values; +{ writeln('MTF OK');} + {Undo the Burrows Wheeler transformation.} + detransform; +{ writeln('Detransform OK');} + decode_available:=tt_count; + end + else + begin + if magic<>#$17'rE8P'#$90 then + error(streaderror,bzip2_bad_block_magic); + decode_block:=false; + end; +end; + +procedure Tbzip2_decode_stream.new_block; + +begin + if decode_block then + nextrle:=@tt^[tt^[block_origin] shr 8] + else + begin + error(streaderror,bzip2_endoffile); + nextrle:=nil; + end; +end; + +procedure Tbzip2_decode_stream.consume_rle;inline; + +{Make nextrle point to the next decoded byte. If nextrle did point to the last + byte in the current block, decode the next block.} + +begin +{ Pcardinal(nextrle)^:=Pcardinal(nextrle)^ shr 8;} + nextrle:=@tt^[Pcardinal(nextrle)^ shr 8]; + dec(decode_available); + if decode_available=0 then + new_block; +end; + +procedure Tbzip2_decode_stream.rle_read(bufptr:Pbyte;var count:sw_word); + +var rle_len:cardinal; + data:byte; + +label rle_write; + +begin + rle_len:=rle_run_left; + data:=rle_run_data; + if block_randomized then + {Not yet implemented.} + runerror(212) + else + begin + if rle_len<>0 then + {Speed is important. Instead of an if statement within the + repeat loop use a goto outside the loop.} + goto rle_write; + repeat + if decode_available=0 then + break; + rle_len:=1; + data:=nextrle^; + consume_rle; + if (decode_available>0) and (data=nextrle^) then + begin + inc(rle_len); + consume_rle; + if (decode_available>0) and (data=nextrle^) then + begin + inc(rle_len); + consume_rle; + if (decode_available>0) and (data=nextrle^) then + begin + consume_rle; + inc(rle_len,nextrle^+1); + consume_rle; + end; + end; + end; +rle_write: + repeat + bufptr^:=data; + inc(bufptr); + dec(count); + dec(rle_len); + until (rle_len and count)=0; + until count=0; + short:=count; + end; + rle_run_data:=data; + rle_run_left:=rle_len; +end; + +procedure Tbzip2_decode_stream.read(var buf;count:sw_word); + +var bufptr:Pbyte; + +begin + short:=0; + bufptr:=@buf; + if decode_available=high(decode_available) then + begin + {Initialize the rle process: + - Decode a block + - Initialize pointer.} + if not decode_block then + begin + error(streaderror,bzip2_endoffile); + nextrle:=nil; + end; + nextrle:=@tt^[tt^[block_origin] shr 8]; + end; + rle_read(bufptr,count); +end; + +destructor Tbzip2_decode_stream.done; + +begin + if tt<>nil then + freemem(tt,blocksize*100000*sizeof(cardinal)); + inherited done; +end; + +end. diff --git a/packages/extra/bzip2/bzip2i386.inc b/packages/extra/bzip2/bzip2i386.inc new file mode 100644 index 0000000000..2f9223726b --- /dev/null +++ b/packages/extra/bzip2/bzip2i386.inc @@ -0,0 +1,56 @@ +{$ASMMODE intel} + +{$define HAVE_DETRANSFORM} +{ +procedure Tbzip2_decode_stream.detransform; + +var a:cardinal; + p,q,r:Pcardinal; + +begin + a:=0; + p:=@tt^[0]; + q:=p+tt_count; + while p<>q do + begin + r:=@tt^[cftab[p^ and $ff]]; + inc(cftab[p^ and $ff]); + r^:=r^ or a; + inc(a,256); + inc(p); + end; +end; +} + +{const c:cardinal=0; + +procedure mcount;external name 'mcount';} + + +procedure Tbzip2_decode_stream.detransform;assembler; + +asm +{ mov edx,offset c + call mcount} + xor edx,edx + lea ebx,[esi+Tbzip2_decode_stream.cftab] + mov ecx,[esi+Tbzip2_decode_stream.tt_count] + push esi + push ebp + mov esi,[esi+Tbzip2_decode_stream.tt] + mov edi,esi + lea ebp,[4*ecx+esi] + jmp @a2 +@a1: + movzx eax,byte [esi] + mov ecx,[ebx+4*eax] + inc dword [ebx+4*eax] + or [edi+4*ecx],edx + add edx,$100 + add esi,4 +@a2: + cmp esi,ebp + jne @a1 + pop ebp + pop esi +end ['eax','ebx','ecx','edx','edi']; diff --git a/packages/extra/bzip2/pasbzip.pas b/packages/extra/bzip2/pasbzip.pas new file mode 100644 index 0000000000..b3c5a524cd --- /dev/null +++ b/packages/extra/bzip2/pasbzip.pas @@ -0,0 +1,35 @@ +program pasbzip; + +uses objects,bzip2; + +var infile,outfile:Tbufstream; + decoder:Tbzip2_decode_stream; + a:array[1..4096] of byte; + i,readsize:cardinal; + +begin + assign(output,'pasbzip.out'); + rewrite(output); + if paramcount<>1 then + writeln('Usage: pasbunzip ') + else + begin + infile.init(paramstr(1),stopenread,4096); + outfile.init('OUTFILE',stcreate,4096); + decoder.init(@infile); + if decoder.status<>stok then + writeln('Fout: ',decoder.status,' ',decoder.errorinfo); + repeat + readsize:=4096; + decoder.read(a,readsize); + dec(readsize,decoder.short); + outfile.write(a,readsize); + until decoder.status<>0; + if decoder.status<>stok then + writeln('Fout: ',decoder.status,' ',decoder.errorinfo); + decoder.done; + infile.done; + outfile.done; + end; + close(output); +end.