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