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             'my ' . $inv . ' = shift;',
  48             $self->_inline_curried_arguments,
  49             'if (@_ == 1 || @_ == 2) {',
  50                 $self->_inline_reader_core($inv, $slot_access),
  51             '}',
  52             'elsif (@_ == 3) {',
  53                 $self->_inline_writer_core($inv, $slot_access),
  54             '}',
  55             'else {',
  56                 $self->_inline_check_argument_count,
  57             '}',
  58         '}',
  59     );
  60 }
  61
  62 sub _minimum_arguments { 1 }
  63 sub _maximum_arguments { 3 }
  64
  65 sub _inline_process_arguments {
  66     my $self = shift;
  67     my ($inv, $slot_access) = @_;
  68
  69     return (
  70         'my $offset = shift;',
  71         'my $length = @_ ? shift : length ' . $slot_access . ';',
  72         'my $replacement = shift;',
  73     );
  74 }
  75
  76 sub _inline_check_arguments {
  77     my $self = shift;
  78     my ($for_writer) = @_;
  79
  80     my @code = (
  81         'if ($offset !~ /^-?\d+$/) {',
  82             $self->_inline_throw_error(
  83                 '"The first argument passed to substr must be an integer"'
  84             ) . ';',
  85         '}',
  86         'if ($length !~ /^-?\d+$/) {',
  87             $self->_inline_throw_error(
  88                 '"The second argument passed to substr must be an integer"'
  89             ) . ';',
  90         '}',
  91     );
  92
  93     if ($for_writer) {
  94         push @code, (
  95             'if (!Moose::Util::_STRINGLIKE0($replacement)) {',
  96                 $self->_inline_throw_error(
  97                     '"The third argument passed to substr must be a string"'
  98                 ) . ';',
  99             '}',
 100         );
 101     }
 102
 103     return @code;
 104 }
 105
 106 sub _potential_value {
 107     my $self = shift;
 108     my ($slot_access) = @_;
 109
 110     return '(do { '
 111              . 'my $potential = ' . $slot_access . '; '
 112              . '@return = substr $potential, $offset, $length, $replacement; '
 113              . '$potential; '
 114          . '})';
 115 }
 116
 117 sub _inline_optimized_set_new_value {
 118     my $self = shift;
 119     my ($inv, $new, $slot_access) = @_;
 120
 121     return '@return = substr ' . $slot_access . ', '
 122                            . '$offset, $length, $replacement;';
 123 }
 124
 125 sub _return_value {
 126     my $self = shift;
 127     my ($slot_access, $for_writer) = @_;
 128
 129     return '$return[0]' if $for_writer;
 130
 131     return 'substr ' . $slot_access . ', $offset, $length';
 132 }
 133
 134 no Moose::Role;
 135
 136 1;