File Coverage

blib/lib/Text/HumanComputerWords.pm

Criterion	Covered	Total	%
statement	69	69	100.0
branch	23	24	95.8
condition			n/a
subroutine	12	12	100.0
pod	3	3	100.0
total	107	108	99.0

package Text::HumanComputerWords;

use strict;
use warnings;
use 5.022;
use experimental qw( signatures refaliasing );
use Ref::Util qw( is_ref is_plain_coderef );
use Carp qw( croak );

# ABSTRACT: Split human and computer words in a naturalish manner
our $VERSION = '0.04'; # VERSION


sub new ($class, @args)
{
  croak "uneven arguments passed to constructor" if @args % 2;

  my $i=0;
  while(exists $args[$i])
  {
    my $name = $args[$i];
    my $code = $args[$i+1];

    croak "argument @{[ $i+1 ]} is undef" unless defined $name;
    croak "argument @{[ $i+2 ]} is undef" unless defined $code;
    croak "argument @{[ $i+1 ]} is not a plain string" if is_ref $name;
    croak "argument @{[ $i+2 ]} is not a plain code reference" unless is_plain_coderef $code;

    $i+=2;
  }

  bless [@args], $class;
}


sub default_perl
{
  return (
    path_name => sub ($text) {
         $text =~ m{^/(bin|boot|dev|etc|home|lib|lib32|lib64|mnt|opt|proc|root|sbin|tmp|usr|var)(/|$)}
      || $text =~ m{^[a-z]:[\\/]}i
    },
    url_link => sub ($text) {
         $text =~ /^[a-z]+:\/\//i
      || $text =~ /^(file|ftps?|gopher|https?|ldapi|ldaps|mailto|mms|news|nntp|nntps|pop|rlogin|rtsp|sftp|snew|ssh|telnet|tn3270|urn|wss?):\S/i
    },
    module => sub ($text) {
         $text =~ /^[a-z]+::([a-z]+(::[a-z]+)*('s)?)$/i
    },
  );
}


sub split ($self, $text)
{
  my @result;

  frag_loop: foreach my $frag (CORE::split /\s+/, $text)
  {
    next unless $frag =~ /\w/;

    my $i=0;
    while(defined $self->[$i])
    {
      my $name = $self->[$i++];
      my $code = $self->[$i++];
      if($name eq 'substitute')
      {
        \local $_ = \$frag;
        $code->();
      }
      elsif($code->($frag))
      {
        push @result, [ $name, $frag ] unless $name eq 'skip';
        next frag_loop;
      }
    }

    word_loop: foreach my $word (CORE::split /\b{wb}/, $frag)
    {
      next word_loop unless $word =~ /\w/;
      push @result, [ word => $word ];
    }

  }

  @result;
}

1;

__END__