lib/Moose/Meta/Method/Accessor/Native/String/substr.pm

   1 package Moose::Meta::Method::Accessor::Native::String::substr;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Moose::Util ();
   7
   8 our $VERSION = '1.19';
   9 $VERSION = eval $VERSION;
  10 our $AUTHORITY = 'cpan:STEVAN';
  11
  12 use Moose::Role;
  13
  14 with 'Moose::Meta::Method::Accessor::Native::Reader' => {
  15     -excludes => [
  16         qw( _generate_method
  17             _minimum_arguments
  18             _maximum_arguments
  19             _inline_process_arguments
  20             _inline_check_arguments
  21             _return_value
  22             )
  23     ]
  24     },
  25     'Moose::Meta::Method::Accessor::Native::Writer' => {
  26     -excludes => [
  27         qw(
  28             _generate_method
  29             _minimum_arguments
  30             _maximum_arguments
  31             _inline_process_arguments
  32             _inline_check_arguments
  33             _inline_optimized_set_new_value
  34             _return_value
  35             )
  36     ]
  37     };
  38
  39 sub _generate_method {
  40     my $self = shift;
  41
  42     my $inv         = '$self';
  43     my $slot_access = $self->_get_value($inv);
  44
  45     return (
  46         'sub {',
  47             $self->_inline_pre_body(@_),
  48             'my ' . $inv . ' = shift;',
  49             $self->_inline_curried_arguments,
  50             'if (@_ == 1 || @_ == 2) {',
  51                 $self->_inline_reader_core($inv, $slot_access),
  52             '}',
  53             'elsif (@_ == 3) {',
  54                 $self->_inline_writer_core($inv, $slot_access),
  55                 $self->_inline_post_body(@_),
  56             '}',
  57             'else {',
  58                 $self->_inline_check_argument_count,
  59             '}',
  60         '}',
  61     );
  62 }
  63
  64 sub _minimum_arguments { 1 }
  65 sub _maximum_arguments { 3 }
  66
  67 sub _inline_process_arguments {
  68     my $self = shift;
  69     my ($inv, $slot_access) = @_;
  70
  71     return (
  72         'my $offset = shift;',
  73         'my $length = @_ ? shift : length ' . $slot_access . ';',
  74         'my $replacement = shift;',
  75     );
  76 }
  77
  78 sub _inline_check_arguments {
  79     my $self = shift;
  80     my ($for_writer) = @_;
  81
  82     my @code = (
  83         'if ($offset !~ /^-?\d+$/) {',
  84             $self->_inline_throw_error(
  85                 '"The first argument passed to substr must be an integer"'
  86             ) . ';',
  87         '}',
  88         'if ($length !~ /^-?\d+$/) {',
  89             $self->_inline_throw_error(
  90                 '"The second argument passed to substr must be an integer"'
  91             ) . ';',
  92         '}',
  93     );
  94
  95     if ($for_writer) {
  96         push @code, (
  97             'if (!Moose::Util::_STRINGLIKE0($replacement)) {',
  98                 $self->_inline_throw_error(
  99                     '"The third argument passed to substr must be a string"'
 100                 ) . ';',
 101             '}',
 102         );
 103     }
 104
 105     return @code;
 106 }
 107
 108 sub _potential_value {
 109     my $self = shift;
 110     my ($slot_access) = @_;
 111
 112     return '(do { '
 113              . 'my $potential = ' . $slot_access . '; '
 114              . '@return = substr $potential, $offset, $length, $replacement; '
 115              . '$potential; '
 116          . '})';
 117 }
 118
 119 sub _inline_optimized_set_new_value {
 120     my $self = shift;
 121     my ($inv, $new, $slot_access) = @_;
 122
 123     return '@return = substr ' . $slot_access . ', '
 124                            . '$offset, $length, $replacement;';
 125 }
 126
 127 sub _return_value {
 128     my $self = shift;
 129     my ($slot_access, $for_writer) = @_;
 130
 131     return '$return[0]' if $for_writer;
 132
 133     return 'substr ' . $slot_access . ', $offset, $length';
 134 }
 135
 136 no Moose::Role;
 137
 138 1;