local-lib5/lib/perl5/MooseX/Declare/Context.pm

   1 package MooseX::Declare::Context;
   2
   3 use Moose;
   4 use Moose::Util::TypeConstraints;
   5 use Carp qw/croak/;
   6
   7 use aliased 'Devel::Declare::Context::Simple', 'DDContext';
   8
   9 use namespace::clean -except => 'meta';
  10
  11 subtype 'MooseX::Declare::BlockCodePart',
  12     as 'ArrayRef',
  13     where { @$_ > 1 and sub { grep { $_[0] eq $_ } qw( BEGIN END ) } -> ($_->[0]) };
  14
  15 subtype 'MooseX::Declare::CodePart',
  16      as 'Str|MooseX::Declare::BlockCodePart';
  17
  18 has _dd_context => (
  19     is          => 'ro',
  20     isa         => DDContext,
  21     required    => 1,
  22     builder     => '_build_dd_context',
  23     lazy        => 1,
  24     handles     => qr/.*/,
  25 );
  26
  27 has _dd_init_args => (
  28     is          => 'rw',
  29     isa         => 'HashRef',
  30     default     => sub { {} },
  31     required    => 1,
  32 );
  33
  34 has provided_by => (
  35     is          => 'ro',
  36     isa         => 'ClassName',
  37     required    => 1,
  38 );
  39
  40 has caller_file => (
  41     is          => 'rw',
  42     isa         => 'Str',
  43     required    => 1,
  44 );
  45
  46 has preamble_code_parts => (
  47     traits    => ['Array'],
  48     is        => 'ro',
  49     isa       => 'ArrayRef[MooseX::Declare::CodePart]',
  50     required  => 1,
  51     default   => sub { [] },
  52     handles   => {
  53         add_preamble_code_parts => 'push',
  54     },
  55 );
  56
  57 has scope_code_parts => (
  58     traits    => ['Array'],
  59     is        => 'ro',
  60     isa       => 'ArrayRef[MooseX::Declare::CodePart]',
  61     required  => 1,
  62     default   => sub { [] },
  63     handles   => {
  64         add_scope_code_parts => 'push',
  65     },
  66 );
  67
  68 has cleanup_code_parts => (
  69     traits    => ['Array'],
  70     is        => 'ro',
  71     isa       => 'ArrayRef[MooseX::Declare::CodePart]',
  72     required  => 1,
  73     default   => sub { [] },
  74     handles   => {
  75         add_cleanup_code_parts       => 'push',
  76         add_early_cleanup_code_parts => 'unshift',
  77     },
  78 );
  79
  80 has stack => (
  81     is          => 'rw',
  82     isa         => 'ArrayRef',
  83     default     => sub { [] },
  84     required    => 1,
  85 );
  86
  87 sub inject_code_parts_here {
  88     my ($self, @parts) = @_;
  89
  90     # get code to inject and rest of line
  91     my $inject  = $self->_joined_statements(\@parts);
  92     my $linestr = $self->get_linestr;
  93
  94     # add code to inject to current line and inject it
  95     substr($linestr, $self->offset, 0, "$inject");
  96     $self->set_linestr($linestr);
  97
  98     return 1;
  99 }
 100
 101 sub peek_next_char {
 102     my ($self) = @_;
 103
 104     # return next char in line
 105     my $linestr = $self->get_linestr;
 106     return substr $linestr, $self->offset, 1;
 107 }
 108
 109 sub peek_next_word {
 110     my ($self) = @_;
 111
 112     $self->skipspace;
 113
 114     my $len = Devel::Declare::toke_scan_word($self->offset, 1);
 115     return unless $len;
 116
 117     my $linestr = $self->get_linestr;
 118     return substr($linestr, $self->offset, $len);
 119 }
 120
 121 sub inject_code_parts {
 122     my ($self, %args) = @_;
 123
 124     # default to injecting cleanup code
 125     $args{inject_cleanup_code_parts} = 1
 126         unless exists $args{inject_cleanup_code_parts};
 127
 128     # add preamble and scope statements to injected code
 129     my $inject;
 130     $inject .= $self->_joined_statements('preamble');
 131     $inject .= ';' . $self->_joined_statements('scope');
 132
 133     # if we should also inject the cleanup code
 134     if ($args{inject_cleanup_code_parts}) {
 135         $inject .= ';' . $self->scope_injector_call($self->_joined_statements('cleanup'));
 136     }
 137
 138     $inject .= ';';
 139
 140     # we have a block
 141     if ($self->peek_next_char eq '{') {
 142         $self->inject_if_block("$inject");
 143     }
 144
 145     # there was no block to inject into
 146     else {
 147         # require end of statement
 148         croak "block or semi-colon expected after " . $self->declarator . " statement"
 149             unless $self->peek_next_char eq ';';
 150
 151         # if we can't handle non-blocks, we expect one
 152         croak "block expected after " . $self->declarator . " statement"
 153             unless exists $args{missing_block_handler};
 154
 155         # delegate the processing of the missing block
 156         $args{missing_block_handler}->($self, $inject, %args);
 157     }
 158
 159     return 1;
 160 }
 161
 162 sub _joined_statements {
 163     my ($self, $section) = @_;
 164
 165     # if the section was not an array reference, get the
 166     # section contents of that name
 167     $section = $self->${\"${section}_code_parts"}
 168         unless ref $section;
 169
 170     # join statements via semicolon
 171     # array references are expected to be in the form [FOO => 1, 2, 3]
 172     # which would yield BEGIN { 1; 2; 3 }
 173     return join '; ', map {
 174         not( ref $_ ) ? $_ : do {
 175             my ($block, @parts) = @$_;
 176             sprintf '%s { %s }', $block, join '; ', @parts;
 177         };
 178     } @{ $section };
 179 }
 180
 181 sub BUILD {
 182     my ($self, $attrs) = @_;
 183
 184     # remember the constructor arguments for the delegated context
 185     $self->_dd_init_args($attrs);
 186 }
 187
 188 sub _build_dd_context {
 189     my ($self) = @_;
 190
 191     # create delegated context with remembered arguments
 192     return DDContext->new(%{ $self->_dd_init_args });
 193 }
 194
 195 sub strip_word {
 196     my ($self) = @_;
 197
 198     $self->skipspace;
 199     my $linestr = $self->get_linestr;
 200     return if substr($linestr, $self->offset, 1) =~ /[{;]/;
 201
 202     # TODO:
 203     # - provide a reserved_words attribute
 204     # - allow keywords to consume reserved_words autodiscovery role
 205     my $word = $self->peek_next_word;
 206     return if !defined $word || $word =~ /^(?:extends|with|is)$/;
 207
 208     return scalar $self->strip_name;
 209 }
 210
 211 1;
 212
 213 __END__
 214
 215 =head1 NAME
 216
 217 MooseX::Declare::Context - Per-keyword declaration context
 218
 219 =head1 DESCRIPTION
 220
 221 This is not a subclass of L<Devel::Declare::Context::Simple>, but it will
 222 delegate all default methods and extend it with some attributes and methods
 223 of its own.
 224
 225 A context object will be instanciated for every keyword that is handled by
 226 L<MooseX::Declare>. If handlers want to communicate with other handlers (for
 227 example handlers that will only be setup inside a namespace block) it must
 228 do this via the generated code.
 229
 230 =head1 TYPES
 231
 232 =head2 CodePart
 233
 234 A part of code represented by either a C<Str> or a L</BlockCodePart>.
 235
 236 =head2 BlockCodePart
 237
 238 An C<ArrayRef> with at least one element that stringifies to either C<BEGIN>
 239 or C<END>. The other parts will be stringified and used as the body for the
 240 generated block. An example would be this compiletime role composition:
 241
 242   ['BEGIN', 'with q{ MyRole }']
 243
 244 =head1 ATTRIBUTES
 245
 246 =head2 caller_file
 247
 248 A required C<Str> containing the file the keyword was encountered in.
 249
 250 =head2 preamble_code_parts
 251
 252 An C<ArrayRef> of L</CodePart>s that will be used as preamble. A preamble in
 253 this context means the beginning of the generated code.
 254
 255 =head2 scope_code_parts
 256
 257 These parts will come before the actual body and after the
 258 L</preamble_code_parts>. It is an C<ArrayRef> of L</CodePart>s.
 259
 260 =head2 cleanup_code_parts
 261
 262 An C<ArrayRef> of L</CodePart>s that will not be directly inserted
 263 into the code, but instead be installed in a handler that will run at
 264 the end of the scope so you can do namespace cleanups and such.
 265
 266 =head2 stack
 267
 268 An C<ArrayRef> that contains the stack of handlers. A keyword that was
 269 only setup inside a scoped block will have the blockhandler be put in
 270 the stack.
 271
 272 =head1 METHODS
 273
 274 All methods from L<Devel::Declare::Context::Simple> should be available and
 275 will be delegated to an internally stored instance of it.
 276
 277 =head2 add_preamble_code_parts(CodePart @parts)
 278
 279 =head2 add_scope_code_parts(CodePart @parts)
 280
 281 =head2 add_cleanup_code_parts(CodePart @parts)
 282
 283   Object->add_preamble_code_parts (CodeRef @parts)
 284   Object->add_scope_code_parts    (CodeRef @parts)
 285   Object->add_cleanup_code_parts  (CodeRef @parts)
 286
 287 For these three methods please look at the corresponding C<*_code_parts>
 288 attribute in the list above. These methods are merely convenience methods
 289 that allow adding entries to the code part containers.
 290
 291 =head2 inject_code_parts_here
 292
 293   True Object->inject_code_parts_here (CodePart @parts)
 294
 295 Will inject the passed L</CodePart>s at the current position in the code.
 296
 297 =head2 peek_next_char
 298
 299   Str Object->peek_next_char ()
 300
 301 Will return the next char without stripping it from the stream.
 302
 303 =head2 inject_code_parts
 304
 305   Object->inject_code_parts (
 306       Bool    :$inject_cleanup_code_parts,
 307       CodeRef :$missing_block_handler
 308   )
 309
 310 This will inject the code parts from the attributes above at the current
 311 position. The preamble and scope code parts will be inserted first. Then
 312 then call to the cleanup code will be injected, unless the options
 313 contain a key named C<inject_cleanup_code_parts> with a false value.
 314
 315 The C<inject_if_block> method will be called if the next char is a C<{>
 316 indicating a following block.
 317
 318 If it is not a block, but a semi-colon is found and the options
 319 contained a C<missing_block_handler> key was passed, it will be called
 320 as method on the context object with the code to inject and the
 321 options as arguments. All options that are not recognized are passed
 322 through to the C<missing_block_handler>. You are well advised to prefix
 323 option names in your extensions.
 324
 325 =head2 strip_name_and_options
 326
 327   List Object->strip_name_and_options ()
 328
 329 This will remove an identifier plus any options that follow it from the
 330 stream. Options are things like C<is Trait>, C<with Role> and
 331 C<extends ParentClass>. Currently, only these are supported.
 332
 333 The return value is a list with two values:
 334
 335 =over
 336
 337 =item Str $name
 338
 339 The name that was read.
 340
 341 =item HashRef $options
 342
 343 The options that followed the name. This is the returned format:
 344
 345   Dict[
 346       is      => HashRef[Bool],
 347       extends => ArrayRef[ParentClass],
 348       with    => ArrayRef[Role],
 349   ]
 350
 351 =back
 352
 353 =head1 SEE ALSO
 354
 355 =over
 356
 357 =item * L<MooseX::Declare>
 358
 359 =item * L<Devel::Declare>
 360
 361 =item * L<Devel::Declare::Context::Simple>
 362
 363 =back
 364
 365 =head1 AUTHOR, COPYRIGHT & LICENSE
 366
 367 See L<MooseX::Declare>
 368
 369 =cut