view release on metacpan or  search on metacpan

lib/Treex/PML/Instance.pm  view on Meta::CPAN

              return $value;
            }
          } else {
            my $msg = "Can't follow attribute path '$path' (no sequence element found at step '$step')";
            croak $msg if ($strict==2);
            warn $msg."\n";
            return; # ERROR
          }
        }
      } else {
        return; # ERROR
      }
    } elsif (ref($val)) {
      if (@steps) {
        if (!defined($val->{$step}) and $steps[0]!~/^\[/) {
          $val->{$step}=Treex::PML::Factory->createStructure();
        }
        $val = $val->{$step};
      } else {
        $val->{$step} = $value;
        return $value;
      }
    } elsif (defined($val)) {
      my $msg = "Can't follow attribute path '$path' (step '$step')";
      croak $msg if ($strict==2);
      warn $msg."\n";
      return; # ERROR
    } else {
      return '';
    }
  }
  return;
}



sub __match_path {
  my ($match_paths, $step)=@_;
  my @r;
  my $s = $step;
  $s =~ s/^\[\d+\]//;
  foreach my $m (@$match_paths) {
    my ($m_step,@rest) = @{$m->[0]};
    if (defined $m_step and length($m_step)==0) {
      # handle //
      push @r,$m, [\@rest=>$m->[1]];
    } elsif ($m_step eq $step or $m_step eq '*') {
      push @r,[\@rest=>$m->[1]];
    } elsif ($m_step !~ /^\[/) {
      if (!length($s)) {
        push @r,$m;
      } elsif ($s eq $m_step) {
        push @r,[\@rest=>$m->[1]];
      }
    }
  }
  return \@r;
}

sub __split_path {
  my @p =  split m{/}, $_[0];
  if (@p>0 and length($p[0])==0) { shift @p; }
  return \@p;
}

sub for_each_match {
  my ($obj,$paths,$opts) = @_;
  $opts||={};
  my @match_paths;
  if (UNIVERSAL::isa($paths,'HASH')) {
    @match_paths = map { [ __split_path($_) => $paths->{$_} ] } keys %$paths;
  } else {
    croak("Usage: \$pml->for_each_match( { path1 => callback1, path2 => callback2,...} )\n".
          "   or: Treex::PML::Instance::for_each_match( \$obj, { path1 => callback1, ... } )\n");
  }
  my $type;
  if (UNIVERSAL::DOES::does($obj,'Treex::PML::Instance')) {
    if (exists $opts->{type}) {
      $type = $opts->{type}
    } else {
      $type = $obj->get_schema->get_root_type
    }
    $obj = $obj->get_root;
  } elsif (exists $opts->{type}) {
    $type = $opts->{type};
  }
  __for_each_match_dispatch('','',\@match_paths,$obj,$type) if @match_paths;
}

sub __for_each_match_dispatch {
  my ($path, $step, $match_paths, $v, $type)=@_;
  $path .= $path eq '/' ? $step : '/'.$step;
  my $match = __match_path($match_paths,$step);
  my @m;
  if (defined $type) {
    my $dt = $type->get_decl_type;
    if ($dt==PML_ATTRIBUTE_DECL ||
        $dt==PML_MEMBER_DECL    ||
        $dt==PML_ELEMENT_DECL) {
      $type = $type->get_content_decl;
    }
  }
  for my $m (@$match) {
    if ( @{$m->[0]}>0 ) {
      push @m, $m;
    } else {
      my $cb = $m->[1];
      my @args;
      if (UNIVERSAL::isa($cb,'ARRAY')) {
        ($cb,@args) = @$cb;
      }
      $cb->({path => $path,  value => $v, type=>$type},@args);
    }
  }
  __for_each_match($path,$v,\@m,$type) if (@m);
}

sub __for_each_match {
  my ($p, $val, $match_paths,$type)=@_;
  if ($val) {
    my $dt = (defined($type)||undef) && $type->get_decl_type;