File Coverage

blib/lib/OLE/Storage_Lite.pm
Criterion Covered Total %
statement 76 672 11.3
branch 3 266 1.1
condition 0 48 0.0
subroutine 21 61 34.4
pod 6 8 75.0
total 106 1055 10.0


line stmt bran cond sub pod time code
1             # OLE::Storage_Lite
2             # by Kawai, Takanori (Hippo2000) 2000.11.4, 8, 14
3             # This Program is Still ALPHA version.
4             #//////////////////////////////////////////////////////////////////////////////
5             # OLE::Storage_Lite::PPS Object
6             #//////////////////////////////////////////////////////////////////////////////
7             #==============================================================================
8             # OLE::Storage_Lite::PPS
9             #==============================================================================
10             package OLE::Storage_Lite::PPS;
11             require Exporter;
12 2     2   1394 use strict;
  2         10  
  2         85  
13 2     2   13 use vars qw($VERSION @ISA);
  2         5  
  2         2081  
14             @ISA = qw(Exporter);
15             $VERSION = '0.22';
16              
17             #------------------------------------------------------------------------------
18             # new (OLE::Storage_Lite::PPS)
19             #------------------------------------------------------------------------------
20             sub new ($$$$$$$$$$;$$) {
21             #1. Constructor for General Usage
22 0     0   0 my($sClass, $iNo, $sNm, $iType, $iPrev, $iNext, $iDir,
23             $raTime1st, $raTime2nd, $iStart, $iSize, $sData, $raChild) = @_;
24              
25 0 0       0 if($iType == OLE::Storage_Lite::PpsType_File()) { #FILE
    0          
    0          
26 0         0 return OLE::Storage_Lite::PPS::File->_new
27             ($iNo, $sNm, $iType, $iPrev, $iNext, $iDir, $raTime1st, $raTime2nd,
28             $iStart, $iSize, $sData, $raChild);
29             }
30             elsif($iType == OLE::Storage_Lite::PpsType_Dir()) { #DIRECTRY
31 0         0 return OLE::Storage_Lite::PPS::Dir->_new
32             ($iNo, $sNm, $iType, $iPrev, $iNext, $iDir, $raTime1st, $raTime2nd,
33             $iStart, $iSize, $sData, $raChild);
34             }
35             elsif($iType == OLE::Storage_Lite::PpsType_Root()) { #ROOT
36 0         0 return OLE::Storage_Lite::PPS::Root->_new
37             ($iNo, $sNm, $iType, $iPrev, $iNext, $iDir, $raTime1st, $raTime2nd,
38             $iStart, $iSize, $sData, $raChild);
39             }
40             else {
41 0         0 die "Error PPS:$iType $sNm\n";
42             }
43             }
44             #------------------------------------------------------------------------------
45             # _new (OLE::Storage_Lite::PPS)
46             # for OLE::Storage_Lite
47             #------------------------------------------------------------------------------
48             sub _new ($$$$$$$$$$$;$$) {
49 0     0   0 my($sClass, $iNo, $sNm, $iType, $iPrev, $iNext, $iDir,
50             $raTime1st, $raTime2nd, $iStart, $iSize, $sData, $raChild) = @_;
51             #1. Constructor for OLE::Storage_Lite
52 0         0 my $oThis = {
53             No => $iNo,
54             Name => $sNm,
55             Type => $iType,
56             PrevPps => $iPrev,
57             NextPps => $iNext,
58             DirPps => $iDir,
59             Time1st => $raTime1st,
60             Time2nd => $raTime2nd,
61             StartBlock => $iStart,
62             Size => $iSize,
63             Data => $sData,
64             Child => $raChild,
65             };
66 0         0 bless $oThis, $sClass;
67 0         0 return $oThis;
68             }
69             #------------------------------------------------------------------------------
70             # _DataLen (OLE::Storage_Lite::PPS)
71             # Check for update
72             #------------------------------------------------------------------------------
73             sub _DataLen($) {
74 0     0   0 my($oSelf) =@_;
75 0 0       0 return 0 unless(defined($oSelf->{Data}));
76             return ($oSelf->{_PPS_FILE})?
77 0 0       0 ($oSelf->{_PPS_FILE}->stat())[7] : length($oSelf->{Data});
78             }
79             #------------------------------------------------------------------------------
80             # _makeSmallData (OLE::Storage_Lite::PPS)
81             #------------------------------------------------------------------------------
82             sub _makeSmallData($$$) {
83 0     0   0 my($oThis, $aList, $rhInfo) = @_;
84 0         0 my ($sRes);
85 0         0 my $FILE = $rhInfo->{_FILEH_};
86 0         0 my $iSmBlk = 0;
87              
88 0         0 foreach my $oPps (@$aList) {
89             #1. Make SBD, small data string
90 0 0       0 if($oPps->{Type}==OLE::Storage_Lite::PpsType_File()) {
91 0 0       0 next if($oPps->{Size}<=0);
92 0 0       0 if($oPps->{Size} < $rhInfo->{_SMALL_SIZE}) {
93             my $iSmbCnt = int($oPps->{Size} / $rhInfo->{_SMALL_BLOCK_SIZE})
94 0 0       0 + (($oPps->{Size} % $rhInfo->{_SMALL_BLOCK_SIZE})? 1: 0);
95             #1.1 Add to SBD
96 0         0 for (my $i = 0; $i<($iSmbCnt-1); $i++) {
97 0         0 print {$FILE} (pack("V", $i+$iSmBlk+1));
  0         0  
98             }
99 0         0 print {$FILE} (pack("V", -2));
  0         0  
100              
101             #1.2 Add to Data String(this will be written for RootEntry)
102             #Check for update
103 0 0       0 if($oPps->{_PPS_FILE}) {
104 0         0 my $sBuff;
105 0         0 $oPps->{_PPS_FILE}->seek(0, 0); #To The Top
106 0         0 while($oPps->{_PPS_FILE}->read($sBuff, 4096)) {
107 0         0 $sRes .= $sBuff;
108             }
109             }
110             else {
111 0         0 $sRes .= $oPps->{Data};
112             }
113             $sRes .= ("\x00" x
114             ($rhInfo->{_SMALL_BLOCK_SIZE} - ($oPps->{Size}% $rhInfo->{_SMALL_BLOCK_SIZE})))
115 0 0       0 if($oPps->{Size}% $rhInfo->{_SMALL_BLOCK_SIZE});
116             #1.3 Set for PPS
117 0         0 $oPps->{StartBlock} = $iSmBlk;
118 0         0 $iSmBlk += $iSmbCnt;
119             }
120             }
121             }
122 0         0 my $iSbCnt = int($rhInfo->{_BIG_BLOCK_SIZE}/ OLE::Storage_Lite::LongIntSize());
123 0 0       0 print {$FILE} (pack("V", -1) x ($iSbCnt - ($iSmBlk % $iSbCnt)))
  0         0  
124             if($iSmBlk % $iSbCnt);
125             #2. Write SBD with adjusting length for block
126 0         0 return $sRes;
127             }
128             #------------------------------------------------------------------------------
129             # _savePpsWk (OLE::Storage_Lite::PPS)
130             #------------------------------------------------------------------------------
131             sub _savePpsWk($$)
132             {
133 0     0   0 my($oThis, $rhInfo) = @_;
134             #1. Write PPS
135 0         0 my $FILE = $rhInfo->{_FILEH_};
136 0         0 print {$FILE} (
137             $oThis->{Name}
138             . ("\x00" x (64 - length($oThis->{Name}))) #64
139             , pack("v", length($oThis->{Name}) + 2) #66
140             , pack("c", $oThis->{Type}) #67
141             , pack("c", 0x00) #UK #68
142             , pack("V", $oThis->{PrevPps}) #Prev #72
143             , pack("V", $oThis->{NextPps}) #Next #76
144             , pack("V", $oThis->{DirPps}) #Dir #80
145             , "\x00\x09\x02\x00" #84
146             , "\x00\x00\x00\x00" #88
147             , "\xc0\x00\x00\x00" #92
148             , "\x00\x00\x00\x46" #96
149             , "\x00\x00\x00\x00" #100
150             , OLE::Storage_Lite::LocalDate2OLE($oThis->{Time1st}) #108
151             , OLE::Storage_Lite::LocalDate2OLE($oThis->{Time2nd}) #116
152             , pack("V", defined($oThis->{StartBlock})?
153             $oThis->{StartBlock}:0) #116
154             , pack("V", defined($oThis->{Size})?
155 0 0       0 $oThis->{Size} : 0) #124
    0          
156             , pack("V", 0), #128
157             );
158             }
159              
160             #//////////////////////////////////////////////////////////////////////////////
161             # OLE::Storage_Lite::PPS::Root Object
162             #//////////////////////////////////////////////////////////////////////////////
163             #==============================================================================
164             # OLE::Storage_Lite::PPS::Root
165             #==============================================================================
166             package OLE::Storage_Lite::PPS::Root;
167             require Exporter;
168 2     2   15 use strict;
  2         4  
  2         53  
169 2     2   1018 use IO::File;
  2         17663  
  2         237  
170 2     2   14 use IO::Handle;
  2         4  
  2         70  
171 2     2   10 use Fcntl;
  2         3  
  2         622  
172 2     2   18 use vars qw($VERSION @ISA);
  2         4  
  2         6829  
173             @ISA = qw(OLE::Storage_Lite::PPS Exporter);
174             $VERSION = '0.22';
175             sub _savePpsSetPnt($$$);
176             sub _savePpsSetPnt2($$$);
177             #------------------------------------------------------------------------------
178             # new (OLE::Storage_Lite::PPS::Root)
179             #------------------------------------------------------------------------------
180             sub new ($;$$$) {
181 0     0   0 my($sClass, $raTime1st, $raTime2nd, $raChild) = @_;
182 0         0 OLE::Storage_Lite::PPS::_new(
183             $sClass,
184             undef,
185             OLE::Storage_Lite::Asc2Ucs('Root Entry'),
186             5,
187             undef,
188             undef,
189             undef,
190             $raTime1st,
191             $raTime2nd,
192             undef,
193             undef,
194             undef,
195             $raChild);
196             }
197             #------------------------------------------------------------------------------
198             # save (OLE::Storage_Lite::PPS::Root)
199             #------------------------------------------------------------------------------
200             sub save($$;$$) {
201 0     0   0 my($oThis, $sFile, $bNoAs, $rhInfo) = @_;
202             #0.Initial Setting for saving
203 0 0       0 $rhInfo = {} unless($rhInfo);
204             $rhInfo->{_BIG_BLOCK_SIZE} = 2**
205             (($rhInfo->{_BIG_BLOCK_SIZE})?
206 0 0       0 _adjust2($rhInfo->{_BIG_BLOCK_SIZE}) : 9);
207             $rhInfo->{_SMALL_BLOCK_SIZE}= 2 **
208             (($rhInfo->{_SMALL_BLOCK_SIZE})?
209 0 0       0 _adjust2($rhInfo->{_SMALL_BLOCK_SIZE}): 6);
210 0         0 $rhInfo->{_SMALL_SIZE} = 0x1000;
211 0         0 $rhInfo->{_PPS_SIZE} = 0x80;
212              
213 0         0 my $closeFile = 1;
214              
215             #1.Open File
216             #1.1 $sFile is Ref of scalar
217 0 0       0 if(ref($sFile) eq 'SCALAR') {
    0          
    0          
218 0         0 require IO::Scalar;
219 0         0 my $oIo = new IO::Scalar $sFile, O_WRONLY;
220 0         0 $rhInfo->{_FILEH_} = $oIo;
221             }
222             #1.1.1 $sFile is a IO::Scalar object
223             # Now handled as a filehandle ref below.
224              
225             #1.2 $sFile is a IO::Handle object
226             elsif(UNIVERSAL::isa($sFile, 'IO::Handle')) {
227             # Not all filehandles support binmode() so try it in an eval.
228 0         0 eval{ binmode $sFile };
  0         0  
229 0         0 $rhInfo->{_FILEH_} = $sFile;
230             }
231             #1.3 $sFile is a simple filename string
232             elsif(!ref($sFile)) {
233 0 0       0 if($sFile ne '-') {
234 0         0 my $oIo = new IO::File;
235 0 0       0 $oIo->open(">$sFile") || return undef;
236 0         0 binmode($oIo);
237 0         0 $rhInfo->{_FILEH_} = $oIo;
238             }
239             else {
240 0         0 my $oIo = new IO::Handle;
241 0 0       0 $oIo->fdopen(fileno(STDOUT),"w") || return undef;
242 0         0 binmode($oIo);
243 0         0 $rhInfo->{_FILEH_} = $oIo;
244             }
245             }
246             #1.4 Assume that if $sFile is a ref then it is a valid filehandle
247             else {
248             # Not all filehandles support binmode() so try it in an eval.
249 0         0 eval{ binmode $sFile };
  0         0  
250 0         0 $rhInfo->{_FILEH_} = $sFile;
251             # Caller controls filehandle closing
252 0         0 $closeFile = 0;
253             }
254              
255 0         0 my $iBlk = 0;
256             #1. Make an array of PPS (for Save)
257 0         0 my @aList=();
258 0 0       0 if($bNoAs) {
259 0         0 _savePpsSetPnt2([$oThis], \@aList, $rhInfo);
260             }
261             else {
262 0         0 _savePpsSetPnt([$oThis], \@aList, $rhInfo);
263             }
264 0         0 my ($iSBDcnt, $iBBcnt, $iPPScnt) = $oThis->_calcSize(\@aList, $rhInfo);
265              
266             #2.Save Header
267 0         0 $oThis->_saveHeader($rhInfo, $iSBDcnt, $iBBcnt, $iPPScnt);
268              
269             #3.Make Small Data string (write SBD)
270 0         0 my $sSmWk = $oThis->_makeSmallData(\@aList, $rhInfo);
271 0         0 $oThis->{Data} = $sSmWk; #Small Datas become RootEntry Data
272              
273             #4. Write BB
274 0         0 my $iBBlk = $iSBDcnt;
275 0         0 $oThis->_saveBigData(\$iBBlk, \@aList, $rhInfo);
276              
277             #5. Write PPS
278 0         0 $oThis->_savePps(\@aList, $rhInfo);
279              
280             #6. Write BD and BDList and Adding Header informations
281 0         0 $oThis->_saveBbd($iSBDcnt, $iBBcnt, $iPPScnt, $rhInfo);
282              
283             #7.Close File
284 0 0       0 return $rhInfo->{_FILEH_}->close if $closeFile;
285             }
286             #------------------------------------------------------------------------------
287             # _calcSize (OLE::Storage_Lite::PPS)
288             #------------------------------------------------------------------------------
289             sub _calcSize($$)
290             {
291 0     0   0 my($oThis, $raList, $rhInfo) = @_;
292              
293             #0. Calculate Basic Setting
294 0         0 my ($iSBDcnt, $iBBcnt, $iPPScnt) = (0,0,0);
295 0         0 my $iSmallLen = 0;
296 0         0 my $iSBcnt = 0;
297 0         0 foreach my $oPps (@$raList) {
298 0 0       0 if($oPps->{Type}==OLE::Storage_Lite::PpsType_File()) {
299 0         0 $oPps->{Size} = $oPps->_DataLen(); #Mod
300 0 0       0 if($oPps->{Size} < $rhInfo->{_SMALL_SIZE}) {
301             $iSBcnt += int($oPps->{Size} / $rhInfo->{_SMALL_BLOCK_SIZE})
302 0 0       0 + (($oPps->{Size} % $rhInfo->{_SMALL_BLOCK_SIZE})? 1: 0);
303             }
304             else {
305             $iBBcnt +=
306             (int($oPps->{Size}/ $rhInfo->{_BIG_BLOCK_SIZE}) +
307 0 0       0 (($oPps->{Size}% $rhInfo->{_BIG_BLOCK_SIZE})? 1: 0));
308             }
309             }
310             }
311 0         0 $iSmallLen = $iSBcnt * $rhInfo->{_SMALL_BLOCK_SIZE};
312 0         0 my $iSlCnt = int($rhInfo->{_BIG_BLOCK_SIZE}/ OLE::Storage_Lite::LongIntSize());
313 0 0       0 $iSBDcnt = int($iSBcnt / $iSlCnt)+ (($iSBcnt % $iSlCnt)? 1:0);
314             $iBBcnt += (int($iSmallLen/ $rhInfo->{_BIG_BLOCK_SIZE}) +
315 0 0       0 (( $iSmallLen% $rhInfo->{_BIG_BLOCK_SIZE})? 1: 0));
316 0         0 my $iCnt = scalar(@$raList);
317 0         0 my $iBdCnt = $rhInfo->{_BIG_BLOCK_SIZE}/OLE::Storage_Lite::PpsSize();
318 0 0       0 $iPPScnt = (int($iCnt/$iBdCnt) + (($iCnt % $iBdCnt)? 1: 0));
319 0         0 return ($iSBDcnt, $iBBcnt, $iPPScnt);
320             }
321             #------------------------------------------------------------------------------
322             # _adjust2 (OLE::Storage_Lite::PPS::Root)
323             #------------------------------------------------------------------------------
324             sub _adjust2($) {
325 0     0   0 my($i2) = @_;
326 0         0 my $iWk;
327 0         0 $iWk = log($i2)/log(2);
328 0 0       0 return ($iWk > int($iWk))? int($iWk)+1:$iWk;
329             }
330             #------------------------------------------------------------------------------
331             # _saveHeader (OLE::Storage_Lite::PPS::Root)
332             #------------------------------------------------------------------------------
333             sub _saveHeader($$$$$) {
334 0     0   0 my($oThis, $rhInfo, $iSBDcnt, $iBBcnt, $iPPScnt) = @_;
335 0         0 my $FILE = $rhInfo->{_FILEH_};
336              
337             #0. Calculate Basic Setting
338 0         0 my $iBlCnt = $rhInfo->{_BIG_BLOCK_SIZE} / OLE::Storage_Lite::LongIntSize();
339 0         0 my $i1stBdL = int(($rhInfo->{_BIG_BLOCK_SIZE} - 0x4C) / OLE::Storage_Lite::LongIntSize());
340 0         0 my $i1stBdMax = $i1stBdL * $iBlCnt - $i1stBdL;
341 0         0 my $iBdExL = 0;
342 0         0 my $iAll = $iBBcnt + $iPPScnt + $iSBDcnt;
343 0         0 my $iAllW = $iAll;
344 0 0       0 my $iBdCntW = int($iAllW / $iBlCnt) + (($iAllW % $iBlCnt)? 1: 0);
345 0 0       0 my $iBdCnt = int(($iAll + $iBdCntW) / $iBlCnt) + ((($iAllW+$iBdCntW) % $iBlCnt)? 1: 0);
346 0         0 my $i;
347              
348 0 0       0 if ($iBdCnt > $i1stBdL) {
349             #0.1 Calculate BD count
350 0         0 $iBlCnt--; #the BlCnt is reduced in the count of the last sect is used for a pointer the next Bl
351 0         0 my $iBBleftover = $iAll - $i1stBdMax;
352              
353 0 0       0 if ($iAll >$i1stBdMax) {
354 0         0 while(1) {
355 0 0       0 $iBdCnt = int(($iBBleftover) / $iBlCnt) + ((($iBBleftover) % $iBlCnt)? 1: 0);
356 0 0       0 $iBdExL = int(($iBdCnt) / $iBlCnt) + ((($iBdCnt) % $iBlCnt)? 1: 0);
357 0         0 $iBBleftover = $iBBleftover + $iBdExL;
358 0 0       0 last if($iBdCnt == (int(($iBBleftover) / $iBlCnt) + ((($iBBleftover) % $iBlCnt)? 1: 0)));
    0          
359             }
360             }
361 0         0 $iBdCnt += $i1stBdL;
362             #print "iBdCnt = $iBdCnt \n";
363             }
364             #1.Save Header
365 0 0       0 print {$FILE} (
  0         0  
366             "\xD0\xCF\x11\xE0\xA1\xB1\x1A\xE1"
367             , "\x00\x00\x00\x00" x 4
368             , pack("v", 0x3b)
369             , pack("v", 0x03)
370             , pack("v", -2)
371             , pack("v", 9)
372             , pack("v", 6)
373             , pack("v", 0)
374             , "\x00\x00\x00\x00" x 2
375             , pack("V", $iBdCnt),
376             , pack("V", $iBBcnt+$iSBDcnt), #ROOT START
377             , pack("V", 0)
378             , pack("V", 0x1000)
379             , pack("V", $iSBDcnt ? 0 : -2) #Small Block Depot
380             , pack("V", $iSBDcnt)
381             );
382             #2. Extra BDList Start, Count
383 0 0       0 if($iAll <= $i1stBdMax) {
384 0         0 print {$FILE} (
  0         0  
385             pack("V", -2), #Extra BDList Start
386             pack("V", 0), #Extra BDList Count
387             );
388             }
389             else {
390 0         0 print {$FILE} (
  0         0  
391             pack("V", $iAll+$iBdCnt),
392             pack("V", $iBdExL),
393             );
394             }
395              
396             #3. BDList
397 0   0     0 for($i=0; $i<$i1stBdL and $i < $iBdCnt; $i++) {
398 0         0 print {$FILE} (pack("V", $iAll+$i));
  0         0  
399             }
400 0 0       0 print {$FILE} ((pack("V", -1)) x($i1stBdL-$i)) if($i<$i1stBdL);
  0         0  
401             }
402             #------------------------------------------------------------------------------
403             # _saveBigData (OLE::Storage_Lite::PPS)
404             #------------------------------------------------------------------------------
405             sub _saveBigData($$$$) {
406 0     0   0 my($oThis, $iStBlk, $raList, $rhInfo) = @_;
407 0         0 my $iRes = 0;
408 0         0 my $FILE = $rhInfo->{_FILEH_};
409              
410             #1.Write Big (ge 0x1000) Data into Block
411 0         0 foreach my $oPps (@$raList) {
412 0 0       0 if($oPps->{Type}!=OLE::Storage_Lite::PpsType_Dir()) {
413             #print "PPS: $oPps DEF:", defined($oPps->{Data}), "\n";
414 0         0 $oPps->{Size} = $oPps->_DataLen(); #Mod
415 0 0 0     0 if(($oPps->{Size} >= $rhInfo->{_SMALL_SIZE}) ||
      0        
416             (($oPps->{Type} == OLE::Storage_Lite::PpsType_Root()) && defined($oPps->{Data}))) {
417             #1.1 Write Data
418             #Check for update
419 0 0       0 if($oPps->{_PPS_FILE}) {
420 0         0 my $sBuff;
421 0         0 my $iLen = 0;
422 0         0 $oPps->{_PPS_FILE}->seek(0, 0); #To The Top
423 0         0 while($oPps->{_PPS_FILE}->read($sBuff, 4096)) {
424 0         0 $iLen += length($sBuff);
425 0         0 print {$FILE} ($sBuff); #Check for update
  0         0  
426             }
427             }
428             else {
429 0         0 print {$FILE} ($oPps->{Data});
  0         0  
430             }
431 0         0 print {$FILE} (
432             "\x00" x
433             ($rhInfo->{_BIG_BLOCK_SIZE} -
434             ($oPps->{Size} % $rhInfo->{_BIG_BLOCK_SIZE}))
435 0 0       0 ) if ($oPps->{Size} % $rhInfo->{_BIG_BLOCK_SIZE});
436             #1.2 Set For PPS
437 0         0 $oPps->{StartBlock} = $$iStBlk;
438             $$iStBlk +=
439             (int($oPps->{Size}/ $rhInfo->{_BIG_BLOCK_SIZE}) +
440 0 0       0 (($oPps->{Size}% $rhInfo->{_BIG_BLOCK_SIZE})? 1: 0));
441             }
442             }
443             }
444             }
445             #------------------------------------------------------------------------------
446             # _savePps (OLE::Storage_Lite::PPS::Root)
447             #------------------------------------------------------------------------------
448             sub _savePps($$$)
449             {
450 0     0   0 my($oThis, $raList, $rhInfo) = @_;
451             #0. Initial
452 0         0 my $FILE = $rhInfo->{_FILEH_};
453             #2. Save PPS
454 0         0 foreach my $oItem (@$raList) {
455 0         0 $oItem->_savePpsWk($rhInfo);
456             }
457             #3. Adjust for Block
458 0         0 my $iCnt = scalar(@$raList);
459 0         0 my $iBCnt = $rhInfo->{_BIG_BLOCK_SIZE} / $rhInfo->{_PPS_SIZE};
460 0 0       0 print {$FILE} ("\x00" x (($iBCnt - ($iCnt % $iBCnt)) * $rhInfo->{_PPS_SIZE}))
  0         0  
461             if($iCnt % $iBCnt);
462 0 0       0 return int($iCnt / $iBCnt) + (($iCnt % $iBCnt)? 1: 0);
463             }
464             #------------------------------------------------------------------------------
465             # _savePpsSetPnt2 (OLE::Storage_Lite::PPS::Root)
466             # For Test
467             #------------------------------------------------------------------------------
468             sub _savePpsSetPnt2($$$)
469             {
470 0     0   0 my($aThis, $raList, $rhInfo) = @_;
471             #1. make Array as Children-Relations
472             #1.1 if No Children
473 0 0       0 if($#$aThis < 0) {
    0          
474 0         0 return 0xFFFFFFFF;
475             }
476             elsif($#$aThis == 0) {
477             #1.2 Just Only one
478 0         0 push @$raList, $aThis->[0];
479 0         0 $aThis->[0]->{No} = $#$raList;
480 0         0 $aThis->[0]->{PrevPps} = 0xFFFFFFFF;
481 0         0 $aThis->[0]->{NextPps} = 0xFFFFFFFF;
482 0         0 $aThis->[0]->{DirPps} = _savePpsSetPnt2($aThis->[0]->{Child}, $raList, $rhInfo);
483 0         0 return $aThis->[0]->{No};
484             }
485             else {
486             #1.3 Array
487 0         0 my $iCnt = $#$aThis + 1;
488             #1.3.1 Define Center
489 0         0 my $iPos = 0; #int($iCnt/ 2); #$iCnt
490              
491 0         0 my @aWk = @$aThis;
492 0 0       0 my @aPrev = ($#$aThis > 1)? splice(@aWk, 1, 1) : (); #$iPos);
493 0         0 my @aNext = splice(@aWk, 1); #, $iCnt - $iPos -1);
494 0         0 $aThis->[$iPos]->{PrevPps} = _savePpsSetPnt2(
495             \@aPrev, $raList, $rhInfo);
496 0         0 push @$raList, $aThis->[$iPos];
497 0         0 $aThis->[$iPos]->{No} = $#$raList;
498              
499             #1.3.2 Devide a array into Previous,Next
500 0         0 $aThis->[$iPos]->{NextPps} = _savePpsSetPnt2(
501             \@aNext, $raList, $rhInfo);
502 0         0 $aThis->[$iPos]->{DirPps} = _savePpsSetPnt2($aThis->[$iPos]->{Child}, $raList, $rhInfo);
503 0         0 return $aThis->[$iPos]->{No};
504             }
505             }
506             #------------------------------------------------------------------------------
507             # _savePpsSetPnt2 (OLE::Storage_Lite::PPS::Root)
508             # For Test
509             #------------------------------------------------------------------------------
510             sub _savePpsSetPnt2s($$$)
511             {
512 0     0   0 my($aThis, $raList, $rhInfo) = @_;
513             #1. make Array as Children-Relations
514             #1.1 if No Children
515 0 0       0 if($#$aThis < 0) {
    0          
516 0         0 return 0xFFFFFFFF;
517             }
518             elsif($#$aThis == 0) {
519             #1.2 Just Only one
520 0         0 push @$raList, $aThis->[0];
521 0         0 $aThis->[0]->{No} = $#$raList;
522 0         0 $aThis->[0]->{PrevPps} = 0xFFFFFFFF;
523 0         0 $aThis->[0]->{NextPps} = 0xFFFFFFFF;
524 0         0 $aThis->[0]->{DirPps} = _savePpsSetPnt2($aThis->[0]->{Child}, $raList, $rhInfo);
525 0         0 return $aThis->[0]->{No};
526             }
527             else {
528             #1.3 Array
529 0         0 my $iCnt = $#$aThis + 1;
530             #1.3.1 Define Center
531 0         0 my $iPos = 0; #int($iCnt/ 2); #$iCnt
532 0         0 push @$raList, $aThis->[$iPos];
533 0         0 $aThis->[$iPos]->{No} = $#$raList;
534 0         0 my @aWk = @$aThis;
535             #1.3.2 Devide a array into Previous,Next
536 0         0 my @aPrev = splice(@aWk, 0, $iPos);
537 0         0 my @aNext = splice(@aWk, 1, $iCnt - $iPos -1);
538 0         0 $aThis->[$iPos]->{PrevPps} = _savePpsSetPnt2(
539             \@aPrev, $raList, $rhInfo);
540 0         0 $aThis->[$iPos]->{NextPps} = _savePpsSetPnt2(
541             \@aNext, $raList, $rhInfo);
542 0         0 $aThis->[$iPos]->{DirPps} = _savePpsSetPnt2($aThis->[$iPos]->{Child}, $raList, $rhInfo);
543 0         0 return $aThis->[$iPos]->{No};
544             }
545             }
546             #------------------------------------------------------------------------------
547             # _savePpsSetPnt (OLE::Storage_Lite::PPS::Root)
548             #------------------------------------------------------------------------------
549             sub _savePpsSetPnt($$$)
550             {
551 0     0   0 my($aThis, $raList, $rhInfo) = @_;
552             #1. make Array as Children-Relations
553             #1.1 if No Children
554 0 0       0 if($#$aThis < 0) {
    0          
555 0         0 return 0xFFFFFFFF;
556             }
557             elsif($#$aThis == 0) {
558             #1.2 Just Only one
559 0         0 push @$raList, $aThis->[0];
560 0         0 $aThis->[0]->{No} = $#$raList;
561 0         0 $aThis->[0]->{PrevPps} = 0xFFFFFFFF;
562 0         0 $aThis->[0]->{NextPps} = 0xFFFFFFFF;
563 0         0 $aThis->[0]->{DirPps} = _savePpsSetPnt($aThis->[0]->{Child}, $raList, $rhInfo);
564 0         0 return $aThis->[0]->{No};
565             }
566             else {
567             #1.3 Array
568 0         0 my $iCnt = $#$aThis + 1;
569             #1.3.1 Define Center
570 0         0 my $iPos = int($iCnt/ 2); #$iCnt
571 0         0 push @$raList, $aThis->[$iPos];
572 0         0 $aThis->[$iPos]->{No} = $#$raList;
573 0         0 my @aWk = @$aThis;
574             #1.3.2 Devide a array into Previous,Next
575 0         0 my @aPrev = splice(@aWk, 0, $iPos);
576 0         0 my @aNext = splice(@aWk, 1, $iCnt - $iPos -1);
577 0         0 $aThis->[$iPos]->{PrevPps} = _savePpsSetPnt(
578             \@aPrev, $raList, $rhInfo);
579 0         0 $aThis->[$iPos]->{NextPps} = _savePpsSetPnt(
580             \@aNext, $raList, $rhInfo);
581 0         0 $aThis->[$iPos]->{DirPps} = _savePpsSetPnt($aThis->[$iPos]->{Child}, $raList, $rhInfo);
582 0         0 return $aThis->[$iPos]->{No};
583             }
584             }
585             #------------------------------------------------------------------------------
586             # _savePpsSetPnt (OLE::Storage_Lite::PPS::Root)
587             #------------------------------------------------------------------------------
588             sub _savePpsSetPnt1($$$)
589             {
590 0     0   0 my($aThis, $raList, $rhInfo) = @_;
591             #1. make Array as Children-Relations
592             #1.1 if No Children
593 0 0       0 if($#$aThis < 0) {
    0          
594 0         0 return 0xFFFFFFFF;
595             }
596             elsif($#$aThis == 0) {
597             #1.2 Just Only one
598 0         0 push @$raList, $aThis->[0];
599 0         0 $aThis->[0]->{No} = $#$raList;
600 0         0 $aThis->[0]->{PrevPps} = 0xFFFFFFFF;
601 0         0 $aThis->[0]->{NextPps} = 0xFFFFFFFF;
602 0         0 $aThis->[0]->{DirPps} = _savePpsSetPnt($aThis->[0]->{Child}, $raList, $rhInfo);
603 0         0 return $aThis->[0]->{No};
604             }
605             else {
606             #1.3 Array
607 0         0 my $iCnt = $#$aThis + 1;
608             #1.3.1 Define Center
609 0         0 my $iPos = int($iCnt/ 2); #$iCnt
610 0         0 push @$raList, $aThis->[$iPos];
611 0         0 $aThis->[$iPos]->{No} = $#$raList;
612 0         0 my @aWk = @$aThis;
613             #1.3.2 Devide a array into Previous,Next
614 0         0 my @aPrev = splice(@aWk, 0, $iPos);
615 0         0 my @aNext = splice(@aWk, 1, $iCnt - $iPos -1);
616 0         0 $aThis->[$iPos]->{PrevPps} = _savePpsSetPnt(
617             \@aPrev, $raList, $rhInfo);
618 0         0 $aThis->[$iPos]->{NextPps} = _savePpsSetPnt(
619             \@aNext, $raList, $rhInfo);
620 0         0 $aThis->[$iPos]->{DirPps} = _savePpsSetPnt($aThis->[$iPos]->{Child}, $raList, $rhInfo);
621 0         0 return $aThis->[$iPos]->{No};
622             }
623             }
624             #------------------------------------------------------------------------------
625             # _saveBbd (OLE::Storage_Lite)
626             #------------------------------------------------------------------------------
627             sub _saveBbd($$$$)
628             {
629 0     0   0 my($oThis, $iSbdSize, $iBsize, $iPpsCnt, $rhInfo) = @_;
630 0         0 my $FILE = $rhInfo->{_FILEH_};
631             #0. Calculate Basic Setting
632 0         0 my $iBbCnt = $rhInfo->{_BIG_BLOCK_SIZE} / OLE::Storage_Lite::LongIntSize();
633 0         0 my $iBlCnt = $iBbCnt - 1;
634 0         0 my $i1stBdL = int(($rhInfo->{_BIG_BLOCK_SIZE} - 0x4C) / OLE::Storage_Lite::LongIntSize());
635 0         0 my $i1stBdMax = $i1stBdL * $iBbCnt - $i1stBdL;
636 0         0 my $iBdExL = 0;
637 0         0 my $iAll = $iBsize + $iPpsCnt + $iSbdSize;
638 0         0 my $iAllW = $iAll;
639 0 0       0 my $iBdCntW = int($iAllW / $iBbCnt) + (($iAllW % $iBbCnt)? 1: 0);
640 0         0 my $iBdCnt = 0;
641 0         0 my $i;
642             #0.1 Calculate BD count
643 0         0 my $iBBleftover = $iAll - $i1stBdMax;
644 0 0       0 if ($iAll >$i1stBdMax) {
645              
646 0         0 while(1) {
647 0 0       0 $iBdCnt = int(($iBBleftover) / $iBlCnt) + ((($iBBleftover) % $iBlCnt)? 1: 0);
648 0 0       0 $iBdExL = int(($iBdCnt) / $iBlCnt) + ((($iBdCnt) % $iBlCnt)? 1: 0);
649 0         0 $iBBleftover = $iBBleftover + $iBdExL;
650 0 0       0 last if($iBdCnt == (int(($iBBleftover) / $iBlCnt) + ((($iBBleftover) % $iBlCnt)? 1: 0)));
    0          
651             }
652             }
653 0         0 $iAllW += $iBdExL;
654 0         0 $iBdCnt += $i1stBdL;
655             #print "iBdCnt = $iBdCnt \n";
656              
657             #1. Making BD
658             #1.1 Set for SBD
659 0 0       0 if($iSbdSize > 0) {
660 0         0 for ($i = 0; $i<($iSbdSize-1); $i++) {
661 0         0 print {$FILE} (pack("V", $i+1));
  0         0  
662             }
663 0         0 print {$FILE} (pack("V", -2));
  0         0  
664             }
665             #1.2 Set for B
666 0         0 for ($i = 0; $i<($iBsize-1); $i++) {
667 0         0 print {$FILE} (pack("V", $i+$iSbdSize+1));
  0         0  
668             }
669 0         0 print {$FILE} (pack("V", -2));
  0         0  
670              
671             #1.3 Set for PPS
672 0         0 for ($i = 0; $i<($iPpsCnt-1); $i++) {
673 0         0 print {$FILE} (pack("V", $i+$iSbdSize+$iBsize+1));
  0         0  
674             }
675 0         0 print {$FILE} (pack("V", -2));
  0         0  
676             #1.4 Set for BBD itself ( 0xFFFFFFFD : BBD)
677 0         0 for($i=0; $i<$iBdCnt;$i++) {
678 0         0 print {$FILE} (pack("V", 0xFFFFFFFD));
  0         0  
679             }
680             #1.5 Set for ExtraBDList
681 0         0 for($i=0; $i<$iBdExL;$i++) {
682 0         0 print {$FILE} (pack("V", 0xFFFFFFFC));
  0         0  
683             }
684             #1.6 Adjust for Block
685 0 0       0 print {$FILE} (pack("V", -1) x ($iBbCnt - (($iAllW + $iBdCnt) % $iBbCnt)))
  0         0  
686             if(($iAllW + $iBdCnt) % $iBbCnt);
687             #2.Extra BDList
688 0 0       0 if($iBdCnt > $i1stBdL) {
689 0         0 my $iN=0;
690 0         0 my $iNb=0;
691 0         0 for($i=$i1stBdL;$i<$iBdCnt; $i++, $iN++) {
692 0 0       0 if($iN>=($iBbCnt-1)) {
693 0         0 $iN = 0;
694 0         0 $iNb++;
695 0         0 print {$FILE} (pack("V", $iAll+$iBdCnt+$iNb));
  0         0  
696             }
697 0         0 print {$FILE} (pack("V", $iBsize+$iSbdSize+$iPpsCnt+$i));
  0         0  
698             }
699 0 0       0 print {$FILE} (pack("V", -1) x (($iBbCnt-1) - (($iBdCnt-$i1stBdL) % ($iBbCnt-1))))
  0         0  
700             if(($iBdCnt-$i1stBdL) % ($iBbCnt-1));
701 0         0 print {$FILE} (pack("V", -2));
  0         0  
702             }
703             }
704              
705             #//////////////////////////////////////////////////////////////////////////////
706             # OLE::Storage_Lite::PPS::File Object
707             #//////////////////////////////////////////////////////////////////////////////
708             #==============================================================================
709             # OLE::Storage_Lite::PPS::File
710             #==============================================================================
711             package OLE::Storage_Lite::PPS::File;
712             require Exporter;
713 2     2   16 use strict;
  2         5  
  2         61  
714 2     2   11 use vars qw($VERSION @ISA);
  2         3  
  2         870  
715             @ISA = qw(OLE::Storage_Lite::PPS Exporter);
716             $VERSION = '0.22';
717             #------------------------------------------------------------------------------
718             # new (OLE::Storage_Lite::PPS::File)
719             #------------------------------------------------------------------------------
720             sub new ($$$) {
721 0     0   0 my($sClass, $sNm, $sData) = @_;
722 0         0 OLE::Storage_Lite::PPS::_new(
723             $sClass,
724             undef,
725             $sNm,
726             2,
727             undef,
728             undef,
729             undef,
730             undef,
731             undef,
732             undef,
733             undef,
734             $sData,
735             undef);
736             }
737             #------------------------------------------------------------------------------
738             # newFile (OLE::Storage_Lite::PPS::File)
739             #------------------------------------------------------------------------------
740             sub newFile ($$;$) {
741 0     0   0 my($sClass, $sNm, $sFile) = @_;
742 0         0 my $oSelf =
743             OLE::Storage_Lite::PPS::_new(
744             $sClass,
745             undef,
746             $sNm,
747             2,
748             undef,
749             undef,
750             undef,
751             undef,
752             undef,
753             undef,
754             undef,
755             '',
756             undef);
757             #
758 0 0 0     0 if((!defined($sFile)) or ($sFile eq '')) {
    0          
    0          
759 0         0 $oSelf->{_PPS_FILE} = IO::File->new_tmpfile();
760             }
761             elsif(UNIVERSAL::isa($sFile, 'IO::Handle')) {
762 0         0 $oSelf->{_PPS_FILE} = $sFile;
763             }
764             elsif(!ref($sFile)) {
765             #File Name
766 0         0 $oSelf->{_PPS_FILE} = new IO::File;
767 0 0       0 return undef unless($oSelf->{_PPS_FILE});
768 0 0       0 $oSelf->{_PPS_FILE}->open("$sFile", "r+") || return undef;
769             }
770             else {
771 0         0 return undef;
772             }
773 0 0       0 if($oSelf->{_PPS_FILE}) {
774 0         0 $oSelf->{_PPS_FILE}->seek(0, 2);
775 0         0 binmode($oSelf->{_PPS_FILE});
776 0         0 $oSelf->{_PPS_FILE}->autoflush(1);
777             }
778 0         0 return $oSelf;
779             }
780             #------------------------------------------------------------------------------
781             # append (OLE::Storage_Lite::PPS::File)
782             #------------------------------------------------------------------------------
783             sub append ($$) {
784 0     0   0 my($oSelf, $sData) = @_;
785 0 0       0 if($oSelf->{_PPS_FILE}) {
786 0         0 print {$oSelf->{_PPS_FILE}} $sData;
  0         0  
787             }
788             else {
789 0         0 $oSelf->{Data} .= $sData;
790             }
791             }
792              
793             #//////////////////////////////////////////////////////////////////////////////
794             # OLE::Storage_Lite::PPS::Dir Object
795             #//////////////////////////////////////////////////////////////////////////////
796             #------------------------------------------------------------------------------
797             # new (OLE::Storage_Lite::PPS::Dir)
798             #------------------------------------------------------------------------------
799             package OLE::Storage_Lite::PPS::Dir;
800             require Exporter;
801 2     2   20 use strict;
  2         5  
  2         58  
802 2     2   10 use vars qw($VERSION @ISA);
  2         8  
  2         255  
803             @ISA = qw(OLE::Storage_Lite::PPS Exporter);
804             $VERSION = '0.22';
805             sub new ($$;$$$) {
806 0     0   0 my($sClass, $sName, $raTime1st, $raTime2nd, $raChild) = @_;
807 0         0 OLE::Storage_Lite::PPS::_new(
808             $sClass,
809             undef,
810             $sName,
811             1,
812             undef,
813             undef,
814             undef,
815             $raTime1st,
816             $raTime2nd,
817             undef,
818             undef,
819             undef,
820             $raChild);
821             }
822             #==============================================================================
823             # OLE::Storage_Lite
824             #==============================================================================
825             package OLE::Storage_Lite;
826             require Exporter;
827              
828 2     2   13 use strict;
  2         4  
  2         47  
829 2     2   21 use Carp;
  2         4  
  2         142  
830 2     2   14 use IO::File;
  2         3  
  2         317  
831 2     2   12 use List::Util qw(first);
  2         5  
  2         279  
832 2     2   1154 use Time::Local 'timegm';
  2         4682  
  2         130  
833              
834 2     2   17 use vars qw($VERSION @ISA @EXPORT);
  2         4  
  2         227  
835             @ISA = qw(Exporter);
836             $VERSION = '0.22';
837             sub _getPpsSearch($$$$$;$);
838             sub _getPpsTree($$$;$);
839             #------------------------------------------------------------------------------
840             # Const for OLE::Storage_Lite
841             #------------------------------------------------------------------------------
842             #0. Constants
843             use constant {
844 2         6769 PpsType_Root => 5,
845             PpsType_Dir => 1,
846             PpsType_File => 2,
847             DataSizeSmall => 0x1000,
848             LongIntSize => 4,
849             PpsSize => 0x80,
850             # 0xFFFFFFFC : BDList, 0xFFFFFFFD : BBD,
851             # 0xFFFFFFFE: End of Chain 0xFFFFFFFF : unused
852             NormalBlockEnd => 0xFFFFFFFC,
853 2     2   14 };
  2         4  
854             #------------------------------------------------------------------------------
855             # new OLE::Storage_Lite
856             #------------------------------------------------------------------------------
857             sub new($$) {
858 0     0 1 0 my($sClass, $sFile) = @_;
859 0         0 my $oThis = {
860             _FILE => $sFile,
861             };
862 0         0 bless $oThis;
863 0         0 return $oThis;
864             }
865             #------------------------------------------------------------------------------
866             # getPpsTree: OLE::Storage_Lite
867             #------------------------------------------------------------------------------
868             sub getPpsTree($;$)
869             {
870 0     0 1 0 my($oThis, $bData) = @_;
871             #0.Init
872 0         0 my $rhInfo = _initParse($oThis->{_FILE});
873 0 0       0 return undef unless($rhInfo);
874             #1. Get Data
875 0         0 my ($oPps) = _getPpsTree(0, $rhInfo, $bData);
876 0         0 close(IN);
877 0         0 return $oPps;
878             }
879             #------------------------------------------------------------------------------
880             # getSearch: OLE::Storage_Lite
881             #------------------------------------------------------------------------------
882             sub getPpsSearch($$;$$)
883             {
884 0     0 1 0 my($oThis, $raName, $bData, $iCase) = @_;
885             #0.Init
886 0         0 my $rhInfo = _initParse($oThis->{_FILE});
887 0 0       0 return undef unless($rhInfo);
888             #1. Get Data
889 0         0 my @aList = _getPpsSearch(0, $rhInfo, $raName, $bData, $iCase);
890 0         0 close(IN);
891 0         0 return @aList;
892             }
893             #------------------------------------------------------------------------------
894             # getNthPps: OLE::Storage_Lite
895             #------------------------------------------------------------------------------
896             sub getNthPps($$;$)
897             {
898 0     0 1 0 my($oThis, $iNo, $bData) = @_;
899             #0.Init
900 0         0 my $rhInfo = _initParse($oThis->{_FILE});
901 0 0       0 return undef unless($rhInfo);
902             #1. Get Data
903 0         0 my $oPps = _getNthPps($iNo, $rhInfo, $bData);
904 0         0 close IN;
905 0         0 return $oPps;
906             }
907             #------------------------------------------------------------------------------
908             # _initParse: OLE::Storage_Lite
909             #------------------------------------------------------------------------------
910             sub _initParse($) {
911 0     0   0 my($sFile)=@_;
912 0         0 my $oIo;
913             #1. $sFile is Ref of scalar
914 0 0       0 if(ref($sFile) eq 'SCALAR') {
    0          
    0          
915 0         0 require IO::Scalar;
916 0         0 $oIo = new IO::Scalar;
917 0         0 $oIo->open($sFile);
918             }
919             #2. $sFile is a IO::Handle object
920             elsif(UNIVERSAL::isa($sFile, 'IO::Handle')) {
921 0         0 $oIo = $sFile;
922 0         0 binmode($oIo);
923             }
924             #3. $sFile is a simple filename string
925             elsif(!ref($sFile)) {
926 0         0 $oIo = new IO::File;
927 0 0       0 $oIo->open("<$sFile") || return undef;
928 0         0 binmode($oIo);
929             }
930             #4 Assume that if $sFile is a ref then it is a valid filehandle
931             else {
932 0         0 $oIo = $sFile;
933             # Not all filehandles support binmode() so try it in an eval.
934 0         0 eval{ binmode $oIo };
  0         0  
935             }
936 0         0 return _getHeaderInfo($oIo);
937             }
938             #------------------------------------------------------------------------------
939             # _getPpsTree: OLE::Storage_Lite
940             #------------------------------------------------------------------------------
941             sub _getPpsTree($$$;$) {
942 0     0   0 my($iNo, $rhInfo, $bData, $raDone) = @_;
943 0 0       0 if(defined($raDone)) {
944 0 0       0 return () if(exists($raDone->{$iNo}));
945             }
946             else {
947 0         0 $raDone={};
948             }
949 0         0 $raDone->{$iNo} = undef;
950              
951 0         0 my $iRootBlock = $rhInfo->{_ROOT_START} ;
952             #1. Get Information about itself
953 0         0 my $oPps = _getNthPps($iNo, $rhInfo, $bData);
954             #2. Child
955 0 0       0 if($oPps->{DirPps} != 0xFFFFFFFF) {
956 0         0 my @aChildL = _getPpsTree($oPps->{DirPps}, $rhInfo, $bData, $raDone);
957 0         0 $oPps->{Child} = \@aChildL;
958             }
959             else {
960 0         0 $oPps->{Child} = undef;
961             }
962             #3. Previous,Next PPSs
963 0         0 my @aList = ();
964             push @aList, _getPpsTree($oPps->{PrevPps}, $rhInfo, $bData, $raDone)
965 0 0       0 if($oPps->{PrevPps} != 0xFFFFFFFF);
966 0         0 push @aList, $oPps;
967             push @aList, _getPpsTree($oPps->{NextPps}, $rhInfo, $bData, $raDone)
968 0 0       0 if($oPps->{NextPps} != 0xFFFFFFFF);
969 0         0 return @aList;
970             }
971             #------------------------------------------------------------------------------
972             # _getPpsSearch: OLE::Storage_Lite
973             #------------------------------------------------------------------------------
974             sub _getPpsSearch($$$$$;$) {
975 0     0   0 my($iNo, $rhInfo, $raName, $bData, $iCase, $raDone) = @_;
976 0         0 my $iRootBlock = $rhInfo->{_ROOT_START} ;
977 0         0 my @aRes;
978             #1. Check it self
979 0 0       0 if(defined($raDone)) {
980 0 0       0 return () if(exists($raDone->{$iNo}));
981             }
982             else {
983 0         0 $raDone={};
984             }
985 0         0 $raDone->{$iNo} = undef;
986 0         0 my $oPps = _getNthPps($iNo, $rhInfo, undef);
987             # if(first {$_ eq $oPps->{Name}} @$raName) {
988 0 0 0 0   0 if(($iCase && (first {/^\Q$oPps->{Name}\E$/i} @$raName)) ||
  0   0     0  
989 0     0   0 (first {$_ eq $oPps->{Name}} @$raName)) {
990 0 0       0 $oPps = _getNthPps($iNo, $rhInfo, $bData) if ($bData);
991 0         0 @aRes = ($oPps);
992             }
993             else {
994 0         0 @aRes = ();
995             }
996             #2. Check Child, Previous, Next PPSs
997             push @aRes, _getPpsSearch($oPps->{DirPps}, $rhInfo, $raName, $bData, $iCase, $raDone)
998 0 0       0 if($oPps->{DirPps} != 0xFFFFFFFF) ;
999             push @aRes, _getPpsSearch($oPps->{PrevPps}, $rhInfo, $raName, $bData, $iCase, $raDone)
1000 0 0       0 if($oPps->{PrevPps} != 0xFFFFFFFF );
1001             push @aRes, _getPpsSearch($oPps->{NextPps}, $rhInfo, $raName, $bData, $iCase, $raDone)
1002 0 0       0 if($oPps->{NextPps} != 0xFFFFFFFF);
1003 0         0 return @aRes;
1004             }
1005             #===================================================================
1006             # Get Header Info (BASE Informain about that file)
1007             #===================================================================
1008             sub _getHeaderInfo($){
1009 0     0   0 my($FILE) = @_;
1010 0         0 my($iWk);
1011 0         0 my $rhInfo = {};
1012 0         0 $rhInfo->{_FILEH_} = $FILE;
1013 0         0 my $sWk;
1014             #0. Check ID
1015 0         0 $rhInfo->{_FILEH_}->seek(0, 0);
1016 0         0 $rhInfo->{_FILEH_}->read($sWk, 8);
1017 0 0       0 return undef unless($sWk eq "\xD0\xCF\x11\xE0\xA1\xB1\x1A\xE1");
1018             #BIG BLOCK SIZE
1019 0         0 $iWk = _getInfoFromFile($rhInfo->{_FILEH_}, 0x1E, 2, "v");
1020 0 0       0 return undef unless(defined($iWk));
1021 0         0 $rhInfo->{_BIG_BLOCK_SIZE} = 2 ** $iWk;
1022             #SMALL BLOCK SIZE
1023 0         0 $iWk = _getInfoFromFile($rhInfo->{_FILEH_}, 0x20, 2, "v");
1024 0 0       0 return undef unless(defined($iWk));
1025 0         0 $rhInfo->{_SMALL_BLOCK_SIZE} = 2 ** $iWk;
1026             #BDB Count
1027 0         0 $iWk = _getInfoFromFile($rhInfo->{_FILEH_}, 0x2C, 4, "V");
1028 0 0       0 return undef unless(defined($iWk));
1029 0         0 $rhInfo->{_BDB_COUNT} = $iWk;
1030             #START BLOCK
1031 0         0 $iWk = _getInfoFromFile($rhInfo->{_FILEH_}, 0x30, 4, "V");
1032 0 0       0 return undef unless(defined($iWk));
1033 0         0 $rhInfo->{_ROOT_START} = $iWk;
1034             #MIN SIZE OF BB
1035             # $iWk = _getInfoFromFile($rhInfo->{_FILEH_}, 0x38, 4, "V");
1036             # return undef unless(defined($iWk));
1037             # $rhInfo->{_MIN_SIZE_BB} = $iWk;
1038             #SMALL BD START
1039 0         0 $iWk = _getInfoFromFile($rhInfo->{_FILEH_}, 0x3C, 4, "V");
1040 0 0       0 return undef unless(defined($iWk));
1041 0         0 $rhInfo->{_SBD_START} = $iWk;
1042             #SMALL BD COUNT
1043 0         0 $iWk = _getInfoFromFile($rhInfo->{_FILEH_}, 0x40, 4, "V");
1044 0 0       0 return undef unless(defined($iWk));
1045 0         0 $rhInfo->{_SBD_COUNT} = $iWk;
1046             #EXTRA BBD START
1047 0         0 $iWk = _getInfoFromFile($rhInfo->{_FILEH_}, 0x44, 4, "V");
1048 0 0       0 return undef unless(defined($iWk));
1049 0         0 $rhInfo->{_EXTRA_BBD_START} = $iWk;
1050             #EXTRA BD COUNT
1051 0         0 $iWk = _getInfoFromFile($rhInfo->{_FILEH_}, 0x48, 4, "V");
1052 0 0       0 return undef unless(defined($iWk));
1053 0         0 $rhInfo->{_EXTRA_BBD_COUNT} = $iWk;
1054             #GET BBD INFO
1055 0         0 $rhInfo->{_BBD_INFO}= _getBbdInfo($rhInfo);
1056             #GET ROOT PPS
1057 0         0 my $oRoot = _getNthPps(0, $rhInfo, undef);
1058 0         0 $rhInfo->{_SB_START} = $oRoot->{StartBlock};
1059 0         0 $rhInfo->{_SB_SIZE} = $oRoot->{Size};
1060             # cache lookaheads for huge performance improvement in some cases
1061 0         0 my $iNextCount = keys(%{$rhInfo->{_BBD_INFO}});
  0         0  
1062 0         0 my $iBlockNo = $rhInfo->{_ROOT_START};
1063 0         0 my $iBigBlkSize=$rhInfo->{_BIG_BLOCK_SIZE};
1064 0         0 $rhInfo->{_BBD_ROOT_START}= [$iBlockNo];
1065 0         0 for(1..$iNextCount) {
1066 0   0     0 $iBlockNo = $rhInfo->{_BBD_INFO}->{$iBlockNo} // $iBlockNo+1;
1067 0 0       0 last unless $iBlockNo < OLE::Storage_Lite::NormalBlockEnd();
1068 0         0 $rhInfo->{_BBD_ROOT_START}->[$_] = $iBlockNo;
1069             }
1070 0         0 $iBlockNo = $rhInfo->{_SB_START};
1071 0         0 $rhInfo->{_BBD_SB_START}= [($iBlockNo+1)*$iBigBlkSize];
1072 0         0 for(1..$iNextCount) {
1073 0   0     0 $iBlockNo = $rhInfo->{_BBD_INFO}->{$iBlockNo} // $iBlockNo+1;
1074 0 0       0 last unless $iBlockNo < OLE::Storage_Lite::NormalBlockEnd();
1075 0         0 $rhInfo->{_BBD_SB_START}->[$_] = ($iBlockNo+1)*$iBigBlkSize;
1076             }
1077 0         0 $iBlockNo = $rhInfo->{_SBD_START};
1078 0         0 $rhInfo->{_BBD_SBD_START}= [($iBlockNo+1)*$iBigBlkSize];
1079 0         0 for(1..$iNextCount) {
1080 0   0     0 $iBlockNo = $rhInfo->{_BBD_INFO}->{$iBlockNo} // $iBlockNo+1;
1081 0 0       0 last unless $iBlockNo < OLE::Storage_Lite::NormalBlockEnd();
1082 0         0 $rhInfo->{_BBD_SBD_START}->[$_] = ($iBlockNo+1)*$iBigBlkSize;
1083             }
1084 0         0 my @aKeys= sort({$a<=>$b} keys(%{$rhInfo->{_BBD_INFO}}));
  0         0  
  0         0  
1085 0         0 $rhInfo->{_BBD_INFO_SORTED}= \@aKeys;
1086 0         0 return $rhInfo;
1087             }
1088             #------------------------------------------------------------------------------
1089             # _getInfoFromFile
1090             #------------------------------------------------------------------------------
1091             sub _getInfoFromFile($$$$) {
1092 0     0   0 my($FILE, $iPos, $iLen, $sFmt) =@_;
1093 0         0 my($sWk);
1094 0 0       0 return undef unless($FILE);
1095 0 0       0 return undef if($FILE->seek($iPos, 0)==0);
1096 0 0       0 return undef if($FILE->read($sWk, $iLen)!=$iLen);
1097 0         0 return unpack($sFmt, $sWk);
1098             }
1099             #------------------------------------------------------------------------------
1100             # _getBbdInfo
1101             #------------------------------------------------------------------------------
1102             sub _getBbdInfo($) {
1103 0     0   0 my($rhInfo) =@_;
1104 0         0 my @aBdList = ();
1105 0         0 my $iBdbCnt = $rhInfo->{_BDB_COUNT};
1106 0         0 my $iBigBlkSize = $rhInfo->{_BIG_BLOCK_SIZE};
1107 0         0 my $iGetCnt;
1108             my $sWk;
1109 0         0 my $i1stCnt = int(($iBigBlkSize - 0x4C) / OLE::Storage_Lite::LongIntSize());
1110 0         0 my $iBdlCnt = int($iBigBlkSize / OLE::Storage_Lite::LongIntSize()) - 1;
1111              
1112             #1. 1st BDlist
1113 0         0 $rhInfo->{_FILEH_}->seek(0x4C, 0);
1114 0 0       0 $iGetCnt = ($iBdbCnt < $i1stCnt)? $iBdbCnt: $i1stCnt;
1115 0         0 $rhInfo->{_FILEH_}->read($sWk, OLE::Storage_Lite::LongIntSize()*$iGetCnt);
1116 0         0 push @aBdList, unpack("V$iGetCnt", $sWk);
1117 0         0 $iBdbCnt -= $iGetCnt;
1118             #2. Extra BDList
1119 0         0 my $iBlock = $rhInfo->{_EXTRA_BBD_START};
1120 0   0     0 while(($iBdbCnt> 0) && $iBlock < OLE::Storage_Lite::NormalBlockEnd()){
1121 0         0 $rhInfo->{_FILEH_}->seek(($iBlock+1)*$iBigBlkSize, 0);
1122 0 0       0 $iGetCnt= ($iBdbCnt < $iBdlCnt)? $iBdbCnt: $iBdlCnt;
1123 0         0 $rhInfo->{_FILEH_}->read($sWk, OLE::Storage_Lite::LongIntSize()*$iGetCnt);
1124 0         0 push @aBdList, unpack("V$iGetCnt", $sWk);
1125 0         0 $iBdbCnt -= $iGetCnt;
1126 0         0 $rhInfo->{_FILEH_}->read($sWk, OLE::Storage_Lite::LongIntSize());
1127 0         0 $iBlock = unpack("V", $sWk);
1128             }
1129             #3.Get BDs
1130 0         0 my @aWk;
1131             my %hBd;
1132 0         0 my $iBlkNo = 0;
1133 0         0 my $iBdL;
1134             my $i;
1135 0         0 my $iBdCnt = int($iBigBlkSize / OLE::Storage_Lite::LongIntSize());
1136 0         0 foreach $iBdL (@aBdList) {
1137 0         0 $rhInfo->{_FILEH_}->seek(($iBdL+1)*$iBigBlkSize, 0);
1138 0         0 $rhInfo->{_FILEH_}->read($sWk, $iBigBlkSize);
1139 0         0 @aWk = unpack("V$iBdCnt", $sWk);
1140 0         0 for($i=0;$i<$iBdCnt;$i++, $iBlkNo++) {
1141 0 0       0 if($aWk[$i] != ($iBlkNo+1)){
1142 0         0 $hBd{$iBlkNo} = $aWk[$i];
1143             }
1144             }
1145             }
1146 0         0 return \%hBd;
1147             }
1148             #------------------------------------------------------------------------------
1149             # getNthPps (OLE::Storage_Lite)
1150             #------------------------------------------------------------------------------
1151             sub _getNthPps($$$){
1152 0     0   0 my($iPos, $rhInfo, $bData) = @_;
1153 0         0 my($iPpsBlock, $iPpsPos);
1154 0         0 my $sWk;
1155 0         0 my $iBlock;
1156              
1157 0         0 my $iBaseCnt = $rhInfo->{_BIG_BLOCK_SIZE} / OLE::Storage_Lite::PpsSize();
1158 0         0 $iPpsBlock = int($iPos / $iBaseCnt);
1159 0         0 $iPpsPos = $iPos % $iBaseCnt;
1160              
1161             $iBlock = $rhInfo->{_BBD_ROOT_START}->[$iPpsBlock] //
1162 0   0     0 _getNthBlockNo($rhInfo->{_ROOT_START}, $iPpsBlock, $rhInfo);
1163 0 0       0 return undef unless(defined($iBlock));
1164              
1165             $rhInfo->{_FILEH_}->seek(($iBlock+1)*$rhInfo->{_BIG_BLOCK_SIZE}+
1166 0         0 (OLE::Storage_Lite::PpsSize()*$iPpsPos), 0);
1167 0         0 $rhInfo->{_FILEH_}->read($sWk, OLE::Storage_Lite::PpsSize());
1168 0 0       0 return undef unless($sWk);
1169 0         0 my ($iNmSize, $iType, undef, $lPpsPrev, $lPpsNext, $lDirPps) =
1170             unpack("vCCVVV", substr($sWk, 0x40, 2+2+3*OLE::Storage_Lite::LongIntSize()));
1171 0 0       0 $iNmSize = ($iNmSize > 2)? $iNmSize - 2 : $iNmSize;
1172 0         0 my $sNm= substr($sWk, 0, $iNmSize);
1173 0 0 0     0 my @raTime1st =
    0 0        
1174             (($iType == OLE::Storage_Lite::PpsType_Root()) or ($iType == OLE::Storage_Lite::PpsType_Dir()))?
1175             OLEDate2Local(substr($sWk, 0x64, 8)) : undef ,
1176             my @raTime2nd =
1177             (($iType == OLE::Storage_Lite::PpsType_Root()) or ($iType == OLE::Storage_Lite::PpsType_Dir()))?
1178             OLEDate2Local(substr($sWk, 0x6C, 8)) : undef,
1179             my($iStart, $iSize) = unpack("VV", substr($sWk, 0x74, 8));
1180 0 0       0 if($bData) {
1181 0         0 my $sData = _getData($iType, $iStart, $iSize, $rhInfo);
1182 0         0 return OLE::Storage_Lite::PPS->new(
1183             $iPos, $sNm, $iType, $lPpsPrev, $lPpsNext, $lDirPps,
1184             \@raTime1st, \@raTime2nd, $iStart, $iSize, $sData, undef);
1185             }
1186             else {
1187 0         0 return OLE::Storage_Lite::PPS->new(
1188             $iPos, $sNm, $iType, $lPpsPrev, $lPpsNext, $lDirPps,
1189             \@raTime1st, \@raTime2nd, $iStart, $iSize, undef, undef);
1190             }
1191             }
1192             #------------------------------------------------------------------------------
1193             # _getNthBlockNo (OLE::Storage_Lite)
1194             #------------------------------------------------------------------------------
1195             sub _getNthBlockNo($$$){
1196 0     0   0 my($iBlockNo, $iNth, $rhInfo) = @_;
1197 0         0 my $rhBbdInfo = $rhInfo->{_BBD_INFO};
1198 0         0 for(1..$iNth) {
1199 0   0     0 $iBlockNo = $rhBbdInfo->{$iBlockNo} // $iBlockNo+1;
1200 0 0       0 return undef unless $iBlockNo < OLE::Storage_Lite::NormalBlockEnd();
1201             }
1202 0         0 return $iBlockNo;
1203             }
1204             #------------------------------------------------------------------------------
1205             # _getData (OLE::Storage_Lite)
1206             #------------------------------------------------------------------------------
1207             sub _getData($$$$)
1208             {
1209 0     0   0 my($iType, $iBlock, $iSize, $rhInfo) = @_;
1210 0 0       0 if ($iType == OLE::Storage_Lite::PpsType_File()) {
    0          
    0          
1211 0 0       0 if($iSize < OLE::Storage_Lite::DataSizeSmall()) {
1212 0         0 return _getSmallData($iBlock, $iSize, $rhInfo);
1213             }
1214             else {
1215 0         0 return _getBigData($iBlock, $iSize, $rhInfo);
1216             }
1217             }
1218             elsif($iType == OLE::Storage_Lite::PpsType_Root()) { #Root
1219 0         0 return _getBigData($iBlock, $iSize, $rhInfo);
1220             }
1221             elsif($iType == OLE::Storage_Lite::PpsType_Dir()) { # Directory
1222 0         0 return undef;
1223             }
1224             }
1225             #------------------------------------------------------------------------------
1226             # _getBigData (OLE::Storage_Lite)
1227             #------------------------------------------------------------------------------
1228             sub _getBigData($$$)
1229             {
1230 0     0   0 my($iBlock, $iSize, $rhInfo) = @_;
1231 0         0 my($iRest, $sWk, $sRes);
1232              
1233 0 0       0 return '' unless($iBlock < OLE::Storage_Lite::NormalBlockEnd());
1234 0         0 $iRest = $iSize;
1235 0         0 my($i, $iGetSize, $iNext);
1236 0         0 $sRes = '';
1237 0         0 my $aKeys= $rhInfo->{_BBD_INFO_SORTED};
1238              
1239 0         0 while ($iRest > 0) {
1240             # lower_bound binary search
1241 0         0 my $iCount = @$aKeys;
1242 0         0 my $iFirst = 0;
1243 0         0 while ($iCount > 0) {
1244 0         0 my $iStep = $iCount >> 1;
1245 0         0 my $iIndex = $iFirst + $iStep;
1246 0 0       0 if ($$aKeys[$iIndex] < $iBlock) {
1247 0         0 $iFirst = ++$iIndex;
1248 0         0 $iCount -= $iStep + 1;
1249             } else {
1250 0         0 $iCount = $iStep;
1251             }
1252             }
1253 0         0 my $iNKey = $$aKeys[$iFirst];
1254 0         0 $i = $iNKey - $iBlock;
1255 0 0       0 croak "Invalid block read" if ($i < 0);
1256 0         0 $iNext = $rhInfo->{_BBD_INFO}{$iNKey};
1257 0         0 $rhInfo->{_FILEH_}->seek(($iBlock+1)*$rhInfo->{_BIG_BLOCK_SIZE}, 0);
1258 0         0 my $iGetSize = ($rhInfo->{_BIG_BLOCK_SIZE} * ($i+1));
1259 0 0       0 $iGetSize = $iRest if($iRest < $iGetSize);
1260 0         0 $rhInfo->{_FILEH_}->read( $sWk, $iGetSize);
1261 0         0 $sRes .= $sWk;
1262 0         0 $iRest -= $iGetSize;
1263 0         0 $iBlock= $iNext;
1264             }
1265 0         0 return $sRes;
1266             }
1267             #------------------------------------------------------------------------------
1268             # _getSmallData (OLE::Storage_Lite)
1269             #------------------------------------------------------------------------------
1270             sub _getSmallData($$$)
1271             {
1272 0     0   0 my($iSmBlock, $iSize, $rhInfo) = @_;
1273 0         0 my($sRes, $sWk);
1274             my($iBigBlkSize, $iSmallBlkSize, $rhFd) =
1275 0         0 @$rhInfo{qw(_BIG_BLOCK_SIZE _SMALL_BLOCK_SIZE _FILEH_)};
1276              
1277 0         0 $sRes = '';
1278 0         0 while ($iSize > 0) {
1279 0         0 my $iBaseCnt = $iBigBlkSize / $iSmallBlkSize;
1280 0         0 my $iNth = int($iSmBlock/$iBaseCnt);
1281 0         0 my $iPos = $iSmBlock % $iBaseCnt;
1282             my $iBlk = $rhInfo->{_BBD_SB_START}->[$iNth] //
1283 0   0     0 ((_getNthBlockNo($rhInfo->{_SB_START}, $iNth, $rhInfo)+1)*$iBigBlkSize);
1284              
1285 0         0 $rhFd->seek($iBlk+($iPos*$iSmallBlkSize), 0);
1286 0 0       0 if ($iSize > $iSmallBlkSize) {
1287 0         0 $rhFd->read($sWk, $iSmallBlkSize);
1288 0         0 $sRes .= $sWk;
1289 0         0 $iSize -= $iSmallBlkSize;
1290             } else {
1291 0         0 $rhFd->read($sWk, $iSize);
1292 0         0 $sRes .= $sWk;
1293 0         0 last;
1294             }
1295             # get next small block
1296 0         0 $iBaseCnt = $iBigBlkSize / OLE::Storage_Lite::LongIntSize();
1297 0         0 $iNth = int($iSmBlock/$iBaseCnt);
1298 0         0 $iPos = $iSmBlock % $iBaseCnt;
1299             $iBlk = $rhInfo->{_BBD_SBD_START}->[$iNth] //
1300 0   0     0 ((_getNthBlockNo($rhInfo->{_SBD_START}, $iNth, $rhInfo)+1)*$iBigBlkSize);
1301 0         0 $rhFd->seek($iBlk+($iPos*OLE::Storage_Lite::LongIntSize()), 0);
1302 0         0 $rhFd->read($sWk, OLE::Storage_Lite::LongIntSize());
1303 0         0 $iSmBlock = unpack("V", $sWk);
1304             }
1305 0         0 return $sRes;
1306             }
1307             #------------------------------------------------------------------------------
1308             # Asc2Ucs: OLE::Storage_Lite
1309             #------------------------------------------------------------------------------
1310             sub Asc2Ucs($)
1311             {
1312 0     0 1 0 return join("\x00", split //, $_[0]) . "\x00";
1313             }
1314             #------------------------------------------------------------------------------
1315             # Ucs2Asc: OLE::Storage_Lite
1316             #------------------------------------------------------------------------------
1317             sub Ucs2Asc($)
1318             {
1319 0     0 1 0 return pack('c*', unpack('v*', $_[0]));
1320             }
1321              
1322             #------------------------------------------------------------------------------
1323             # OLEDate2Local()
1324             #
1325             # Convert from a Window FILETIME structure to a localtime array. FILETIME is
1326             # a 64-bit value representing the number of 100-nanosecond intervals since
1327             # January 1 1601.
1328             #
1329             # We first convert the FILETIME to seconds and then subtract the difference
1330             # between the 1601 epoch and the 1970 Unix epoch.
1331             #
1332             sub OLEDate2Local {
1333              
1334 99     99 0 52562 my $oletime = shift;
1335              
1336             # Unpack the FILETIME into high and low longs.
1337 99         323 my ( $lo, $hi ) = unpack 'V2', $oletime;
1338              
1339             # Convert the longs to a double.
1340 99         203 my $nanoseconds = $hi * 2**32 + $lo;
1341              
1342             # Convert the 100 nanosecond units into seconds.
1343 99         171 my $time = $nanoseconds / 1e7;
1344              
1345             # Subtract the number of seconds between the 1601 and 1970 epochs.
1346 99         149 $time -= 11644473600;
1347              
1348             # Convert to a localtime (actually gmtime) structure.
1349 99         400 my @localtime = gmtime($time);
1350              
1351 99         287 return @localtime;
1352             }
1353              
1354             #------------------------------------------------------------------------------
1355             # LocalDate2OLE()
1356             #
1357             # Convert from a localtime array to a Window FILETIME structure. FILETIME is
1358             # a 64-bit value representing the number of 100-nanosecond intervals since
1359             # January 1 1601.
1360             #
1361             # We first convert the localtime (actually gmtime) to seconds and then add the
1362             # difference between the 1601 epoch and the 1970 Unix epoch. We convert that to
1363             # 100 nanosecond units, divide it into high and low longs and return it as a
1364             # packed 64bit structure.
1365             #
1366             sub LocalDate2OLE {
1367              
1368 99     99 0 53488 my $localtime = shift;
1369              
1370 99 50       252 return "\x00" x 8 unless $localtime;
1371              
1372             # Convert from localtime (actually gmtime) to seconds.
1373 99         135 my @localtimecopy = @{$localtime};
  99         300  
1374 99 100       328 $localtimecopy[5] += 1900 unless $localtimecopy[5] > 99;
1375 99         285 my $time = timegm( @localtimecopy );
1376              
1377             # Add the number of seconds between the 1601 and 1970 epochs.
1378 99         3290 $time += 11644473600;
1379              
1380             # The FILETIME seconds are in units of 100 nanoseconds.
1381 99         165 my $nanoseconds = $time * 1E7;
1382              
1383 2     2   1049 use POSIX 'fmod';
  2         15749  
  2         10  
1384              
1385             # Pack the total nanoseconds into 64 bits...
1386 99         167 my $hi = int( $nanoseconds / 2**32 );
1387 99         294 my $lo = fmod($nanoseconds, 2**32);
1388              
1389 99         256 my $oletime = pack "VV", $lo, $hi;
1390              
1391 99         258 return $oletime;
1392             }
1393              
1394             1;
1395             __END__