view release on metacpan or  search on metacpan

lib/Dallycot/Library/Core/Strings.pm  view on Meta::CPAN

use Promises qw(deferred);

use Dallycot::Library::Core          ();
use Dallycot::Library::Core::Streams ();

ns 'http://www.dallycot.net/ns/strings/1.0#';

uses 'http://www.dallycot.net/ns/loc/1.0#',
     'http://www.dallycot.net/ns/core/1.0#',
     'http://www.dallycot.net/ns/streams/1.0#';

#====================================================================
#
# Basic string functions

define
  'string-contains?' => (
  hold => 0,
  arity => 2,
  options => {}
  ),
  sub {
  my ( $engine, $options, $string, $patt ) = @_;

  if ( !$string -> isa('Dallycot::Value::String') ) {
    croak 'The first argument of string-contains? must be a string';
  }
  if ( !$patt -> isa('Dallycot::Value::String') ) {
    croak 'The pattern for string-contains? must be a string';
  }

  return Dallycot::Value::Boolean -> new(
    index($string -> value, $patt -> value) != -1
  );
};

define
  'string-split' => (
  hold    => 0,
  arity   => [1,3],
  options => {}
  ),
  sub {
  my ( $engine, $options, $string, $patt, $max_count ) = @_;

  if ( !$string ) {
    return Dallycot::Value::EmptyStream->new;
  }
  my @bits;
  my $source = $string -> value;
  if(!$patt) {
    @bits = split( /\s+/, $source );
  }
  else {
    my $count;
    if($max_count) {
      if ( $max_count->isa('Dallycot::Value::Numeric') ) {
        $count = $max_count->value->numify;
      }
      else {
        croak 'Limit for string-split must be numeric';
      }
    }
    if($patt -> isa('Dallycot::Value::String')) {
      if($count) {
        @bits = split($patt -> value, $source, $count);
      }
      else {
        @bits = split($patt -> value, $source);
      }
    }
    else {
      croak 'Pattern for string-split must be a string';
    }
  }
  return Dallycot::Value::Vector->new(
    map {
      Dallycot::Value::String->new($_, $string->lang)
    } @bits
  );
};

define
  'string-take' => (
  hold    => 0,
  arity   => 2,
  options => {}
  ),
  sub {
  my ( $engine, $options, $string, $spec ) = @_;

  if ( !$string ) {
    my $d = deferred;
    $d->resolve( $engine->UNDEFINED );
    return $d->promise;
  }
  elsif ( !$spec ) {
    my $d = deferred;
    $d->resolve( $engine->UNDEFINED );
    return $d->promise;
  }
  else {
    if ( $spec->isa('Dallycot::Value::Numeric') ) {
      my $length = $spec->value->numify;
      return $string->take_range( $engine, 1, $length );
    }
    elsif ( $spec->isa('Dallycot::Value::Vector') ) {
      given ( scalar(@$spec) ) {
        when (1) {
          if ( $spec->[0]->isa('Dallycot::Value::Numeric') ) {
            my $offset = $spec->[0]->value->numify;
            return $string->value_at( $engine, $offset );
          }
          else {
            my $d = deferred;
            $d->reject("Offset must be numeric");
            return $d->promise;
          }
        }
        when (2) {
          if ( $spec->[0]->isa('Dallycot::Value::Numeric')
            && $spec->[1]->isa('Dallycot::Value::Numeric') )
          {
            my ( $offset, $length )
              = ( $spec->[0]->value->numify, $spec->[1]->value->numify );

            return $string->take_range( $engine, $offset, $length );
          }
          else {
            my $d = deferred;
            $d->reject("string-take requires numeric offsets");
            return $d->promise;
          }