BEGIN {
$Mason::Interp::VERSION
=
'2.08'
;
}
qw(catdir catfile combine_similar_paths find_wanted first_index is_absolute json_decode mason_canon_path read_file taint_is_on touch_file uniq write_file)
;
my
$default_out
=
sub
{
print
(
$_
[0] ) };
my
$next_id
= 0;
my
$max_depth
= 16;
has
'allow_globals'
=> (
isa
=>
'ArrayRef[Str]'
,
default
=>
sub
{ [] },
trigger
=>
sub
{
shift
->allowed_globals_hash } );
has
'autobase_names'
=> (
isa
=>
'ArrayRef[Str]'
,
lazy_build
=> 1 );
has
'autoextend_request_path'
=> (
isa
=>
'Bool'
,
default
=> 1 );
has
'comp_root'
=> (
required
=> 1,
isa
=>
'Mason::Types::CompRoot'
,
coerce
=> 1 );
has
'component_class_prefix'
=> (
lazy_build
=> 1 );
has
'data_dir'
=> (
lazy_build
=> 1 );
has
'dhandler_names'
=> (
isa
=>
'ArrayRef[Str]'
,
lazy_build
=> 1 );
has
'index_names'
=> (
isa
=>
'ArrayRef[Str]'
,
lazy_build
=> 1 );
has
'mason_root_class'
=> (
required
=> 1 );
has
'no_source_line_numbers'
=> (
default
=> 0 );
has
'object_file_extension'
=> (
default
=>
'.mobj'
);
has
'plugins'
=> (
default
=>
sub
{ [] } );
has
'pure_perl_extensions'
=> (
default
=>
sub
{ [
'.mp'
] } );
has
'static_source'
=> ();
has
'static_source_touch_file'
=> ();
has
'top_level_extensions'
=> (
default
=>
sub
{ [
'.mc'
,
'.mp'
] } );
has
'allowed_globals_hash'
=> (
init_arg
=>
undef
,
lazy_build
=> 1 );
has
'code_cache'
=> (
init_arg
=>
undef
,
lazy_build
=> 1 );
has
'distinct_string_count'
=> (
init_arg
=>
undef
,
default
=> 0 );
has
'globals_package'
=> (
init_arg
=>
undef
,
lazy_build
=> 1 );
has
'id'
=> (
init_arg
=>
undef
,
default
=>
sub
{
$next_id
++ } );
has
'match_request_path'
=> (
init_arg
=>
undef
,
lazy_build
=> 1 );
has
'pure_perl_regex'
=> (
lazy_build
=> 1 );
has
'request_params'
=> (
init_arg
=>
undef
);
has
'top_level_regex'
=> (
lazy_build
=> 1 );
CLASS->_define_class_override_methods();
our
(
$current_load_interp
);
method current_load_interp () {
$current_load_interp
}
method BUILD (
$params
) {
if
(
$self
->{static_source} ) {
$self
->{static_source_touch_file} ||= catfile(
$self
->data_dir,
'purge.dat'
);
$self
->{static_source_touch_lastmod} = 0;
$self
->_check_static_source_touch_file();
}
$self
->{request_params} = {};
my
%is_request_attribute
=
map
{ (
$_
->init_arg ||
$_
->name, 1 ) }
$self
->request_class->meta->get_all_attributes();
foreach
my
$key
(
keys
(
%$params
) ) {
if
(
$is_request_attribute
{
$key
} ) {
$self
->{request_params}->{
$key
} =
delete
(
$params
->{
$key
} );
}
}
}
method _build_allowed_globals_hash () {
my
@allow_globals
= uniq( @{
$self
->allow_globals } );
my
@canon_globals
=
map
{
join
(
""
,
$self
->_parse_global_spec(
$_
) ) }
@allow_globals
;
return
{
map
{ (
$_
, 1 ) }
@canon_globals
};
}
method _build_globals_package () {
return
"Mason::Globals"
.
$self
->id;
}
method _build_autobase_names () {
return
[
map
{
"Base"
.
$_
} @{
$self
->top_level_extensions } ];
}
method _build_code_cache () {
return
Mason::CodeCache->new();
}
method _build_component_class_prefix () {
return
"MC"
.
$self
->id;
}
method _build_data_dir () {
return
tempdir(
'mason-data-XXXX'
,
TMPDIR
=> 1,
CLEANUP
=> 1 );
}
method _build_dhandler_names () {
return
[
map
{
"dhandler"
.
$_
} @{
$self
->top_level_extensions } ];
}
method _build_index_names () {
return
[
map
{
"index"
.
$_
} @{
$self
->top_level_extensions } ];
}
method _build_pure_perl_regex () {
my
$extensions
=
$self
->pure_perl_extensions;
if
( !
@$extensions
) {
return
qr/(?!)/
;
}
else
{
my
$regex
=
join
(
'|'
,
@$extensions
) .
'$'
;
return
qr/$regex/
;
}
}
method _build_top_level_regex () {
my
$extensions
=
$self
->top_level_extensions;
if
( !
@$extensions
) {
return
qr/./
;
}
else
{
my
$regex
=
join
(
'|'
,
@$extensions
);
if
(
my
@other_names
=
grep
{ !/
$regex
/ } @{
$self
->dhandler_names },
@{
$self
->index_names } )
{
$regex
.=
'|(?:/(?:'
.
join
(
'|'
,
@other_names
) .
'))'
;
}
$regex
=
'(?:'
.
$regex
.
')$'
;
return
qr/$regex/
;
}
}
method all_paths (
$dir_path
) {
$dir_path
||=
'/'
;
$self
->_assert_absolute_path(
$dir_path
);
return
$self
->_collect_paths_for_all_comp_roots(
sub
{
my
$root_path
=
shift
;
my
$dir
=
$root_path
.
$dir_path
;
return
( -d
$dir
) ? find_wanted(
sub
{ -f },
$dir
) : ();
}
);
}
method comp_exists (
$path
) {
croak
"path required"
if
!
defined
(
$path
);
$path
= Mason::Util::mason_canon_path(
$path
);
return
( (
$self
->static_source &&
$self
->code_cache->get(
$path
) )
||
$self
->_source_file_for_path(
$path
) ) ? 1 : 0;
}
method flush_code_cache () {
my
$code_cache
=
$self
->code_cache;
foreach
my
$key
(
$code_cache
->get_keys() ) {
$code_cache
->remove(
$key
);
}
}
method glob_paths (
$glob_pattern
) {
return
$self
->_collect_paths_for_all_comp_roots(
sub
{
my
$root_path
=
shift
;
return
glob
(
$root_path
.
$glob_pattern
);
}
);
}
our
$in_load
= 0;
method load (
$path
) {
local
$current_load_interp
=
$self
;
my
$code_cache
=
$self
->code_cache;
croak
"path required"
if
!
defined
(
$path
);
$path
= Mason::Util::mason_canon_path(
$path
);
if
(
$self
->static_source ) {
if
(
my
$entry
=
$code_cache
->get(
$path
) ) {
return
$entry
->{compc};
}
}
local
$in_load
=
$in_load
+ 1;
if
(
$in_load
>
$max_depth
) {
die
">$max_depth levels deep in inheritance determination (inheritance cycle?)"
if
$in_load
>=
$max_depth
;
}
my
$compile
= 0;
my
(
$default_parent_path
,
$source_file
,
$source_lastmod
,
$object_file
,
$object_lastmod
,
@source_stat
,
@object_stat
);
my
$stat_source_file
=
sub
{
if
(
$source_file
=
$self
->_source_file_for_path(
$path
) ) {
@source_stat
=
stat
$source_file
;
if
(
@source_stat
&& !-f _ ) {
die
"source file '$source_file' exists but it is not a file"
;
}
}
$source_lastmod
=
@source_stat
?
$source_stat
[9] : 0;
};
my
$stat_object_file
=
sub
{
$object_file
=
$self
->_object_file_for_path(
$path
);
@object_stat
=
stat
$object_file
;
if
(
@object_stat
&& !-f _ ) {
die
"object file '$object_file' exists but it is not a file"
;
}
$object_lastmod
=
@object_stat
?
$object_stat
[9] : 0;
};
$stat_source_file
->() or
return
;
$default_parent_path
=
$self
->_default_parent_path(
$path
);
if
(
$self
->static_source ) {
if
(
$stat_object_file
->() ) {
if
(
$self
->{static_source_touch_lastmod} >=
$object_lastmod
) {
if
(
$source_lastmod
>
$object_lastmod
) {
$compile
= 1;
}
else
{
touch_file(
$object_file
);
}
}
}
else
{
$compile
= 1;
}
}
else
{
if
(
my
$entry
=
$code_cache
->get(
$path
) ) {
if
(
$entry
->{source_lastmod} >=
$source_lastmod
&&
$entry
->{source_file} eq
$source_file
&&
$entry
->{default_parent_path} eq
$default_parent_path
)
{
my
$compc
=
$entry
->{compc};
if
(
$entry
->{superclass_signature} eq
$self
->_superclass_signature(
$compc
) ) {
return
$compc
;
}
}
$code_cache
->remove(
$path
);
}
$stat_object_file
->();
$compile
= ( !
$object_lastmod
||
$object_lastmod
<
$source_lastmod
);
}
$self
->_compile_to_file(
$source_file
,
$path
,
$object_file
)
if
$compile
;
my
$compc
=
$self
->_comp_class_for_path(
$path
);
$self
->_load_class_from_object_file(
$compc
,
$object_file
,
$path
,
$default_parent_path
);
$compc
->meta->make_immutable();
$code_cache
->set(
$path
,
{
source_file
=>
$source_file
,
source_lastmod
=>
$source_lastmod
,
default_parent_path
=>
$default_parent_path
,
compc
=>
$compc
,
superclass_signature
=>
$self
->_superclass_signature(
$compc
),
}
);
return
$compc
;
}
method _superclass_signature (
$compc
) {
my
@superclasses
=
$compc
->meta->superclasses;
foreach
my
$superclass
(
@superclasses
) {
if
(
my
$cmeta
=
$superclass
->cmeta ) {
my
$path
=
$cmeta
->path;
$self
->load(
$cmeta
->path );
}
}
return
join
(
","
,
map
{
join
(
"-"
,
$_
,
$_
->cmeta ?
$_
->cmeta->id : 0 ) }
@superclasses
);
}
memoize(
'comp_exists'
);
memoize(
'load'
);
method object_dir () {
return
catdir(
$self
->data_dir,
'obj'
);
}
method run () {
my
%request_params
;
while
(
ref
(
$_
[0] ) eq
'HASH'
) {
%request_params
= (
%request_params
, %{
shift
(
@_
) } );
}
my
$path
=
shift
;
my
$request
=
$self
->_make_request(
%request_params
);
$request
->run(
$path
,
@_
);
}
method set_global () {
my
(
$spec
,
$value
) =
@_
;
croak
"set_global expects a var name and value"
unless
$value
;
my
(
$sigil
,
$name
) =
$self
->_parse_global_spec(
$spec
);
croak
"${sigil}${name} is not in the allowed globals list"
unless
$self
->allowed_globals_hash->{
"${sigil}${name}"
};
my
$varname
=
sprintf
(
"%s::%s"
,
$self
->globals_package,
$name
);
no
strict
'refs'
;
no
warnings
'once'
;
$$varname
=
$value
;
}
method DEMOLISH () {
return
if
in_global_destruction;
$self
->flush_code_cache();
}
method _compile (
$source_file
,
$path
) {
my
$compilation
=
$self
->compilation_class->new(
source_file
=>
$source_file
,
path
=>
$path
,
interp
=>
$self
);
return
$compilation
->compile();
}
method _compile_to_file (
$source_file
,
$path
,
$object_file
) {
if
(
defined
$object_file
&& !-f
$object_file
) {
my
(
$dirname
) = dirname(
$object_file
);
if
( !-d
$dirname
) {
unlink
(
$dirname
)
if
( -e _ );
mkpath(
$dirname
, 0, 0775 );
}
rmtree(
$object_file
)
if
( -d
$object_file
);
}
my
$object_contents
=
$self
->_compile(
$source_file
,
$path
);
$self
->write_object_file(
$object_file
,
$object_contents
);
}
method is_pure_perl_comp_path (
$path
) {
return
(
$path
=~
$self
->pure_perl_regex ) ? 1 : 0;
}
method is_top_level_comp_path (
$path
) {
return
(
$path
=~
$self
->top_level_regex ) ? 1 : 0;
}
method _load_class_from_object_file (
$compc
,
$object_file
,
$path
,
$default_parent_path
) {
my
$flags
=
$self
->_extract_flags_from_object_file(
$object_file
);
my
$parent_compc
=
$self
->_determine_parent_compc(
$path
,
$flags
)
|| (
$default_parent_path
eq
'/'
&&
$self
->component_class )
||
$self
->load(
$default_parent_path
);
my
$code
=
sprintf
(
'package %s; use Moose; extends "%s"; do("%s"); die $@ if $@'
,
$compc
,
$parent_compc
,
$object_file
);
(
$code
) = (
$code
=~ /^(.*)/s )
if
taint_is_on();
eval
(
$code
);
die
$@
if
$@;
$compc
->_set_class_cmeta(
$self
);
$self
->modify_loaded_class(
$compc
);
}
method modify_loaded_class (
$compc
) {
$self
->_add_default_wrap_method(
$compc
);
}
method write_object_file (
$object_file
,
$object_contents
) {
write_file(
$object_file
,
$object_contents
);
}
method _build_match_request_path (
$interp
:) {
my
@dhandler_subpaths
=
map
{
"/$_"
} @{
$interp
->dhandler_names };
my
$ignore_file_regex
=
'(/'
.
join
(
"|"
, @{
$interp
->autobase_names }, @{
$interp
->dhandler_names } ) .
')$'
;
$ignore_file_regex
=
qr/$ignore_file_regex/
;
my
%is_dhandler_name
=
map
{ (
$_
, 1 ) } @{
$interp
->dhandler_names };
my
@autoextensions
=
$interp
->autoextend_request_path ? @{
$interp
->top_level_extensions } : ();
return
sub
{
my
(
$request
,
$request_path
) =
@_
;
my
$path_info
=
''
;
my
$declined_paths
=
$request
->declined_paths;
my
@index_subpaths
=
map
{
"/$_"
} @{
$interp
->index_names };
my
$path
=
$request_path
;
my
@tried_paths
;
while
(1) {
my
@candidate_paths
=
(
$path_info
eq
''
&& !
@autoextensions
) ? (
$path
)
: (
$path
eq
'/'
) ? (
@index_subpaths
,
@dhandler_subpaths
)
: (
(
grep
{ !/
$ignore_file_regex
/ }
map
{
$path
.
$_
}
@autoextensions
),
(
map
{
$path
.
$_
} (
@index_subpaths
,
@dhandler_subpaths
) )
);
push
(
@tried_paths
,
@candidate_paths
);
foreach
my
$candidate_path
(
@candidate_paths
) {
next
if
$declined_paths
->{
$candidate_path
};
if
(
my
$compc
=
$interp
->load(
$candidate_path
) ) {
if
(
$compc
->cmeta->is_top_level
&& (
$path_info
eq
''
||
$compc
->cmeta->is_dhandler
||
$compc
->allow_path_info )
)
{
$request
->{path_info} =
$path_info
;
return
$compc
->cmeta->path;
}
}
}
$interp
->_top_level_not_found(
$request_path
, \
@tried_paths
)
if
$path
eq
'/'
;
my
$name
= basename(
$path
);
$path_info
=
length
(
$path_info
) ?
"$name/$path_info"
:
$name
;
$path
= dirname(
$path
);
@index_subpaths
= ();
}
};
}
method _parse_global_spec () {
my
$spec
=
shift
;
croak
"only scalar globals supported at this time (not '$spec')"
if
$spec
=~ /^[@%]/;
$spec
=~ s/^\$//;
die
"'$spec' is not a valid global var name"
unless
$spec
=~
qr/^[[:alpha:]_]\w*$/
;
return
(
'$'
,
$spec
);
}
method _add_default_wrap_method (
$compc
) {
unless
(
$compc
->meta->has_method(
'wrap'
) ) {
my
$path
=
$compc
->cmeta->path;
my
$code
=
sub
{
my
$self
=
shift
;
if
(
$self
->cmeta->path eq
$path
) {
if
(
$self
->can(
'main'
) ) {
$self
->main(
@_
);
}
else
{
die
sprintf
(
"component '%s' ('%s') was called but has no main method - did you forget to define 'main' or 'handle'?"
,
$path
,
$compc
->cmeta->source_file );
}
}
else
{
$compc
->_inner();
}
};
$compc
->meta->add_augment_method_modifier(
wrap
=>
$code
);
}
}
method _assert_absolute_path (
$path
) {
$path
||=
''
;
croak
"'$path' is not an absolute path"
unless
is_absolute(
$path
);
}
method _check_static_source_touch_file () {
if
(
my
$touch_file
=
$self
->static_source_touch_file ) {
return
unless
-f
$touch_file
;
my
$touch_file_lastmod
= (
stat
(
$touch_file
) )[9];
if
(
$touch_file_lastmod
>
$self
->{static_source_touch_lastmod} ) {
$self
->flush_code_cache;
$self
->{static_source_touch_lastmod} =
$touch_file_lastmod
;
}
}
}
method _collect_paths_for_all_comp_roots (
$code
) {
my
@paths
;
foreach
my
$root_path
( @{
$self
->comp_root } ) {
my
$root_path_length
=
length
(
$root_path
);
my
@files
=
$code
->(
$root_path
);
push
(
@paths
,
map
{
substr
(
$_
,
$root_path_length
) }
@files
);
}
return
uniq(
@paths
);
}
method _comp_class_for_path (
$path
) {
my
$classname
=
substr
(
$path
, 1 );
$classname
=~ s/[^\w]/_/g;
$classname
=~ s/\//::/g;
$classname
=
join
(
"::"
,
$self
->component_class_prefix,
$classname
);
return
$classname
;
}
method _construct_distinct_string () {
my
$number
= ++
$self
->{distinct_string_count};
my
$str
=
$self
->_construct_distinct_string_for_number(
$number
);
return
$str
;
}
method _construct_distinct_string_for_number (
$number
) {
my
$distinct_delimeter
=
"__MASON__"
;
return
sprintf
(
"%s%d%s"
,
$distinct_delimeter
,
$number
,
$distinct_delimeter
);
}
method _default_parent_path (
$orig_path
) {
my
(
$dir_path
,
$base_name
) = (
$orig_path
=~ m{^(/.*?)/?([^/]+)$} )
or
die
"not a valid absolute component path - '$orig_path'"
;
my
$path
=
$dir_path
;
my
@autobase_subpaths
=
map
{
"/$_"
} @{
$self
->autobase_names };
while
(1) {
my
@candidate_paths
=
(
$path
eq
'/'
)
?
@autobase_subpaths
: (
map
{
$path
.
$_
}
@autobase_subpaths
);
if
( (
my
$index
= first_index {
$_
eq
$orig_path
}
@candidate_paths
) != -1 ) {
splice
(
@candidate_paths
, 0,
$index
+ 1 );
}
foreach
my
$candidate_path
(
@candidate_paths
) {
if
(
$self
->comp_exists(
$candidate_path
) ) {
return
$candidate_path
;
}
}
if
(
$path
eq
'/'
) {
return
'/'
;
}
$path
= dirname(
$path
);
}
}
method _determine_parent_compc (
$path
,
$flags
) {
my
$parent_compc
;
if
(
exists
(
$flags
->{
extends
} ) ) {
my
$extends
=
$flags
->{
extends
};
if
(
defined
(
$extends
) ) {
$extends
= mason_canon_path(
join
(
"/"
, dirname(
$path
),
$extends
) )
if
substr
(
$extends
, 0, 1 ) ne
'/'
;
$parent_compc
=
$self
->load(
$extends
)
or
die
"could not load '$extends' for extends flag"
;
}
else
{
$parent_compc
=
$self
->component_class;
}
}
return
$parent_compc
;
}
method _extract_flags_from_object_file (
$object_file
) {
my
$flags
= {};
open
(
my
$fh
,
"<"
,
$object_file
) or
die
"could not open '$object_file': $!"
;
my
$line
= <
$fh
>;
if
(
my
(
$flags_str
) = (
$line
=~ /\
$flags
= json_decode(
$flags_str
);
}
return
$flags
;
}
method _flush_load_cache () {
Memoize::flush_cache(
'comp_exists'
);
Memoize::flush_cache(
'load'
);
}
method _make_request () {
return
$self
->request_class->new(
interp
=>
$self
, %{
$self
->request_params },
@_
);
}
method _object_file_for_path (
$path
) {
return
catfile(
$self
->object_dir, (
split
/\//,
$path
) ) .
$self
->object_file_extension;
}
method _source_file_for_path (
$path
) {
$self
->_assert_absolute_path(
$path
);
foreach
my
$root_path
( @{
$self
->comp_root } ) {
my
$source_file
=
$root_path
.
$path
;
return
$source_file
if
-f
$source_file
;
}
return
undef
;
}
method _top_level_not_found (
$path
,
$tried_paths
) {
my
@combined_paths
= combine_similar_paths(
@$tried_paths
);
Mason::Exception::TopLevelNotFound->throw(
error
=>
sprintf
(
"could not resolve request path '%s'; searched for components (%s) under %s\n"
,
$path
,
join
(
", "
,
map
{
"'$_'"
}
@combined_paths
),
@{
$self
->comp_root } > 1
?
"component roots "
.
join
(
", "
,
map
{
"'$_'"
} @{
$self
->comp_root } )
:
"component root '"
.
$self
->comp_root->[0] .
"'"
)
);
}
sub
_define_class_override_methods {
my
%class_overrides
= (
code_cache_class
=>
'CodeCache'
,
compilation_class
=>
'Compilation'
,
component_class
=>
'Component'
,
component_moose_class
=>
'Component::Moose'
,
component_class_meta_class
=>
'Component::ClassMeta'
,
component_import_class
=>
'Component::Import'
,
request_class
=>
'Request'
,
result_class
=>
'Result'
,
);
while
(
my
(
$method_name
,
$name
) =
each
(
%class_overrides
) ) {
my
$base_method_name
=
"base_$method_name"
;
my
$default_base_class
=
"Mason::$name"
;
Class::MOP::load_class(
$default_base_class
);
has
$method_name
=> (
init_arg
=>
undef
,
lazy_build
=> 1 );
has
$base_method_name
=> (
isa
=>
'Str'
,
default
=>
$default_base_class
);
__PACKAGE__->meta->add_method(
"_build_$method_name"
=>
sub
{
my
$self
=
shift
;
my
$base_class
=
$self
->
$base_method_name
;
Class::MOP::load_class(
$base_class
);
return
Mason::PluginManager->apply_plugins_to_class(
$base_class
,
$name
,
$self
->plugins );
}
);
}
}
__PACKAGE__->meta->make_immutable();
1;