rovf has asked for the wisdom of the Perl Monks concerning the following question:

Please suggest how to improve my code. My function lchompx basically removes several occurences of a certain string from the beginning of another string. For example, $r=lchompx('abababcdef','ab') sets $r to 'bcdef'. The details, however, are tricky: .

Here is my implementation: 

sub lchompx {
  my $lchompstr=quotemeta(@_ > 0 ? $_[-1] : "\n");
  my $change_in_place=!defined wantarray;
  my $default_argument=(@_<2);
  unless($change_in_place) {
    @_ = $default_argument ? $_ : @_;
  }
  if($change_in_place && $default_argument) {
    s/^($lchompstr)*//
  } else {
    $_[0] =~ s/^($lchompstr)*//
  }
  $_[0]
}

[download]
This seems to work, butit is ugly, since the substitution expression has to be repeated for the special case "Changing $_ in place". Any idea how to code this in a nicer way?

-- 
Ronald Fischer <ynnor@mm.st>

Replies are listed 'Best First'.
Re: How can I avoid code repetition here
by moritz (Cardinal) on Oct 07, 2009 at 12:48 UTC
    I wouldn't worry too much about code duplication here. It's just one statement which is repeated twice. If you abstract it away in another function, you repeat the function call twice - no real net gain.

    What you can do is to make the regex in the substitution as simple as possible, by constructing it first: 

    my $subst_re = qr{^($lchompstr)*};
...
s/$subst_re//;

    [download]

    If you later on decide that you want to use non-capturing groups for the regex, you just have to change it one place.

    Perl 6 - links to (nearly) everything that is Perl 6.
[reply]
[d/l]
Re: How can I avoid code repetition here
by ikegami (Patriarch) on Oct 07, 2009 at 16:43 UTC

    If you're going to base something on chomp, you should use the same interface. In other words, you should work in-place. 

    sub chimpx {
    my $pat = @_ ? shift : $/; for @_ ? @_ : $_;
}

    [download]

    If you want do a non-destructive chimp, use 

    chimpx $pat, my $dst = $src;

    [download]

    Update: ok, since I didn't preserve chomp's return value, let's do it your way: 

    sub chimpx {
    my $pat = @_ ? shift : $/;
    my $targs = sub { \@_ }->( @_ ? @_ : $_ );
    @$targs = @$targs if defined(wantarray);
    s/^(?:\Q$pat\E)*// for @$targs;
    return wantarray ? @$targs : $targs->[0];
}

    [download]

    Tests: 

    use Test::More tests => 18;

{
    local $_ = 'ababac';
    my $x = 'ababac';
    chimpx 'ab', $x;
    is($_, 'ababac', 'void pat var - $_ preservation');
    is($x, 'ac',     'void pat var - result verification');
}

{
    local $_ = 'ababac';
    my $x = 'ababac';
    my $y = chimpx 'ab', $x;
    is($_, 'ababac', 'scalar pat var - $_ preservation');
    is($x, 'ababac', 'scalar pat var - arg preservation');
    is($y, 'ac',     'scalar pat var - result verification');
}

{
    local $_ = 'ababac';
    chimpx 'ab';
    is($_, 'ac', 'void pat novar - result verification');
}

{
    local $_ = 'ababac';
    my $y = chimpx 'ab';
    is($_, 'ababac', 'scalar pat novar - $_ preservation');
    is($y, 'ac',     'scalar pat novar - result verification');
}

{
    local $_ = "$/$/c";
    chimpx;
    is($_, 'c',      'void nopat novar - result verification');
}

{
    local $_ = "$/$/c";
    my $y = chimpx;
    is($_, "$/$/c", 'scalar nopat novar - $_ preservation');
    is($y, 'c',     'scalar nopat novar - result verification');
}

{
    local $/ = 'ab';
    local $_ = "$/$/ac";
    chimpx;
    is($_, 'ac', 'alt $/ - result verification');
}

{
    my $x1 = 'ababac';
    my $x2 = 'ababad';
    chimpx('ab', $x1, $x2);
    is($x1, 'ac', 'void multiple args - 1st result verification');
    is($x2, 'ad', 'void multiple args - 2nd result verification');
}

{
    my $x1 = 'ababac';
    my $x2 = 'ababad';
    my ($y1, $y2) = chimpx('ab', $x1, $x2);
    is($x1, 'ababac', 'scalar multi args - 1st arg preservation');
    is($x2, 'ababad', 'scalar multi args - 2nd arg preservation');
    is($y1, 'ac',     'scalar multi args - 1st result verification');
    is($y2, 'ad',     'scalar multi args - 2nd result verification');
}

    [download]
[reply]
[d/l]
[select]
Re: How can I avoid code repetition here
by Bloodnok (Vicar) on Oct 07, 2009 at 13:08 UTC
    Whilst taking note of moritzs reply, I would implement your requirement as (untested): 
    my $str = $change_in_place && $default_argument ? $_ : $_[0];
  $str =~ s/^($lchompstr)*//;
  $_[0];
}

    [download]
    Or possibly 
      (my $str = $change_in_place && $default_argument ? $_ : $_[0]) =~ s/
+^($lchompstr)*//;
  $_[0];
}

    [download]
    i.e. substituting either of the above for 
    .
.
.
if($change_in_place && $default_argument) {
    s/^($lchompstr)*//
  } else {
    $_[0] =~ s/^($lchompstr)*//;
  }
  $_[0];
}

    [download]
    A user level that continues to overstate my experience :-))
[reply]
[d/l]
[select]
      my $str = $change_in_place && $default_argument ? $_ : $_[0];
  $str =~ s/^($lchompstr)*//;
  $_[0];
}

      [download]
      I think this would (in the case $change_in_place && $default_argument) change only a copy of $_, not $_ itself. Maybe one could somehow use a foreach loop iterating over a one-element list, but I don't see how this would work in the general case.

      -- 
      Ronald Fischer <ynnor@mm.st>
[reply]
[d/l]
[select]
        my $str = $change_in_place && $default_argument ? $_ : $_[0];
$str =~ s/^($lchompstr)*//;

        [download]
        I think this would (in the case $change_in_place && $default_argument) change only a copy of $_, not $_ itself. Maybe one could somehow use a foreach loop iterating over a one-element list, but I don't see how this would work in the general case.
        I think that you could just take advantage of the fact that “ternary conditionals preserve lvalue-ness”, and write: 
        ($change_in_place && $default_argument ? $_ : $_[0]) =~ s/^(?:$lchomps
+tr)*//;

        [download]
        (I've taken the liberty of making your parentheses non-capturing. :-) ) I'm not sure why you end with the $_[0] statement, though—it seems that you're returning the first argument even if you ignored it (because of $change_in_place and $default_argument).
[reply]
[d/l]
[select]
Re: How can I avoid code repetition here
by bv (Friar) on Oct 07, 2009 at 16:24 UTC

    I'm not sure if this will help or hurt, but it seems to me that the more natural ordering of your arguments would be ($lchompstr, $optional_string_arg), since that would mirror the syntax of split, unpack, and others that act on $_ by default.

    print pack("A25",pack("V*",map{1919242272+$_}(34481450,-49737472,6228,0,-285028276,6979,-1380265972)))
[reply]
[d/l]
[select]
      the more natural ordering of your arguments would be ($lchompstr, $optional_string_arg)

      In hindsight you are right. Unfortunately we already have other functions in use, which have the ordering in the way may lchompx is going to be used, and I don't know yet whether I'll have the nerves to change all these consistently. Maybe I'll do one day, and certainly I would do it in the way you propose, if I had to develop all this again.

      -- 
      Ronald Fischer <ynnor@mm.st>
[reply]
[d/l]
Re: How can I avoid code repetition here
by JavaFan (Canon) on Oct 07, 2009 at 16:12 UTC
    Your code will not work if $_ is lexical. And I don't know whether that can be fixed. At first I thought you could solve it with a prototype: 
    sub lchompx (;$_)

    [download]
    (swapping the arguments if two arguments are given). But will it gives you access to a lexical $_ is called with one argument, it won't pass $_ if not called with any arguments. A prototype of _;$ will fail to do right thing if one argument is given.
[reply]
[d/l]
[select]
      Your code will not work if $_ is lexical.
      You can't make $_ a lexical: 

      $ perl -lwe "my $_='abc'; chop; print"
Can't use global $_ in "my" at -e line 1, near "my $_"
Execution of -e aborted due to compilation errors.

      [download]

      -- 
      Ronald Fischer <ynnor@mm.st>
[reply]
[d/l]
        You have been able to do that for the past 22 months: 
        $ perl -wle 'my $_ = "abc"; chop; print'
ab
$

        [download]
[reply]
[d/l]

Back to Seekers of Perl Wisdom