"Fossies" - the Fresh Open Source Software Archive

Member "HTTP-DAV-0.49/lib/HTTP/DAV/Lock.pm" (28 Nov 2018, 14084 Bytes) of package /linux/www/HTTP-DAV-0.49.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. For more information about "Lock.pm" see the Fossies "Dox" file reference documentation and the latest Fossies "Diffs" side-by-side code changes report: 0.48_vs_0.49.

    1 package HTTP::DAV::Lock;
    2 
    3 use strict;
    4 use vars qw($VERSION);
    5 use HTTP::DAV::Utils;
    6 
    7 $VERSION = '0.09';
    8 
    9 ###########################################################################
   10 
   11 =head1 NAME
   12 
   13 HTTP::DAV::Lock - Represents a WebDAV Lock.
   14 
   15 =head1 SYNOPSIS
   16 
   17  Need example
   18 
   19 =head1 DESCRIPTION
   20 
   21 =cut
   22 
   23 sub new {
   24     my $self = {};
   25     bless $self, shift;
   26     $self->_init(@_);
   27     return $self;
   28 }
   29 
   30 sub _init {
   31    my ($self,@p) = @_;
   32    my($owned) = HTTP::DAV::Utils::rearrange(['OWNED'],@p);
   33    $self->{_owned} = $owned || 0;
   34 }
   35 
   36 ###########################################################################
   37 
   38 =head1 ACCESSOR METHODS
   39 
   40 =over
   41 
   42 =cut
   43 
   44 # GET
   45 sub get_owner { $_[0]->{_owner}; }
   46 sub get_token { $_[0]->{_token}; }
   47 sub get_depth { $_[0]->{_depth}; }
   48 sub get_timeout { $_[0]->{_timeout}; }
   49 sub get_locktoken { $_[0]->{_locktokens}[0]; }
   50 sub get_locktokens{ $_[0]->{_locktokens}; }
   51 
   52 sub set_scope     { $_[0]->{_scope}     = $_[1]; }
   53 sub set_owned     { $_[0]->{_owned}     = $_[1]; }
   54 sub set_type      { $_[0]->{_type}      = $_[1]; }
   55 sub set_owner     { $_[0]->{_owner}     = $_[1]; }
   56 sub set_depth     { $_[0]->{_depth}     = $_[1]; }
   57 sub set_timeout   { $_[0]->{_timeout}   = $_[1]; }
   58 sub set_locktoken { 
   59    my ($self,$href) = @_;
   60    # Remove leading and trailing space from "  http://.../..."
   61    $href =~ s/^\s*//g; $href =~ s/\s*$//g; 
   62    # Remove < > from around it available
   63    $href =~ s/^<(.*)>$/$1/g;
   64 
   65    push (@{$self->{_locktokens}}, $href); 
   66 }
   67 
   68 # IS
   69 sub is_owned { $_[0]->{_owned}; }
   70 
   71 ###########################################################################
   72 # Synopsis: 
   73 # Full parameters
   74 # make_lock_xml (
   75 #    -owner => (owner|http://mysite/~mypage/)
   76 #    -timeout => num_of_seconds (e.g. 134123432)
   77 #    -scope => (exclusive|shared)
   78 #    -type =>  (write)
   79 # )
   80 sub make_lock_xml {
   81    my ($self,@p) = @_;
   82    my($owner,$timeout,$scope,$type,@other) = 
   83       HTTP::DAV::Utils::rearrange(['OWNER','TIMEOUT','SCOPE','TYPE'],@p);  
   84 
   85    ####
   86    # Create a new XML document
   87    # It may look something like this
   88    # <?xml version=1.0 encoding="utf-8"?>
   89    #   <D:lockinfo xmlns:D="DAV:">
   90    #       <D:lockscope><D:exclusive/></D:lockscope>
   91    #       <D:locktype><D:write/></D:locktype>
   92    #       <D:owner>
   93    #          <D:href>http://mysite/~mypage.html</D:href>
   94    #       </D:owner>
   95    #   </D:lockinfo>
   96    my $xml_request = qq{<?xml version="1.0" encoding="utf-8"?>\n};
   97 
   98    $xml_request .= "<D:lockinfo xmlns:D='DAV:'>\n";
   99    $xml_request .= "<D:lockscope><D:$scope/></D:lockscope>\n";
  100    $xml_request .= "<D:locktype><D:$type/></D:locktype>\n";
  101 #$xml_request = <<END;
  102 #<?xml version="1.0" encoding="utf-8"?>
  103 #<lockinfo xmlns='DAV:'>
  104 #<lockscope><$scope/></lockscope>
  105 #<locktype><$type/></locktype>
  106 ##</lockinfo>
  107 #END
  108 
  109 
  110    # If the owner is an HREF then set it into an <D:href> tag 
  111    # else just enter it as text.
  112    my $o = URI->new($owner);
  113    if ($o->scheme) {
  114       $xml_request .= "<D:owner><D:href>$owner</D:href></D:owner>\n";
  115       #$xml_request .= "<owner><href>$owner</href></owner>\n";
  116    } elsif ( $owner ) {
  117       $xml_request .= "<D:owner>$owner</D:owner>\n";
  118       #$xml_request .= "<owner>$owner</owner>\n";
  119    }
  120 
  121    $xml_request .= "</D:lockinfo>\n";
  122    #$xml_request .= "</lockinfo>\n";
  123  
  124    return ($xml_request);
  125 }
  126 
  127 ###########################################################################
  128 # Synopsis: @locks = XML_lockdiscovery_parse($node);
  129 # With this XML node:
  130 #<D:lockdiscovery>
  131 #   <D:activelock>
  132 #      <D:locktype><D:write/></D:locktype>
  133 #      <D:lockscope><D:exclusive/></D:lockscope>
  134 #      <D:depth>0</D:depth>
  135 #      <D:timeout>Infinite</D:timeout>
  136 #      <D:owner>pcollins</D:owner>
  137 #      <D:locktoken>
  138 #          <D:href>opaquelocktoken:d3ae67b0-1dd1-a5f7-f067587e98e1</D:href>
  139 #          <D:href>...</D:href>
  140 #      </D:locktoken>
  141 #   </D:activelock>
  142 #</D:lockdiscovery>
  143 # 
  144 # returns an array of locks (will be more than one in shared locks scenarios)
  145 
  146 sub XML_lockdiscovery_parse {
  147    my ($self,$node_lockdiscovery) = @_;
  148    my @found_locks = ();
  149 
  150    # <!ELEMENT lockdiscovery (activelock)* >
  151    my @nodes_activelock= HTTP::DAV::Utils::get_elements_by_tag_name($node_lockdiscovery,"D:activelock");
  152 
  153    # <!ELEMENT activelock (lockscope, locktype, depth, owner?, timeout?, locktoken?) >
  154    foreach my $node_activelock ( @nodes_activelock ) {
  155 
  156       my $lock = HTTP::DAV::Lock->new();
  157       push(@found_locks,$lock);
  158    
  159       my $nodes_lock_params = $node_activelock->getChildNodes();
  160       next unless $nodes_lock_params;
  161       my $prop_count = $nodes_lock_params->getLength;
  162 
  163       for (my $prop_num = 0; $prop_num < $prop_count; $prop_num++) {
  164          my $node_lock_param = $nodes_lock_params->item($prop_num);   
  165 
  166          # $node_lock_param is one of the following
  167          # 1. <!ELEMENT lockscope (exclusive | shared) >
  168          # 2. <!ELEMENT locktype (write) >
  169          # 3. <!ELEMENT depth (#PCDATA) >
  170          # 4. <!ELEMENT owner ANY >
  171          # 5. <!ELEMENT timeout (#PCDATA) >
  172          # 6. <!ELEMENT locktoken (href+) >
  173 
  174          my $lock_prop_name = $node_lock_param->getNodeName();
  175          $lock_prop_name =~ s/.*:(.*)/$1/g;
  176    
  177          # 1. RFC2518 currently only allows locktype of exclusive or shared
  178          if ( $lock_prop_name eq "lockscope" ) {
  179             my $node_lock_scope = HTTP::DAV::Utils::get_only_element($node_lock_param);
  180             my $lock_scope = $node_lock_scope->getNodeName;
  181             $lock_scope =~ s/.*:(.*)/$1/g;
  182             $lock->set_scope($lock_scope);
  183          } 
  184    
  185          # 2. RFC2518 currently only allows locktype of "write"
  186          elsif ( $lock_prop_name eq "locktype" ) {
  187             my $node_lock_type = HTTP::DAV::Utils::get_only_element($node_lock_param);
  188             my $lock_type = $node_lock_type->getNodeName;
  189             $lock_type =~ s/.*:(.*)/$1/g;
  190             $lock->set_type($lock_type);
  191          } 
  192    
  193          # 3. RFC2518 allows only depth of 0,1,infinity
  194          elsif ( $lock_prop_name eq "depth" ) {
  195             my $lock_depth = HTTP::DAV::Utils::get_only_cdata($node_lock_param);
  196             $lock->set_depth($lock_depth);
  197          }
  198    
  199          # 4. RFC2518 allows anything here.
  200          # Patrick: I'm just going to convert the XML to a string
  201          elsif ( $lock_prop_name eq "owner" ) {
  202             $lock->set_owner( $node_lock_param->getFirstChild->toString );
  203          }
  204    
  205          # 5. RFC2518 (Section 9.8) e.g. Timeout: Second-234234 or Timeout: infinity
  206          elsif ( $lock_prop_name eq "timeout" ) {
  207             my $lock_timeout = HTTP::DAV::Utils::get_only_cdata($node_lock_param);
  208             my $timeout = HTTP::DAV::Lock->interpret_timeout($lock_timeout);
  209             $lock->set_timeout( $timeout );
  210             #if ( $HTTP::DAV::DEBUG ) {
  211             #   $lock->{ "_timeout_val" } = HTTP::Date::time2str($timeout) 
  212             #}
  213          }
  214    
  215          # 6. RFC2518 allows one or more <href>'s
  216          # Push them all into the lock object.
  217          elsif ( $lock_prop_name eq "locktoken" ) {
  218             my @nodelist_hrefs = HTTP::DAV::Utils::get_elements_by_tag_name($node_lock_param,"D:href");
  219             foreach my $node ( @nodelist_hrefs) {
  220                my $href_cdata = HTTP::DAV::Utils::get_only_cdata( $node );
  221                $lock->set_locktoken( $href_cdata );
  222             }
  223          }
  224 
  225       } # Foreach property
  226    } # Foreach ActiveLock
  227 
  228    return @found_locks;
  229 }
  230 
  231 ###########################################################################
  232 # Synopsis: $hashref = get_supportedlock_details($node);
  233 #<D:supportedlock>
  234 #   <D:lockentry>
  235 #      <D:lockscope> <D:exclusive/> </D:lockscope>
  236 #      <D:locktype>  <D:write/>     </D:locktype>
  237 #   </D:lockentry>
  238 #   <D:lockentry>
  239 #      <D:lockscope> <D:shared/>    </D:lockscope>
  240 #      <D:locktype>  <D:write/>     </D:locktype>
  241 #   </D:lockentry>
  242 #</D:supportedlock>
  243 #
  244 # Returns something similar to:
  245 #  @supportedlocks'  = (
  246 #    { 'type' => 'write', 'scope' => 'exclusive' },
  247 #    { 'type' => 'write', 'scope' => 'shared'    }
  248 #  );    
  249 
  250 sub get_supportedlock_details {
  251    my ($node_supportedlock) = @_;
  252 
  253    return unless $node_supportedlock;
  254 
  255    # Return values
  256    my @supportedlocks=();
  257 
  258    my @nodelist_lockentries = HTTP::DAV::Utils::get_elements_by_tag_name($node_supportedlock,"D:lockentry");
  259    foreach my $i ( 0 .. $#nodelist_lockentries ) {
  260       my $node_lockentry = $nodelist_lockentries[$i];
  261 
  262       my $lock_prop_name = $node_lockentry->getNodeName();
  263       next unless $lock_prop_name;
  264 
  265       # RFC2518 currently only allows lockscope of exclusive or shared
  266       # <D:lockscope> <D:shared|exclusive/>    </D:lockscope>
  267       my $node_lockscope=HTTP::DAV::Utils::get_only_element($node_lockentry,"D:lockscope");
  268       if ( $node_lockscope ) {
  269          my $node_lockscope_param =HTTP::DAV::Utils::get_only_element($node_lockscope);
  270          my $lockscope = $node_lockscope_param->getNodeName;
  271          $lockscope =~ s/.*:(.*)/$1/g;
  272          $supportedlocks[$i]{ "scope" } = $lockscope;
  273       }
  274 
  275       # RFC2518 currently only allows locktype of "write"
  276       # <D:locktype>  <D:write/>     </D:locktype>
  277       my $node_locktype = HTTP::DAV::Utils::get_only_element($node_lockentry,"D:locktype");
  278       if ( $node_locktype ) {
  279          my $node_locktype_param =HTTP::DAV::Utils::get_only_element($node_locktype);
  280          my $locktype = $node_locktype_param->getNodeName;
  281          $locktype =~ s/.*:(.*)/$1/g;
  282          $supportedlocks[$i]{ "type" } = $locktype;
  283       }
  284    }
  285 
  286    return \@supportedlocks;
  287 }
  288 
  289 
  290 ###########################################################################
  291 =item Timeout
  292 This parameter can take an absolute or relative timeout.
  293 The following forms are all valid for the -timeout field:
  294 
  295 Timeouts in:
  296     300
  297     30s                              30 seconds from now
  298     10m                              ten minutes from now
  299     1h                               one hour from now
  300     1d                               tomorrow
  301     3M                               in three months
  302     10y                              in ten years time
  303 Timeout at:
  304     2000-02-31 00:40:33              at the indicated time & date
  305     For more time and date formats that are handled see HTTP::Date
  306 
  307 RFC2518 states that the timeout value MUST NOT be greater 
  308 than 2^32-1. If this occurs it will simply set the timeout to infinity
  309 =cut
  310 
  311 sub timeout {
  312    my ($self,$timeout) = @_;
  313    my $timeoutret;
  314 
  315    return 0 unless $timeout;
  316 
  317    if ($timeout =~ /^\d+[a-zA-Z]$/ ) {
  318       $timeoutret = _timeout_calc($timeout);
  319    } 
  320    elsif ($timeout =~ /infinity/i || $timeout =~ /^\d+$/ ) {
  321       $timeoutret = $timeout;
  322    } 
  323    else {
  324       my ($epochgmt) = HTTP::Date::str2time($timeout);
  325       $timeoutret = $epochgmt - time;
  326    }
  327 
  328    # Timeout value cannot be greater than 2^32-1 as per RFC2518
  329    if ( $timeoutret =~ /infinity/i || $timeoutret >= 4294967295 ) {
  330       return "Infinite, Second-4294967295 ";
  331    } 
  332    elsif ( $timeoutret <= 0 ) {
  333       return 0;
  334    } else {
  335       return "Second-$timeoutret ";
  336    }
  337 }
  338 
  339 ###########################################################################
  340 sub interpret_timeout {
  341    my ($self,$timeout) = @_;
  342 
  343    return "Infinite" if $timeout =~ /Infinite/i;
  344    return "Infinite" if !defined $timeout || $timeout eq "";
  345 
  346    if ($timeout =~ /Second\-(\d+)/ ) {
  347       return time + $1;
  348    } else {
  349       HTTP::DAV::Utils::bad("Ugh... can't interpret Timeout value \"timeout: $timeout\"\n");
  350    }
  351 }
  352 
  353 ###########################################################################
  354 # This internal routine creates an expires time exactly some number of
  355 # hours from the current time.  It incorporates modifications from
  356 # Mark Fisher.
  357 # Borrowed from Lincoln Stein's CGI.pm
  358 
  359 sub _timeout_calc {
  360     my($time) = @_;
  361     my(%mult) = ('s'=>1,
  362                  'm'=>60,
  363                  'h'=>60*60,
  364                  'd'=>60*60*24,
  365                  'M'=>60*60*24*30,
  366                  'y'=>60*60*24*365);
  367     # format for time can be in any of the forms...
  368     # "180s" -- in 180 seconds
  369     # "2m" -- in 2 minutes
  370     # "12h" -- in 12 hours
  371     # "1d"  -- in 1 day
  372     # "3M"  -- in 3 months
  373     # "2y"  -- in 2 years
  374     # "3m"  -- 3 minutes
  375     # If you don't supply one of these forms, we assume you are
  376     # specifying the date yourself
  377     my($offset);
  378     if (!$time || (lc($time) eq 'now')) {
  379         $offset = 0;
  380     } elsif ($time=~/^(\d+|\d*\.\d*)([mhdMy]?)/) {
  381         $offset = ($mult{$2} || 1)*$1;
  382     } else {
  383         return $time;
  384     }
  385     return $offset;
  386 }
  387 
  388 
  389 ###########################################################################
  390 =item $r->as_string()
  391 
  392 Method returning a textual representation of the request.
  393 Mainly useful for debugging purposes. It takes no arguments.
  394 
  395 =cut
  396 
  397 sub as_string
  398 {
  399    my ($self,$space,$debug) = @_;
  400    my ($str) = "";
  401    $space = "   " if !defined $space;
  402    $str .= "${space}Lock Object ($self)\n";
  403    $space  .= "   ";
  404    $str .= "${space}'_owned':   " . ($self->{_owned}||"") . "\n";
  405    $str .= "${space}'_scope':   " . ($self->{_scope}||"") . "\n";
  406    $str .= "${space}'_type':    " . ($self->{_type} ||"") . "\n";
  407    $str .= "${space}'_owner':   " . ($self->{_owner}||"") . "\n";
  408    $str .= "${space}'_depth':   " . ($self->{_depth}||"") . "\n";
  409    $str .= "${space}'_timeout': " . ($self->{_timeout}||"") . "\n";
  410    $str .= "${space}'_locktokens': " . join(", ", @{$self->get_locktokens()} ) . "\n";
  411 
  412    $str;
  413 }
  414 
  415 sub pretty_print
  416 {
  417    my ($self,$space) = @_;
  418    my ($str) = "";
  419    $str .= "${space}Owner:   $self->{_owner}\n";
  420    $str .= "${space}Scope:   $self->{_scope}\n";
  421    $str .= "${space}Type:    $self->{_type}\n";
  422    $str .= "${space}Depth:   $self->{_depth}\n";
  423    $str .= "${space}Timeout: $self->{_timeout}\n";
  424    $str .= "${space}LockTokens: " . join(", ", @{$self->get_locktokens()} ) . "\n";
  425 
  426    $str;
  427 }
  428 
  429 
  430 ###########################################################################
  431 =back
  432 
  433 =head1 SEE ALSO
  434 
  435 L<HTTP::Headers>, L<HTTP::Message>, L<HTTP::Request::Common>
  436 
  437 =head1 COPYRIGHT
  438 
  439 Copyright 2000 Patrick Collins.
  440 
  441 This library is free software; you can redistribute it and/or
  442 modify it under the same terms as Perl itself.
  443 
  444 =cut
  445 
  446 1;