view release on metacpan or  search on metacpan

lib/Text/Glob/DWIW.pm  view on Meta::CPAN

sub _nth (&$@)  { my ($f,$n)=splice@_,0,2; first { $f->($_)&&--$n<0 } @_ }
sub _addparens  { $_[0]=~/^$ch{'('}*[|] | [|]$ch{')'}*$ | \).*\(/xs ? "(?:$_[0])" : $_[0] }
sub __funwa(;$) { my ($name,$wa)=(caller 1+($_[0]//0))[3,5];$name=~s/^.*:://;($name,$wa)}
#~~ element count & guess
sub __mlen ($$) { my@l=map length,@_; my$r= $l[0] ne $l[1] ? max @l :
        length +("$_[0]$_[1]"=~/^(.*)(.*)(?=.{$l[0]}$)(?:\1).*$/s)[1];--$r if $r>0&&$r<4; }
# ^- mattered length, ignore same start, => 26**_mlen(...) = a roughly guess for range size
#~~ errors
sub _2wide ($$) { my($mx,$v)=@_;croak"Step size too wide (>$mx)." if$mx&&$mx>0&&$v&& $mx<$v}
sub _2much($$;$){ my($br,$v,$d)=@_;croak "Too much (>$br)." if$br&& $br<abs $v/max 1,$d//1 }
sub _2void ()   { my($n,$wa)=__funwa 1; $wa//croak "Useless call of '$n' in void context." }
sub _2opt (;$)  { croak join ': ','Error in option setting',grep $_,@_ }
#~ option handling
sub _hinthash() { my($l,$f,$hh)=0; do{($f,$hh)=(caller++$l)[3,10]} while $f=~/^_|::_/; $hh }
sub _uuid ()    { int rand max ~0,2**32 };
sub _hval ($$)  {exists$_[0]->{$_[1]}&&$_[0]->{$_[1]}} # (+$) not under 5.10
sub _opt_get { @_ ? (_reft($_[0])eq'HASH' ?shift : _reft($_[$#_])eq'HASH' ?pop : ()) : () }
sub _opt_def { +{qw'anchored 1  capture 0  tree 0  chunk 0   range 1  star 1  invert 0
                    anchors  0  pattern 0  case 1  minus 1   break 0  twin 1  quant  1
                   backslash 0 stepsize 0  last 1 greedy 0            mell 0 default 0',
                 (map {$_=>''} qw'unhead unchar charclass'), rewrite=>undef, tilde=>undef} }
             # not planned: braces 1  parens/parentheses 0  sort 0  brackets 1?
sub _opt_chk ($;$$)
{ my ($opt,$adef,$fillup)=@_; $adef||=_opt_def; $fillup//=1;
  eval { lock_keys %$opt, keys %$adef; %$opt=(%$adef,%$opt) if $fillup; $opt } or do
     { croak "Unknown option '$1'." if $@=~/^Hash\s*has\s*key\s*'(.*?)'/; _2opt $@ }
}
our (%_prv,%_opt); # inside-out, lexical
sub _opt_lex (;$)
{ my $hh=$_[0]||_hinthash; my $hv=_hval $hh,$keyH;                         my @ohist;
  for (my$i=$hv; $i; $i=_hval\%_prv,$i) { unshift @ohist,$_opt{$i} if _hval \%_opt,$i }
  my $lexcfg={ map %$_,_opt_def,@ohist };
  wantarray ? %$lexcfg : $lexcfg; # X: silent fallback to _opt_def if lex-scope...
}
sub textglob_options
{ my $new=@_<2?shift:{@_}; my $hh=_hinthash; my $hv; _2void unless $new;
  croak "Options must be given as hash(ref)." if $new && _reft($new) ne 'HASH';
  _2opt 'Scope of use declaration not found.' unless $hv=_hval $hh,$keyH;
  my $lexcfg=_opt_lex $hh if defined wantarray;
  $_opt{$hv}={$_opt{$hv}?%{$_opt{$hv}}:(),%$new} if $new; # ensure copy of $new
  wantarray ? %$lexcfg : $lexcfg;
}
sub _opt     # use: my %o=&_opt; => shift/pop;  _opt @_ => don't shift/pop
{ my $opt=&_opt_get//{};
  if (keys %$opt==keys %{+_opt_def}  || $opt->{default}) { _opt_chk $opt }
  else                                         { _opt_chk($opt,_opt_lex) }
  for ($opt->{greedy})   { $_||=0; $_=1 if /[^0-9]/; $_=2 if $_>2 } # only 0,1,2
  for ($opt->{stepsize}) { $_=0 if $_ && /[^-+0-9]/ }
  for (qw'range{[ anchored^$az anchors^$az twin***** star******?','quant#,##')
     { my($k,$v)=split/\b/,$_,2; $_= $_&&!/[\Q$v\E]|^[0,\s]*$/ ? $v : $_//'' for$opt->{$k} }
  for (@$opt{qw'unchar unhead backslash'})
     { $_//=''; $_=join'',textglob_expand $_,{default=>1} if /.../&&/^$charclass$/ }
  wantarray ? %$opt : $opt;
}
sub _opt_fmt     # use: my %o=&_opt; => shift/pop;  _opt @_ => don't shift/pop
   { my $opt=&_opt_get//{}; _opt_chk $opt,{qw'paired 0'}; wantarray ? %$opt : $opt }

#~~ import-export                           # v- every 'use' hold a option hash forever
{ sub import   { $INC{'TGDWIW.pm'}=__FILE__ if first {/^:use$/} @_; # use-abbr
                 splice @_,0,1,$pkg if $_[0] eq 'TGDWIW';   my $opt=&_opt_get;
                 my $p=$^H{$keyH}; $^H{$keyH}=my$dk=_uuid;   $_prv{$dk}=$p if $p;
                 $_opt{$dk}=_opt_chk $opt,0,0 if $opt; goto &Exporter::import }
  sub unimport { undef $^H{$keyH} }           # at compile-time: so we can't free any data;
  *TGDWIW::import=\&import; *TGDWIW::unimport=\&unimport; #\ also not called often anyway
}                                                # i: refaddr \%^H is same for same scope
#~~ inner of range
sub _succ ($;$) # wrapping magic++ => # 1a..12g, 1a1..2b2 works (test: {9y-10b})
{ my($val,$to)=@_; $^R=[]; my $carry=1; #use re 'eval';
  return ++$val if $val!~/^(?:([a-z]+[0-9]*|[0-9]+)(?{ [@{$^R},$^N] }))*$/xis; #<< fallback
  my $r=join '',reverse               # ^- no ...|| @{$^R}<=1 optimization,because of carry
    map { my $p=$_;++$p if $carry; $carry=substr $p,0,my$d=length($p)-length; substr$p,$d }
    reverse @{$^R};                                 return "$carry$r" unless $to && $carry;
    no warnings 'substr';    my $t=substr $to,-1-length$r,1; $carry=__toA($t,$carry) if $t;
    "$carry$r"
}
sub __le   ($$) { (length($_[0])<=>length($_[1])||$_[0]cmp$_[1])<=0 }
sub __toA       { (local$_,my$q)=@_;"$_$q"=~/$pure/?$q:/[0-9]/?1:/[a-z]/?'a':/[A-Z]/?'A':$q}
sub __toZ  ($$) { (local$_,my$q)=@_;"$_$q"=~/$pure/?$q:/[0-9]/?9:/[a-z]/?'z':/[A-Z]/?'Z':$q}
sub _prep  ($$) { my($f,$t)=@_;for my $p (1..length$f)   #\ a-9 aa-b9 0-a => a-z aa-bz 0-9
                                 { $_=__toZ substr($f,-$p,1),$_ for substr$t,-$p,1 }; $t }
sub __formnumber{ $_[0]=~/^[+-]?(0\d*)/ ? '%0'.length($1).'s' : '%s' }
sub __formpat ($) # so ranges can have punctation in it...
{ my ($inp)=@_; my @def=($inp,sub{$_[0]});                    my $pu='[[:punct:]]';
  return @def if $inp=~/\\/ || $inp=~/^.$/s; # don't know how to handle '\' reliable
  my $beg= $inp=~s/^($pu++)//sg ? $1 : '';   # $3-$5000, (0)-(1000) ...
  (my $val=$inp)=~s/$pu++//sg;                            my $pat=$inp; my $wrap=0;
  $pat=~s{([^[:punct:]]++)$pu*}{++$wrap; my$l=length $1; my$l2=$l<3?'':'{1,'.($l-1).'}';
                  !pos $pat ? '(.+))?' : "(.{$l})|(^.$l2))?" }seg;
  $pat=('(?:' x $wrap).$pat;                      my $re=qr/^(?:\Q$beg\E)?$pat\z/s;
  (my $frm=$inp)=~s/(%|[^[:punct:]]++)/$1 eq'%' ? '%%' : '%s'/seg; $beg=~s/%/%%/sg;
  return $val eq $def[0] || $val eq '' ? @def :
    ($val,sub{ my$c=my@parts=grep defined$_, $_[0]=~/$re/;   # 1_1_1-1
               (my $f=$frm)=~s/.*( (?:$pu*? (?<!%)(?:%%)*?%s $pu*?){$c} )$/$1/xsg if $c;
               $c ? sprintf $beg.$f,@parts : undef })
}
sub _updwn ($$$$;$)
{ my ($br,$ssz, $f,$t,$step)=@_; $step||=1; my @r; return $f if $f eq $t;
  if ("$f$t"=~/^([[:punct:]])\1*\z/)
  { if (($f=length$f)<=($t=length$t)) # *****-*
         {while ($f<=$t) { push @r,$1 x$f; $f+=$step; _2much$br,@r } }
    else {while ($t<=$f) { push @r,$1 x$f; $f-=$step; _2much$br,@r } }
  }
  elsif ($f=~/$int/ && $t=~/$int/)
  { my $x=__formnumber abs($f)<abs($t)?$f:$t; # 01..10 vs. 1..10
    if ($f<=$t)
         {while ($f<=$t) { push @r,sprintf$x,$f;$f+=$step; _2much$br,@r } }
    else {while ($t<=$f) { push @r,sprintf$x,$f;$f-=$step; _2much$br,@r } }
  } else
  { my ($f1,$pf)=__formpat($f); my ($t1,$pt)=__formpat($t);
    return $step>1 ? $f : ($f,$t) if ($f1 eq $t1 && $f ne $t); # 1#1,1'1
    my $mod=0; my $last; my $fnext;
    my ($f2,$t2,$do)=(__le $f1,$t1)
       ?($f1,$t1, sub{ push    @r,$fnext->($_[0],$pf,$pt) if !($mod%=$step)++ })
       :($t1,$f1, sub{ unshift @r,$fnext->($_[0],$pt,$pf) if !($mod%=$step)++ });
    my $chlen=length($f2) - (length($f2)==length$t2);
    $fnext=sub{ my($v,$f,$g)=@_; _2much$br,@r,$ssz; # only here, doesn't matter 4 int
                $last=(defined$last && length($v)>$chlen ? $g->($v):()) // $f->($v) };
    my $nm=$f2=~/$int/; my $t3=_prep $f2, $t2; $t3=$t2 if $t3 eq $f2; # aa-z9
    while (__le$f2,$t3)                          # v- ..,undef$last,.. vs. ..,--$mod,..
      {$do->($f2);$f2=_succ($f2,$t3); $do->($t2),undef$last,last if !$nm&&$f2=~/$int/; }
    #$do->($t2) if defined$last&& !__le($t2,$last)&&!__le($f2,$t2) && ($t2 eq $t3 ||@r<2);