File Coverage

blib/lib/Set/String.pm

Criterion	Covered	Total	%
statement	71	200	35.5
branch	13	98	13.2
condition	13	71	18.3
subroutine	16	26	61.5
pod	1	2	50.0
total	114	397	28.7

##################################################################
# Set::String
#
# See POD
##################################################################
package Set::String;
use strict;
use Carp qw/croak cluck/;
use Want;
use Set::Array;
use attributes qw(reftype);

use subs qw(chop chomp crypt defined eval index lc lcfirst ord);
use subs qw(pack pos substr uc ucfirst unpack);

# Subclass of Set::Array
BEGIN{
   use vars qw(@ISA $VERSION);
   @ISA = qw(Set::Array);
   $VERSION = '0.03';
}

#+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
# Used to decrypt an encrypted string.  Given that there's no
# way to access this variably directly (that I know of), I think
# this is a fairly safe implementation.
#+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
my $decrypted;

sub new{
   my($class,$string) = @_;
   $string = @$class if !$string && ref($class);
   my @array = CORE::split('',$string);
   undef $string;
   return bless \@array, ref($class) || $class;
}

sub chop{
   my($self,$num) = @_;

   $num ||= 1;

   if(want('OBJECT') or !(CORE::defined wantarray)){
      for(1..$num){ $self->SUPER::pop }
      return $self;
   }

   my $copy = CORE::join('',@$self);
   my @chopped;
   for(1..$num){
      push(@chopped,CORE::chop $copy);
   }

   return reverse @chopped if wantarray;
   return scalar @chopped if defined wantarray;
}

sub chomp{
   my($self,$num) = @_;

   $num ||= 1;

   if(want('OBJECT') or !(CORE::defined wantarray)){
      my $string = join '',@$self;
      for(1..$num){
         CORE::chomp $string;
      }
      @$self = split '',$string;
      undef $string;
      return $self;
   }

   my $copy = CORE::join('',@$self);
   my @chomped;
   for(1..$num){
      push(@chomped,CORE::chop $copy);
   }

   return reverse @chomped if wantarray;
   return scalar @chomped if defined wantarray;
}

sub crypt{
   my($self,$salt) = @_;

   croak("No salt provided to 'crypt()' method") unless $salt;

   $decrypted = CORE::join('',@$self);
   my $temp = CORE::crypt($decrypted,$salt);

   if(want('OBJECT') or !(defined wantarray)){
      @$self = split('',$temp);
      undef $temp;
      return $self;
   }

   return $temp;
}

sub decrypt{
   my($self) = @_;

   unless(defined $decrypted){
      cluck("Pointless to decrypt an unencrypted string.  Ignoring");
      if(want('OBJECT') or !(defined wantarray)){ return $self }
      return @$self if wantarray;
      return join('',@$self) if defined wantarray;
   }

   if(want('OBJECT') or !(defined wantarray)){
      @$self = split('',$decrypted);
      return $self;
   }

   return $decrypted;
}

# Returns 1 or 0
sub defined{
   my($self) = @_;
   return 0 unless CORE::defined($self->[0]);
   return 1;
}

############################################################################
# Eval the string as is.  The object becomes the eval'd string, replacing
# the original content (or assigning them to an lvalue).
#
# I'm considering allowing an alternate string to be eval'd, but how do I
# handle it exactly?
############################################################################
sub eval{
   my($self) = @_;
   my $result = CORE::eval CORE::join('',@$self);
   if(want('OBJECT') or !(CORE::defined wantarray)){
      @$self = CORE::split('',$result);
      undef $result;
      return $self;
   }
   return $result;
}

sub index{
   my($self,$substr,$start) = @_;

   croak("No substring provided to 'index()' method") unless $substr;

   my $pos;
   if(defined $start){
      $pos = CORE::index(CORE::join('',@$self),$substr,$start);
   }
   else{
      $pos = CORE::index(CORE::join('',@$self),$substr);
   }

   if(want('OBJECT') or !(defined wantarray)){
      return bless \$pos;
   }

   return $pos if $pos;
   return -1;
}

###############################################################
# Slightly different from standard lc in that you can specify
# the number of characters you want to lc (left to right).
###############################################################
sub lc{
  my($self,$n) = @_;

  if( (CORE::defined $n) && ($n > scalar(@$self)) ){
     croak("Argument to method 'lc()' exceeds length of string");
  }

  $n ||= scalar(@$self);
  $n -= 1;
  if($n < 0){ $n = 0 }

  if($n !~ /\d+/){
     croak("Invalid argument to 'lc()' method");
  }

  if(want('OBJECT') || !(CORE::defined wantarray)){
     for(my $m = 0; $m <= $n; $m++){
        $self->[$m] = CORE::lc($self->[$m]);
     }
     undef $n;
     return $self;
  }

  my $copy = CORE::join('',@$self);
  return CORE::lc($copy);
}

sub lcfirst{
   my($self) = @_;

   if(want('OBJECT') || !(CORE::defined wantarray)){
      $self->[0] = CORE::lc($self->[0]);
      return $self;
   }

  my $copy = CORE::join('',@$self);
  return CORE::lcfirst($copy);
}

###############################################################################
# Slightly different than standard 'ord' in that the programmer may
# specify a range of characters to get ord vals on.  Alternatively, a single
# index may be specified.
#
# By default, this method will return all ord values unless an
# index is specified.  Returns a list or list ref.
###############################################################################
sub ord{
   my($self,$num) = @_;

   cluck("Calling 'ord()' on empty array") if scalar(@$self) == 0;

   $num = scalar(@$self) unless CORE::defined $num;

   $num--;

   if(want('OBJECT') or !(defined wantarray)){
      for(0..$num){ $self->[$_] = CORE::ord($self->[$_]) }
      return $self;
   }

   my @copy = @$self;
   for(0..$num){ $copy[$_] = CORE::ord($copy[$_]) }

   return @copy if wantarray;
   return \@copy if defined wantarray;
}

# Overload the Set::Array version of pack (and unpack)
sub pack{
   my($self,$template) = @_;

   croak("No template provided to 'pack()' method") unless $template;

   if(want('OBJECT') || !(defined wantarray)){
      @$self = join('',@$self);
      @$self = CORE::pack($template,@$self);
      return $self;
   }

   my @temp = join('',@$self);
   return CORE::pack($template,@temp);
}

###########################################################################
# Returns an index or array of indices
#
# e.g. if string is "fee fie foe foo" and 'e' is the pattern, 2,3,7 and 11
# would be returned.
###########################################################################
sub pos{
   my($self,$pattern) = @_;

   croak("No pattern supplied to 'pos()' method") unless $pattern;

   my @indices;
   my $string = CORE::join('',@$self);

   while($string =~ /$pattern/g){
      my $pos = CORE::pos $string;
      push @indices, $pos;
   }

   if(want('OBJECT') or !(defined wantarray)){
      @$self = @indices;
      undef @indices;
      return $self;
   }

   return @indices if wantarray;
   return \@indices if defined wantarray;
}

sub substr{
   my($self,$offset,$length) = @_;

   croak("No offset specified for 'substr()' method") unless defined $offset;

   if( (defined $length) && ($length <= 0) ){
      croak("Nonsensical value used as length for 'substr()' method");
   }

   my $string = CORE::join('',@$self);

   my $substr;

   if($length){
      $substr = CORE::substr($string,$offset,$length);
   }
   else{
      $substr = CORE::substr($string,$offset);
   }

   if( want('OBJECT') or !(defined wantarray) ){
      @$self = CORE::split('',$substr);
      undef $string;
      return $self;
   }

   return $substr;
}

# Not yet implemented
sub unpack{
   my($self,$template) = @_;

   croak("No template provided to 'unpack()' method") unless $template;

   if( want('OBJECT') or !(defined wantarray) ){
      @$self = CORE::unpack($template,join('',@$self));
      return $self;
   }

   my $temp = join('',@$self);
   if(wantarray){ return CORE::unpack($template,$temp) }
   if(defined wantarray){ return CORE::unpack($template,$temp) }
}

# Not yet implemented
#sub quotemeta{}

# Not yet implemented
#sub split{}

# May not be implemented
#sub study{}

###############################################################
# Slightly different from standard uc in that you can specify
# the number of characters you want to uc (left to right).
###############################################################
sub uc{
  my($self,$n) = @_;

  if( (CORE::defined $n) && ($n > scalar(@$self)) ){
     croak("Argument to method 'uc()' exceeds length of string");
  }

  $n ||= scalar(@$self);
  $n -= 1;
  if($n < 0){ $n = 0 }

  if($n !~ /\d+/){
     croak("Invalid argument to 'uc()' method");
  }

  if(want('OBJECT') || !(CORE::defined wantarray)){
     for(my $m = 0; $m <= $n; $m++){
        $self->[$m] = CORE::uc($self->[$m]);
     }
     undef $n;
     return $self;
  }

  my $copy = CORE::join('',@$self);
  return CORE::uc($copy);
}

sub ucfirst{
   my($self) = @_;

   if(want('OBJECT') || !(CORE::defined wantarray)){
      $self->[0] = CORE::uc($self->[0]);
      return $self;
   }

  my $copy = CORE::join('',@$self);
  return CORE::ucfirst($copy);
}

# Not yet implemented
#sub vec {}
1;
__END__