view release on metacpan or  search on metacpan

lib/HTTP/DAV/Utils.pm  view on Meta::CPAN

        if (exists $pos{$key}) {
            $result[$pos{$key}] = shift(@param);
        } else {
            $leftover{$key} = shift(@param);
        }
    }

    push (@result,&make_attributes(\%leftover)) if %leftover;
    @result;
}

#### Method: use_named_parameters
# Borrowed from Lincoln Stein's CGI.pm
# Force DAV.pm to use named parameter-style method calls
# rather than positional parameters.  The same effect
# will happen automatically if the first parameter
# begins with a -.
my $named=0;
sub use_named_parameters {
    my($use_named) = shift;
    return $named unless defined ($use_named);

    # stupidity to avoid annoying warnings
    return $named = $use_named;
}

# Borrowed from Lincoln Stein's CGI.pm
sub make_attributes {
    my($attr) = @_;
    return () unless $attr && ref($attr) && ref($attr) eq 'HASH';
    my(@att);
    foreach (keys %{$attr}) {
        my($key) = $_;
        $key=~s/^\-//;     # get rid of initial - if present
        $key=~tr/a-z_/A-Z-/; # parameters are upper case, use dashes
        push(@att,defined($attr->{$_}) ? qq/$key="$attr->{$_}"/ : qq/$key/);
    }
    return @att;
}

###########################################################################
sub bad {
   my($str) = @_;
   print STDERR "Error: $str\n";
   exit;
}

sub bad_node {
   my($node,$str) = @_;
   print STDERR "XML error in " . $node->getNodeName . ": $str";
   print STDERR "\n";
   print STDERR "DUMP:\n";
   print STDERR $node->toString if $node;
   exit;
}

###########################################################################
# This method searches for any text-based data in the children of 
# the node supplied. It will croak if the node has anything other 
# than text values (such as Elements or Comments).
sub get_only_cdata {
   my($node) = @_;
   my $return_cdata = "";
   my $nodes = $node->getChildNodes();
   my $n = $nodes->getLength;
   for (my $i = 0; $i < $n; $i++) {
      my $node = $nodes->item($i);   
      if ( $node->getNodeTypeName eq "TEXT_NODE" ) {
         $return_cdata .= $node->getNodeValue;
      } else {
         #bad_node($node, "node has non TEXT children");
      }
   }

   return $return_cdata;
}


# This is a sibling to the XML::DOM's getElementsByTagName().
# The main difference here is that it ignores the namespace 
# component of the element. This was done because it 
# Takes a node and returns a list of nodes.
# Note that the real getElementsByTagName allows you to 
# specify recurse or not. This routine doesn't allow recurse.
sub get_elements_by_tag_name {
   my ($node, $elemname ) = @_;

   return unless $node;

   my @return_nodes;

   # This is gruesome. Because we don't yet support namespaces, it 
   # just lops off the first half of the Element name
   $elemname =~ s/.*?:(.*)$/$1/g;

   my $nodelist = $node->getChildNodes();
   my $length = $nodelist->getLength();
   for ( my $i=0; $i < $length; $i++ ) {
      my $node = $nodelist->item($i);
      # Debian change?
      if ( $node->getNodeName() =~ /(?:^|:)$elemname$/ ) {
         push(@return_nodes,$node);
      }
   }

   return @return_nodes;
}

sub get_only_element {
   my($node,$elemname) = @_;

   return unless $node;

   # Find the one child element of a specific name
   if ( $elemname ) {

      # This is gruesome. Because we don't yet support namespaces, it 
      # just lops off the first half of the Element name.
      $elemname =~ s/.*?:(.*)$/$1/g;

      #my $nodes = $node->getElementsByTagName($elemname,0);
      my $nodelist = $node->getChildNodes();
      my $length = $nodelist->getLength();
      for ( my $i=0; $i < $length; $i++ ) {
         my $node = $nodelist->item($i);
         return $node if $node->getNodeName() =~ /$elemname/;
      }

#      if ( $nodes->getLength > 1 ) {
#         bad_node($node, "Too many \"$elemname\" in node"); 
#      } elsif ( $nodes->getLength < 1 ) {
#         return;
#         #bad_node($node, "No node found matching \"$elemname\" in node");
#      }
#      return $nodes->item(0);