File Coverage

blib/lib/Convert/Context.pm

Criterion	Covered	Total	%
statement	378	417	90.6
branch	172	224	76.7
condition	41	55	74.5
subroutine	39	42	92.8
pod	24	27	88.8
total	654	765	85.4

#
# $Id: Context.pm,v 1.77 1998/10/03 22:21:23 martin Exp $
#
# Convert::Context, an attributed text data type
#
# Copyright (C) 1996, 1997 Martin Schwartz
#
#    This program is free software; you can redistribute it and/or modify
#    it under the terms of the GNU General Public License as published by
#    the Free Software Foundation; either version 2 of the License, or
#    (at your option) any later version.
#
#    This program is distributed in the hope that it will be useful,
#    but WITHOUT ANY WARRANTY; without even the implied warranty of
#    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#    GNU General Public License for more details.
#
#    You should have received a copy of the GNU General Public License
#    along with this program; if not, you should find it at:
#
#    http://wwwwbs.cs.tu-berlin.de/~schwartz/pmh/COPYING
#

package Convert::Context;
use strict;
my $VERSION=do{my@R=('$Revision: 1.77 $'=~/\d+/g);sprintf"%d."."%d"x$#R,@R};

sub CS () {"C"};
my $Debug = 0;
my $default_acmp = sub { $_[0] cmp $_[1] };

sub acmp       { shift->_member("A", @_) }
sub docmode    { shift->_mode(@_ ? ("DOC"):())  eq "DOC" }
sub textmode   { shift->_mode(@_ ? ("TEXT"):()) eq "TEXT" }

sub _attrib    { shift->_member("ATT", @_) }
sub _charsize  { shift->_member(CS, @_) }
sub _mode      { shift->_member("MOD", @_) }
sub _offset    { shift->_member("O", @_) }
sub _text      { shift->_member("T", @_) }

sub _member { my $S=shift; my $n=shift; $S->{$n}=shift if @_; $S->{$n} }

sub append {
#
# $Ct1 = $Ct1 -> append (($Ctn||$strn||$strRn)*)
#
   my $S = shift;
   my $acmp = $S->acmp();

   my ($Ct2, $o);
   while (@_) {
      $Ct2 = shift;
      if (!ref($Ct2)) {
         ${$S->_text} .= $Ct2;
         next;
      } elsif (ref ($Ct2) =~ /^SCALAR$/) {
         ${$S->_text} .= $$Ct2;
         next;
      }
      $o = $S->length();

      if (!$o) {
         ${$S->_text} .= ${$Ct2->_text};
         @{$S->_offset}=();
         @{$S->_attrib}=();
         push (@{$S->_offset}, @{$Ct2->_offset});
         push (@{$S->_attrib}, @{$Ct2->_attrib});
         next;
      }

      ${$S->_text} .= ${$Ct2->_text};
      next if $S->textmode;
      my $cs   = $S->_charsize;
      my $cs2  = $Ct2->_charsize;
      my $flag = ($cs==$cs2);

      if (! &$acmp ($S->_attrib->[$#{$S->_attrib}], $Ct2->_attrib->[0])) {
         my $end = $#{$Ct2->_offset};
         push (@{$S->_offset}, map
            {$flag ? $_+$o : $o+$_/$cs2*$cs} @{$Ct2->_offset}[1..$end]
         );
         push (@{$S->_attrib}, @{$Ct2->_attrib}[1..$end]);
      } else {
         push (@{$S->_offset}, map
            {$flag ? $_+$o : $o+$_/$cs2*$cs} @{$Ct2->_offset}
         );
         push (@{$S->_attrib}, @{$Ct2->_attrib});
      }
   }
   $S;
}

sub attrib {
#
# (1)           $attrib = $Ct  -> attrib ($o, [$attrib])
# (2) ([@attrib], [@o]) = $Ct  -> attrib ($o, $l)
# (3)           $attrib = $Ct  -> attrib ($o, $l, $attrib)
# (4)        1 || undef = $Ct  -> attrib ($o1, $l1, [@attrib], [@o])
# (5)        1 || undef = $Ct  -> attrib ($o1, $l1, [@attrib], [@o], $o2, $l2)
# (6)        1 || undef = $Ct1 -> attrib ($o, $l, $Ct2)
# (7)        1 || undef = $Ct1 -> attrib ($o1, $l1, $Ct2, $o2, $l2)
#
   my $S = shift;
   return undef if $S->textmode;

   if (!$#_ || ($#_==1) && ref($_[1])) {
      # case (1)
      my $o = @_ ? shift : 0;
      $o += $S->length() if $o<0;
      return undef if $o<0;

      my $i = $S->_index($o);
      $S->_attrib->[$i] = shift->[0] if @_;
      return $S->_attrib->[$i];
   }

   my $o1 = @_ ? shift : 0;
   $o1 += $S->length() if $o1<0;
   return undef if $o1<0;
   my $l1 = @_ ? shift : 0;
   if (!@_) {
      # case (2)
      my $il = $S->_index($o1) || 0;
      my $ir = $S->_index($o1+$l1-1) || 0;
      return (
         [@{$S->_attrib}[$il, $il+1..$ir]],
         [0, map $_-$o1, @{$S->_offset}[$il+1..$ir]]
      );
   }

   my $ref = @_ ? ref($_[0]) : "";
   if (!$ref) {
      # case (3)
      my $attrib = @_ ? shift: 0;
      return $S->_subattr($o1, $l1, [$attrib], [0]) && $attrib;
   } elsif ($ref =~ /^ARRAY$/) {
      # case (4) and (5)
      return $S->_subattr($o1, $l1, @_);
   } else {
      # case (6) and (7)
      my $Ct2 = shift;
      push (@_, $_[2]) if $#_==2;
      return $S->_subattr($o1, $l1, $Ct2->_attrib, $Ct2->_offset, @_);
   }

   undef;
}

sub charsize {
   my ($S, $cs) = @_;
   my $cs_orig = $S->_charsize();
   return $cs_orig if !$cs || $cs_orig==$cs;
   my $O = $S->_offset;
   for (@$O) {
      $_*=$cs_orig; $_/=$cs;
   }
   $S->_charsize($cs);
}

sub chunks {
#
# [ [$str1, $attr1], [$str2, $attr2], [$str3, $attr3] ...] = $S->chunks
#
   my $S = shift;
   my $A = $S->_attrib;
   my $O = $S->_offset;
   my $T = $S->_text;
   my $n = $#{$S->_offset};
   my $left = 0;
   my $cs = $S->_charsize;
   [  map (
         [substr($$T, $O->[$_-1]*$cs, $O->[$_]*$cs-$O->[$_-1]*$cs), $A->[$_-1]],
         (1..$n)
      ),
      [ substr($$T, $O->[$n]*$cs, $S->length()*$cs-$O->[$n]*$cs), $A->[$n] ]
   ];
}

sub clone {
   my $S = shift;
   my $N = $S->new(
      $S->_charsize,
      \(my $text = ${$S->_text}),
      [@{$S->_attrib}],
      [@{$S->_offset}],
      1
   );
   $N->_mode($S->_mode);
   $N->acmp($S->acmp);
   $N;
}

sub dump {
   my ($S, $mode) = @_;
   print "Dumping (mode $mode), object ".
      (($S =~ /(^[^=]*)/) && $1).
      "\n" . ${$S->sdump($mode)} . "Done.\n\n\n"
   ;
   $S;
}

sub eq {
#
# 1||0 = $Ct1 -> eq ($Ct2)
#
   my ($S, $Ct2) = @_;
   return undef if !$Ct2;
   return 1 if $S eq $Ct2;
   return 0 if !ref($Ct2);
   return 0 if ref($S) ne ref($Ct2);
   return 0 if $S->_charsize != $Ct2->_charsize;
   return 0 if ${$S->_text} ne ${$Ct2->_text};
   $S->_cmp_attribs($Ct2);
}

sub index {
#
# $pos = $Ct -> index ($string [,$pos])
#
   my ($S, $str, $pos) = @_;
   my $cs = $S->charsize;
   my $i = ($pos||0) * $cs - $cs;
   while (1) {
      $i = index(${$S->_text}, $str, $i+(($i%$cs)||$cs));
      return $i if $cs == 1;
      return $i if $i == -1;
      if (!($i % $cs)) {
         return $i / $cs;
      }
   }
}

sub join {
#
# $Ct  = Convert::Context -> join ($expr, ($Ctn||$strn||$strRn)*)
#
# $Ct1 = $Ct1 -> join ($expr, ($Ctn||$strn||$strRn)*)
#
   my $S = shift;
   return undef if !@_;
   my $expr = shift;
   my @extra = ();

   if (!ref($S)) {
      $S = $S -> new (eval {$_[0]->charsize});
   } else {
      @extra = ($expr);
   }
   return $S if !@_;

   $S->append( @extra, shift, map {($expr, $_)} @_ );
}

sub lc      { shift->_apply_f_to_t("CORE::lc") }
sub lcfirst { shift->_apply_f_to_t("CORE::lcfirst") }

sub length {
#
# $len = $Ct -> length ()
#
   length(${$_[0]->_text}) / $_[0]->_charsize();
}

sub ne {
   !shift->eq(@_);
}

sub new {
   my $proto = shift;
   my $S = bless ({}, ref($proto) || $proto);
   $S->docmode (1);
   $S->acmp ($default_acmp);

   if (@_ && !ref($_[0])) {
      $S->_charsize(shift());
   } else {
      $S->_charsize(1);
   }

   if (@_ && ref($_[0])=~ /^ARRAY/) {
      $S->_entry(@{shift()});
      for (@_) { $S->append( $S->new(@{$_}) ) }
   } else {
      $S->_entry(@_);
   }

   # Offsets and Attribute pairs doesn't match
   return 0 if $#{$S->_offset} != $#{$S->_attrib};

   $S;
}

sub replace {
   my ($S, $pattern, $replace, $option) = @_;
   return 0      if !defined $pattern;
   $replace = "" if !defined $replace;
   $option  = "" if !defined $option;

   my @L = ();
   my %R_Context = ();
   my %R_scalar  = ();
   my $array = "";
   my $code = "";
   my $Ct = "";
   my $s_pattern = "";
   my $s_replace = "";

   if ($array = ref ($pattern) =~ /^ARRAY/) {
      for (0..$#{$pattern}) {
         if (ref($pattern->[$_])) {
            $R_Context {${$pattern->[$_]->_text}} = $_;
            $s_pattern .= ${$pattern->[$_]->_text};
         } else {
            $R_scalar {$pattern->[$_]} = $_;
            $s_pattern .= $pattern->[$_];
         }
         $s_pattern .= '|';
      };
      $s_pattern =~ s/\|$//;
   } elsif (ref ($pattern)) {
      $Ct = $pattern;
      $s_pattern = ${$pattern->_text};
      $code = (ref ($replace) =~ /^CODE/);
   } else {
      $s_pattern = $pattern;
      $code = (ref ($replace) =~ /^CODE/);
   }
   $s_replace=$replace;

   my ($i, $m, $n, $oc, $lc);
   my $cs = $S ->_charsize;
   $n = eval '${$S->text} =~ '.
      's#$s_pattern#{
         $oc=CORE::length($`); return $& if ($oc%$cs); $oc/=$cs;
         $lc=CORE::length($&);
         if ($lc%$cs) {
            $lc+=($lc%$cs);
            $m = CORE::substr(${$S->_text}, $oc*$cs, $lc);
         } else {
            $m = $&;
         }
         $lc/=$cs;
         if ($array) {
            if (defined ($i = $R_Context{$&})) {
               $Ct = $pattern->[$i];
               $s_replace = $replace->[$i];
            } elsif (defined ($i = $R_scalar{$&})) {
               $Ct = "";
               $s_replace = $replace->[$i];
            } else {
               $Ct = "";
               $s_replace = "";
            }
            $code = (ref ($s_replace) =~ /^CODE/);
         }
         if (!$Ct || $Ct->_cmp_attribs($S->attrib($oc, $lc))) {
            push (@L, [$oc, $lc, $code ? &$s_replace($m, $S, $oc):$s_replace]);
         }
         $&;
      }#e'.($option||"")
   ;
   while (@L) {
      $S->substr(@{pop(@L)});
   }
   $n;
}

sub sdump {
#
# \$buf = $S->sdump($mode)
#
   my ($S, $mode) = @_;
   my $n;
   my $buf="";

   if ($mode) {
      $buf .= "\"";
      for (@{$S->chunks}) {
         $buf .= sprintf ("<%s>", $_->[1]) if defined $_->[1];
         $buf .= $_->[0];
      }
      $buf .= "\"\n";
   } else {
      $buf .= "   text => \"" . ${$S->_text} . "\"\n";
   }
   if ($S->charsize()!=1) {
      $buf .= sprintf ("   charsize=%d, textlen=%d\n",
         $S->charsize(), $S->length()
      );
   }
   $n = $#{$S->_attrib}+1;
   $buf .= sprintf ("   attrib => [ " . ("%3s " x $n) . "]\n", @{$S->_attrib});
   $n = $#{$S->_offset}+1;
   $buf .= sprintf ("   offset => [ " . ("%03x " x $n) . "]\n", @{$S->_offset});
   \$buf;
}

sub split {
#
# @Ct = $Ct -> split ($pattern, $option, $limit)
#
   my ($S, $pattern, $option, $limit) = @_;
   my @L = ();

   my $Ct = ref ($pattern) ? $pattern : "";
   $pattern = ${$Ct->_text} if $Ct;
   my $cs = $S->_charsize;

   my $o = 0;
   my ($l, $ml);
   eval '${$S->text} =~ '.
      's#$pattern#{
         $l = CORE::length($`);
         $ml = CORE::length($&); $ml+=($ml%$cs); $ml/=$cs;
         if (!($l % $cs) &&
            (!$Ct ||
               $Ct->_cmp_attribs($S->attrib($l/$cs, $ml))
            )
         ) {
            push (@L, $S->substr($o, $l/$cs-$o));
            $o = ($l/$cs+$ml);
         }
         $&;
      }#e'."g".($option||"")
   ;
   push (@L, $S->substr($o));
   if ($limit) {
      # no better idea, how to limit, sigh...
      @L[0..$limit-1];
   } else {
      # Split strips "trailing null fields", when no $limit given.
      while (@L) { last if $L[$#L]->length(); pop(@L) }
      @L;
   }
}

sub substr {
#
# $Context1 = $Context1 -> substr (
#    $o1||undef, $l1||undef, $Context2, $o2||undef, $l2||undef
# )
#
# Substitutes $Context1->substr($o1, $l1) with $Context2->substr($o2, $l2)
#
# o1|o2: undef => 0
# l1|l2: undef => length($Contextn)
#
   my ($S, $o1, $l1, $Ct2, $o2, $l2) = @_;

   my $len1 = $S->length();
   $o1 = 0 if !defined $o1;
   $o1 += $len1 if $o1<0;
   return undef if $o1<0;
   my $cs = $S->_charsize;

   $l1 = $len1 - $o1 if !defined $l1;

   #
   # Case 1: Return a new partial Context
   #
   if (!$Ct2) {
      return $S->new(
         $cs,
         \(my $text = substr(${$S->_text}, $o1*$cs, $l1*$cs)),
         $S->attrib($o1, $l1),
         1
      );
   }

   my $len2;

   #
   # Case 2: Substitute argument is a simple string
   #
   if (!ref $Ct2) {
      $len2 = CORE::length($Ct2);
      $o2 = 0 if !defined $o2;
      $o2 += $len2 if $o2<0;
      $l2 = $len2 - $o2 if !defined $l2;

      # Special case: same string lengths: change only string.
      if ($l1*$cs == $l2) {
         substr(${$S->_text}, $o1*$cs, $l1*$cs) =
            substr($Ct2, $o2, $l2)
         ;
         return $S;
      }
      # Normal case: different string lengths: create Context on the fly.
      $Ct2 = $S->new(
         $S->_charsize, \substr($Ct2, $o2, $l2), $S->attrib($o1, $l1)
      );
      $o2 = 0;
      $l2 /= $cs;
   }

   #
   # Case 3: Substitute argument is another Context
   #
   #
   # Note: The following 3 lines could do a similar job like the messy
   # looking code afterwards. Everything would look fine and easy.
   # The problem: That code would construct a new Context and would not
   # change the old Context; further more I suspect it to be slower.
   #
   # return = $S->substr(0, $o1)
   #    ->join($Ct2)
   #    ->join($S->substr($o1+$l1))
   # ;
   #

   my $cs2 = $Ct2->_charsize;
   $len2 = $Ct2->length();
   $o2 = 0 if !defined $o2;
   $o2 += $len2 if $o2<0;
   $l2 = $len2 - $o2 if !defined $l2;

   if (!$S->textmode) {
      $S->_subattr($o1, $l1, $Ct2->_attrib, $Ct2->_offset, $o2, $l2, $l2);
   }

   substr(${$S->_text}, $o1*$cs, $l1*$cs) =
      substr(${$Ct2->_text}, $o2*$cs2, $l2*$cs2)
   ;

   $S;
}

sub rindex {
#
# $pos = $Ct -> rindex ($string [,$pos])
#
   my ($S, $str, $pos) = @_;
   $pos = $S->length() if !defined $pos;
   my $cs = $S->charsize;
   my $i = $pos * $cs + $cs;
   while (1) {
      $i = rindex(${$S->_text}, $str, $i-(($i%$cs)||$cs));
      return $i if $cs == 1;
      return $i if $i == -1;
      if (!($i % $cs)) {
         return $i / $cs;
      }
   }
}

sub text {
   shift->_text();
}

sub tr      { goto &y }
sub uc      { shift->_apply_f_to_t("CORE::uc") }
sub ucfirst { shift->_apply_f_to_t("CORE::ucfirst") }

sub y {
#
# $Ct -> y ($search_str, $replace_str, $mode)
# $Ct -> y (\@search[0..n], \@replace[0..n], $mode)
#
   my ($S, $search, $replace, $mode) = @_;
   $search  = "" if !defined $search;
   $replace = "" if !defined $replace;
   $mode    = "" if !defined $mode;
   my $cs = $S->_charsize;
   if (ref($search)) {
      $S->replace($search, $replace, "g$mode");
   } elsif ($cs==1) {
      $mode =~ s/g//g;
      eval '${$S->_text} =~ y/'.
         ($search||"")."/".($replace||"")."/".($mode||"")
      ;
   } else {
      $S->replace(
         [map CORE::substr($search, $_*$cs, $cs), (0..(CORE::length($search)/$cs-1))],
         [map CORE::substr($replace, $_*$cs, $cs), (0..(CORE::length($replace)/$cs-1))],
         "g$mode"
      );
   }
   $S;
}
sub _dl { my ($lR,$str)=@_;
   print "$str: " if $str; printf "(".("'%s', "x($#{$lR}+1)).")\n", @{$lR};
}

sub _apply_f_to_t {
#
# lc, lcfirst, uc, ucfirst
#
   my ($S, $apply) = @_;
   $S->new (
      $S->_charsize,
      \(eval "$apply".'(${$S->_text})'),
      [@{$S->_attrib}], [@{$S->_offset}],
      1
   );
}

sub _cmp_attribs {
#
# 1||0 = $Ct1 -> _cmp_attribs ($Ct2)
# 1||0 = $Ct1 -> _cmp_attribs ([@attrib], [@offset])
#
   my ($S, $a2R, $o2R) = @_;
   if (!defined $o2R) {
      my $Ct2 = $a2R;
      $a2R = $Ct2->_attrib;
      $o2R = $Ct2->_offset;
   }
   return 0 if !$S->_cmp_slist($S->_attrib, $a2R);
   return 0 if !$S->_cmp_nlist($S->_offset, $o2R);
1}

sub _cmp_nlist {
#
# 1||0 = _cmp_nlist ([@list1], [@list2])
#
   my ($S, $aR, $bR) = @_;
   return 0 unless @$aR == @$bR;
   for (0..$#$aR) { return 0 if $aR->[$_] != $bR->[$_] }
1}
sub _cmp_slist {
#
# 1||0 = _cmp_slist ([@list1], [@list2])
#
   my ($S, $aR, $bR) = @_;
   my $acmp = $S->acmp();
   return 0 unless @$aR == @$bR;
   for (0..$#$aR) { return 0 if &$acmp ($aR->[$_], $bR->[$_]) }
1}

sub _entry {
#
# 1 = $S -> entry (\$text, [@attrib], [@offset], $mode)
#
# mode = 0: make copies of text, attrib and offset (store values)
#        1: use given references                   (store references)
#
   my ($S, $textR, $attribR, $offsetR, $mode) = @_;

   if (!$mode) {
      $S->_text   (\(my $text = $textR ? $$textR : ""));
      $S->_attrib ($attribR ? [@$attribR] : [0]);
      $S->_offset ($offsetR ? [@$offsetR] : [0]);
   } else {
      $S->_text   ($textR   ? $textR : \(""));
      $S->_attrib ($attribR ? $attribR : [0]);
      $S->_offset ($offsetR ? $offsetR : [0]);
   }
1}

sub _index {
#
# $context_index = -> _index ($position [,[@offset]])
#
   my ($S, $pos, $oR) = @_;
   return 0     if !$pos;
   return undef if $pos < 0;
   $oR = $S->_offset if !defined $oR;

   my $og = $#{$oR};
   return $og if $pos >= ($oR->[$og]);
   my $ug = 0;
   my $step;

   while ($step = ($og-$ug) >> 1) {
      if ($oR->[$ug+$step] <= $pos) {
         $ug += $step;
      } else {
         $og -= $step;
      }
   }

   $ug;
}

sub _subattr {
#
# ([@attrib], [@o]) =
#    $Ct -> _subattr ($o1, $l1, [@attrib], [@o] [,$o2, $al2 [,$tl2]])
#
# Substitutes $Ct's attributes from position o1 and length l1 with
# @attrib and @o. The substituted textlength will stay l1, unless tl2 given.
#
   my ($S, $o1, $l1, $aR2, $oR2, $o2, $al2, $tl2) = @_;
   return undef if !defined $oR2;

   my $len1 = $S->length();
   $o1 += $len1 if $o1<0;
   return undef if $o1<0;
   return undef if ($o1+$l1) > $len1;
   return 1 if ($o1 && ($o1==$len1));

   $al2 = $l1 if !defined $al2;
   $tl2 = $l1 if !defined $tl2;
   $o2 = 0 if !defined $o2;
   return undef if $o2<0;

   my $i1_right = $o1 ? $S->_index($o1-1) : 0;
   my $i2_left  = $S->_index($o2, $oR2);
   my $i2_right = ($o2+$al2-1) ? $S->_index($o2+$al2-1, $oR2) : 0;
   my $i3_left  = $S->_index($o1+$l1);

   my $a1_right = $S->_attrib->[$i1_right];
   my $a2_left  = $aR2->[$i2_left];
   my $a2_right = $aR2->[$i2_right];
   my $a3_left  = $S->_attrib->[$i3_left];

   my $o1_right = $S->_offset->[$i1_right];
   my $o2_left  = $oR2->[$i2_left];

   my @a_left=();  my @o_left=();
   my @a_right=(); my @o_right=();

   my $diff_middle = $tl2 - $l1;
   my $diff_right = $o1 - $o2;

   my $acmp = $S->acmp();

   if ($o1) {
      push (@a_left, $a1_right);
      push (@o_left, $o1_right);
   }

   if ((!$o1) || &$acmp($a1_right, $a2_left)) {
      push (@a_left, $a2_left);
      push (@o_left, $o1);
   }

   if ( (($o1+$l1) < $len1) &&
      &$acmp ($a2_right, $a3_left)
   ) {
      push (@a_right, $a3_left);
      push (@o_right, $o1+$tl2);
   }
#print "a1r=$a1_right a2l=$a2_left a2r=$a2_right a3l=$a3_left\n";
#print "i1r=$i1_right i2l=$i2_left i2r=$i2_right i3l=$i3_left\n";
#print "o1=$o1 l1=$l1  o2=$o2 al2=$al2 tl2=$tl2  o1r=$o1_right o2l=$o2_left\n";
#print "len1=$len1\n";
#print "al=(@a_left) ar=(@a_right)  ol=(@o_left) or=(@o_right)\n\n";

   splice (@{$S->_attrib},
      $i1_right,
      $i3_left-$i1_right+1,
      (@a_left,
       @{$aR2}[$i2_left+1..$i2_right],
       @a_right
      )
   );

   for (@{$S->_offset}[$i3_left+1 .. $#{$S->_offset}]) {
      $_ += $diff_middle
   }

   splice (@{$S->_offset},
      $i1_right,
      $i3_left-$i1_right+1,
      (@o_left,
       (map {$_+$diff_right} @{$oR2}[$i2_left+1..$i2_right]),
       @o_right
      )
   );
1}

"Atomkraft? Nein, danke!"

__END__