view release on metacpan or  search on metacpan

lib/OPC.pm  view on Meta::CPAN

	my $Filter;
	if( $RelationParams{type} ) {
		$Filter = '@Type="'.$RelationParams{type}.'"';
	}

  if( $RelationParams{id} ) {
		$Filter = '@Id="'.$RelationParams{id}.'"';
	}

	return $XC->findnodes(
		"/opcr:Relationships/opcr:Relationship[$Filter]",
		$RelsDoc );
}

# Retrieve relations by type and return list of hashref
sub RelationsByType {
	my( $self, $RelsPartName, $RelType ) = @_;
	return $self->Relations( $RelsPartName, type => $RelType );
}

# Извлекает связь заданного типа из rels части, что связь данного типа только одна,
# иначе выбрасывает фатальную ошибку
# Don't use RelationByType with $GetMulty param, use RelationsByType method instead
sub RelationByType {
	my( $self, $RelsPartName, $RelType, $GetMulty ) = @_;

	my @Relations = $self->RelationsByType( $RelsPartName, $RelType );
	if( !$GetMulty && @Relations > 1 ) {
		die "Expected only one relation of type $RelType in $RelsPartName but found several";
	}
	
  if ($GetMulty) {
    return @Relations;
  } elsif (@Relations) {
    return %{$Relations[0]};
  } else {
    return ();
  }
}

# вспомогательная функция: получить полное имя части по относительной ссылке на неё
# и имени части, относительно которой ищем
sub FullPartNameFromRelative {
  my $Name = shift;
  my $Dir = shift;
  $Dir =~ s:/$::; # remove trailing slash

  my $FullName = ( $Name =~ m:^/: ) ? $Name :       # в $Name - полный путь
                                      "$Dir/$Name"; # в $Name - относительная ссылка

  $FullName =~ s:^/::; # remove leading slash

  $FullName = do{
    use bytes; # A-Za-z are case insensitive
    lc $FullName;
  };

  # обрабатываем все . и .. в имени
  my @CleanedSegments;
  my @OriginalSegments = split m:/:, $FullName;
  for my $Part ( @OriginalSegments ) {
    if( $Part eq '.' ) {
      # просто пропускаем
    } elsif( $Part eq '..' ) {
      if( @CleanedSegments > 0 ) {
        pop @CleanedSegments;
      } else {
        die "/$FullName part name is invalid, because it's pointing out of FB3 root";
      }
    } else {
      push @CleanedSegments, $Part;
    }
  }

  return '/'.( join '/', @CleanedSegments );
}

sub Root {
	my $self = shift;

	return OPC::Root->new( package => $self );
}

sub Part {
	my( $self, %Params ) = @_;
	my $PartName = $Params{name};

	return OPC::Part->new( package => $self, name => $PartName )
}

=head1 LICENSE AND COPYRIGHT

Copyright (C) 2018 Litres.ru

The GNU Lesser General Public License version 3.0

OPC is free software: you can redistribute it and/or modify it
under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3.0 of the License.

OPC 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 Lesser General Public
License for more details.

Full text of License L<http://www.gnu.org/licenses/lgpl-3.0.en.html>.

=cut

1;