package SForm;
use Data::Dumper;
use XML::Simple;
use Carp;
sub new {
my($pkg,$xsd_filename,$data) = @_;
my $schema = XMLin($xsd_filename, ForceArray => 0, KeyAttr => qq/name/);
hash($schema->{'xs:simpleType'}); # repair "name" keys..
hash($schema->{'xs:complexType'});
hash($schema->{'xs:attribute'});
hash($schema->{'xs:element'});
return bless $schema, $pkg;
}
sub form_array {
my($schema,$element_name) = @_;
my $array = $schema->generate_element(
$schema->find_element($element_name),0);
return $array;
}
sub js_value {
my($value) = @_; # todo: escape strings properly..
return "null" unless(defined $value);
return "\"$value\"" unless(ref $value);
return "[".join(", ",map js_value($_), @$value)."]"
if(ref $value eq 'ARRAY');
return "{".join(", ",map "\"$_\": ".js_value($value->{$_}),
keys %$value)."}" if(ref $value eq 'HASH');
die "internal: unknown type: ".Dumper($js_value);
}
sub js_dump_form {
my($level,$form) = @_;
my $js = $level."[ ".join("",
map js_value($form->{$_}).", ", qw/type name title repeat args xml/);
if($form->{subfields} and @{$form->{subfields}}) {
my @lines = map js_dump_form($level." ",$_), @{$form->{subfields}};
$js .= "[\n".join(",\n",@lines)."\n".$level." ]";
} else {
$js .= "null";
}
return $js." ]";
}
sub array_to_js {
my($pkg,$name,$form) = @_;
return "var ".$name." = ".js_dump_form("",$form).";\n";
}
#my %buildinType = (
# 'xs:string' => { },
# 'xs:boolean' => { 'xs:restriction' => { 'base' => 'xs:string'},
#);
# 'dmlcz-number' => {
# 'xs:restriction' => {
# 'xs:pattern' => { 'value' => '\\d+([-,]\\d+)*' },
# 'base' => 'xs:string'
# }
# },
sub find_element {
my($schema,$name) = @_;
confess "internal: no \$name to find\n" unless($name);
my $element = $schema->{'xs:element'};
return $element->{$name} if($element->{$name});
die "$name: global element `$name' not found\n";
}
sub find_attribute {
my($schema,$name) = @_;
my $attribute = $schema->{'xs:attribute'};
return $attribute->{$name} if($attribute->{$name});
die "$name: global attribute `$name' not found\n";
}
sub find_type { # vrati sTdef i pro simpleType..
my($schema,$type) = @_;
my $complex = $schema->{'xs:complexType'};
my $simple = $schema->{'xs:simpleType'};
my $sTdef = $simple->{$type} if($simple);
my $cTdef = $complex->{$type} if($complex);
$sTdef = get_buildin_type($type) if($type =~ /^xs:/);
die "$type: global type `$type' ambiguous\n" if($sTdef and $cTdef);
die "$type: global type `$type' not found\n" unless($sTdef or $cTdef);
return($sTdef,$cTdef);
}
sub repeat_element {
my($el) = @_;
my $min = defined $el->{minOccurs} ? $el->{minOccurs} : 1;
my $max = defined $el->{maxOccurs} ? $el->{maxOccurs} : 1;
return "single" if($min eq '1' and $max eq '1');
return "option" if($min eq '0' and $max eq '1');
return "more" if($min eq '1');
return "any";
}
sub repeat_attribute {
my($attr) = @_;
my $use = defined $attr->{'use'} ? $attr->{'use'} : "optional";
return $use eq 'optional' ? "option" : "single";
}
sub array {
my($foo) = @_;
return () unless(defined $foo);
return @$foo if(ref $foo eq 'ARRAY');
return ($foo);
}
sub hash { # like array, but repair hashes which contain "name" key
my($foo) = @_;
return () unless(defined $foo);
return @$foo if(ref $foo eq 'ARRAY');
if(ref $foo eq 'HASH') {
return ($foo) if($foo->{name});
map $foo->{$_}->{name} = $_, keys %$foo;
return values %$foo;
}
die "internal: XML Schema parse error??";
}
sub get_buildin_type {
my($type) = @_; # generate sTdef as simpleType without restrictions
return { 'restriction' => { 'base' => $type } };
}
sub generate_scalar { # simple element or an attribute
my($schema,$name,$default,$repeat,$sTdef,$is_attr) = @_;
# [ type, name, title, default, repeat, [subfields], {args} ];
# todo: cele prekopat..
# posbirej restriction->patterns..
# pokud je to bool tak checkbox,...
# TypeInput/TypeTextArea podle xs:string/xs:normalizedString?
my $title = $sTdef->{'form:title'};
my $args = {};
# tady cekame form:* atributy pro simple typy
my $formRender = $sTdef->{'form:render'} || 'TypeInput';
if($formRender eq 'TypeInput') {
# fix: podle restriction->{'length'}?
my $size = $sTdef->{'form:inputSize'};
$args->{size} = $size if(defined $size);
} elsif($formRender eq 'TypeTextArea') {
$args->{rows} = $sTdef->{'form:textareaRows'};
$args->{cols} = $sTdef->{'form:textareaCols'};
} elsif($formRender eq 'TypeEnum') {
$args->{'options'} = []; # add xs:enumeration values, but as global var
}
my $xml = { is_attr => $is_attr };
# return [ $formRender, $name, $title, $repeat, $args, undef ];
return { type => $formRender, name => $name, title => $title,
default => $default, repeat => $repeat, xml => $xml,
subfields => undef, args => $args };
}
sub generate_complex {
my($schema,$name,$default,$repeat,$cTdef) = @_;
# zkonstruuj complex strukturu
my $complex = { content => undef, sequence => [], attribute => [] };
add_to_complex($schema,$complex,$name,$cTdef);
# vygeneruj z ni seznam subfields, u sequence to muze byt zas cTdef..
my @subfields;
push @subfields, $schema->generate_scalar("content",$default,"single",
$complex->{content}) if($complex->{content});
push @subfields, $schema->generate_element($_,1)
foreach(@{$complex->{attribute}});
push @subfields, $schema->generate_element($_,0)
foreach(@{$complex->{sequence}});
my $args = {}; # pro Folding/Listing/LineHeader..
my $title;
# tady cekame form:* atributy pro simple typy
my $formRender = $cTdef->{'form:render'} || 'Folding';
# return [ $formRender, $name, $title, $repeat, $args, \@subfields ];
return { type => $formRender, name => $name, title => $title,
default => undef, repeat => $repeat, xml => {},
subfields => \@subfields, args => $args };
}
sub add_to_complex {
my($schema,$complex,$debug,$cTdef) = @_;
if($cTdef->{'xs:simpleContent'}) {
my $extension = $cTdef->{'xs:simpleContent'}->{'xs:extension'}
or die "$debug: no xs:extension in xs:simpleContent\n";
die "$debug: unknown base of xs:extension\n" unless($extension->{base});
my($sTdef,$cTdef) = $schema->find_type($extension->{'base'});
die "can't extend complexType in simpleContent" if($cTdef);
die "complex content already defined??" if($complex->{content});
$complex->{content} = $sTdef;
push @{$complex->{attribute}}, hash($extension->{'xs:attribute'});
} elsif($cTdef->{'xs:complexContent'}) {
my $extension = $cTdef->{'xs:simpleContent'}->{'xs:extension'}
or die "$debug: no xs:extension in xs:complexContent\n";
die "$debug: unknown base of xs:extension\n" unless($extension->{base});
my($sTdef,$cTdef) = $schema->find_type_by_name($extension->{'base'});
die "can't extend simpleType in complexContent" if($sTdef);
add_to_complex($complex,$debug,$cTdef);
}
if($cTdef->{'xs:sequence'}) {
my @els = array($cTdef->{'xs:sequence'}->{'xs:element'});
push @{$complex->{sequence}}, @els;
}
push @{$complex->{attribute}}, hash($cTdef->{'xs:attribute'});
return $complex; # $complex is R/W actually..
}
# generate_element - vytvori form-hash z elementu nebo attributu
# generate_scalar - vytvori form-hash z udaju o simpleType
# generate_complex - vytvori form-hash z udaju o complexType
sub generate_element {
my($schema,$el,$is_attr) = @_;
my $name = $el->{name};
my $default = $el->{'default'};
my $repeat = $is_attr ? repeat_attribute($el) : repeat_element($el);
if($el->{'ref'}) { # swap el object now
$el = $schema->find_element($el->{'ref'});
$default = $el->{'default'} unless(defined $default);
die "internal: which name should we use?" if($name and $el->{name});
$name = $el->{name}; # or should we keep old $name?
}
confess "internal: no \$name" unless($name);
my($sTdef,$cTdef) = ($el->{'xs:simpleType'},$el->{'xs:complexType'});
($sTdef,$cTdef) = $schema->find_type($el->{'type'}) if($el->{'type'});
die "$name: not simple nor complex Type?" unless($sTdef xor $cTdef);
# mame: $name, $default, $repeat, [ $sTdef | $cTdef ]
return $sTdef ?
$schema->generate_scalar($name,$default,$repeat,$sTdef,$is_attr) :
$schema->generate_complex($name,$default,$repeat,$cTdef);
}
1;
