#
# $Id: laola.pl,v 0.5.1.5 1997/07/01 00:06:42 schwartz Rel $
#
# laola.pl, LAOLA filesystem.
#
# This perl 4 library gives raw access to "Ole/Com" documents. These are
# documents like created by Microsoft Word 6.0+ or newer Star Divisions
# Word by using so called "Structured Storage" technology. Write access
# still is nearly not supported, but will be done one day. This library
# is part of LAOLA, a distribution this file should have come along with.
# It can be found at:
#
# http://wwwwbs.cs.tu-berlin.de/~schwartz/pmh/index.html
# or
# http://www.cs.tu-berlin.de/~schwartz/pmh/index.html
#
# Copyright (C) 1996, 1997 Martin Schwartz
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, you should find it at:
#
# http://wwwwbs.cs.tu-berlin.de/~schwartz/pmh/COPYING
#
# Diese Veröffentlichung erfolgt ohne Berücksichtigung eines eventuellen
# Patentschutzes. Warennamen werden ohne Gewährleistung einer freien
# Verwendung benutzt. ;-)
#
# Contact: schwartz@cs.tu-berlin.de
#
#
# Really important topics still MISSING until now:
#
# - human rights and civil rights where _you_live_
# - Reformfraktion president for Technische Universität Berlin
#
# - creating documents
# - sensible error handling...
# - many property set things:
# * documentation of variable types
# * code page support
# - opening multiple documents at a time
# - consistant name giving, checked against MS'
#
# Please refer to the Quick Reference at Laolas home page for further
# explanations.
#
#
# Abbreviations
#
# bbd Big Block Depot
# pps Property Storage
# ppset Property Set
# ppss Property Set Storage
# sb Start Block
# sbd Small Block Depot
# tss Time Stamp Seconds
# tsd Time Stamp Days
#
##
## "public"
##
sub laola_open_document { &laola'laola_open_document; }
sub laola_close_document { &laola'laola_close_document; }
sub laola_pps_get_name { &laola'laola_pps_get_name; }
sub laola_pps_get_date { &laola'laola_pps_get_date; }
sub laola_is_directory { &laola'laola_is_directory; }
sub laola_get_directory { &laola'laola_get_directory; }
sub laola_get_dirhandles { &laola'laola_get_dirhandles; }
sub laola_is_file { &laola'laola_is_file; }
sub laola_get_filesize { &laola'laola_get_filesize; }
sub laola_get_file { &laola'laola_get_file; }
sub laola_is_root { &laola'laola_is_root; }
#
# writing
#
sub laola_modify_file { &laola'laola_modify_file; }
#
# property set handling
#
sub laola_is_file_ppset { &laola'laola_is_file_ppset; }
sub laola_ppset_get_dictionary { &laola'laola_ppset_get_dictionary; }
sub laola_ppset_get_idset { &laola'laola_ppset_get_idset; }
sub laola_ppset_get_property { &laola'laola_ppset_get_property; }
#
# trash handling
#
sub laola_get_trashsize { &laola'laola_get_trashsize; }
sub laola_get_trash { &laola'laola_get_trash; }
sub laola_modify_trash { &laola'laola_modify_trash; }
package laola;
$laola_date = "03/25/97";
changable_options: {
$optional_do_iobuf=0; # 0: don't cache 1: cache whole compound document
$optional_do_debug=0; # 0: don't debug 1: print some debugging information
}
##
## File and directory handling
##
sub laola_open_document { ##
#
# "ok"||$error = laola_open_document($filename [,$openmode [,$streambuf]]);
#
# openmode bitmask (0 is default):
#
# Bit 0: 0 read only 1 read and write
# Bit 4: 0 file mode 1 buffer mode
#
local($status)="";
open_doc1: {
&init_vars();
if ( ($status=&init_io(@_)) ne "ok") {
last;
}
if ( ($status=&init_doc()) ne "ok") {
&laola_close_document();
last;
}
return "ok";
}
$status;
}
sub laola_close_document { ##
#
# "ok" = laola_close_document([streambuf])
#
if ($openmode & 0x10) {
if (defined $_[0]) {
$_[0]=$iobuf;
}
} else {
&flush_cache();
&clean_file();
}
&init_vars();
return "ok";
}
sub laola_is_directory { ##
#
# 1||0 = laola_is_directory($pps)
#
local($pps)=shift;
(!$pps || ($pps_type[$pps] == 1));
}
sub laola_is_file { ##
#
# 1||0 = laola_is_file($pps)
#
($pps_type[shift] == 2);
}
sub laola_is_root { ##
#
# 1||0 = laola_is_root($pps)
#
($pps_type[shift] == 5);
}
sub laola_get_dirhandles { ##
#
# @pps = laola_get_dirhandles($pps);
#
local($start)=shift;
local (@chain) = ();
local (%chaincontrol) = ();
(!$start || &laola_is_directory($start))
&& &get_ppss_chain($pps_dir[$start])
;
@chain;
}
sub laola_get_directory { ##
#
# %pps_names = laola_get_directory($pps);
#
local(%pps_namehandle)=();
for (&laola_get_dirhandles) {
$pps_namehandle{&laola_pps_get_name($_)} = $_;
}
%pps_namehandle;
}
sub laola_pps_get_name { ##
#
# $name_of_pps = laola_pps_get_name($pps);
#
$pps_name[shift];
}
sub laola_pps_get_date { ##
#
# ($day,$month,$year,$hour,$min,$sec)||0 = laola_pps_get_date($pps)
# (1..31, 1..12, 1601..., 0..23, 0..59, 0.x .. 59.x)
#
local($pps)=shift;
&laola_is_directory($pps)
&& &filetime_to_time($pps_ts2s[$pps], $pps_ts2d[$pps]);
}
sub laola_get_filesize { ##
#
# $filesize || 0 = laola_get_filesize($pps);
#
local($pps)=shift;
&laola_is_file($pps) && $pps_size[$pps];
}
sub laola_get_file { ##
#
# "ok"||$error = laola_get_file($pps, extern $buf [,$offset, $size]);
#
&rw_file("r", @_);
}
sub laola_modify_file { ##
#
# "ok"||$error = laola_modify_file($pps,extern $buf, $offset, $size);
#
return "Laola: File is write protected!" if !io_writable;
&rw_file("w", @_);
}
##
## Property set handling
##
sub laola_is_file_ppset { ##
#
# ppset_type || 0 = laola_is_file_ppset($pps)
# ppset_type e {1, 5}
#
local($pps)=shift;
(&laola_is_file($pps))
&& ( (&laola_pps_get_name($pps) =~ /^\05/) && 5
|| (&laola_pps_get_name($pps) =~ /^\01CompObj$/) && 1
);
}
sub laola_ppset_get_dictionary { ##
#
# ("ok", %dictionary)||$error = laola_ppset_get_dictionary($pps)
#
local($pps)=shift;
local($status) = &load_propertyset($pps);
if ($status ne "ok") {
return $status;
} else {
return ("ok", %ppset_dictionary);
}
}
sub laola_ppset_get_idset { ##
#
# ("ok", %ppset_idset) || $error = laola_ppset_get_idset($pps);
#
local($pps)=shift;
local($status) = &load_propertyset($pps);
return $status if $status ne "ok";
local(%ts)=();
foreach $key (keys %ppset_fido) {
$ts{$key} = $ppset_dictionary{$key};
}
("ok", %ts);
}
sub laola_ppset_get_property { ##
#
# ($type,@mixed)||("error",$error)=laola_ppset_get_property($pps, $id)
#
local($pps, $id)=@_;
local($type, $l, $var, @var);
local($o, $n);
local($status)= &load_propertyset($pps);
return ("error", $status) if $status ne "ok";
return "" if !defined $ppset_fido{$id};
$n = int($id / 0x1000);
$o = $ppset_o[$n]+$ppset_fido{$id};
if ($ppset_type == 5) {
#return ("error", "Property Identifier is invalid.") if $id < 2;
($type, $l, @var) = &ppset_get_property($o);
return ($type, @var);
} elsif ($ppset_type == 1) {
($l, $var) = &ppset_get_var(0x1e, $o);
return (0x1e, $var);
}
}
##
## Trash handling
##
sub laola_get_trashsize { ##
#
# $sizeof_trash_section = laola_get_trashsize($type)
#
&get_trash_size(@_);
}
sub laola_get_trash { ##
#
# "ok"||$error = laola_get_trash ($type, extern $buf [,$offset,$size]);
#
&rw_trash("r", @_);
}
sub laola_modify_trash { ##
#
# "ok"||$error = laola_modify_trash ($type, extern $buf [,$offset,$size]);
#
return "Laola: File is write protected!" if !io_writable;
&rw_trash("w", @_);
}
##
## "private"
##
global_init: {
&var_init();
&filetime_init();
&propertyset_type_init();
$[=0;
}
#
# laola_open_document ->
#
sub init_vars {
# laola_open_document->init_vars
# laola_close_document->init_vars
internal: {
$infilename=undef;
$filesize=undef;
$openmode=undef;
$io_writable=undef;
$curfile=undef;
@curfile_iolist = ();
$iobuf=undef;
@iobuf_modify_a=();
@iobuf_modify_l=();
}
&init_propertyset();
OLEstructure: {
# unknown header things that matter:
# ? $version=undef; # word(1a)
# ? $revision=undef; # word(18)
# ? $bigunknown=undef; # byte(1e)
# known header things that matter:
$header_size=0x200;
$big_block_size=undef; # word(1e)
$small_block_size=undef; # word(20)
$num_of_bbd_blocks=undef; # long(2c)
$root_startblock=undef; # long(30)
$sbd_startblock=undef; # long(3c)
$ext_startblock=undef; # long(44)
$num_of_ext_blocks=undef; # long(48)
# property storage things
@pps_name=(); # 0 .. pps_sizeofname
#pps_sizeofname=(); # word(40)
@pps_type=(); # byte(42)
@pps_uk0=(); # byte(43)
@pps_prev=(); # long(44)
@pps_next=(); # long(48)
@pps_dir=(); # long(4c)
@pps_ts1s=(); # long(64)
@pps_ts1d=(); # long(68)
@pps_ts2s=(); # long(6c)
@pps_ts2d=(); # long(70)
@pps_sb=(); # long(74)
@pps_size=(); # long(78)
}
various: {
$maxblock=undef;
$maxsmallblock=undef;
# block depot blocks
# - these blocks are building the block depots
@bbd_list=();
@sbd_list=();
# block depot tables
@bbd=();
@sbd=();
# contents blocks
@root_list=();
@sb_list=();
blockusage: {
@bb_usage=(); # big blocks usage
@sb_usage=(); # small blocks usage
$usage_known=undef;
}
trash: {
%trashsize=();
@trash1_o=(); @trash1_l=();
@trash2_o=(); @trash2_l=();
@trash3_o=(); @trash3_l=();
@trash4_o=(); @trash4_l=();
$trash_known=undef;
}
}
}
sub init_io {
($infilename, $openmode) = @_;
if ($openmode & 0x10) {
return &init_stream;
} else {
return &init_file;
}
}
sub init_stream {
return "No stream data available!" if !defined $_[2];
#$openmode &= 0xfffffffe; # clear writeable flag
$optional_do_iobuf=1;
$iobuf = $_[2];
$filesize = length($iobuf);
if ( (&read_long(0) != 0xe011cfd0) ||
(&read_long(4) != 0xe11ab1a1) ) {
return "\"$infilename\" is no Ole / Compound Document!\n";
}
"ok";
}
sub init_file {
local($status);
return "\"$infilename\" does not exist!" if ! -e $infilename;
return "\"$infilename\" is a directory!" if -d $infilename;
return "\"$infilename\" is no proper file!" if ! -f $infilename;
return "Cannot read \"$infilename\"!" if ! -r $infilename;
if ($openmode & 1) {
return "\"$infilename\" is write protected!" if ! -w $infilename;
$io_writable = 1;
$status = open(IO, '+<'.$infilename);
} else {
$io_writable = 0;
$status = open(IO, $infilename);
}
return "Cannot open \"$infilename\"!" if !$status;
binmode(IO);
if ($io_writable) {
select(IO); $|=1; select(STDOUT);
}
if ( (&read_long(0) != 0xe011cfd0) ||
(&read_long(4) != 0xe11ab1a1) ) {
return "\"$infilename\" is no Ole / Compound Document!\n";
}
$filesize = -s $infilename;
read_iobuf: {
if ($optional_do_iobuf) {
if (!&myread(0, $filesize, $iobuf, 0)) {
undef $iobuf;
}
}
}
"ok";
}
sub init_doc {
# read bbd,
# get bbd -> root-chain, get bbd -> sbd-chain
local($i, $tmp)=(undef, undef);
local(@tmp)=undef;
header_information: {
$big_block_size=1<<&read_word(0x1e);
$small_block_size=1<<&read_word(0x20);
$num_of_bbd_blocks=&read_long(0x2c);
$root_startblock=&read_long(0x30);
$sbd_startblock=&read_long(0x3c);
$ext_startblock=&read_long(0x44);
$num_of_ext_blocks=&read_long(0x48);
$maxsmallblock= int (
&read_long( $header_size + $root_startblock*$big_block_size + 0x78 )
/ $small_block_size
-1
);
}
internal: {
$maxblock = int ( ($filesize-$header_size) / $big_block_size -1);
return "Document is corrupt - size is too small." if $maxblock < 1;
}
# read big block depot
read_bbd: {
$max_in_header = int ( ($header_size-0x4c)/4 );
$todo = $num_of_bbd_blocks;
$num = $todo;
$num = $max_in_header if $num_of_bbd_blocks > $max_in_header;
for ($i=0; $i<$num; $i++) {
push (@bbd_list, &read_long(0x4c+4*$i));
}
$todo -= $num;
$next = $ext_startblock;
while ($todo > 0) {
$num = $todo;
$num = ($big_block_size-4)/4 if $todo>(($big_block_size-4)/4);
$o = $header_size + $next*$big_block_size;
for ($i=0; $i<$num; $i++) {
push (@bbd_list, &read_long($o+4*$i));
}
$todo -= $num;
$next = &read_long($o+4*$num);
}
$tmp="";
&rw_iolist("r", $tmp,
&get_iolist(3, 0, 0xffffffff, 0, @bbd_list)
);
@bbd = unpack ($vtype{"l"}.($maxblock+1), $tmp);
}
# read small block depot
read_sbd: {
$tmp="";
@sbd_list=&get_list_from_depot($sbd_startblock, 1);
&rw_iolist("r", $tmp,
&get_iolist(3, 0, 0xffffffff, 0, @sbd_list)
);
@sbd = unpack ($vtype{"l"}.($maxsmallblock+1), $tmp);
}
root_and_sb_chains: {
@root_list=&get_list_from_depot($root_startblock, 1);
return "Document is corrupt - no root entry." if !@root_list;
@sb_list=&get_list_from_depot (
&read_long ( $header_size + $root_startblock*$big_block_size + 0x74 ),
1
);
}
read_PropertyStorages: {
&read_ppss(0);
#
# If there are many property storages, they will be loaded
# dynamically. If there are few (I randomly chosed 50), they
# all will be read (ditto for debugging).
#
last if $#root_list>50 || !$optional_do_debug;
local($buf)="";
local($i, $nl);
&rw_iolist("r", $buf,
&get_iolist(3, 0, 0xffffffff, 0, @root_list)
);
print "\n\n"
."---------------------------------------------\n"
."LAOLA INTERNAL start of debugging information\n\n"
." n size chain typ name date\n"
;
for ($i=0; $i<=($#root_list+1)*4; $i++) {
&read_ppss_buf($i, $buf);
&debug_report_pps($i) if $optional_do_debug;
}
print "\n"
."LAOLA INTERNAL end of debugging information\n"
."-------------------------------------------\n\n"
;
}
&report_blockuse_statistic() if $optional_do_debug;
"ok";
}
##
## laola_close_document ->
##
sub clean_file {
close(IO);
}
##
## -------------------------- File IO ------------------------------
##
sub rw_file {
#
# "ok"||error = rw_file("r"||"w", $pps_handle, extern $buf [,$offset, $size])
#
local($maxarg)=$#_;
local($rw, $pps) = @_[0..1];
return "Laola: pps is no file!" if !&laola_is_file($pps);
return "Laola: no method \"$rw\"!" if !($rw =~ /^[rw]$/i);
local($status, $offset, $size) =
&get_default_iosize($pps_size[$pps], $rw, @_[2..$maxarg]);
return $status if $status ne "ok";
return "Bad document structure!" if ! &get_curfile_iolist($pps);
return "ok" if &rw_iolist($rw, $_[2], &get_iolist(4, $offset, $size));
$rw =~ /^r$/i ? "Laola: read error!" : "Laola: write error!";
}
sub get_default_iosize {
#
# ("ok", $offset, $size) || $error =
# get_default_iosize (defsize, "r"||"w", extern buf, offset, size)
#
local($maxarg)=$#_;
local($defsize, $rw) = @_[0..1];
local($offset, $size) = @_[3..4];
if (!$size) {
if ($rw =~ /^r$/i) {
if ($maxarg < 4) {
# read default: read trashsize
$offset=0; $size=$defsize;
} else {
# read zero size: no problem
$_[2]="";
}
} else {
if ($maxarg < 4) {
# write default: not allowed!
return "Laola: write error! Unknown size.";
} else {
# write zero size: no problem
}
}
}
("ok", $offset, $size);
}
sub get_curfile_iolist {
#
# 1||0 = get_curfile_iolist($pps)
#
# Gets the iolist for the current file $pps
#
if ($curfile) {
return 1 if $curfile==$pps;
}
@curfile_iolist = &get_iolist(
$pps_size[$pps]>=0x1000, 0, $pps_size[$pps], $pps_sb[$pps]
);
$curfile = $pps;
1;
}
sub get_all_filehandles {
#
# &get_all_filehandles(starting directory)
#
# !recursive!
# Recurse over all files and directories,
# return all file handles as @files.
#
local($directory_pps)=shift;
local(@dir)=&laola_get_dirhandles($directory_pps);
local(@files)=();
local(%filescontrol)=();
foreach $entry (@dir) {
if (!$filescontrol{$entry}) {
$filescontrol{$entry} = 1;
if (&laola_is_file($entry)) {
push (@files, $entry)
} elsif (&laola_is_directory($entry)) {
push (@files, &get_all_filehandles($entry));
}
} else {
print STDERR "This document is corrupt!\n";
}
}
@files;
}
##
## --------------------- Property Set Handling -------------------------
##
sub propertyset_type_init {
%ppset_vtype = (
0x00, "empty",
0x01, "null",
0x02, "i2",
0x03, "i4",
0x04, "r4",
0x05, "r8",
0x06, "cy",
0x07, "date",
0x08, "bstr",
0x0a, "error",
0x0b, "bool",
0x0c, "variant",
0x11, "ui1",
0x12, "ui2",
0x13, "ui4",
0x14, "i8",
0x15, "ui8",
0x1e, "lpstr",
0x1f, "lpwstr",
0x40, "filetime",
0x41, "blob",
0x42, "stream",
0x43, "storage",
0x44, "streamed_object",
0x45, "stored_object",
0x46, "blobobject",
0x48, "clsid",
0x49, "cf",
0xfff, "typemask",
);
local(@type) = keys %ppset_vtype;
for (@type) {
$ppset_vtype{$_+0x1000} = $ppset_vtype{$_}.'[]';
}
# \05
%ppset_SummaryInformation = (
2, "title", 3, "subject", 4, "authress", 5, "keywords",
6, "comments", 7, "template", 8, "lastauthress",
9, "revnumber", 10, "edittime", 11, "lastprinted",
12, "create_dtm_ro", 13, "lastsave_dtm", 14, "pagecount",
15, "wordcount", 16, "charcount", 17, "thumbnail",
18, "appname", 19, "security"
);
%ppset_DocumentSummaryInformation = (
15, "organization"
);
# \01CompObj
%ppset_CompObj = (
0, "doc_long", 1, "doc_class", 2, "doc_spec"
);
}
sub load_dictionary {
#
# "ok"||"done"||0 = load_dictionary($pps)
#
local($pps)=shift;
&load_dictionary_defaults($pps);
local($i, $n, $o, $ps);
local($did, $dname, $l);
foreach $id (keys %ppset_fido_dict) {
next if !$ppset_fido_dict{$id};
$ps = int($id/0x1000);
$o = $ppset_o[$ps]+$ppset_fido_dict{$id};
$n = &get_long($o, $ppset_buf); $o+=4;
for (; $n; $n--) {
$did = &get_long($o, $ppset_buf); $o+=4;
($l, $dname) = &ppset_get_var(0x1e, $o); $o+=$l;
$ppset_dictionary{$did+$ps*0x1000} = $dname;
}
}
return "ok";
}
sub load_dictionary_defaults {
local($name)=&laola_pps_get_name($pps);
if ($name eq "\05SummaryInformation") {
%ppset_dictionary = %ppset_SummaryInformation;
return "ok";
} elsif ($name eq "\05DocumentSummaryInformation") {
%ppset_dictionary = %ppset_DocumentSummaryInformation;
return "ok";
} elsif ($name eq "\01CompObj") {
%ppset_dictionary = %ppset_CompObj;
return "ok";
}
return 0;
}
sub load_propertyset {
local($pps)=shift;
local($status)="";
check_current: {
if ($ppset_current && $pps && ($ppset_current == $pps)) {
$status="ok"; last;
}
if (!&laola_is_file_ppset($pps)) {
$status="This is not a property set handle."; last;
}
&init_propertyset();
if (!&laola_get_file($pps, $ppset_buf)) {
$status="Cannot load property set.";
}
$ppset_type = &laola_is_file_ppset($pps);
}
return $status if $status;
if ($ppset_type == 5) {
$status = &load_propertyset_05($pps);
return $status if $status ne "ok";
} elsif ($ppset_type == 1) {
$status = &load_propertyset_01CompObj($pps);
return $status if $status ne "ok";
} else {
return "Unknown property set!";
}
$status = &load_dictionary($pps);
return $status;
}
sub init_propertyset {
# !global! property set things
$ppset_current=undef; # current property storage handle
$ppset_type=undef; # \05, \01CompObj
$ppset_buf=undef; # buffer for whole property
%ppset_fido=(); # $ppset_fido{Identifier}=Offset;
# Format Pairs of $ppset_current
%ppset_fido_dict=(); # Dictionaries
%ppset_fido_cp=(); # Code pages
$ppset_codepage=undef;
%ppset_dictionary=();
structure_05: { # 05 ppsets
# Header
$ppset_byteorder=undef; # word (0) {0xfffe}
$ppset_format=undef; # word (2) {0}
$ppset_osver=undef; # word (4) {lbyte=version hbyte=revision}
$ppset_os=undef; # word (6) {0=win16|1=mac|2=win32)
@ppset_clsid=(); # class identifier (8) {e.g. @0}
$ppset_reserved=undef; # long (18) {>=1}
# FormatIDOffset
@ppset_fmtid=(); # format identifier (1c)
@ppset_o=(); # ppset_o[0]: long (2c)
# PropertySectionHeader
@ppset_size=(); # word ($ppset_o[])
@ppset_num=(); # long ($ppset_o[]+4)
}
#structure_01CompObj: {
#$ppset_uk1=undef; # word (0) {0x0001}
#$ppset_byteorder=undef; # word (2) {0xfffe}
#$ppset_osver=undef; # word (4) {lbyte=version hbyte=revision}
#$ppset_os=undef; # word (6) {0=win16|1=mac|2=win32)
# { ff ff ff ff 00 09 02 00 00 00 00 00
# c0 00 00 00 00 00 00 46 }
#@ppset_o=(); # 0x1c
#}
}
sub load_propertyset_01CompObj {
local($pps)=shift;
set_current: {
$ppset_current = $pps;
get_structure: {
$ppset_byteorder = &get_word(0x02, $ppset_buf);
$ppset_osver = &get_word(0x04, $ppset_buf);
$ppset_os = &get_word(0x06, $ppset_buf);
@ppset_o = (0x1c);
}
check_structure: {
if ($ppset_byteorder !=0xfffe) {
return "Cannot understand property set.";
}
}
}
get_offsets: {
local($i);
local($offset, $length)=(0, 0);
for ($i=0; $i<3; $i++) {
$length = &get_long($ppset_o[0] + $offset, $ppset_buf);
last if !$length;
$ppset_fido{$i} = $offset;
$offset = $offset + 4 + $length;
}
}
"ok";
}
sub load_propertyset_05 {
local($pps)=shift;
set_current: {
$ppset_current = $pps;
get_structure: {
($ppset_byteorder, $ppset_format, $ppset_osver, $ppset_os) =
&get_nword(4, 0, $ppset_buf)
;
@ppset_clsid = &get_uuid(0x08, $ppset_buf);
$ppset_reserved = &get_long(0x18, $ppset_buf);
@ppset_fmtid = &get_uuid(0x1c, $ppset_buf);
$ppset_o[0] = &get_word(0x2c, $ppset_buf);
$ppset_size[0] = &get_word($ppset_o[0], $ppset_buf);
$ppset_num[0] = &get_word($ppset_o[0]+4, $ppset_buf);
}
check_structure: {
$status="Cannot understand property set.";
last if $ppset_byteorder != 0xfffe;
last if $ppset_format != 0;
last if $ppset_reserved < 1;
last if $ppset_o[0] < 0x30;
$status="";
}
}
return $status if $status;
get_ids_and_offsets: {
local($i, $id, $n, $num, $fido);
local($o)=$ppset_o[0];
for ($n=0; $n<$ppset_reserved; $n++) {
# default dictionary and codepage
$ppset_fido_dict{$n*0x1000+0} = 0;
$ppset_fido_cp{$n*0x1000+1} = 0x4e4;
$num=&get_word($o+4, $ppset_buf);
for ($i=0; $i<$num; $i++) {
$id = &get_long($o+8+$i*8, $ppset_buf);
if ($n) {
$id = $i if $id>1; # ! hacky !
}
$fido = &get_long($o+8+$i*8+4, $ppset_buf);
if ($id>1) {
$ppset_fido{$n*0x1000+$id} = $fido;
} elsif ($id==1) {
$ppset_fido_cp{$n*0x1000+1} = $fido;
} elsif ($id==0) {
$ppset_fido_dict{$n*0x1000} = $fido;
}
}
$o+=&get_word($o, $ppset_buf);
$ppset_o[$n+1]=$o;
}
}
# todo: code page
"ok";
}
sub ppset_get_property {
#
# ($type, $size, @mixed)||("error", $debuginfo) = ppset_get_property($offset)
#
local($o_begin)=$_[0];
local($o)=$o_begin;
local($type) = &get_long($o, $ppset_buf);
if (! ($type & 0x1000)) {
return ($type, &ppset_get_var($type, $o+4));
} else {
local(@mixed)=();
local($n)=&get_long($o+4, $ppset_buf); $o+=8;
local($t, $l, @var);
for (; $n; $n--) {
@var=();
($l, @var) = &ppset_get_var($type^0x1000, $o);
push (@mixed, 1+($#var+1), $type^0x1000, @var);
$o+=$l;
}
return ($type, $o-$o_begin, @mixed);
}
}
sub ppset_get_var {
#
# ($size, @var) = &ppset_get_var($type, $offset);
#
local($type, $o)=@_;
if (!$type || $type == 0x01) { # empty, null
return (0, "");
} elsif ($type == 0x02) { # i2
local($tmp) = &get_word($o, $ppset_buf);
$tmp = - (($tmp^0xffff) +1) if ($tmp & 0x8000);
return (2, $tmp);
} elsif ($type == 0x03) { # i4
local($tmp) = &get_long($o, $ppset_buf);
$tmp = - (($tmp^0xffffffff) +1) if ($tmp & 0x80000000);
return (4, $tmp);
} elsif ($type == 0x04) { # real
return (4, unpack("f", substr($ppset_buf, $o, 4)) );
} elsif ($type == 0x05) { # double
return (8, unpack("d", substr($ppset_buf, $o, 8)) );
} elsif ($type == 0x0a) { # error
return (4, &get_word($o, $ppset_buf));
} elsif ($type == 0x0b) { # bool (0==false, -1==true)
return (4, &get_long($o, $ppset_buf));
} elsif ($type == 0x0c) { # variant
local($t, $l, @var);
$t = &get_long($o, $ppset_buf);
($l, @var) = &ppset_get_var($t, $o+4);
return (4+$l, $t, @var);
} elsif ($type == 0x11) { # ui1
return (1, &get_byte($o, $ppset_buf));
} elsif ($type == 0x12) { # ui2
return (2, &get_word($o, $ppset_buf));
} elsif ($type == 0x13) { # ui4
return (4, &get_long($o, $ppset_buf));
} elsif ($type == 0x1e) { # lpstr
local($l)=&get_long($o, $ppset_buf);
if ($l) {
return (4+$l, substr($ppset_buf, $o+4, $l-1));
} else {
return (4, "");
}
} elsif ($type==0x40) { # filetime
return (8, &filetime_to_time(&get_nlong(2, $o, $ppset_buf)) );
} else {
return (
"error",
sprintf("(offset=%x, type=%x, buf[0]=%x)",
$o, $type, &get_long($o+4, $ppset_buf)
)
);
}
}
##
## Basic laola data types
##
sub var_init {
#
# At this work I still don't trust in signed integers, therefore I
# prefer the unsigned 0xffffffff to -1 (don't beat me)
#
$vtype{"c"}="C"; $vsize{"c"}=1; # unsigned char
$vtype{"w"}="v"; $vsize{"w"}=2; # 0xfe21 == 21 fe
$vtype{"l"}="V"; $vsize{"l"}=4; # 0xfe21abde == de ab 21 fe
}
sub get_chars {
#
# get_chars ($offset, $number, extern $sourcebuf);
#
substr($_[2], $_[0], $_[1]);
}
sub read_chars {
#
# read_chars ($offset, $number);
#
local($tmp)="";
&myread($_[0], $_[1], $tmp) && $tmp;
}
# get_thing ($offset, extern $buf);
sub get_byte { &get_var("c", @_); }
sub get_word { &get_var("w", @_); }
sub get_long { &get_var("l", @_); }
sub get_var {
unpack ($vtype{$_[0]}, substr($_[2], $_[1], $vsize{$_[0]}));
}
# get_nthing ($n, $offset, extern $buf);
sub get_nbyte { &get_nvar("c", @_); }
sub get_nword { &get_nvar("w", @_); }
sub get_nlong { &get_nvar("l", @_); }
sub get_nvar {
unpack ($vtype{$_[0]}.$_[1], substr($_[3], $_[2], $vsize{$_[0]}*$_[1]));
}
# read_thing ($offset);
sub read_byte { &read_var("c", @_); }
sub read_word { &read_var("w", @_); }
sub read_long { &read_var("l", @_); }
sub read_var {
unpack ($vtype{$_[0]}, &read_chars($_[1], $vsize{$_[0]}));
}
# read_nthing ($n, $offset);
sub read_nbyte { &read_nvar("c", @_); }
sub read_nword { &read_nvar("w", @_); }
sub read_nlong { &read_nvar("l", @_); }
sub read_nvar {
unpack ($vtype{$_[0]}.$_[1], &read_chars($_[2], $vsize{$_[0]}*$_[1]));
}
##
## --------------------------- IO handling ------------------------------
##
sub myio {
#
# 1||0= myio("r"||"w", $file_offset, $num_of_chars, $extern_var [,$var_offset])
#
$_ = shift;
/^r$/i ? &myread : /^w$/i ? &mywrite : 0;
}
sub myread {
#
# 1||0 = myread($file_offset, $num_of_chars, $extern_var [,$var_offset])
#
local($varoffset)= $_[3] || 0;
if ($optional_do_iobuf && $iobuf) {
substr($_[2], $varoffset, $_[1])=substr($iobuf, $_[0], $_[1]);
return 1;
} else {
seek(IO, $_[0], 0) && (read(IO,$_[2],$_[1],$varoffset) == $_[1]);
}
}
sub mywrite {
#
# 1||0 = mywrite($file_offset, $num_of_chars, $extern_var [,$var_offset])
#
return 0 if !$io_writable;
local($varoffset)= $_[3] || 0;
local($tmp) = substr($_[2], $varoffset, $_[1]);
$tmp .= "\00" x ($_[1]-length($tmp));
if ($optional_do_iobuf && $iobuf) {
substr($iobuf, $_[0], $_[1]) = $tmp;
push(@iobuf_modify_a, $_[0]);
push(@iobuf_modify_l, $_[1]);
return 1;
} else {
seek(IO, $_[0], 0) && print IO $tmp;
}
}
sub flush_cache {
#
# void = flush_cache()
#
# flush io cache, if caching is turned on
#
return if !($optional_do_iobuf && $iobuf);
&rw_iolist("w", $iobuf,
&aggregate_iolist(2, @iobuf_modify_a, @iobuf_modify_l)
);
@iobuf_modify_a=(); @iobuf_modify_l=();
}
##
## The "logical" core of laola
##
sub get_ppss_chain {
#
# @blocks = get_ppss_chain($ppss)
#
# !recursive!
#
local($ppss) = @_;
return if $ppss == 0xffffffff;
if ($chaincontrol{$ppss}) {
# Recursive entry!
@chain = ();
print STDERR "This document is corrupt!\n";
return;
} else {
&read_ppss($ppss);
$chaincontrol{$ppss}=1;
}
&get_ppss_chain ( $pps_prev[$ppss] );
push(@chain, $ppss);
&get_ppss_chain ( $pps_next[$ppss] );
}
sub read_ppss_buf {
#
# "ok" = read_ppss_buf ($i, extern $buf)
#
local($i)=$_[0];
local($nl);
return "ok" if $pps_name[$i];
return if ! ($nl = &get_word($i*0x80+0x40, $_[1]));
$pps_name[$i] = &pps_name_to_string($i*0x80, $nl, $_[1]);
($pps_type[$i], $pps_uk0[$i],
$pps_prev[$i], $pps_next[$i], $pps_dir[$i]) =
unpack($vtype{"c"}."2".$vtype{"l"}."3",
substr($_[1], $i*0x80+0x42, $vsize{"c"}*2+$vsize{"l"}*3))
;
($pps_ts1s[$i], $pps_ts1d[$i], $pps_ts2s[$i], $pps_ts2d[$i],
$pps_sb[$i], $pps_size[$i]) =
&get_nlong(6, $i*0x80+0x64, $_[1])
;
"ok";
}
sub read_ppss {
#
# "ok" = read_ppss ($i)
#
local($i)=shift;
return "ok" if $pps_name[$i];
local($buf)="";
&rw_iolist("r", $buf, &get_iolist(3, $i*0x80, 0x80, 0, @root_list));
local($nl);
return if ! ($nl = &get_word(0x40, $buf));
$pps_name[$i] = &pps_name_to_string(0, $nl, $buf);
($pps_type[$i], $pps_uk0[$i], $pps_prev[$i], $pps_next[$i], $pps_dir[$i])=
unpack($vtype{"c"}."2".$vtype{"l"}."3",
substr($buf, 0x42, $vsize{"c"}*2+$vsize{"l"}*3)
)
;
($pps_ts1s[$i], $pps_ts1d[$i], $pps_ts2s[$i], $pps_ts2d[$i],
$pps_sb[$i], $pps_size[$i]) = unpack(
$vtype{"l"}."6", substr($buf, 0x64, $vsize{"l"}*6)
);
"ok";
}
sub get_list_from_depot {
#
# @blocks = get_list_from_depot ($start, depottype)
#
# Read a block chain starting with block $start out of a either
# depot @bbd (for $t) or depot @sbd (for !$t).
#
local($start, $t)=@_;
local(@chain)=();
return @chain if $start == 0xfffffffe;
push (@chain, $start);
while ( ($start = $t?$bbd[$start]:$sbd[$start]) != 0xfffffffe ) {
push(@chain, $start);
}
@chain;
}
sub get_iolist {
#
# @iolist = get_iolist ($depottype, $offset, $size, $startblock [,@depot])
#
# This is the main IO logic. Returns the iolist for a data stream according
# to depot type $t. The stream may start at offset $offset and can have a
# size $size. If size is bigger than the total size of the stream according
# to its depot, it will be cut correctly. (So if you want to read until the
# files end without knowing how many bytes that are, take 0xffffffff as size).
#
# depottype $t:
# 0 small block (for @sbd) small block depot
# 1 big block (for @bbd) big block depot
# 2 small block (for @_[4..$#]) some small blocks
# 3 big block (for @_[4..$#]) some big blocks
# 4 variable (for @curfile_iolist) iolist of current file
# 5 variable (for @_[4..$#] == (@o, @l)) some iolist
#
local($t, $offset, $size, $sb) = (shift||0, shift||0, shift||0, shift||0);
local($di);
local($bs, $max);
local(@empty)=();
return @empty if !$size;
local($begin, $done, $len);
local(@o)=(); local(@l)=();
$bs = ($t==1 || $t==3) ? $big_block_size : $small_block_size;
if ($t<2) {
# To skip these offsets, stream chains would have to be resolved
# before.
} elsif ($t<4) {
$max = $#_;
# Skip whole blocks, when offset given
$sb += int ($offset / $bs);
$offset -= int ($offset / $bs) * $bs;
} elsif ($t==4) {
$max = ($#curfile_iolist-1)/2;
} elsif ($t==5) {
$max = ($#_-1)/2;
} else {
return @empty;
}
$done = 0;
for ( $di=$sb;
($t<2) ? ($di!=0xfffffffe): ($di<=$max);
$di=&next_dl
) {
last if ($done == $size);
if ($t==4) {
$bs = $curfile_iolist[$max+1+$di];
} elsif ($t==5) {
$bs = $_[$max+1+$di];
}
if ($offset) {
if ($bs <= $offset) {
$offset -= $bs;
next;
} else {
$begin = &depot_offset + $offset;
$len = $bs - $offset;
$offset = 0;
}
} else {
$begin = &depot_offset;
$len = $bs;
}
if ( ($done+$len) > $size ) {
$len = $size - $done;
}
if ( !@o || ($o[$#o]+$l[$#l])!=$begin ) {
push(@o, $begin);
push(@l, $len);
} else {
$l[$#l]+=$len;
}
$done += $len;
}
(@o, @l);
}
sub next_dl { # get_iolist:next_dl
#
# index = depot ($di==index, $t==depothandle)
#
# Returns next chain link of depot @bbd ($t) or @sbd (!$t)
#
return $sbd[$di] if !$t;
return $bbd[$di] if $t==1;
$di+1;
}
sub depot_offset { # get_iolist:depot_offset
#
# offset = depot_offset ($di==index, $t==depottype)
#
return (($sb_list[$di/8]+1)*8 + ($di%8))*$small_block_size if $t==0;
return $header_size + $di*$big_block_size if $t==1;
return (($sb_list[$_[$di]/8]+1)*8 + ($_[$di]%8))*$small_block_size if $t==2;
return $header_size + $_[$di]*$big_block_size if $t==3;
return ($curfile_iolist[$di]) if $t==4;
return ($_[$di]) if $t==5;
}
sub aggregate_iolist {
#
# (@offsets, @lengths)||() = aggregate_iolist(method,@offsets,@lengths)
#
# method:
# 1 @offsets shall be sorted, no overlap allowed
# 2 @offsets shall be sorted, overlap is allowed
# 3 @offsets are sorted, no overlap allowed
# 4 @offsets are sorted, overlap is allowed
#
local($method)=shift;
local(@empty)=();
return @empty if ($method<1)||($method>4); # Don't know method!
local($max)=int(($#_+1)/2);
local($i, $j);
local(@o_in)=(); local(@l_in)=();
local(%o_in)=();
local(@o_out)=(); local(@l_out)=();
local($offset, $len);
#
# Sort
#
if ( ($method==1) || ($method==2)) {
# sort offsets
for ($i=0; $i<$max; $i++) {
next if !$_[$max+$i];
if ($o_in{$_[$i]}) {
return @empty if $method==1; # Data chunks overlap!
$o_in{$_[$i]}=$i if $_[$max+$i]>$o_in{$_[$i]};
} else {
$o_in{$_[$i]}=$i;
}
}
foreach $key (sort {$a <=> $b} keys %o_in) {
push(@o_in, $_[$o_in{$key}]);
push(@l_in, $_[$max + $o_in{$key}]);
}
} else {
@o_in=@_[0..($max-1)];
@l_in=@_[$max..$#_];
}
#
# Aggregate
#
$offset=$o_in[0];
$len=$l_in[0];
for ($i=1; $i<=($#o_in+1); $i++) {
if ( ($i==($#o_in+1))
|| ($o_in[$i]<$offset)
|| ($o_in[$i]>($offset+$len))
) {
push(@o_out, $offset);
push(@l_out, $len);
$offset=$o_in[$i];
$len=$l_in[$i];
} elsif ($o_in[$i]<($offset+$len)) {
return @empty if ($type==1 || $type==3); # Data chunks overlap!
if ( ($o_in[$i]+$l_in[$i]) > ($offset+$len) ) {
$len=$o_in[$i]+$l_in[$i]-$offset;
}
} else {
$len += $l_in[$i];
}
}
(@o_out, @l_out);
}
sub rw_iolist {
#
# 1||0 = rw_iolist("r"||"w", extern buf, @offsets, @lengths);
# . read or write global chunklist
#
local($done, $i, $l);
local($max) = int(($#_-2+1)/2);
$done=0;
for ($i=0; $i<$max; $i++) {
next if ! ($l = $_[2+$i+$max]);
if (&myio($_[0], $_[2+$i], $l, $_[1], $done)) {
$done += $l;
} else {
# io error!
return 0;
}
}
1;
}
##
## ---------------------- Property Set Handling --------------------------
##
sub pps_name_to_string {
#
# $string = pps_name_to_string($offset, $pps_name_len, extern $buf)
#
local($l)=$_[1]-2;
local($i);
local($tmp)="";
for ($i=0; $i<$l; $i+=2) {
$tmp.=substr($_[2], $_[0]+$i, 1);
}
$tmp;
}
sub learn_guids {
@guids = ("dsi", "si");
$guid_dsi="\0x5DocumentSummaryInformation";
@guid_dsi=( 0xd5cdd502, 0x2e9c, 0x101b,
"\0x93\0x97\0x08\0x00\0x2b\0x2c\0xf9\0xae" );
$guid_si="\0x5SummaryInformation";
@guid_si=( 0xf29f85e0, 0x4ff9, 0x1068,
"\0xab\0x91\0x08\0x00\0x2b\0x27\0xb3\0xd9" );
}
sub get_uuid {
local($o)=$_[0];
( &get_long($o, $_[1]),
&get_word($o+4, $_[1]),
&get_word($o+6, $_[1]),
&get_chars($o+8, 8, $_[1])
);
}
#
# This section refers to pps_ts2 and pps_ts1, the one ore two timestamps
# used for each "Storage" Property Set. It seems, that the second timestamp
# gets actualized, when changing the storage. The first stamp is sometimes
# used, sometimes unused.
#
# The stamp is a 64 bit ulong. It counts every second 10 * 10 ^ 6,
# starting at 01/01/1601. When the 64 bit int gets evaluated as
# two 32 bit integers, the faster running ("least significant long")
# can hold just 0x100000000 / 10000000.0 (about 429.5) seconds. So the
# slower running ("most significant long") increments every 429.5 seconds.
#
sub filetime_init {
@monsum = ( 0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334,
0, 31, 60, 91, 121, 152, 182, 213, 244, 274, 305, 335 );
$a_minute = 60 * 10000000.0 / (0x10000000 * 16);
}
sub is_schaltjahr {
local($year)=shift;
!($year%4) && ($year%100 || !($year%400) ) && 1;
}
sub filetime_years_to_days {
local($year)=shift;
int($year-1600) * 365
+ int( ($year-1600) / 4 )
- int( ($year-1600) / 100 )
+ int( ($year-1600) / 400 )
;
}
sub filetime_to_time {
local($ds, $dd)=@_;
local($day, $month, $year, $hour, $min, $sec);
local($i, $m, $d, $dsum, $tmpsec);
$dsum = $dd + ($ds / (0x10000000 * 16.0));
$d= int( $dsum/($a_minute*60*24) )+1;
$m= $dsum - ($d-1)*$a_minute*60*24;
$year = int( $d/365.2425 ) + 1601;
$d -= &filetime_years_to_days($year-1);
for( $i=11; $i && ($d <= $monsum[$i+&is_schaltjahr($year)*12]); $i--) {}
$month = $i+1;
$day = $d - $monsum[$i+&is_schaltjahr($year)*12];
$hour = int( $m / ($a_minute*60) );
$min = int( $m/$a_minute - $hour*60 );
$sec = ( ($m/$a_minute - $hour*60 - $min) * 60);
($day, $month, $year, $hour, $min, $sec);
}
sub time_to_filetime {
local($day, $month, $year, $hour, $min, $sec)=@_;
local($d, $tss, $tsd);
$d = &filetime_years_to_days($year-1)
+ $monsum[$month-1 + &is_schaltjahr($year)*12]
+ $day-1;
$tsd = (24*60*$d + 60*$hour +$min +$sec/60.0) * $a_minute;
$tss = ($tsd-int($tsd)) * 0x10000000 * 16;
( int($tss), int($tsd) );
}
##
## ------------------------- Trash Handling ------------------------------
##
sub make_blockuse_statistic {
#
# block statistic:
# 0 == irregular free (block depot entry != -1) (== undef)
# 1 == regular free (block depot entry == -1)
# 2 == used for ole system
# 3 == used for ole application
#
return 1 if $usage_known;
local($i, @list);
# default: all small and big blocks are undef
#
# regular system data
#
# ole system blocks
for (@bbd_list, @sbd_list, @root_list, @sb_list) {
$bb_usage[$_]=2;
}
# free blocks according to block depots
for (@bbd) {
$bb_usage[$_]=1 if $bbd[$_]==0xffffffff;
}
for (@sbd) {
$sb_usage[$_]=1 if $sbd[$_]==0xffffffff;
}
#
# OLE application blocks
#
foreach $file (&get_all_filehandles(0)) {
if ($pps_size[$file]>=0x1000) {
for (&get_list_from_depot($pps_sb[$file], 1)) { $bb_usage[$_]=3; }
} else {
for (&get_list_from_depot($pps_sb[$file], 0)) { $sb_usage[$_]=3; }
}
}
$usage_known=1;
}
sub get_trash_info {
#
# void get_trash_info();
#
# Trash types:
#
# 0 == all
# 1 == unused big blocks
# 2 == unused small blocks
# 4 == unused file space, according to sizeof pps_size (incl. root_entry)
# 8 == unused system space (header, sb_table, bb_table)
#
return 1 if $trash_known;
&make_blockuse_statistic();
local(@o, @l);
local(@list);
local($size, $m);
local($i);
local($begin, $len);
unused_big_blocks: {
$size=0; @list=();
for ($i=0; $i<=$maxblock; $i++) {
push(@list, $i) if $bb_usage[$i]<=1;
}
@trash1_o = &get_iolist(3, 0, 0xfffffff, 0, @list);
@trash1_l = splice(@trash1_o, ($#trash1_o+1)/2);
$m=$#trash1_o; for ($i=0; $i<=$m; $i++) { $size+=$trash1_l[$i]; }
$trashsize{1}=$size;
}
unused_small_blocks: {
$size=0; @list=();
for ($i=0; $i<=$maxsmallblock; $i++) {
push(@list, $i) if $sb_usage[$i]<=1;
}
@trash2_o = &get_iolist(2, 0, 0xfffffff, 0, @list);
@trash2_l = splice(@trash2_o, ($#trash2_o+1)/2);
$m=$#trash2_o; for ($i=0; $i<=$m; $i++) { $size+=$trash2_l[$i]; }
$trashsize{2}=$size;
}
unused_file_space: {
$size=0;
# 3.1. normal files
foreach $file (&get_all_filehandles(0)) {
@o = &get_iolist(
$pps_size[$file]>=0x1000 && 1,
$pps_size[$file], 0xffffffff, $pps_sb[$file]
);
push(@trash3_l, splice(@o, ($#o+1)/2));
push(@trash3_o, @o);
}
$m=$#trash3_o; for ($i=0; $i<=$m; $i++) { $size+=$trash3_l[$i]; }
# 3.2. system file of root_entry (small block file)
@list = ();
while (($#list+$#sbd+2) % 8) {
push(@list, $#list+$#sbd+2);
}
@o = &get_iolist(2, 0, 0xfffffff, 0, @list);
@l = splice(@o, ($#o+1)/2);
push(@trash3_o, @o); push(@trash3_l, @l);
$m=$#o; for ($i=0; $i<=$m; $i++) { $size+=$l[$i]; }
$trashsize{3}=$size;
}
unused_system_space: {
$size=0;
# 4.1. header block
$begin = 0x4c + $num_of_bbd_blocks*4;
$len = $header_size - $begin;
push(@trash4_o, $begin); push(@trash4_l, $len);
$size+=$len;
# 4.2. big block depot
@o = &get_iolist(3, ($maxblock+1)*4, 0xffffffff, 0, @bbd_list);
@l = splice(@o, ($#o+1)/2);
push(@trash4_o, @o); push(@trash4_l, @l);
$m=$#o; for ($i=0; $i<=$m; $i++) { $size+=$l[$i]; }
# 4.3. small block depot
@o = &get_iolist(3, ($maxsmallblock+1)*4, 0xffffffff, 0, @sbd_list);
@l = splice(@o, ($#o+1)/2);
push(@trash4_o, @o); push(@trash4_l, @l);
$m=$#o; for ($i=0; $i<=$m; $i++) { $size+=$l[$i]; }
$trashsize{4}=$size;
}
$trash_known=1;
}
sub get_trash_size {
local($type)=shift;
$type = (1|2|4|8) if !$type;
&get_trash_info();
local($trashsize)=0;
$trashsize += $trashsize{1} if $type & 1;
$trashsize += $trashsize{2} if $type & 2;
$trashsize += $trashsize{3} if $type & 4;
$trashsize += $trashsize{4} if $type & 8;
$trashsize;
}
sub rw_trash {
#
# "ok"||error = rw_trash("r"||"w", $type, extern $buf [,$offset,$size])
#
local($maxarg)=$#_;
&get_trash_info();
local($rw, $type) = @_[0..1];
$type = (1|2|4|8) if !$type;
local($status, $offset, $size) =
&get_default_iosize(&laola_get_trashsize($type), $rw, @_[2..$maxarg]);
return $status if $status ne "ok";
local(@o)=(); local(@l)=();
if ($type & 1) { push (@o, @trash1_o); push (@l, @trash1_l); }
if ($type & 2) { push (@o, @trash2_o); push (@l, @trash2_l); }
if ($type & 4) { push (@o, @trash3_o); push (@l, @trash3_l); }
if ($type & 8) { push (@o, @trash4_o); push (@l, @trash4_l); }
return "ok" if &rw_iolist(
$rw, $_[2],
&get_iolist(5, $offset, $size, 0, &aggregate_iolist(1, @o, @l))
);
"Laola: IO Error!";
}
##
## ----------------------------- Debugging -------------------------------
##
#
# Some debug information. Switch it on via $optional_do_debug=1
# Information will be shown directly after opening any document.
#
sub debug_report_pps {
local($i)=shift;
local($out)="";
local($tmp, $tmp2)="";
return if !$pps_name[$i];
$out = sprintf ("%2x", $i);
$out .= $pps_uk0[$i]==1 ? ": " : sprintf ("#%-2x", $pps_uk0[$i]);
if (&laola_is_directory($i)) {
$out .= "--> ";
} elsif (&laola_is_file($i)) {
$out .= sprintf ("%-5x ",
&laola_get_filesize($i));
} else {
$out .= " ";
}
if ($pps_prev[$i]==0xffffffff) { $out .= " .";
} else { $out .= sprintf ("%3x", $pps_prev[$i]); }
if ($pps_next[$i]==0xffffffff) { $out .= " .";
} else { $out .= sprintf ("%3x", $pps_next[$i]); }
if ($pps_dir[$i]==0xffffffff) { $out .= " .";
} else { $out .= sprintf ("%3x", $pps_dir[$i]); }
if (&laola_is_file_ppset($i)) {
$out .= " set";
} else {
$out .= " pp ";
}
($tmp=$pps_name[$i]) =~ s/[^_a-zA-Z0-9]/ /g;
$out .= sprintf (" \"%s\"",$tmp);
$out .= " " x (50 - length($out));
if ($pps_ts2d[$i]) {
$out .= sprintf (" %d.%d.%d %02d.%02d:%02d",
&filetime_to_time($pps_ts2s[$i], $pps_ts2d[$i])
);
}
print "$out\n";
}
sub report_blockuse_statistic {
return 1;
print "--- LAOLA internal, begin block statistic ---\n\n";
&make_blockuse_statistic();
local($i, $j, $m);
local(@o, @l);
print "Big blocks:\n";
for ($i=0; $i<4; $i++) {
@o=(); @l=();
$m=$#bb_usage; for ($j=0; $j<=$m; $j++) {
next if $bb_usage[$j]!=$i;
push(@o, $j); push(@l, 1);
}
&report_blockuse_list($i, &aggregate_iolist(1, @o, @l));
}
print "Small blocks:\n";
for ($i=0; $i<4; $i++) {
@o=(); @l=();
$m=$#sb_usage; for ($j=0; $j<=$m; $j++) {
next if $sb_usage[$j]!=$i;
push(@o, $j); push(@l, 1);
}
&report_blockuse_list($i, &aggregate_iolist(1, @o, @l));
}
print "\n--- LAOLA internal, end block statistic ---\n\n";
}
sub report_blockuse_list {
local($type)=shift;
return if !@_;
local(%info)=(0, "Trash", 1, "Free", 2, "System", 3, "Application");
local($max)=($#_+1)/2;
local($i); local($o, $l);
print "Type $type {$info{$type}} = (";
for ($i=0; $i<$max; $i++) {
$o=$_[$i]; $l=$_[$max+$i];
if ($l==1) {
printf (" %x ", $o);
} else {
printf (" %x-%x ", $o, $o+$l-1);
}
}
print ")\n";
}
sub report_trash_statistic {
return;
&get_trash_info();
print "Trash statistic.\n";
print "Free big block chunks: (\n";
&report_trash_list($trashsize{1}, @trash1_o, @trash1_l);
print "\nFree small block chunks: (\n";
&report_trash_list($trashsize{2}, @trash2_o, @trash2_l);
print "\nUnused file space: (\n";
&report_trash_list($trashsize{3}, @trash3_o, @trash3_l);
print "\nUnused system space: (\n";
&report_trash_list($trashsize{4}, @trash4_o, @trash4_l);
print "\nSummary: (\n";
&report_trash_list(
$trashsize{1}+$trashsize{2}+$trashsize{3}+$trashsize{4},
&aggregate_iolist( 1,
@trash1_o, @trash2_o, @trash3_o, @trash4_o,
@trash1_l, @trash2_l, @trash3_l, @trash4_l
)
);
}
sub report_trash_list {
local($size)=shift;
local(@o)=@_;
local(@l)=splice(@o, ($#o+1)/2);
local($i, $m);
printf (" %d elements, size=%x\n", $#o+1, $size);
$m=$#o; for ($i=0; $i<=$m; $i++) {
printf (" offset %5x (len %x)\n", $o[$i], $l[$i]);
}
print ")\n";
}
sub print_iolist {
local(@o)=@_;
local(@l)=splice(@o, ($#o+1)/2);
local($i);
$m=$#o; for ($i=0; $i<=$m; $i++) {
printf(" o=%6x (%x)\n", $o[$i], $l[$i]);
}
}
"Atomkraft? Nein, danke!"