our
$VERSION
=
'0.135'
;
my
%Default_Plugins
= ();
my
%Default_Types
= (
str
=>
'Str'
,
string
=>
'Str'
,
cistr
=>
'CIStr'
,
cistring
=>
'CIStr'
,
bool
=>
'Bool'
,
boolean
=>
'Bool'
,
hash
=>
'Hash'
,
array
=>
'Array'
,
object
=>
'Object'
,
obj
=>
'Object'
,
int
=>
'Int'
,
integer
=>
'Int'
,
float
=>
'Float'
,
either
=>
'Either'
,
or
=>
'Either'
,
any
=>
'Either'
,
all
=>
'All'
,
and
=>
'All'
,
typename
=>
'TypeName'
,
);
for
(
keys
%Default_Types
) {
$Default_Types
{
$_
} =
"Data::Schema::Type::"
.
$Default_Types
{
$_
} }
my
%Package_Default_Types
;
my
%Package_Default_Plugins
;
my
$Current_Call_Pkg
;
sub
ds_validate {
my
(
$data
,
$schema
) =
@_
;
my
$ds
= __PACKAGE__->new(
schema
=>
$schema
);
$ds
->validate(
$data
);
}
our
$Merger
= new Data::ModeMerge;
$Merger
->config->recurse_array(1);
has
plugins
=> (
is
=>
'rw'
);
has
type_handlers
=> (
is
=>
'rw'
);
has
compiled_subnames
=> (
is
=>
'rw'
);
has
config
=> (
is
=>
'rw'
);
has
validation_state_stack
=> (
is
=>
'rw'
);
has
schema
=> (
is
=>
'rw'
);
has
too_many_errors
=> (
is
=>
'rw'
);
has
too_many_warnings
=> (
is
=>
'rw'
);
has
errors
=> (
is
=>
'rw'
);
has
warnings
=> (
is
=>
'rw'
);
has
data_pos
=> (
is
=>
'rw'
);
has
schema_pos
=> (
is
=>
'rw'
);
has
stash
=> (
is
=>
'rw'
);
has
logs
=> (
is
=>
'rw'
);
has
compilation_state_stack
=> (
is
=>
'rw'
);
has
outer_stash
=> (
is
=>
'rw'
);
sub
BUILD {
my
(
$self
,
$args
) =
@_
;
if
(
$self
->config) {
my
$is_hashref
=
ref
(
$self
->config) eq
'HASH'
;
die
"config must be a hashref or a Data::Schema::Config"
unless
$is_hashref
|| UNIVERSAL::isa(
$self
->config,
"Data::Schema::Config"
);
$self
->config(Data::Schema::Config->new(%{
$self
->config }))
if
$is_hashref
;
die
"config->schema_search_path must be an arrayref"
unless
ref
(
$self
->config->schema_search_path) eq
'ARRAY'
;
}
else
{
$self
->config(Data::Schema::Config->new);
}
if
(
$args
->{type_handlers}) {
die
"type_handlers must be a hashref"
unless
ref
(
$args
->{type_handlers}) eq
'HASH'
;
}
else
{
$self
->type_handlers({});
my
$deftypes
=
$Current_Call_Pkg
&&
$Package_Default_Types
{
$Current_Call_Pkg
} ?
$Package_Default_Types
{
$Current_Call_Pkg
} : \
%Default_Types
;
$self
->register_type(
$_
,
$deftypes
->{
$_
})
for
keys
%$deftypes
;
}
if
(
$self
->plugins) {
die
"plugins must be an arrayref"
unless
ref
(
$self
->plugins) eq
'ARRAY'
;
}
else
{
$self
->plugins([]);
my
$defpl
=
$Current_Call_Pkg
&&
$Package_Default_Plugins
{
$Current_Call_Pkg
} ?
$Package_Default_Plugins
{
$Current_Call_Pkg
} : \
%Default_Plugins
;
$self
->register_plugin(
$_
)
for
keys
%$defpl
;
}
$self
->validation_state_stack([])
unless
$self
->validation_state_stack;
$self
->compilation_state_stack([])
unless
$self
->compilation_state_stack;
$self
->compiled_subnames({})
unless
$self
->compiled_subnames;
};
sub
merge_attr_hashes {
my
(
$self
,
$attr_hashes
) =
@_
;
my
@merged
;
my
$res
= {
error
=>
''
};
my
$i
= -1;
while
(++
$i
<
@$attr_hashes
) {
if
(!
$i
) {
push
@merged
,
$attr_hashes
->[
$i
];
next
}
my
$has_merge_prefix
=
grep
{/^[*+.!^-]/}
keys
%{
$attr_hashes
->[
$i
] };
if
(!
$has_merge_prefix
) {
push
@merged
,
$attr_hashes
->[
$i
];
next
}
my
$mres
=
$Merger
->merge(
$merged
[-1],
$attr_hashes
->[
$i
]);
if
(!
$mres
->{success}) {
$res
->{error} =
$mres
->{error};
last
;
}
$merged
[-1] =
$mres
->{result};
}
$res
->{result} = \
@merged
unless
$res
->{error};
$res
->{success} = !
$res
->{error};
$res
;
}
sub
init_validation_state {
my
(
$self
) =
@_
;
$self
->schema(
undef
);
$self
->errors([]);
$self
->warnings([]);
$self
->too_many_errors(0);
$self
->too_many_warnings(0);
$self
->data_pos([]);
$self
->schema_pos([]);
$self
->stash({});
}
sub
save_validation_state {
my
(
$self
) =
@_
;
my
$state
= {
schema
=>
$self
->schema,
errors
=>
$self
->errors,
warnings
=>
$self
->warnings,
too_many_errors
=>
$self
->too_many_errors,
too_many_warnings
=>
$self
->too_many_warnings,
data_pos
=>
$self
->data_pos,
schema_pos
=>
$self
->schema_pos,
stash
=>
$self
->stash,
};
push
@{
$self
->validation_state_stack },
$state
;
}
sub
restore_validation_state {
my
(
$self
) =
@_
;
my
$state
=
pop
@{
$self
->validation_state_stack };
die
"Can't restore validation state, stack is empty!"
unless
$state
;
$self
->schema(
$state
->{schema});
$self
->errors(
$state
->{errors});
$self
->warnings(
$state
->{warnings});
$self
->too_many_errors(
$state
->{too_many_errors});
$self
->too_many_warnings(
$state
->{too_many_warnings});
$self
->data_pos(
$state
->{data_pos});
$self
->schema_pos(
$state
->{schema_pos});
$self
->stash(
$state
->{stash});
}
sub
init_compilation_state {
my
(
$self
,
$inner
) =
@_
;
$self
->stash({});
$self
->schema_pos([])
unless
$self
->schema_pos;
$self
->outer_stash({
compiling
=>1})
unless
$inner
;
}
sub
save_compilation_state {
my
(
$self
) =
@_
;
my
$state
= {
stash
=>
$self
->stash,
};
push
@{
$self
->compilation_state_stack },
$state
;
}
sub
restore_compilation_state {
my
(
$self
) =
@_
;
my
$state
=
pop
@{
$self
->compilation_state_stack };
die
"Can't restore validation state, stack is empty!"
unless
$state
;
$self
->stash(
$state
->{stash});
}
sub
emitpl_my {
my
(
$self
,
@varnames
) =
@_
;
join
(
""
,
map
{ !
$self
->stash->{
"C_var_$_"
}++ ?
"my $_;\n"
:
""
}
@varnames
);
}
sub
emitpl_require {
my
(
$self
,
@modnames
) =
@_
;
join
(
""
,
map
{ !
$self
->outer_stash->{
"C_req_$_"
}++ ?
"require $_;\n"
:
""
}
@modnames
);
}
sub
data_error {
my
(
$self
,
$message
) =
@_
;
return
if
$self
->too_many_errors;
do
{
$self
->too_many_errors(1);
$self
->debug(
"Too many errors"
, 3);
return
}
if
defined
(
$self
->config->max_errors) &&
$self
->config->max_errors > 0 &&
@{
$self
->errors } >=
$self
->config->max_errors;
push
@{
$self
->errors }, [[@{
$self
->data_pos}], [@{
$self
->schema_pos}],
$message
];
}
sub
emitpl_data_error {
my
(
$self
,
$msg
,
$is_literal
) =
@_
;
my
$perl
;
my
$lit
;
if
(
$is_literal
) {
$lit
=
$msg
;
}
else
{
$msg
=~ s/(['\\])/\\$1/g;
$lit
=
"'$msg'"
;
}
$perl
=
'push @errors, [[@$datapos],[@$schemapos],'
.
$lit
.
']; last L1 if @errors >= '
.
$self
->config->max_errors.
";"
;
if
(
defined
(
$self
->config->max_errors) &&
$self
->config->max_errors > 0) {
$perl
=
'if (@errors < '
.
$self
->config->max_errors.
') { '
.
$perl
.
' }'
;
}
$perl
;
}
sub
data_warn {
my
(
$self
,
$message
) =
@_
;
return
if
$self
->too_many_warnings;
do
{
$self
->too_many_warnings(1);
return
}
if
defined
(
$self
->config->max_warnings) &&
$self
->config->max_warnings > 0 &&
@{
$self
->warnings } >=
$self
->config->max_warnings;
push
@{
$self
->warnings }, [[@{
$self
->data_pos}], [@{
$self
->schema_pos}],
$message
];
}
sub
emitpl_data_warn {
my
(
$self
,
$msg
,
$is_literal
) =
@_
;
my
$perl
;
my
$lit
;
if
(
$is_literal
) {
$lit
=
$msg
;
}
else
{
$msg
=~ s/(['\\])/\\$1/g;
$lit
=
"'$msg'"
;
}
$perl
=
'push @warnings, [[@$datapos],[@$schemapos],'
.
$lit
.
']; '
;
if
(
defined
(
$self
->config->max_warnings) &&
$self
->config->max_warnings > 0) {
$perl
=
'if (@warnings < '
.
$self
->config->max_warnings.
') { '
.
$perl
.
'} '
;
}
$perl
;
}
sub
debug {
my
(
$self
,
$message
,
$level
) =
@_
;
$level
//= 1;
return
unless
$level
<=
$self
->config->debug;
$message
=
$message
->()
if
ref
(
$message
) eq
'CODE'
;
push
@{
$self
->logs }, [[@{
$self
->data_pos}], [@{
$self
->schema_pos}],
$message
];
}
sub
emitpl_push_errwarn {
my
(
$self
,
$errorsvarname
,
$warningsvarname
) =
@_
;
$errorsvarname
//=
'suberrors'
;
$warningsvarname
//=
'subwarnings'
;
my
$perl1
=
'push @warnings, @$'
.
$warningsvarname
.
'; '
;
if
(
defined
(
$self
->config->max_warnings) &&
$self
->config->max_warnings > 0) {
$perl1
=
'if (@warnings < '
.
$self
->config->max_warnings.
') { '
.
$perl1
.
'} '
;
}
my
$perl2
.=
'push @errors, @$'
.
$errorsvarname
.
'; last L1 if @errors >= '
.
$self
->config->max_errors.
"; "
;
if
(
defined
(
$self
->config->max_errors) &&
$self
->config->max_errors > 0) {
$perl2
=
'if (@errors < '
.
$self
->config->max_errors.
') { '
.
$perl2
.
'} '
;
}
$perl1
.
$perl2
;
}
sub
schema_error {
my
(
$self
,
$message
) =
@_
;
die
"Schema error: $message"
;
}
sub
_pos_as_str {
my
(
$self
,
$pos_elems
) =
@_
;
my
$res
=
join
"/"
,
@$pos_elems
;
$res
=~ s/\s+/_/sg;
$res
;
}
sub
check_type_name {
my
(
$self
,
$name
) =
@_
;
$name
=~ /\A[a-z_][a-z0-9_]{0,63}\z/;
}
sub
_load_type_handler {
my
(
$self
,
$name
) =
@_
;
my
$obj_or_class
=
$self
->type_handlers->{
$name
};
die
"BUG: unknown type: $name"
unless
$obj_or_class
;
return
$obj_or_class
if
ref
(
$obj_or_class
);
eval
"require $obj_or_class"
;
die
"Can't load class $obj_or_class: $@"
if
$@;
my
$obj
=
$obj_or_class
->new();
$obj
->validator(
$self
);
$self
->type_handlers->{
$name
} =
$obj
;
$obj
;
}
sub
register_type {
my
(
$self
,
$name
,
$obj_or_class
) =
@_
;
$self
->check_type_name(
$name
) or
die
"Invalid type name syntax: $name"
;
if
(
exists
$self
->type_handlers->{
$name
}) {
die
"Type already registered: $name"
;
}
$self
->type_handlers->{
$name
} =
$obj_or_class
;
if
(
ref
(
$obj_or_class
)) {
$obj_or_class
->validator(
$self
);
}
elsif
(!
$self
->config->defer_loading) {
$self
->_load_type_handler(
$name
);
}
}
sub
register_plugin {
my
(
$self
,
$obj_or_class
) =
@_
;
my
$obj
;
if
(
ref
(
$obj_or_class
)) {
$obj
=
$obj_or_class
;
}
else
{
eval
"use $obj_or_class"
;
die
"Can't load class $obj_or_class: $@"
if
$@;
$obj
=
$obj_or_class
->new();
}
$obj
->validator(
$self
);
push
@{
$self
->plugins },
$obj
;
}
sub
call_handler {
my
(
$self
,
$name
,
@args
) =
@_
;
$name
=
"handle_$name"
unless
$name
=~ /^handle_/;
for
my
$p
(@{
$self
->plugins }) {
if
(
$p
->can(
$name
)) {
my
$res
=
$p
->
$name
(
@args
);
return
$res
if
$res
!= -1;
}
}
-1;
}
sub
get_type_handler {
my
(
$self
,
$name
) =
@_
;
my
$th
;
if
(!(
$th
=
$self
->type_handlers->{
$name
})) {
if
(
$self
->call_handler(
"unknown_type"
,
$name
) > 0) {
$th
=
$self
->type_handlers->{
$name
};
}
}
else
{
unless
(
ref
(
$th
)) {
$th
=
$self
->_load_type_handler(
$name
);
}
}
$th
;
}
sub
normalize_schema {
my
(
$self
,
$schema
) =
@_
;
if
(!
defined
(
$schema
)) {
return
"schema is missing"
;
}
elsif
(!
ref
(
$schema
)) {
return
{
type
=>
$schema
,
attr_hashes
=>[],
def
=>
undef
};
}
elsif
(
ref
(
$schema
) eq
'ARRAY'
) {
my
$type
=
$schema
->[0];
if
(!
defined
(
$type
)) {
return
"array form needs at least 1 element for type"
;
}
my
@attr_hashes
;
for
(1..
@$schema
-1) {
if
(
ref
(
$schema
->[
$_
]) ne
'HASH'
) {
return
"array form element [$_] (attrhash) must be a hashref"
;
}
push
@attr_hashes
,
$schema
->[
$_
];
}
return
{
type
=>
$type
,
attr_hashes
=>\
@attr_hashes
,
def
=>
undef
};
}
elsif
(
ref
(
$schema
) eq
'HASH'
) {
my
$type
=
$schema
->{type};
if
(!
defined
(
$type
)) {
return
"hash form must have 'type' key"
;
}
my
@attr_hashes
;
my
$a
=
$schema
->{attrs};
if
(
defined
(
$a
)) {
if
(
ref
(
$a
) ne
'HASH'
) {
return
"hash form 'attrs' key must be a hashref"
;
}
push
@attr_hashes
,
$a
;
}
$a
=
$schema
->{attr_hashes};
if
(
defined
(
$a
)) {
if
(
ref
(
$a
) ne
'ARRAY'
) {
return
"hash form 'attr_hashes' key must be an arrayref"
;
}
for
(0..
@$a
-1) {
if
(
ref
(
$a
->[
$_
]) ne
'HASH'
) {
return
"hash form 'attr_hashes'[$_] must be a hashref"
;
}
push
@attr_hashes
,
$a
->[
$_
];
}
}
my
$def
= {};
$a
=
$schema
->{def};
if
(
defined
(
$a
)) {
if
(
ref
(
$a
) ne
'HASH'
) {
return
"hash form 'def' key must be a hashref"
;
}
}
$def
=
$a
;
for
(
keys
%$schema
) {
return
"hash form has unknown key `$_'"
unless
/^(type|attrs|attr_hashes|def)$/;
}
return
{
type
=>
$type
,
attr_hashes
=>\
@attr_hashes
,
def
=>
$def
};
}
return
"schema must be a str, arrayref, or hashref"
;
}
sub
register_schema_as_type {
my
(
$self
,
$nschema
,
$name
,
$path
) =
@_
;
$path
||=
""
;
my
$res
= {};
while
(1) {
if
(
$self
->type_handlers->{
$name
}) {
$res
->{error} =
"type `$name' already registered (path `$path')"
;
last
;
}
if
(
ref
(
$nschema
) ne
'HASH'
) {
$res
->{error} =
"schema must be in 3rd form (hash): (path `$path')"
;
last
;
}
if
(
$nschema
->{def}) {
for
(
keys
%{
$nschema
->{def} }) {
my
$r
=
$self
->register_schema_as_type(
$nschema
->{def}{
$_
},
$_
,
"$path/$_"
);
if
(!
$r
->{success}) {
$res
->{error} =
$r
->{error};
last
;
}
}
}
my
$th
= Data::Schema::Type::Schema->new(
nschema
=>
$nschema
,
name
=>
$name
);
$self
->register_type(
$name
=>
$th
);
last
;
}
$res
->{success} = !
$res
->{error};
$res
;
}
sub
validate {
my
(
$self
,
$data
,
$schema
) =
@_
;
my
$saved_schema
=
$self
->schema;
$schema
||=
$self
->schema;
$self
->init_validation_state();
$self
->init_compilation_state()
if
$self
->config->compile;
$self
->logs([]);
$self
->_validate(
$data
,
$schema
);
$self
->schema(
$saved_schema
);
{
success
=> !@{
$self
->errors},
errors
=> [
$self
->errors_as_array],
warnings
=> [
$self
->warnings_as_array],
logs
=> [
$self
->logs_as_array],
};
}
sub
errors_as_array {
my
(
$self
) =
@_
;
map
{
sprintf
"%s (data\@%s schema\@%s)"
,
$_
->[2],
$self
->_pos_as_str(
$_
->[0]),
$self
->_pos_as_str(
$_
->[1]) } @{
$self
->errors };
}
sub
warnings_as_array {
my
(
$self
) =
@_
;
map
{
sprintf
"%s (data\@%s schema\@%s)"
,
$_
->[2],
$self
->_pos_as_str(
$_
->[0]),
$self
->_pos_as_str(
$_
->[1]) } @{
$self
->warnings };
}
sub
logs_as_array {
my
(
$self
) =
@_
;
map
{
sprintf
"%s (data\@%s schema\@%s)"
,
$_
->[2],
$self
->_pos_as_str(
$_
->[0]),
$self
->_pos_as_str(
$_
->[1]) } @{
$self
->logs };
}
sub
_schema2csubname {
my
(
$self
,
$schema
) =
@_
;
local
$self
->config->{gettext_function} =
(
$self
->config->{gettext_function} //
""
).
""
;
my
$n1
=
defined
(
$schema
) ? (
ref
(
$schema
) ? md5_hex(freeze(
$schema
)) :
$schema
) :
""
;
my
$n2
= md5_hex(freeze(
$self
->config));
"__cs_${n1}_$n2"
;
}
sub
emit_perl {
my
(
$self
,
$schema
,
$inner
) =
@_
;
$self
->init_compilation_state(
$inner
);
$self
->_emit_perl(
undef
,
$schema
);
}
sub
_emit_perl {
_validate_or_emit_perl(
@_
,
'EMIT_PERL'
);
}
sub
_validate {
my
(
$self
,
$data
,
$schema
) =
@_
;
_validate_or_emit_perl(
@_
,
'VALIDATE'
);
}
sub
_validate_or_emit_perl {
my
(
$self
,
$data
,
$schema
,
$action
) =
@_
;
die
"Schema must be specified"
unless
defined
(
$schema
);
my
$compile
=
$self
->config->compile;
my
$csubname
=
$self
->_schema2csubname(
$schema
);
if
(
$compile
&&
$action
eq
'VALIDATE'
&&
$self
->compiled_subnames->{
$csubname
}) {
goto
LV1;
}
my
$orig_type_handlers
;
my
$orig_compiled_subnames
;
{
my
$s
=
$self
->normalize_schema(
$schema
);
if
(!
ref
(
$s
)) {
$self
->schema_error(
$s
);
last
;
}
if
(
$s
->{def}) {
$orig_type_handlers
= { %{
$self
->type_handlers} };
$orig_compiled_subnames
= { %{
$self
->compiled_subnames} };
push
@{
$self
->schema_pos },
'def'
,
''
;
my
$has_err
;
for
(
keys
%{
$s
->{def} }) {
$self
->schema_pos->[-1] =
$_
;
my
$subs
=
$self
->normalize_schema(
$s
->{def}{
$_
});
if
(!
ref
(
$subs
)) {
$has_err
++;
$self
->data_error(
"normalize schema type error: $s"
);
last
;
}
my
$res
=
$self
->register_schema_as_type(
$subs
,
$_
);
if
(!
$res
->{success}) {
$has_err
++;
$self
->data_error(
"register schema type error: $res->{error}"
);
last
;
}
}
pop
@{
$self
->schema_pos };
pop
@{
$self
->schema_pos };
last
if
$has_err
;
}
my
$th
=
$self
->get_type_handler(
$s
->{type});
if
(!
$th
) {
$self
->schema_error(
"unknown type `$s->{type}'"
);
last
;
}
if
(
$compile
||
$action
eq
'EMIT_PERL'
) {
$self
->outer_stash->{
"C_def_$csubname"
}++;
my
$code
=
$th
->emit_perl(
$s
->{attr_hashes},
$csubname
);
return
$code
if
$action
eq
'EMIT_PERL'
;
if
(!
$code
) {
$self
->schema_error(
"no Perl code generated"
);
last
;
}
unless
(
$Data::Schema::__compiled::
{
$csubname
}) {
eval
"package Data::Schema::__compiled; $code; package Data::Schema;"
;
my
$eval_error
= $@;
if
(
$eval_error
) {
my
$i
=1;
my
@c
;
for
(
split
/\n/,
$code
) {
push
@c
,
sprintf
"%4d|%s\n"
,
$i
++,
$_
}
$code
=
join
""
,
@c
;
print
STDERR
$code
;
print
STDERR
$eval_error
;
die
"Can't compile code: $eval_error"
;
}
}
$self
->compiled_subnames->{
$csubname
} = 1;
}
else
{
$th
->handle_type(
$data
,
$s
->{attr_hashes});
}
}
if
(
$orig_type_handlers
) {
$self
->type_handlers(
$orig_type_handlers
);
$self
->compiled_subnames(
$orig_compiled_subnames
);
}
LV1:
if
(
$compile
) {
no
strict
'refs'
;
my
(
$errors
,
$warnings
) =
"Data::Schema::__compiled::$csubname"
->(
$data
);
push
@{
$self
->errors },
@$errors
;
push
@{
$self
->warnings },
@$warnings
;
}
}
sub
compile {
my
(
$self
,
$schema
) =
@_
;
my
$csubname
=
$self
->_schema2csubname(
$schema
);
unless
(
$Data::Schema::__compiled::
{
$csubname
}) {
$self
->save_compilation_state;
my
$code
=
$self
->emit_perl(
$schema
);
$self
->restore_compilation_state;
die
"Can't generate Perl code for schema"
unless
$code
;
eval
"package Data::Schema::__compiled; $code; package Data::Schema;"
;
my
$eval_error
= $@;
if
(
$eval_error
) {
my
$i
=1;
my
@c
;
for
(
split
/\n/,
$code
) {
push
@c
,
sprintf
"%4d|%s\n"
,
$i
++,
$_
}
$code
=
join
""
,
@c
;
print
STDERR
$code
;
print
STDERR
$eval_error
;
die
"Can't compile code: $eval_error"
;
}
}
my
$cfullsubname
=
"Data::Schema::__compiled::$csubname"
;
(\
&$cfullsubname
,
$csubname
);
}
sub
emitpls_sub {
my
(
$self
,
$schema
) =
@_
;
my
$csubname
=
$self
->_schema2csubname(
$schema
);
my
$perl
=
''
;
if
(
$Data::Schema::__compiled::
{
$csubname
} ||
$self
->outer_stash->{
"C_def_$csubname"
}++) {
}
else
{
$self
->outer_stash->{
"C_def_$csubname"
}++;
$self
->save_compilation_state;
$perl
=
$self
->emit_perl(
$schema
, 1);
$self
->restore_compilation_state;
die
"Can't generate Perl code for schema"
unless
$perl
;
}
(
$perl
,
$csubname
);
}
sub
import
{
my
$pkg
=
shift
;
$Current_Call_Pkg
=
caller
(0);
no
strict
'refs'
;
my
@export
=
qw(ds_validate)
;
*{
$Current_Call_Pkg
.
"::$_"
} = \&{
$pkg
.
"::$_"
}
for
@export
;
return
if
$Package_Default_Types
{
$Current_Call_Pkg
};
my
$dt
= {
%Default_Types
};
my
$dp
= {
%Default_Plugins
};
for
(
@_
) {
my
$e
=
$_
;
if
(
grep
{
$e
eq
$_
}
@export
) {
}
elsif
(
$e
=~ /^Plugin::/) {
$e
=
"Data::Schema::"
.
$e
;
unless
(
grep
{
$_
eq
$e
}
keys
%$dp
) {
eval
"require $e"
;
die
$@
if
$@;
$dp
->{
$e
} =
$e
->new();
}
}
elsif
(
$e
=~ /^Type::/) {
$e
=
"Data::Schema::"
.
$e
;
eval
"require $e"
;
die
$@
if
$@;
my
$th
=
$e
->new();
my
$names
= ${
$e
.
"::DS_TYPE"
};
die
"$e doesn't have \$DS_TYPE"
unless
$names
;
$names
= [
$names
]
unless
ref
(
$names
) eq
'ARRAY'
;
for
(
@$names
) {
if
(!check_type_name(
undef
,
$_
)) {
die
"$e tries to define invalid type name: `$_`"
;
}
elsif
(
exists
$dt
->{
$_
}) {
die
"$e tries to redefine existing type '$_' (handler: $dt->{$_})"
;
}
$dt
->{
$_
} =
$e
;
}
}
elsif
(
$e
=~ /^Schema::/) {
$e
=
"Data::Schema::"
.
$e
;
eval
"require $e"
;
die
$@
if
$@;
my
$schemas
= ${
$e
.
"::DS_SCHEMAS"
};
die
"$e doesn't have \$DS_SCHEMAS"
unless
$schemas
;
for
(
keys
%$schemas
) {
if
(!check_type_name(
undef
,
$_
)) {
die
"$e tries to define invalid type name: `$_`"
;
}
elsif
(
exists
$dt
->{
$_
}) {
die
"$e tries to redefine existing type '$_' (handler: $dt->{$_})"
;
}
my
$nschema
= normalize_schema(
undef
,
$schemas
->{
$_
});
if
(
ref
(
$nschema
) ne
'HASH'
) {
die
"Can't normalize schema in $e: $nschema"
;
}
$dt
->{
$_
} = Data::Schema::Type::Schema->new(
nschema
=>
$nschema
,
name
=>
$_
);
}
}
else
{
die
"Can't export $_! Can only export: "
.
join
(
@export
, '/^{Plugin,Type,Schema}::.*/');
}
}
$Package_Default_Types
{
$Current_Call_Pkg
} =
$dt
;
$Package_Default_Plugins
{
$Current_Call_Pkg
} =
$dp
;
}
__PACKAGE__->meta->make_immutable;
no
Moose;
1;