sub
new {
my
$this
= {};
bless
$this
,
shift
;
$this
->tl_init(
@_
);
return
$this
;
}
sub
tl_init { confess
"cannot resurrect the dead"
if
shift
->{WAS_DESTROYED} }
sub
tl_getParameters {
my
(
$this
) =
@_
;
confess
"No WINDOW"
unless
$this
->{TL_WINDOW};
my
%gp
=
$this
->{TL_WINDOW}->{PARAMETERS}->get(
$this
);
if
(
$this
->{TL_PARAMS}) {
my
%h
= (
%gp
, %{
$this
->{TL_PARAMS} });
return
%h
;
}
else
{
return
%gp
;
}
}
sub
getParameter {
my
$this
=
shift
;
my
$param
=
shift
;
my
%p
=
(
$this
->{TL_WINDOW}) ?
$this
->tl_getParameters() : %{
$this
->{TL_PARAMS} };
return
(
exists
$p
{
$param
}) ?
$p
{
$param
} :
undef
;
}
sub
tl_getLocalParameters {
return
shift
->{TL_PARAMS} }
sub
tl_inheritParamsFrom {
my
(
$this
,
$obj
) =
@_
;
$this
->{TL_PARAMS_ISA} =
$obj
;
}
sub
setParams {
my
(
$this
,
%params
) =
@_
;
foreach
(
keys
%params
) {
$this
->{TL_PARAMS}->{
$_
} =
$params
{
$_
};
}
return
$this
;
}
sub
tl_destroy {
my
(
$this
) =
@_
;
undef
$this
->{TL_PARAMS};
undef
$this
->{TL_PARAMS_ISA};
$this
->{WAS_DESTROYED} = 1;
}
sub
clone {
my
(
$this
) =
@_
;
delete
$this
->{TL_WINDOW};
delete
$this
->{TL_CONTAINER};
delete
$this
->{TL_FORM};
my
$d
= Data::Dumper->new([
$this
],[
qw(enolc)
]);
$d
->Purity(1);
$d
->Deepcopy(1);
my
$enolc
;
eval
$d
->Dump();
return
$enolc
;
}
sub
getForm {
return
shift
->{TL_FORM} }
sub
getContainer {
return
shift
->{TL_CONTAINER} }
sub
getWindow {
return
shift
->{TL_WINDOW} }
@HTML::TableLayout::Parameters::ISA
=
qw(HTML::TableLayout::TL_BASE)
;
sub
tl_init {
my
$this
=
shift
;
$this
->{DATA} =
shift
;
$this
->SUPER::tl_init(
@_
);
}
sub
set {
my
(
$this
,
$obj
,
%hash
) =
@_
;
$this
->{DATA}->{
$this
->_obj2tag(
$obj
)} = \
%hash
;
}
sub
insert {
my
(
$this
,
$obj
,
%hash
) =
@_
;
foreach
(
keys
%hash
) {
$this
->{DATA}->{
$this
->_obj2tag(
$obj
)}->{
$_
} =
$hash
{
$_
};
}
}
sub
delete
{
my
(
$this
,
@keys
) =
@_
;
map
{
delete
$this
->{DATA}->{
$_
} }
@keys
;
}
sub
get {
my
(
$this
,
$obj
) =
@_
;
my
$h
=
$this
->{DATA}->{
$this
->_obj2tag(
$obj
)};
if
(
$h
) {
return
%$h
;
}
else
{
return
();
}
}
sub
_obj2tag {
my
(
$this
,
$obj
) =
@_
;
my
$name
=
$obj
->{TL_PARAMS_ISA} ||
$obj
;
my
$tag
;
(
$tag
=
$name
) =~ s/^([\w:]+)=.*/$1/;
return
$tag
;
}
@HTML::TableLayout::_Anchor::ISA
=
qw(HTML::TableLayout::TL_BASE)
;
sub
tl_init {
my
$this
=
shift
;
$this
->{anchor} =
shift
;
$this
->SUPER::tl_init(
@_
);
}
sub
value {
my
(
$this
) =
@_
;
SWITCH: {
my
$case
=
$this
->{anchor} ||
return
();
(
$case
eq
"top"
) and
return
(
valign
=>
"top"
);
(
$case
eq
"right"
) and
return
(
align
=>
"right"
);
(
$case
eq
"bottom"
) and
return
(
valign
=>
"bottom"
);
(
$case
eq
"left"
) and
return
(
align
=>
"left"
);
(
$case
eq
"center"
) and
return
(
align
=>
"center"
,
valign
=>
"middle"
);
(
$case
eq
"ne"
) and
return
(
align
=>
"right"
,
valign
=>
"top"
);
(
$case
eq
"se"
) and
return
(
align
=>
"right"
,
valign
=>
"bottom"
);
(
$case
eq
"sw"
) and
return
(
align
=>
"left"
,
valign
=>
"bottom"
);
(
$case
eq
"nw"
) and
return
(
align
=>
"left"
,
valign
=>
"top"
);
(
$case
=~ /^n/) and
return
(
align
=>
"center"
,
valign
=>
"top"
);
(
$case
=~ /^e/) and
return
(
align
=>
"right"
,
valign
=>
"center"
);
(
$case
=~ /^s/) and
return
(
align
=>
"center"
,
valign
=>
"bottom"
);
(
$case
=~ /^w/) and
return
(
align
=>
"left"
,
valign
=>
"center"
);
die
(
"unknown anchor \"$case\""
);
}
}
@HTML::TableLayout::Window::ISA
=
qw(HTML::TableLayout::ComponentContainer)
;
sub
tl_init {
my
$this
=
shift
;
my
$def_params
=
shift
;
my
$title
=
shift
;
my
%params
=
@_
;
$this
->SUPER::tl_init(
@_
);
defined
$params
{Cacheable} and
$this
->{CACHEABLE} = 1;
delete
$params
{Cacheable};
if
(
$def_params
) {
$this
->{PARAMETERS} =
$def_params
;
}
else
{
$this
->{PARAMETERS} = HTML::TableLayout::Parameters->new();
}
$this
->{title} =
$title
;
$this
->{headers} = [];
$this
->{tables} = [];
$this
->{scripts} = [];
$this
->{TL_WINDOW} =
$this
;
$this
->{TL_CONTAINER} =
$this
;
$this
->{INDENT} = 0;
$this
->{CACHEABLE} = 0;
}
sub
tl_destroy {
my
$this
=
shift
;
$this
->{PARAMETERS}->tl_destroy();
undef
$this
->{PARAMETERS};
foreach
(@{
$this
->{headers} }) {
$_
->tl_destroy() }
foreach
(@{
$this
->{tables} }) {
$_
->tl_destroy() }
foreach
(@{
$this
->{scripts} }) {
$_
->tl_destroy() }
$this
->SUPER::tl_destroy();
}
sub
insert {
my
(
$this
,
$component
) =
@_
;
ref
$component
or
die
(
"$component must be an object"
);
$component
->isa(
"HTML::TableLayout::Component"
) or
die
(
"$component must be a component"
);
if
(
$component
->isa(
"HTML::TableLayout::Script"
)) {
push
@{
$this
->{scripts} },
$component
;
}
elsif
(
$component
->isa(
"HTML::TableLayout::WindowHeader"
)) {
push
@{
$this
->{headers} },
$component
;
}
elsif
(
$component
->isa(
"HTML::TableLayout::Table"
)) {
push
@{
$this
->{tables} },
$component
;
}
else
{
die
(
"cannot insert a $component into a window"
);
}
$this
->SUPER::insert(
$component
);
}
sub
render {
my
$this
=
shift
;
$this
->
print
();
$this
->tl_destroy();
}
sub
print
{
my
(
$this
) =
@_
;
$this
->tl_setup();
print
"Content-type: text/html\n\n"
;
$this
->i_print(
"<HTML"
);
$this
->_indentIncrement();
$this
->i_print(
"><HEAD><TITLE>$this->{title}</TITLE></HEAD"
);
foreach
(@{
$this
->{scripts} }) {
$_
->tl_print() }
$this
->i_print(
"><BODY"
.params(
$this
->tl_getParameters()).
""
);
$this
->_indentIncrement();
foreach
(@{
$this
->{headers} }) {
$_
->tl_print() }
foreach
(@{
$this
->{tables} }) {
$_
->tl_print() }
$this
->_indentDecrement();
$this
->i_print(
"></BODY"
);
$this
->_indentDecrement();
$this
->i_print(
"></HTML>"
);
$this
->i_print();
}
sub
toString {
my
(
$this
) =
@_
;
$this
->{CACHEABLE} = 1;
$this
->
print
();
return
$this
->{TEXT_CACHE};
}
sub
i_print {
my
(
$this
,
$text
) =
@_
;
my
$cacheable
=
$this
->{CACHEABLE};
my
$i
;
my
$indent
=
$this
->{INDENT};
$cacheable
?
$this
->{TEXT_CACHE} .=
"\n"
:
print
"\n"
;
if
(
$cacheable
) {
$this
->{TEXT_CACHE} .=
" "
x
$indent
;
}
else
{
print
" "
x
$indent
;
}
if
(
$cacheable
) {
if
(
$text
) {
$this
->{TEXT_CACHE} ||=
""
;
$this
->{TEXT_CACHE} .=
$text
;
}
}
else
{
print
$text
;
}
}
sub
f_print {
my
(
$this
,
$text
) =
@_
;
if
(
$this
->{CACHEABLE}) {
$this
->{TEXT_CACHE} .=
$text
;
}
else
{
print
$text
;
}
}
sub
_indentIncrement {
shift
->{INDENT}++ }
sub
_indentDecrement {
shift
->{INDENT}-- }
sub
_getIndent {
return
shift
->{INDENT} }
sub
_incrementNumForms {
shift
->{NUM_FORMS}++ }
sub
_getNumForms {
return
shift
->{NUM_FORMS} || 0 }
@HTML::TableLayout::Table::ISA
=
qw(HTML::TableLayout::ComponentContainer)
;
sub
tl_init {
my
$this
=
shift
;
$this
->SUPER::tl_init(
@_
);
$this
->{rowindex} = 0;
}
sub
tl_destroy {
my
$this
=
shift
;
undef
$this
->{rowindex};
foreach
(0.. $
$this
->{rows}->[
$_
]->tl_destroy();
undef
$this
->{rows}->[
$_
];
}
undef
$this
->{rows};
$this
->SUPER::tl_destroy();
}
sub
insert {
my
(
$this
,
$c
,
$br
) =
@_
;
if
(!
ref
$c
) {
my
$temp
=
$c
;
$c
= HTML::TableLayout::Cell->new();
$c
->insert(
$temp
,
$br
);
}
$this
->SUPER::insert(
$c
,
$br
);
}
sub
tl_setup {
my
(
$this
) =
@_
;
$this
->tl_setup_form();
my
$first_row
= 1;
my
$i
;
foreach
$i
(0..$
my
$c
=
$this
->{TL_COMPONENTS}->[
$i
];
my
$cell
;
if
(
$c
->isa(
"HTML::TableLayout::Cell"
)) {
my
$h
;
if
(
$h
=
$c
->getHeader()) {
$c
->_forgetIHaveAHeader();
$h
->tl_setContext(
$this
);
my
(
$t
,
$o
);
$o
=
$h
->orientation();
$this
->{TL_COMPONENTS}->[
$i
] =
$cell
= HTML::TableLayout::Cell->new(
Anchor
=>
$o
);
if
(
exists
$c
->{TL_PARAMS}->{colspan}) {
$cell
->{TL_PARAMS}->{colspan} =
$c
->{TL_PARAMS}->{colspan};
delete
$c
->{TL_PARAMS}->{colspan};
}
if
(
exists
$c
->{TL_PARAMS}->{rowspan}) {
$cell
->{TL_PARAMS}->{rowspan} =
$c
->{TL_PARAMS}->{rowspan};
delete
$c
->{TL_PARAMS}->{rowspan};
}
$cell
->insert(
$t
=HTML::TableLayout::Table
->new(
width
=>
"100%"
,
height
=>
"100%"
,
columns
=>(
$o
eq
"top"
or
$o
eq
"bottom"
) ? 1 : 2));
if
(
$o
eq
"top"
or
$o
eq
"left"
) {
$t
->insert(
$h
);
$t
->insert(
$c
);
}
else
{
$t
->insert(
$c
);
$t
->insert(
$h
);
}
}
else
{
$this
->{TL_COMPONENTS}->[
$i
] =
$cell
=
$c
;
}
}
else
{
$this
->{TL_COMPONENTS}->[
$i
] =
$cell
=
HTML::TableLayout::Cell->new()->insert(
$c
);
}
$cell
->tl_setContext(
$this
);
my
$row
;
if
(
$first_row
) {
$first_row
= 0;
$row
=
$this
->{rows}->[0]
= HTML::TableLayout::_Row->new(
$this
,
$this
->{TL_WINDOW},
$this
->{TL_FORM});
$row
->insert(
$cell
) or confess
"insert failed; colspan > columns ??"
;
}
elsif
((
$row
=
$this
->{rows}->[
$this
->{rowindex}])->insert(
$cell
)) {
}
else
{
$this
->_removeOldSpanningCells();
my
$n_ridx
= ++
$this
->{rowindex};
$row
=
$this
->{rows}->[
$n_ridx
]
= HTML::TableLayout::_Row->new(
$this
,
$this
->{TL_WINDOW},
$this
->{TL_FORM});
if
(!
$row
->insert(
$cell
)) {
my
$cs
=
$cell
->getColspan();
my
$cols
=
$this
->getColumns();
if
(
$cs
>
$cols
) {
confess
"colspan [$cs] exceeds max number of columns [$cols]"
;
}
else
{
confess
"?? cannot pack; colspan [$cs] and cols [$cols]"
;
}
}
}
$cell
->tl_setup();
}
}
sub
tl_print {
my
(
$this
) =
@_
;
my
$w
=
$this
->{TL_WINDOW};
my
$p
= params(
$this
->tl_getParameters()) ||
""
;
$w
->i_print(
"><TABLE $p"
);
if
(
$this
->{form_is_mine}) {
$this
->{TL_FORM}->tl_print() }
$w
->_indentIncrement();
foreach
(@{
$this
->{rows} }) {
$_
->tl_print() };
$w
->_indentDecrement();
if
(
$this
->{form_is_mine}) {
$this
->{TL_FORM}->_print_end() }
$w
->i_print(
"></TABLE"
);
}
sub
getColumns {
return
shift
->{TL_PARAMS}->{columns} || 1 }
sub
setColumns {
shift
->{TL_PARAMS}->{columns} =
pop
}
sub
_insertSpanningCell {
my
(
$this
,
$cell
) =
@_
;
push
@{
$this
->{spanning_cells} },
HTML::TableLayout::_SpanningCell->new(
$cell
,
$this
->{TL_WINDOW},
$this
->{TL_FORM})
}
sub
_colspanOfSpanningCells {
my
(
$this
) =
@_
;
my
$sum
= 0;
my
$sc
;
foreach
$sc
(@{
$this
->{spanning_cells} }) {
$sum
+=
$sc
->getColspan();
}
return
$sum
;
}
sub
_removeOldSpanningCells {
my
(
$this
) =
@_
;
my
@old
= @{
$this
->{spanning_cells} };
my
(
@new
,
$sc
);
foreach
$sc
(
@old
) {
if
(
$sc
->decrement() > 0) {
push
@new
,
$sc
;
}
}
$this
->{spanning_cells} = \
@new
;
}
@HTML::TableLayout::_Row::ISA
=
qw(HTML::TableLayout::ComponentContainer)
;
sub
tl_init {
my
$this
=
shift
;
$this
->{TL_CONTAINER} =
shift
;
$this
->{TL_WINDOW} =
shift
;
$this
->{TL_FORM} =
shift
;
$this
->{columns} =
$this
->{TL_CONTAINER}->getColumns();
$this
->SUPER::tl_init(
@_
);
}
sub
tl_destroy {
my
$this
=
shift
;
undef
$this
->{columns};
$this
->SUPER::tl_destroy();
}
sub
setRSOffset {
shift
->{rs_offset} =
pop
}
sub
getRSOffset {
return
shift
->{rs_offset} || 0 }
sub
getVacantSlots {
my
(
$this
) =
@_
;
my
$spaces
=
$this
->{columns};
my
$cs_effect
= sum(
map
{
$_
->getColspan() } @{
$this
->{TL_COMPONENTS} });
my
$rs_effect
=
$this
->{TL_CONTAINER}->_colspanOfSpanningCells();
my
$rs_offset
=
$this
->getRSOffset();
my
$filled
=
$cs_effect
+
$rs_effect
-
$rs_offset
;
return
$spaces
-
$filled
;
}
sub
isFull {
return
shift
->getVacantSlots() <= 0 }
sub
insert {
my
(
$this
,
$cell
) =
@_
;
return
0
if
(
$this
->getVacantSlots() -
$cell
->getColspan() < 0);
if
(
$cell
->tl_getContainer() ne
$this
) {
$cell
->tl_setContext(
$this
);
}
if
(
$cell
->getRowspan() > 1) {
$this
->{TL_CONTAINER}->_insertSpanningCell(
$cell
);
$this
->setRSOffset(
$this
->getRSOffset()+
$cell
->getColspan());
}
$this
->SUPER::insert(
$cell
);
}
sub
tl_print {
my
(
$this
) =
@_
;
my
$w
=
$this
->{TL_WINDOW};
$w
->i_print(
"><TR"
);
$w
->_indentIncrement();
foreach
(@{
$this
->{TL_COMPONENTS} }) {
$_
->tl_print() };
$w
->_indentDecrement();
$w
->i_print(
"></TR"
);
}
@HTML::TableLayout::Cell::ISA
=
qw(HTML::TableLayout::ComponentContainer)
;
sub
tl_destroy {
my
$this
=
shift
;
undef
$this
->{cell_header};
$this
->SUPER::tl_destroy();
}
sub
tl_getParameters {
my
(
$this
) =
@_
;
my
%r
= (
$this
->{TL_WINDOW}->{PARAMETERS}->get(
$this
),
%{
$this
->{TL_PARAMS} },
colspan
=>
$this
->getColspan(),
rowspan
=>
$this
->getRowspan(),
width
=>
$this
->getWidth());
return
%r
;
}
sub
insert {
my
(
$this
,
$c
,
$br
) =
@_
;
if
(
ref
$c
) {
if
(
$c
->isa(
"HTML::TableLayout::CellHeader"
)) {
if
(
$this
->{
"cell_header"
}) {
die
(
"There can only be one header per cell | $this"
);
}
$this
->{
"cell_header"
} =
$c
;
}
elsif
(
$c
->isa(
"HTML::TableLayout::Cell"
)) {
die
(
"Cannot insert a cell into a cell!"
);
}
else
{
$this
->SUPER::insert(
$c
,
$br
);
}
}
else
{
$this
->SUPER::insert(
$c
,
$br
);
}
return
$this
;
}
sub
tl_print {
my
(
$this
) =
@_
;
my
$w
=
$this
->{TL_WINDOW};
$this
->{form_is_mine} and
$this
->{TL_FORM}->tl_print();
$w
->i_print(
"><TD"
.params(
$this
->tl_getParameters()).
""
);
$w
->_indentIncrement();
foreach
(0..$
$this
->{TL_COMPONENTS}->[
$_
]->tl_print();
$this
->{TL_BREAKS}->[
$_
] and
$w
->i_print(
"><BR"
);
}
$w
->_indentDecrement();
$w
->i_print(
"></TD"
);
$this
->{form_is_mine} and
$this
->{TL_FORM}->_print_end();
}
sub
getWidth {
my
(
$this
) =
@_
;
return
$this
->{TL_PARAMS}->{width} ||
int
(100 * (
$this
->getColspan() /
$this
->{TL_CONTAINER}->{TL_CONTAINER}->getColumns())) .
"%"
;
}
sub
getColspan {
return
shift
->{TL_PARAMS}->{colspan} || 1 }
sub
getRowspan {
return
shift
->{TL_PARAMS}->{rowspan} || 1 }
sub
getForm {
return
shift
->{TL_FORM} }
sub
getHeader {
return
shift
->{
"cell_header"
} }
sub
setColspan {
shift
->{TL_PARAMS}->{colspan} =
pop
}
sub
setRowspan {
shift
->{TL_PARAMS}->{rowspan} =
pop
}
sub
_forgetIHaveAHeader {
delete
shift
->{
"cell_header"
} }
@HTML::TableLayout::_SpanningCell::ISA
=
qw(HTML::TableLayout::TL_BASE)
;
sub
tl_init {
my
$this
=
shift
;
$this
->{TL_CONTAINER} =
shift
;
$this
->{size} =
$this
->{TL_CONTAINER}->getRowspan();
$this
->{TL_WINDOW} =
shift
;
$this
->{TL_FORM} =
shift
;
$this
->SUPER::tl_init(
@_
);
}
sub
decrement {
return
--
shift
->{size} }
sub
increment {
return
++
shift
->{size} }
sub
getColspan {
return
shift
->{TL_CONTAINER}->getColspan() }
@HTML::TableLayout::CellHeader::ISA
=
qw(HTML::TableLayout::ComponentContainer HTML::TableLayout::Cell)
;
sub
tl_init {
my
$this
=
shift
;
my
$h
=
shift
;
$this
->SUPER::tl_init(
@_
);
if
(
ref
$h
) {
$this
->{TL_COMPONENTS}->[0] =
$h
;
}
else
{
$this
->{TL_COMPONENTS}->[0]
= HTML::TableLayout::Component::Text->new(
$h
);
}
}
sub
tl_print {
my
(
$this
) =
@_
;
my
$w
=
$this
->{TL_WINDOW};
my
%params
=
$this
->tl_getParameters();
delete
$params
{Orientation};
$w
->i_print(
"><TH"
.params(
%params
).
""
);
$w
->_indentIncrement();
$this
->{TL_COMPONENTS}->[0]->tl_print();
$w
->_indentDecrement();
$w
->i_print(
"></TH"
);
}
sub
orientation {
my
(
$this
) =
@_
;
my
%p
=
$this
->tl_getParameters();
return
$p
{Orientation} ||
"top"
;
}
@HTML::TableLayout::WindowHeader::ISA
=
qw(HTML::TableLayout::ComponentContainer)
;
sub
tl_init {
my
$this
=
shift
;
$this
->{H} =
shift
;
my
$xx
=
shift
;
$this
->SUPER::tl_init(
@_
);
$this
->{TL_COMPONENTS}->[0] =
$xx
;
}
sub
tl_setup {
my
(
$this
) =
@_
;
if
(!
ref
$this
->{TL_COMPONENTS}->[0]) {
$this
->{TL_COMPONENTS}->[0] =
HTML::TableLayout::Component::Text->new(
$this
->{TL_COMPONENTS}->[0]);
}
$this
->SUPER::tl_setup();
}
sub
tl_print {
my
(
$this
) =
@_
;
my
$w
=
$this
->{TL_WINDOW};
if
(
$this
->{H}) {
$w
->i_print(
"><H"
.
$this
->{H}.params(
$this
->tl_getParameters()).
""
);
$w
->_indentIncrement();
$this
->{TL_COMPONENTS}->[0]->tl_print();
$w
->_indentDecrement();
$w
->f_print(
"></H$this->{H}"
);
}
else
{
$w
->i_print();
$this
->{TL_COMPONENTS}->[0]->tl_print();
}
}
@HTML::TableLayout::Script::ISA
=
qw(HTML::TableLayout::Component)
;
sub
tl_init {
my
$this
=
shift
;
$this
->{script} =
shift
;
$this
->SUPER::tl_init(
@_
);
}
sub
tl_print {
my
(
$this
) =
@_
;
my
$w
=
$this
->{TL_WINDOW};
my
$p
= params(
$this
->tl_getParameters()) ||
""
;
$w
->i_print(
"><SCRIPT $p>\n<!--\n"
);
$w
->f_print(
$this
->{
"script"
});
$w
->f_print(
"\n//-->"
);
$w
->i_print(
"</SCRIPT"
);
}
1;