mcu/tools/perl/Spreadsheet/WriteExcel/Format.pm

package Spreadsheet::WriteExcel::Format;

###############################################################################
#
# Format - A class for defining Excel formatting.
#
#
# Used in conjunction with Spreadsheet::WriteExcel
#
# Copyright 2000-2010, John McNamara, jmcnamara@cpan.org
#
# Documentation after __END__
#

use Exporter;
use strict;
use Carp;






use vars qw($AUTOLOAD $VERSION @ISA);
@ISA = qw(Exporter);

$VERSION = '2.37';

###############################################################################
#
# new()
#
# Constructor
#
sub new {

    my $class  = shift;

    my $self   = {
                    _xf_index       => shift || 0,

                    _type           => 0,
                    _font_index     => 0,
                    _font           => 'Arial',
                    _size           => 10,
                    _bold           => 0x0190,
                    _italic         => 0,
                    _color          => 0x7FFF,
                    _underline      => 0,
                    _font_strikeout => 0,
                    _font_outline   => 0,
                    _font_shadow    => 0,
                    _font_script    => 0,
                    _font_family    => 0,
                    _font_charset   => 0,
                    _font_encoding  => 0,

                    _num_format     => 0,
                    _num_format_enc => 0,

                    _hidden         => 0,
                    _locked         => 1,

                    _text_h_align   => 0,
                    _text_wrap      => 0,
                    _text_v_align   => 2,
                    _text_justlast  => 0,
                    _rotation       => 0,

                    _fg_color       => 0x40,
                    _bg_color       => 0x41,

                    _pattern        => 0,

                    _bottom         => 0,
                    _top            => 0,
                    _left           => 0,
                    _right          => 0,

                    _bottom_color   => 0x40,
                    _top_color      => 0x40,
                    _left_color     => 0x40,
                    _right_color    => 0x40,

                    _indent         => 0,
                    _shrink         => 0,
                    _merge_range    => 0,
                    _reading_order  => 0,

                    _diag_type      => 0,
                    _diag_color     => 0x40,
                    _diag_border    => 0,

                    _font_only      => 0,

                    # Temp code to prevent merged formats in non-merged cells.
                    _used_merge     => 0,

                 };

    bless  $self, $class;

    # Set properties passed to Workbook::add_format()
    $self->set_format_properties(@_) if @_;

    return $self;
}


###############################################################################
#
# copy($format)
#
# Copy the attributes of another Spreadsheet::WriteExcel::Format object.
#
sub copy {
    my $self  = shift;
    my $other = $_[0];

    return unless defined $other;
    return unless (ref($self) eq ref($other));

    # Store the properties that we don't want overwritten.
    my $xf                  = $self->{_xf_index};
    my $merge_range         = $self->{_merge_range};
    my $used_merge          = $self->{_used_merge};

    %$self                  = %$other; # Copy properties

    # Restore saved properties.
    $self->{_xf_index}      = $xf;
    $self->{_merge_range}   = $merge_range;
    $self->{_used_merge}    = $used_merge;
}


###############################################################################
#
# get_xf($style)
#
# Generate an Excel BIFF XF record.
#
sub get_xf {

    use integer;    # Avoid << shift bug in Perl 5.6.0 on HP-UX

    my $self = shift;

    my $record;     # Record identifier
    my $length;     # Number of bytes to follow

    my $ifnt;       # Index to FONT record
    my $ifmt;       # Index to FORMAT record
    my $style;      # Style and other options
    my $align;      # Alignment
    my $indent;     #
    my $icv;        # fg and bg pattern colors
    my $border1;    # Border line options
    my $border2;    # Border line options
    my $border3;    # Border line options


    # Set the type of the XF record and some of the attributes.
    if ($self->{_type} == 0xFFF5) {
        $style = 0xFFF5;
    }
    else {
        $style   = $self->{_locked};
        $style  |= $self->{_hidden} << 1;
    }


    # Flags to indicate if attributes have been set.
    my $atr_num     = ($self->{_num_format}     != 0);

    my $atr_fnt     = ($self->{_font_index}     != 0);

    my $atr_alc     = ($self->{_text_h_align}   != 0  ||
                       $self->{_text_v_align}   != 2  ||
                       $self->{_shrink}         != 0  ||
                       $self->{_merge_range}    != 0  ||
                       $self->{_text_wrap}      != 0  ||
                       $self->{_indent}         != 0) ? 1 : 0;

    my $atr_bdr     = ($self->{_bottom}         != 0  ||
                       $self->{_top}            != 0  ||
                       $self->{_left}           != 0  ||
                       $self->{_right}          != 0  ||
                       $self->{_diag_type}      != 0) ? 1: 0;

    my $atr_pat     = ($self->{_fg_color}       != 0x40  ||
                       $self->{_bg_color}       != 0x41  ||
                       $self->{_pattern}        != 0x00) ? 1 : 0;

    my $atr_prot    = ($self->{_hidden}         != 0  ||
                       $self->{_locked}         != 1) ? 1 : 0;


    # Set attribute changed flags for the style formats.
    if ($self->{_xf_index} != 0 and $self->{_type} == 0xFFF5) {

        if ($self->{_xf_index} >= 16) {
            $atr_num    = 0;
            $atr_fnt    = 1;
        }
        else {
            $atr_num    = 1;
            $atr_fnt    = 0;
        }

        $atr_alc    = 1;
        $atr_bdr    = 1;
        $atr_pat    = 1;
        $atr_prot   = 1;
    }


    # Set a default diagonal border style if none was specified.
    $self->{_diag_border} = 1 if !$self->{_diag_border} and $self->{_diag_type};


    # Reset the default colours for the non-font properties
    $self->{_fg_color}     = 0x40 if $self->{_fg_color}     == 0x7FFF;
    $self->{_bg_color}     = 0x41 if $self->{_bg_color}     == 0x7FFF;
    $self->{_bottom_color} = 0x40 if $self->{_bottom_color} == 0x7FFF;
    $self->{_top_color}    = 0x40 if $self->{_top_color}    == 0x7FFF;
    $self->{_left_color}   = 0x40 if $self->{_left_color}   == 0x7FFF;
    $self->{_right_color}  = 0x40 if $self->{_right_color}  == 0x7FFF;
    $self->{_diag_color}   = 0x40 if $self->{_diag_color}   == 0x7FFF;


    # Zero the default border colour if the border has not been set.
    $self->{_bottom_color} = 0 if $self->{_bottom}    == 0;
    $self->{_top_color}    = 0 if $self->{_top}       == 0;
    $self->{_right_color}  = 0 if $self->{_right}     == 0;
    $self->{_left_color}   = 0 if $self->{_left}      == 0;
    $self->{_diag_color}   = 0 if $self->{_diag_type} == 0;


    # The following 2 logical statements take care of special cases in relation
    # to cell colours and patterns:
    # 1. For a solid fill (_pattern == 1) Excel reverses the role of foreground
    #    and background colours.
    # 2. If the user specifies a foreground or background colour without a
    #    pattern they probably wanted a solid fill, so we fill in the defaults.
    #
    if ($self->{_pattern}  <= 0x01 and
        $self->{_bg_color} != 0x41 and
        $self->{_fg_color} == 0x40    )
    {
        $self->{_fg_color} = $self->{_bg_color};
        $self->{_bg_color} = 0x40;
        $self->{_pattern}  = 1;
    }

    if ($self->{_pattern}  <= 0x01 and
        $self->{_bg_color} == 0x41 and
        $self->{_fg_color} != 0x40    )
    {
        $self->{_bg_color} = 0x40;
        $self->{_pattern}  = 1;
    }


    # Set default alignment if indent is set.
    $self->{_text_h_align} = 1 if $self->{_indent} and
                                  $self->{_text_h_align} == 0;


    $record         = 0x00E0;
    $length         = 0x0014;

    $ifnt           = $self->{_font_index};
    $ifmt           = $self->{_num_format};


    $align          = $self->{_text_h_align};
    $align         |= $self->{_text_wrap}     << 3;
    $align         |= $self->{_text_v_align}  << 4;
    $align         |= $self->{_text_justlast} << 7;
    $align         |= $self->{_rotation}      << 8;



    $indent         = $self->{_indent};
    $indent        |= $self->{_shrink}        << 4;
    $indent        |= $self->{_merge_range}   << 5;
    $indent        |= $self->{_reading_order} << 6;
    $indent        |= $atr_num                << 10;
    $indent        |= $atr_fnt                << 11;
    $indent        |= $atr_alc                << 12;
    $indent        |= $atr_bdr                << 13;
    $indent        |= $atr_pat                << 14;
    $indent        |= $atr_prot               << 15;


    $border1        = $self->{_left};
    $border1       |= $self->{_right}         << 4;
    $border1       |= $self->{_top}           << 8;
    $border1       |= $self->{_bottom}        << 12;

    $border2        = $self->{_left_color};
    $border2       |= $self->{_right_color}   << 7;
    $border2       |= $self->{_diag_type}     << 14;


    $border3        = $self->{_top_color};
    $border3       |= $self->{_bottom_color}  << 7;
    $border3       |= $self->{_diag_color}    << 14;
    $border3       |= $self->{_diag_border}   << 21;
    $border3       |= $self->{_pattern}       << 26;

    $icv            = $self->{_fg_color};
    $icv           |= $self->{_bg_color}      << 7;



    my $header      = pack("vv",        $record, $length);
    my $data        = pack("vvvvvvvVv", $ifnt, $ifmt, $style,
                                        $align, $indent,
                                        $border1, $border2, $border3,
                                        $icv);

    return($header . $data);
}


###############################################################################
#
# Note to porters. The majority of the set_property() methods are created
# dynamically via Perl' AUTOLOAD sub, see below. You may prefer/have to specify
# them explicitly in other implementation languages.
#


###############################################################################
#
# get_font()
#
# Generate an Excel BIFF FONT record.
#
sub get_font {

    my $self      = shift;

    my $record;     # Record identifier
    my $length;     # Record length

    my $dyHeight;   # Height of font (1/20 of a point)
    my $grbit;      # Font attributes
    my $icv;        # Index to color palette
    my $bls;        # Bold style
    my $sss;        # Superscript/subscript
    my $uls;        # Underline
    my $bFamily;    # Font family
    my $bCharSet;   # Character set
    my $reserved;   # Reserved
    my $cch;        # Length of font name
    my $rgch;       # Font name
    my $encoding;   # Font name character encoding


    $dyHeight   = $self->{_size} * 20;
    $icv        = $self->{_color};
    $bls        = $self->{_bold};
    $sss        = $self->{_font_script};
    $uls        = $self->{_underline};
    $bFamily    = $self->{_font_family};
    $bCharSet   = $self->{_font_charset};
    $rgch       = $self->{_font};
    $encoding   = $self->{_font_encoding};

    # Handle utf8 strings in perl 5.8.
    if ($] >= 5.008) {
        require Encode;

        if (Encode::is_utf8($rgch)) {
            $rgch = Encode::encode("UTF-16BE", $rgch);
            $encoding = 1;
        }
    }

    $cch = length $rgch;

    # Handle Unicode font names.
    if ($encoding == 1) {
        croak "Uneven number of bytes in Unicode font name" if $cch % 2;
        $cch  /= 2 if $encoding;
        $rgch  = pack 'v*', unpack 'n*', $rgch;
    }

    $record     = 0x31;
    $length     = 0x10 + length $rgch;
    $reserved   = 0x00;

    $grbit      = 0x00;
    $grbit     |= 0x02 if $self->{_italic};
    $grbit     |= 0x08 if $self->{_font_strikeout};
    $grbit     |= 0x10 if $self->{_font_outline};
    $grbit     |= 0x20 if $self->{_font_shadow};


    my $header  = pack("vv",          $record, $length);
    my $data    = pack("vvvvvCCCCCC", $dyHeight, $grbit, $icv, $bls,
                                      $sss, $uls, $bFamily,
                                      $bCharSet, $reserved, $cch, $encoding);

    return($header . $data . $rgch);
}

###############################################################################
#
# get_font_key()
#
# Returns a unique hash key for a font. Used by Workbook->_store_all_fonts()
#
sub get_font_key {

    my $self    = shift;

    # The following elements are arranged to increase the probability of
    # generating a unique key. Elements that hold a large range of numbers
    # e.g. _color are placed between two binary elements such as _italic
    #
    my $key = "$self->{_font}$self->{_size}";
    $key   .= "$self->{_font_script}$self->{_underline}";
    $key   .= "$self->{_font_strikeout}$self->{_bold}$self->{_font_outline}";
    $key   .= "$self->{_font_family}$self->{_font_charset}";
    $key   .= "$self->{_font_shadow}$self->{_color}$self->{_italic}";
    $key   .= "$self->{_font_encoding}";
    $key    =~ s/ /_/g; # Convert the key to a single word

    return $key;
}


###############################################################################
#
# get_xf_index()
#
# Returns the used by Worksheet->_XF()
#
sub get_xf_index {
    my $self   = shift;

    return $self->{_xf_index};
}


###############################################################################
#
# _get_color()
#
# Used in conjunction with the set_xxx_color methods to convert a color
# string into a number. Color range is 0..63 but we will restrict it
# to 8..63 to comply with Gnumeric. Colors 0..7 are repeated in 8..15.
#
sub _get_color {

    my %colors = (
                    aqua    => 0x0F,
                    cyan    => 0x0F,
                    black   => 0x08,
                    blue    => 0x0C,
                    brown   => 0x10,
                    magenta => 0x0E,
                    fuchsia => 0x0E,
                    gray    => 0x17,
                    grey    => 0x17,
                    green   => 0x11,
                    lime    => 0x0B,
                    navy    => 0x12,
                    orange  => 0x35,
                    pink    => 0x21,
                    purple  => 0x14,
                    red     => 0x0A,
                    silver  => 0x16,
                    white   => 0x09,
                    yellow  => 0x0D,
                 );

    # Return the default color, 0x7FFF, if undef,
    return 0x7FFF unless defined $_[0];

    # or the color string converted to an integer,
    return $colors{lc($_[0])} if exists $colors{lc($_[0])};

    # or the default color if string is unrecognised,
    return 0x7FFF if ($_[0] =~ m/\D/);

    # or an index < 8 mapped into the correct range,
    return $_[0] + 8 if $_[0] < 8;

    # or the default color if arg is outside range,
    return 0x7FFF if $_[0] > 63;

    # or an integer in the valid range
    return $_[0];
}


###############################################################################
#
# set_type()
#
# Set the XF object type as 0 = cell XF or 0xFFF5 = style XF.
#
sub set_type {

    my $self = shift;
    my $type = $_[0];

    if (defined $_[0] and $_[0] eq 0) {
        $self->{_type} = 0x0000;
    }
    else {
        $self->{_type} = 0xFFF5;
    }
}


###############################################################################
#
# set_align()
#
# Set cell alignment.
#
sub set_align {

    my $self     = shift;
    my $location = $_[0];

    return if not defined $location;  # No default
    return if $location =~ m/\d/;     # Ignore numbers

    $location = lc($location);

    $self->set_text_h_align(1) if ($location eq 'left');
    $self->set_text_h_align(2) if ($location eq 'centre');
    $self->set_text_h_align(2) if ($location eq 'center');
    $self->set_text_h_align(3) if ($location eq 'right');
    $self->set_text_h_align(4) if ($location eq 'fill');
    $self->set_text_h_align(5) if ($location eq 'justify');
    $self->set_text_h_align(6) if ($location eq 'center_across');
    $self->set_text_h_align(6) if ($location eq 'centre_across');
    $self->set_text_h_align(6) if ($location eq 'merge');        # S:WE name
    $self->set_text_h_align(7) if ($location eq 'distributed');
    $self->set_text_h_align(7) if ($location eq 'equal_space');  # ParseExcel


    $self->set_text_v_align(0) if ($location eq 'top');
    $self->set_text_v_align(1) if ($location eq 'vcentre');
    $self->set_text_v_align(1) if ($location eq 'vcenter');
    $self->set_text_v_align(2) if ($location eq 'bottom');
    $self->set_text_v_align(3) if ($location eq 'vjustify');
    $self->set_text_v_align(4) if ($location eq 'vdistributed');
    $self->set_text_v_align(4) if ($location eq 'vequal_space'); # ParseExcel
}


###############################################################################
#
# set_valign()
#
# Set vertical cell alignment. This is required by the set_format_properties()
# method to differentiate between the vertical and horizontal properties.
#
sub set_valign {

    my $self = shift;
    $self->set_align(@_);
}


###############################################################################
#
# set_center_across()
#
# Implements the Excel5 style "merge".
#
sub set_center_across {

    my $self     = shift;

    $self->set_text_h_align(6);
}


###############################################################################
#
# set_merge()
#
# This was the way to implement a merge in Excel5. However it should have been
# called "center_across" and not "merge".
# This is now deprecated. Use set_center_across() or better merge_range().
#
#
sub set_merge {

    my $self     = shift;

    $self->set_text_h_align(6);
}


###############################################################################
#
# set_bold()
#
# Bold has a range 0x64..0x3E8.
# 0x190 is normal. 0x2BC is bold. So is an excessive use of AUTOLOAD.
#
sub set_bold {

    my $self   = shift;
    my $weight = $_[0];

    $weight = 0x2BC if not defined $weight; # Bold text
    $weight = 0x2BC if $weight == 1;        # Bold text
    $weight = 0x190 if $weight == 0;        # Normal text
    $weight = 0x190 if $weight <  0x064;    # Lower bound
    $weight = 0x190 if $weight >  0x3E8;    # Upper bound

    $self->{_bold} = $weight;
}


###############################################################################
#
# set_border($style)
#
# Set cells borders to the same style
#
sub set_border {

    my $self  = shift;
    my $style = $_[0];

    $self->set_bottom($style);
    $self->set_top($style);
    $self->set_left($style);
    $self->set_right($style);
}


###############################################################################
#
# set_border_color($color)
#
# Set cells border to the same color
#
sub set_border_color {

    my $self  = shift;
    my $color = $_[0];

    $self->set_bottom_color($color);
    $self->set_top_color($color);
    $self->set_left_color($color);
    $self->set_right_color($color);
}


###############################################################################
#
# set_rotation($angle)
#
# Set the rotation angle of the text. An alignment property.
#
sub set_rotation {

    my $self     = shift;
    my $rotation = $_[0];

    # Argument should be a number
    return if $rotation !~ /^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/;

    # The arg type can be a double but the Excel dialog only allows integers.
    $rotation = int $rotation;

    if ($rotation == 270) {
        $rotation = 255;
    }
    elsif ($rotation >= -90 or $rotation <= 90) {
        $rotation = -$rotation +90 if $rotation < 0;
    }
    else {
        carp "Rotation $rotation outside range: -90 <= angle <= 90";
        $rotation = 0;
    }

    $self->{_rotation} = $rotation;
}


###############################################################################
#
# set_format_properties()
#
# Convert hashes of properties to method calls.
#
sub set_format_properties {

    my $self = shift;

    my %properties = @_; # Merge multiple hashes into one

    while (my($key, $value) = each(%properties)) {

        # Strip leading "-" from Tk style properties e.g. -color => 'red'.
        $key =~ s/^-//;

        # Create a sub to set the property.
        my $sub = \&{"set_$key"};
        $sub->($self, $value);
   }
}

# Renamed rarely used set_properties() to set_format_properties() to avoid
# confusion with Workbook method of the same name. The following acts as an
# alias for any code that uses the old name.
*set_properties = *set_format_properties;


###############################################################################
#
# AUTOLOAD. Deus ex machina.
#
# Dynamically create set methods that aren't already defined.
#
sub AUTOLOAD {

    my $self = shift;

    # Ignore calls to DESTROY
    return if $AUTOLOAD =~ /::DESTROY$/;

    # Check for a valid method names, i.e. "set_xxx_yyy".
    $AUTOLOAD =~ /.*::set(\w+)/ or die "Unknown method: $AUTOLOAD\n";

    # Match the attribute, i.e. "_xxx_yyy".
    my $attribute = $1;

    # Check that the attribute exists
    exists $self->{$attribute}  or die "Unknown method: $AUTOLOAD\n";

    # The attribute value
    my $value;


    # There are two types of set methods: set_property() and
    # set_property_color(). When a method is AUTOLOADED we store a new anonymous
    # sub in the appropriate slot in the symbol table. The speeds up subsequent
    # calls to the same method.
    #
    no strict 'refs'; # To allow symbol table hackery

    if ($AUTOLOAD =~ /.*::set\w+color$/) {
        # For "set_property_color" methods
        $value =  _get_color($_[0]);

        *{$AUTOLOAD} = sub {
                                my $self  = shift;

                                $self->{$attribute} = _get_color($_[0]);
                           };
    }
    else {

        $value = $_[0];
        $value = 1 if not defined $value; # The default value is always 1

        *{$AUTOLOAD} = sub {
                                my $self  = shift;
                                my $value = shift;

                                $value = 1 if not defined $value;
                                $self->{$attribute} = $value;
                            };
    }


    $self->{$attribute} = $value;
}


1;


__END__


=head1 NAME

Format - A class for defining Excel formatting.

=head1 SYNOPSIS

See the documentation for Spreadsheet::WriteExcel

=head1 DESCRIPTION

This module is used in conjunction with Spreadsheet::WriteExcel.

=head1 AUTHOR

John McNamara jmcnamara@cpan.org

=head1 COPYRIGHT

© MM-MMX, John McNamara.

All Rights Reserved. This module is free software. It may be used, redistributed and/or modified under the same terms as Perl itself.