#
# $Id: Var.pm,v 1.1.1.1 1998/02/25 21:13:00 schwartz Exp $
#
# OLE::Storage::Var
#
# Property variable handling.
#
# Copyright (C) 1996, 1997, 1998 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
#
# Contact: schwartz@cs.tu-berlin.de
#

package OLE::Storage::Var;
use strict;
my $VERSION=do{my@R=('$Revision: 1.1.1.1 $'=~/\d+/g);sprintf"%d."."%d"x$#R,@R};

use OLE::Storage::Std;
use OLE::Storage::Handler();
use OLE::Storage::Property();
use Unicode::Map();

my $uncool_debug = 0;

##
## --- Public --------------------------------------------------------------
##

sub new {
#
# $Var = new Var;
#
   bless ({}, ref($_[0]) || $_[0])
      -> _init_handling()
   ;
}

sub cs_from  { my $S=shift; $S->{CS_FROM}=shift if @_; $S->{CS_FROM} }
sub map      { my $S=shift; $S->{MAP}=shift if @_; $S->{MAP} }
sub handler  { my $S=shift; $S->{H}=shift if @_; $S->{H} }
sub property { OLE::Storage::Property->new(@_) }


##
## --- Private -------------------------------------------------------------
##

sub error { 
   my ($Var, $str) = @_;
   OLE::Storage::Property->new($Var, \$str, 0, "myerror") 
}


#
# --- Interface to OLE::Storage::Property ------------------------------------
#

sub _IS_SCALAR { !(($_[1] || 0) &  0x1000) }
sub _IS_ARRAY  {   ($_[1] || 0) &  0x1000  }
sub _IS_VARRAY {   ($_[1] || 0) == 0x100c  }
sub _TO_SCALAR {   ($_[1] || 0) &  0xfff   }
sub _TO_ARRAY  {   ($_[1] || 0) |  0x1000  }
sub _TO_VARRAY {                   0x100c  }

sub _STORE {
   my ($S, $bufR, $oR, $from) = @_;
   $S->handler()->convert($from, "store", $bufR, $oR)
   || $uncool_debug && 
      (printf "Error: o=%x, type=%x, buf=".("%08x "x5)."...\n", 
         $$oR, $from, get_nlong(5, $bufR, $$oR)
      )
   || "";
}

sub _RETRIEVE {
   my ($S, $from_ext, $to, $bufR) = @_;
   if (ref($bufR)) {
      $S->handler()->convert([$from_ext, $bufR->[0]], $to, $bufR->[1]);
   }
}

sub _TYPESTR {
   shift->handler()->typestr(shift());
}

#
# --- Init -----------------------------------------------------------------
#

sub _init_handling {
#
# This installs all the methods used to convert properties of type1 to
# variables or properties of type2 (type1 is allowed to equal type2).
# This module stores all variables together with an extra type information, 
# that is strictly private and must not be interesting to other modules.
# The idea is to store variables internally in some few standard 
# representations, like strings, integers or floats.
#
# You see immediately, that this concept is quite slow: as any e.g. integer
# $number will be stored as a data structure: ["int", $number] or any string
# $text would be stored as: ["string", \$text]. (s.b.)
#
   my $S = shift;
   my $H = $S->handler(OLE::Storage::Handler->new);

   $S->map(
      new Unicode::Map ({ 
         ID => ( $ENV{LC_CTYPE} || "CP1252" ) 
      })
   );
   return 0 if !$S->map;

   $H->add (0x00, "empty",	"store",  \&_0x00_store);
   $H->add (0x01, "null",	"store",  \&_0x01_store);
   $H->add (0x02, "i2",		"store",  \&_0x02_store);
   $H->add (0x03, "i4",		"store",  \&_0x03_store);
   $H->add (0x04, "r4",		"store",  \&_0x04_store);
   $H->add (0x05, "r8",		"store",  \&_0x05_store);
   $H->add (0x06, "cy",		"store",  \&_0x06_store);
   $H->add (0x07, "date",	"store",  \&_0x05_store); 
   $H->add (0x08, "bstr");
   $H->add (0x0a, "error",	"store",  \&_0x0a_store);
   $H->add (0x0b, "bool",	"store",  \&_0x0b_store);
   $H->add (0x0c, "variant");   # does exist only as array!
   $H->add (0x11, "ui1",	"store",  \&_0x11_store);
   $H->add (0x12, "ui2",	"store",  \&_0x12_store);
   $H->add (0x13, "ui4",	"store",  \&_0x13_store);
   $H->add (0x14, "i8");
   $H->add (0x15, "ui8");
   $H->add (0x1e, "lpstr",	"store",  \&_0x1e_store);
   $H->add (0x1f, "lpwstr",	"store",  \&_0x1f_store);
   $H->add (0x40, "filetime",	"store",  \&_0x40_store);
   $H->add (0x41, "blob",       "store",  \&_0x41_store);
   $H->add (0x42, "stream");
   $H->add (0x43, "storage");
   $H->add (0x44, "streamed_object");
   $H->add (0x45, "stored_object");
   $H->add (0x46, "blobobject");
   $H->add (0x47, "cf");
   $H->add (0x48, "clsid",	"store",  \&_0x48_store);

   #
   # Normal procedure to store will be to create some variable like a string
   # or a buffer and to pass a reference of this to the following handling 
   # functions. These would take the reference, pass it further and store it 
   # finally. But sometimes it should be clever to pass not references, as e.g. 
   # for integers. The internal types listed below are followed by a dot for 
   # pure data and by an "R" for reference data. (provisorically...)
   #
   $S->_init_bool();	# .
   $S->_init_buf();	# R
   $S->_init_date();	# R
   $S->_init_int();	# .
   $S->_init_string();	# R
   $S->_init_float();	# .
   $S->_init_guid();	# R
   $S->_init_wstring();	# R
   $S->_init_myerror();	# R

   $H->add ("zstr", "zstr",     "store",  \&_zstr_store);
   $H->add ("zwstr", "zwstr",   "store",  \&_zwstr_store);
   
   $S;
}

#
# --- Store ----------------------------------------------------------------
#

sub _0x00_store {	# 0x00 == empty
   ["string", \""]
}
sub _0x01_store {	# 0x01 == null
   ["int", 0]
}
sub _0x02_store {	# 0x02 == i2
   my $int = &get_word;
   $int = - (($int^0xffff) +1) if ($int & 0x8000);
   ["int", $int];
}
sub _0x03_store {	# 0x03 == i4
   my $int = &get_long;
   $int = - (($int^0xffffffff) +1) if ($int & 0x80000000);
   ["int", $int];
}
sub _0x04_store {	# 0x04 == r4
   ["float", &get_real]
}
sub _0x05_store {	# 0x05 == r8
   ["float", &get_double]
}
sub _0x06_store {	# 0x06 == cy
   [0x06, ""];
}
sub _0x0a_store {	# 0x0a == error
   ["int", &get_long];
}
sub _0x0b_store {	# 0x0b == bool
   ["bool", &get_long];
}
sub _0x11_store {	# 0x11 == ui1
   ["int", &get_byte];
}
sub _0x12_store {	# 0x12 == ui2
   ["int", &get_word];
}
sub _0x13_store {	# 0x13 == ui4
   ["int", &get_long];
}
sub _0x1e_store {	# 0x1e == lpstr
   my ($bufR, $oR) = @_;
   ["string", \get_zstr($bufR, $oR, &get_long)];
}
sub _0x1f_store {	# 0x1f == lpwstr
   my ($bufR, $oR) = @_;
   ["wstring", \get_rzwstr($bufR, $oR, &get_long)];
}
sub _0x40_store {
   ["date", &_filetime_to_date];
}
sub _0x41_store {
   my ($bufR, $oR) = @_;
   ["buf", \get_str($bufR, $oR, &get_long)];
}
sub _0x48_store {
   ["guid", [get_struct("LWWBBBBBBBB", @_)] ];
}

sub _zstr_store {
   my ($bufR, $oR) = @_;
   ["string", \get_zstr($bufR, $oR, length($$bufR))];
}
sub _zwstr_store {
   my ($bufR, $oR) = @_;
   ["wstring", \get_rzwstr($bufR, $oR, length($$bufR))];
}

#
# --- bool -----------------------------------------------------------------
#

sub _init_bool {
   my $H = shift()->handler();
   $H->add (["bool", "bool", 
      "store",   \&_bool_store,   "",			# Y
      "bool",    \&_bool_bool,    "",			# Y
      "buf",     \&_bool_buf,     "",			# .
      "date",    \&_bool_date,    "",			# .
      "int",     \&_bool_int,     "",			# Y
      "float",   \&_bool_float,   "",			# Y
      "guid",    \&_bool_guid,    "",			# .
      "string",  \&_bool_string,  ["Yes", "No"],	# Y
      "wstring", \&_bool_wstring, [nwstr("Yes", "No")],	# Y
   ]);
}
sub _bool_store   { ["bool", shift()] }
sub _bool_bool    { shift() }
sub _bool_buf     { undef }
sub _bool_date    { undef }
sub _bool_int     { shift() ? -1 : 0 }
sub _bool_float   { shift() ? -1.0 : 0.0 }
sub _bool_guid    { undef }
sub _bool_string  { my ($val, $x, $par) = @_; $val ? $par->[0] : $par->[1] }
sub _bool_wstring { my ($val, $x, $par) = @_; $val ? $par->[0] : $par->[1] }

#
# --- buf ------------------------------------------------------------------
#

sub _init_buf {
   my $H = shift->handler();
   $H->add (["buf", "buf", 
      "store",   \&buf_store,    "",	# Y
      "bool",    \&_buf_bool,    "",	# .
      "buf",     \&_buf_buf,     "",	# Y
      "date",    \&_buf_date,    "",	# .
      "int",     \&_buf_int,     "",	# .
      "float",   \&_buf_float,   "",	# .
      "guid",    \&_buf_guid,    "",	# .
      "string",  \&_buf_string,  "",	# .
      "wstring", \&_buf_wstring, "",	# .
   ]);
}
sub _buf_store   { ["buf", shift()] }
sub _buf_bool    { undef }
sub _buf_buf     { my $valR = shift; $$valR }
sub _buf_date    { undef }
sub _buf_int     { undef }
sub _buf_float   { undef }
sub _buf_guid    { undef }
sub _buf_string  { undef }
sub _buf_wstring { undef }

#
# --- date -----------------------------------------------------------------
#

sub _init_date {
   my $H = shift->handler();
   $H->add (["date", "date", 
      "store",  \&_date_store, "",	# Y
      "bool",   \&_date_bool,  "",	# .
      "buf",    \&_date_buf,   "",	# .
      "date",   \&_date_date,  "",	# Y
      "int",    \&_date_int,   "",	# Y
      "float",  \&_date_float, "",	# Y
      "guid",   \&_date_guid,  "",	# .
      "string", \&_date_string, 	# Y
         ["%02d.%02d.%04d, %02d:%02d:%02d", "%02d:%02d:%02d", "<undef>"],
      "wstring",   \&_date_wstring, 	# Y
         ["%02d.%02d.%04d, %02d:%02d:%02d", "%02d:%02d:%02d", "<undef>"],
   ]);
}
sub _date_store  { ["date", shift()] }
sub _date_bool   { undef }
sub _date_buf    { undef }
sub _date_date   { my $valR = shift; @$valR }
sub _date_int    { int(_date_float(@_)) }
sub _date_float  { 
   my $valR = shift;
   my ($d, $h) = _date_to_filetime(@$valR);
   $d*2**6+$h/2**26;
}
sub _date_guid   { undef }
sub _date_string {
#
# $datestr = _date_string(
#    \$buf, \$o, 
#    [] || [$da, $mo, $ye, $ho, $mi, $se],
#    [$date_and_time_mask, $time_mask, $undefined_mask]
# );
#
   my ($valR, $oR, $par) = @_;
   return $par->[2] if !@$valR;
   my ($da, $mo, $ye, $ho, $mi, $se) = @$valR;
   if ($ye) {
      sprintf ($par->[0], $da, $mo, $ye, $ho, $mi, $se);
   } else {
      sprintf ($par->[1], $ho, $mi, $se);
   }
}
sub _date_wstring { _string_wstring (\_date_string(@_), 0, "%s") }

#
# --- int ------------------------------------------------------------------
#

sub _init_int {
   my $H = shift->handler();
   $H->add (["int", "int", 
      "store",   \&_int_store,   "",
      "bool",    \&_int_bool,    "",	# Y
      "buf",     \&_int_buf,     "",	# .
      "date",    \&_int_date,    "",	# Y
      "int",     \&_int_int,     "",	# Y
      "float",   \&_int_float,   "",	# Y
      "guid",    \&_int_guid,    "",	# .
      "string",  \&_int_string,  "%d",	# Y
      "wstring", \&_int_wstring, "%d", 	# Y
   ]);
}
sub _int_store   { ["int", shift()] }
sub _int_bool    { shift() ? 1 : 0 }
sub _int_buf     { undef }
sub _int_date    { _float_date(@_) }
sub _int_int     { shift() }
sub _int_float   { shift() + 0.0 }
sub _int_guid    { undef }
sub _int_string  { my ($val, $x, $par) = @_; sprintf $par, $val }
sub _int_wstring { _string_wstring (\_int_string(@_), 0, "%s") }

#
# --- float ----------------------------------------------------------------
#

sub _init_float {
   my $H = shift->handler();
   $H->add (["float", "float", 
      "store",   \&_float_store,   "",
      "bool",    \&_float_bool,    "",		# Y
      "buf",     \&_float_buf,     "",		# .
      "date",    \&_float_date,    "",		# Y
      "int",     \&_float_int,     "",		# Y
      "float",   \&_float_float,   "",		# Y
      "guid",    \&_float_guid,    "",		# .
      "string",  \&_float_string,  "%.2f",	# Y
      "wstring", \&_float_wstring, "%.2f", 	# Y
   ]);
}
sub _float_store  { ["float", shift()] }
sub _float_bool   { shift() ? 1 : 0 }
sub _float_buf    { undef }
sub _float_date   { 
   my $val = shift;
   _filetime_to_date(\nlong([$val*2**26, $val/2**6]));
}
sub _float_int     { int(shift()) }
sub _float_float   { shift() }
sub _float_guid    { undef }
sub _float_string  { my ($val, $oR, $par) = @_; sprintf $par, $val }
sub _float_wstring { _string_wstring (\_float_string(@_), 0, "%s") }

#
# --- guid -----------------------------------------------------------------
#

sub _init_guid {
   my $H = shift->handler();
   $H->add (["guid", "guid",
      "store",   \&_guid_store,   "",				# Y
      "bool",    \&_guid_bool,    "",				# .
      "buf",     \&_guid_buf,     "",				# .
      "date",    \&_guid_date,    "",				# .
      "int",     \&_guid_int,     "",				# .
      "float",   \&_guid_float,   "",				# .
      "guid",    \&_guid_guid,    "",				# Y
      "string",  \&_guid_string,  "%08X-%04X-%04X-%02X%02X-".("%02X"x6), # Y
      "wstring", \&_guid_wstring, "%08X-%04X-%04X-%02X%02X-".("%02X"x6), # Y
   ]);
}
sub _guid_store   { ["guid", shift()] }
sub _guid_bool    { undef }
sub _guid_buf     { undef }
sub _guid_date    { undef }
sub _guid_int     { undef }
sub _guid_float   { undef }
sub _guid_guid    { my $valR = shift; $$valR }
sub _guid_string  { my ($valR, $x, $par) = @_; sprintf $par, @$valR }
sub _guid_wstring { _string_wstring (\_guid_string(@_), 0, "%s") }

#
# CLSIDs:
#
#    00020810-0000-0000-C000-000000000046 	Excel.Sheet.5
#    00020900-0000-0000-C000-000000000046	Word.Document.6
#    00020901-0000-0000-C000-000000000046	Word.Picture.6
#    00020906-0000-0000-C000-000000000046	Word.Document.8
#    00021A11-0000-0000-C000-000000000046       Visio
#


#
# --- string ---------------------------------------------------------------
#

sub _init_string {
   my $S = shift;
   my $H = $S->handler();
   $H->add (["string", "string", 
      "store",   \&_string_store,   "",
      "bool",    \&_string_bool,    "",		# .
      "buf",     \&_string_buf,     "",		# .
      "date",    \&_string_date,    "",		# .
      "int",     \&_string_int,     "",		# .
      "float",   \&_string_float,   "",		# .
      "guid",    \&_string_guid,    "",		# .
      "string",  \&_string_string,  "",		# Y
      "wstring", \&_string_wstring, $S->map	# Y
   ]);
}
sub _string_store   { ["string", shift()] }
sub _string_bool    { undef }
sub _string_buf     { undef }
sub _string_date    { undef }
sub _string_int     { undef }
sub _string_float   { undef }
sub _string_guid    { undef }
sub _string_string  { ${$_[0]} }
sub _string_wstring { $_[2]->to_unicode($_[0]) }

#
# --- wstring -----------------------------------------------------------------
#

sub _init_wstring {
   my $S = shift;
   my $H = $S->handler();
   $H->add (["wstring", "wstring",
      "store",   \&_wstring_store,   "",	# Y
      "bool",    \&_wstring_bool,    "",	# .
      "buf",     \&_wstring_buf,     "",	# .
      "date",    \&_wstring_date,    "",	# .
      "int",     \&_wstring_int,     "",	# .
      "float",   \&_wstring_float,   "",	# .
      "guid",    \&_wstring_guid,    "",	# .
      "wstring", \&_wstring_wstring, "",	# Y
      "string",  \&_wstring_string,  $S->map	# Y
   ]);
}
sub _wstring_store  { ["wstring", shift()] }
sub _wstring_bool   { undef }
sub _wstring_buf    { undef }
sub _wstring_date   { undef }
sub _wstring_int    { undef }
sub _wstring_float  { undef }
sub _wstring_guid   { undef }
sub _wstring_string { $_[2]->from_unicode($_[0]) }
sub _wstring_wstring { ${$_[0]} }

#
# --- myerror --------------------------------------------------------------
#
# I'm thinking about not installing an error handling for properties.
# Anyway, meanwhile...
#

sub _init_myerror {
   my $H = shift->handler();
   $H->add (["myerror", "myerror", 
      "store",   \&_myerror_store,   "",
      "bool",    \&_myerror_bool,    "",
      "buf",     \&_myerror_buf,     "",
      "date",    \&_myerror_date,    "",
      "int",     \&_myerror_int,     "",
      "float",   \&_myerror_float,   "",
      "guid",    \&_myerror_guid,    "",
      "string",  \&_myerror_string,  "",
      "wstring", \&_myerror_wstring, "",
      "myerror", \&_myerror_myerror, "%s", 
   ]);
}
sub _myerror_store   { ["myerror", shift()] }
sub _myerror_bool    { undef }
sub _myerror_buf     { undef }
sub _myerror_date    { undef }
sub _myerror_int     { undef }
sub _myerror_float   { undef }
sub _myerror_guid    { undef }
sub _myerror_string  { "" }
sub _myerror_wstring { "" }
sub _myerror_myerror { &_string_string }

#
# -- FILETIME --------------------------------------------------------------
#

# filetime 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.

my @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]
);
my $a_minute = 60 * 10000000.0 / (0x10000000 * 16);

sub _filetime_to_date {
   my ($ds, $dd) = get_nlong(2, @_);
   return [] if (!$ds) && (!$dd);

   my ($day, $month, $year, $hour, $min, $sec);
   my ($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;
   my $switch = _is_schaltjahr($year);

   $d -= _years_to_days ($year, 1601);
   for( $i=11; $i && ($d <= _days($switch, $i+1)); $i--) {}
   $month = $i+1; 
   $day   = $d - _days($switch, $i+1);

   $hour  = int ( $m / ($a_minute*60) ); 
   $min   = int ( $m/$a_minute - $hour*60 );
   $sec   =     ( ($m/$a_minute - $hour*60 - $min) * 60);

   $year -= 1601 if $year == 1601;
   [$day, $month, $year, $hour, $min, $sec];
}

sub _date_to_filetime {
   my ($day, $month, $year, $hour, $min, $sec) = @_;
   my ($d, $tss, $tsd);
   my $switch = _is_schaltjahr($year);

   $d = _years_to_days($year, 1601) + _days($switch, $month) + $day-1; 
   $tsd = (24*60*$d + 60*$hour +$min +$sec/60.0) * $a_minute;
   $tss = ($tsd-int($tsd)) * 0x10000000 * 16;

   ( int($tsd), int($tss) );
}

sub _is_schaltjahr {
   my $year = shift;
   !($year%4) && ($year%100 || !($year%400) ) && 1 || 0;
}

sub _years_to_days {
   my ($year, $baseyear) = @_;
   int($year-$baseyear) * 365 
     + int( ($year-$baseyear) / 4 )
     - int( ($year-$baseyear) / 100 )
     + int( ($year-$baseyear) / 400 )
   ;
}

sub _days {
   $monsum[shift]->[-1+shift]
}

"Atomkraft? Nein, danke!"

__END__

=head1 NAME

OLE::Storage::Var - Variable handling for properties

$Revision: 1.1.1.1 $ $Date: 1998/02/25 21:13:00 $

=head1 SYNOPSIS

use OLE::Storage::Var;

I<$Var> = new Var;

I<$Property> = I<$Var> -> property (I<\$buf>, I<$o>||I<\$o> [,I<$type>])

I<$Handler> = I<$Var> -> handler ()

=head1 DESCRIPTION

This package is governing the two packages OLE::Storage::Property and
OLE::Storage::Handler. It manages the binary data of properties.
OLE::Storage::Property uses methods of $Var to store and convert properties.
OLE::Storage::Var will probably be changed very much in close future. So
what a luck, that:

Normally the only thing you will have to do with this package is
to create an instance either via package OLE::Storage with
"$Var = OLE::Storage->NewVar", or with same method of package
OLE::PropertySet. This $Var you need to pass to OLE::Storage->open 
calls.

I<Note>: If you should to have to create new properties by your own,
do it always via this $Var interface. 

=head1 SEE ALSO

L<OLE::Storage::Property>, L<OLE::Storage::Handler>, demonstration program "lls"

=head1 AUTHOR

Martin Schwartz E<lt>F<schwartz@cs.tu-berlin.de>E<gt>. 

=cut