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