File Coverage

blib/lib/Sub/HandlesVia/HandlerLibrary/String.pm

Criterion	Covered	Total	%
statement	71	72	98.6
branch	2	2	100.0
condition	2	3	66.6
subroutine	43	44	97.7
pod	21	21	100.0
total	139	142	97.8

use 5.008;
use strict;
use warnings;


our $AUTHORITY = 'cpan:TOBYINK';
our $VERSION   = '0.045';

use Sub::HandlesVia::HandlerLibrary;
our @ISA = 'Sub::HandlesVia::HandlerLibrary';

use Sub::HandlesVia::Handler qw( handler );
use Types::Standard qw( Optional Str CodeRef RegexpRef Int Any Item Defined );

our @METHODS = qw(
	set get inc append prepend chop chomp clear reset
	length substr replace replace_globally uc lc fc
	starts_with   ends_with   contains   match   cmp  eq  ne  gt  lt  ge  le
	starts_with_i ends_with_i contains_i match_i cmpi eqi nei gti lti gei lei
);

my $fold = ( $] >= 5.016 ) ? 'CORE::fc' : 'lc';

	my ($me, $type) = @_;
	if ($type == Str or $type == Defined) {
		return {
			trust_mutated => 'always',
		};
	}
	return $me->SUPER::_type_inspector($type);
}

	handler
		name      => 'String:set',
		args      => 1,
		signature => [Str],
		template  => '« $ARG »',
		lvalue_template => '$GET = $ARG',
		usage     => '$value',
		documentation => "Sets the string to a new value.",
		_examples => sub {
			my ( $class, $attr, $method ) = @_;
			return join "",
				"  my \$object = $class\->new( $attr => 'foo' );\n",
				"  \$object->$method\( 'bar' );\n",
				"  say \$object->$attr; ## ==> 'bar'\n",
				"\n";
		},
}

	handler
		name      => 'String:get',
		args      => 0,
		template  => '$GET',
		documentation => "Gets the current value of the string.",
		_examples => sub {
			my ( $class, $attr, $method ) = @_;
			return join "",
				"  my \$object = $class\->new( $attr => 'foo' );\n",
				"  say \$object->$method; ## ==> 'foo'\n",
				"\n";
		},
}

	handler
		name      => 'String:inc',
		args      => 0,
		template  => '« do { my $shv_tmp = $GET; ++$shv_tmp } »',
		lvalue_template => '++$GET',
		additional_validation => 'no incoming values',
		documentation => "Performs C<< ++ >> on the string.",
}

	handler
		name      => 'String:append',
		args      => 1,
		signature => [Str],
		template  => '« $GET . $ARG »',
		lvalue_template => '$GET .= $ARG',
		usage     => '$tail',
		documentation => "Appends another string to the end of the current string and updates the attribute.",
		_examples => sub {
			my ( $class, $attr, $method ) = @_;
			return join "",
				"  my \$object = $class\->new( $attr => 'foo' );\n",
				"  \$object->$method( 'bar' );\n",
				"  say \$object->$attr; ## ==> 'foobar'\n",
				"\n";
		},
}

	handler
		args      => 1,
		name      => 'String:prepend',
		signature => [Str],
		template  => '« $ARG . $GET »',
		usage     => '$head',
		documentation => "Prepends another string to the start of the current string and updates the attribute.",
		_examples => sub {
			my ( $class, $attr, $method ) = @_;
			return join "",
				"  my \$object = $class\->new( $attr => 'foo' );\n",
				"  \$object->$method( 'bar' );\n",
				"  say \$object->$attr; ## ==> 'barfoo'\n",
				"\n";
		},
}

	handler
		name      => 'String:replace',
		args      => 2,
		signature => [ Str|RegexpRef, Str|CodeRef ],
		usage     => '$regexp, $replacement',
		template  => sprintf(
			'my $shv_tmp = $GET; if (%s) { my $shv_callback = $ARG[2]; $shv_tmp =~ s/$ARG[1]/$shv_callback->()/e } else { $shv_tmp =~ s/$ARG[1]/$ARG[2]/ } «$shv_tmp»',
			CodeRef->inline_check('$ARG[2]'),
		),
		lvalue_template => sprintf(
			'if (%s) { my $shv_callback = $ARG[2]; $GET =~ s/$ARG[1]/$shv_callback->()/e } else { $GET =~ s/$ARG[1]/$ARG[2]/ } $GET',
			CodeRef->inline_check('$ARG[2]'),
		),
		documentation => "Replaces the first regexp match within the string with the replacement string.",
		_examples => sub {
			my ( $class, $attr, $method ) = @_;
			return join "",
				"  my \$object = $class\->new( $attr => 'foo' );\n",
				"  \$object->$method( 'o' => 'a' );\n",
				"  say \$object->$attr; ## ==> 'fao'\n",
				"\n",
				"  my \$object2 = $class\->new( $attr => 'foo' );\n",
				"  \$object2->$method( qr/O/i => sub { return 'e' } );\n",
				"  say \$object2->$attr; ## ==> 'feo'\n",
				"\n";
		},
}

	handler
		name      => 'String:replace_globally',
		args      => 2,
		signature => [ Str|RegexpRef, Str|CodeRef ],
		usage     => '$regexp, $replacement',
		template  => sprintf(
			'my $shv_tmp = $GET; if (%s) { my $shv_callback = $ARG[2]; $shv_tmp =~ s/$ARG[1]/$shv_callback->()/eg } else { $shv_tmp =~ s/$ARG[1]/$ARG[2]/g } «$shv_tmp»',
			CodeRef->inline_check('$ARG[2]'),
		),
		lvalue_template => sprintf(
			'if (%s) { my $shv_callback = $ARG[2]; $GET =~ s/$ARG[1]/$shv_callback->()/eg } else { $GET =~ s/$ARG[1]/$ARG[2]/g } $GET',
			CodeRef->inline_check('$ARG[2]'),
		),
		documentation => "Replaces the all regexp matches within the string with the replacement string.",
		_examples => sub {
			my ( $class, $attr, $method ) = @_;
			return join "",
				"  my \$object = $class\->new( $attr => 'foo' );\n",
				"  \$object->$method( 'o' => 'a' );\n",
				"  say \$object->$attr; ## ==> 'faa'\n",
				"\n",
				"  my \$object2 = $class\->new( $attr => 'foo' );\n",
				"  \$object2->$method( qr/O/i => sub { return 'e' } );\n",
				"  say \$object2->$attr; ## ==> 'fee'\n",
				"\n";
		},
}

	handler
		name      => 'String:match',
		args      => 1,
		signature => [ Str|RegexpRef ],
		usage     => '$regexp',
		template  => '$GET =~ /$ARG/',
		documentation => "Returns true iff the string matches the regexp.",
		_examples => sub {
			my ( $class, $attr, $method ) = @_;
			return join "",
				"  my \$object = $class\->new( $attr => 'foo' );\n",
				"  if ( \$object->$method\( '^f..\$' ) ) {\n",
				"    say 'matched!';\n",
				"  }\n",
				"\n";
		},
}

	handler
		name      => 'String:match_i',
		args      => 1,
		signature => [ Str|RegexpRef ],
		usage     => '$regexp',
		template  => '$GET =~ /$ARG/i',
		documentation => "Returns true iff the string matches the regexp case-insensitively.",
		_examples => sub {
			my ( $class, $attr, $method ) = @_;
			return join "",
				"  my \$object = $class\->new( $attr => 'foo' );\n",
				"  if ( \$object->$method\( '^F..\$' ) ) {\n",
				"    say 'matched!';\n",
				"  }\n",
				"\n";
		},
}

	handler
		name      => 'String:starts_with',
		args      => 1,
		signature => [ Str ],
		usage     => '$head',
		template  => 'substr($GET, 0, length $ARG) eq $ARG',
		documentation => "Returns true iff the string starts with C<< \$head >>.",
}

	handler
		name      => 'String:starts_with_i',
		args      => 1,
		signature => [ Str ],
		usage     => '$head',
		template  => sprintf( '%s(substr($GET, 0, length $ARG)) eq %s($ARG)', $fold, $fold ),
		documentation => "Returns true iff the string starts with C<< \$head >> case-insensitvely.",
}

	handler
		name      => 'String:ends_with',
		args      => 1,
		signature => [ Str ],
		usage     => '$tail',
		template  => 'substr($GET, -length $ARG) eq $ARG',
		documentation => "Returns true iff the string ends with C<< \$tail >>.",
}

	handler
		name      => 'String:ends_with_i',
		args      => 1,
		signature => [ Str ],
		usage     => '$tail',
		template  => sprintf( '%s(substr($GET, -length $ARG)) eq %s($ARG)', $fold, $fold ),
		documentation => "Returns true iff the string ends with C<< \$tail >> case-insensitvely.",
}

	handler
		name      => 'String:contains',
		args      => 1,
		signature => [ Str ],
		usage     => '$str',
		template  => 'index($GET, $ARG) != -1',
		documentation => "Returns true iff the string contains C<< \$str >>.",
}

	handler
		name      => 'String:contains_i',
		args      => 1,
		signature => [ Str ],
		usage     => '$str',
		template  => sprintf( 'index(%s($GET), %s($ARG)) != -1', $fold, $fold ),
		documentation => "Returns true iff the string contains C<< \$str >> case-insensitvely.",
}

	handler
		name      => 'String:chop',
		args      => 0,
		template  => 'my $shv_return = chop(my $shv_tmp = $GET); «$shv_tmp»; $shv_return',
		lvalue_template => 'chop($GET)',
		additional_validation => 'no incoming values',
		documentation => "Like C<chop> from L<perlfunc>.",
}

	handler
		name      => 'String:chomp',
		args      => 0,
		template  => 'my $shv_return = chomp(my $shv_tmp = $GET); «$shv_tmp»; $shv_return',
		lvalue_template => 'chomp($GET)',
		additional_validation => 'no incoming values',
		documentation => "Like C<chomp> from L<perlfunc>.",
}

	handler
		name      => 'String:clear',
		args      => 0,
		template  => '«q()»',
		additional_validation => 'no incoming values',
		documentation => "Sets the string to the empty string.",
		_examples => sub {
			my ( $class, $attr, $method ) = @_;
			return join "",
				"  my \$object = $class\->new( $attr => 'foo' );\n",
				"  \$object->$method;\n",
				"  say \$object->$attr; ## nothing\n",
				"\n";
		},
}

	handler
		name      => 'String:reset',
		args      => 0,
		template  => '« $DEFAULT »',
		default_for_reset => sub { 'q()' },
		documentation => 'Resets the attribute to its default value, or an empty string if it has no default.',
}

	handler
		name      => 'String:length',
		args      => 0,
		template  => 'length($GET)',
		documentation => "Like C<length> from L<perlfunc>.",
		_examples => sub {
			my ( $class, $attr, $method ) = @_;
			return join "",
				"  my \$object = $class\->new( $attr => 'foo' );\n",
				"  say \$object->$method; ## ==> 3\n",
				"\n";
		},
}

	handler
		name      => 'String:substr',
		min_args  => 1,
		max_args  => 3,
		signature => [Int, Optional[Int], Optional[Str]],
		usage     => '$start, $length?, $replacement?',
		template  => 'if (#ARG==1) { substr($GET, $ARG[1]) } elsif (#ARG==2) { substr($GET, $ARG[1], $ARG[2]) } elsif (#ARG==3) { my $shv_tmp = $GET; my $shv_return = substr($shv_tmp, $ARG[1], $ARG[2], $ARG[3]); «$shv_tmp»; $shv_return } ',
		lvalue_template  => 'if (#ARG==1) { substr($GET, $ARG[1]) } elsif (#ARG==2) { substr($GET, $ARG[1], $ARG[2]) } elsif (#ARG==3) { substr($GET, $ARG[1], $ARG[2], $ARG[3]) } ',
		documentation => "Like C<substr> from L<perlfunc>, but is not an lvalue.",
}

for my $comparison ( qw/ cmp eq ne lt gt le ge / ) {
	no strict 'refs';

	*$comparison = sub {
		handler
			name      => "String:$comparison",
			args      => 1,
			signature => [Str],
			usage     => '$str',
			template  => "\$GET $comparison \$ARG",
			documentation => "Returns C<< \$object->attr $comparison \$str >>.",
	};

	*{ $comparison . 'i' } = sub {
		handler
			name      => "String:$comparison" . 'i',
			args      => 1,
			signature => [Str],
			usage     => '$str',
			template  => "$fold(\$GET) $comparison $fold(\$ARG)",
			documentation => "Returns C<< fc(\$object->attr) $comparison fc(\$str) >>. Uses C<lc> instead of C<fc> in versions of Perl older than 5.16.",
	};
}

for my $mutation ( qw/ uc fc lc / ) {
	no strict 'refs';
	my $mutationf = $mutation;
	if ( $mutationf eq 'fc' ) {
		$mutationf = $fold;
	}
	*$mutation = sub {
		handler
			name      => "String:$mutation",
			args      => 0,
			template  => "$mutationf(\$GET)",
			documentation => "Returns C<< $mutation(\$object->attr) >>.",
	};
}

1;