#!/bin/perl
#
# webdav.cgi - a CGI implementing the WebDAV protocol.
# (c)2006, yuno
#
# Permission is hereby granted, free of charge, to any person obtaining a copy
# of this software and associated documentation files (the "Software"), to
# deal in the Software without restriction, including without limitation the
# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
# sell copies of the Software, and to permit persons to whom the Software is
# furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be included in
# all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
# IN THE SOFTWARE.

$rootName = 'webdav';
$root = '/home/sugarpot';
$lock = 'webdav.lock';
#$trace = 'webdav.log';

$path = $ENV{'PATH_INFO'};
$query = $ENV{'QUERY_STRING'};
$method = $ENV{'REQUEST_METHOD'};
$depth = $ENV{'HTTP_DEPTH'};
$range = $ENV{'HTTP_RANGE'};
$ifModifiedSince = $ENV{'HTTP_IF_MODIFIED_SINCE'};
$ifRange = $ENV{'HTTP_IF_RANGE'};
$contentRange = $ENV{'HTTP_CONTENT_RANGE'};
$http_if = $ENV{'HTTP_IF'};
$locktoken = $ENV{'HTTP_LOCK_TOKEN'};
$destination = $ENV{'HTTP_DESTINATION'};
$overwrite = $ENV{'HTTP_OVERWRITE'};
$script = "http://$ENV{HTTP_HOST}$ENV{SCRIPT_NAME}";

read(STDIN, $content, $ENV{'CONTENT_LENGTH'});

@monthName = ('Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec');
@wdayName = ('Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat');

%mimeTypes = (
  'aif'   => 'audio/x-aiff',
  'aiff'  => 'audio/x-aiff',
  'asc'   => 'text/plain',
  'atom'  => 'text/plain',
  'au'    => 'audio/basic',
  'avi'   => 'video/x-msvideo',
  'bmp'   => 'image/bmp',
  'c'     => 'text/plain',
  'cc'    => 'text/plain',
  'cgi'   => 'text/plain',
  'cpp'   => 'text/plain',
  'css'   => 'text/css',
  'cxx'   => 'text/plain',
  'doc'   => 'application/msword',
  'dv'    => 'video/x-dv',
  'eps'   => 'application/postscript',
  'gif'   => 'image/gif',
  'gz'    => 'application/x-gzip',
  'h'     => 'text/plain',
  'hpp'   => 'text/plain',
  'hqx'   => 'application/mac-binhex40',
  'htm'   => 'text/html',
  'html'  => 'text/html',
  'hxx'   => 'text/plain',
  'jar'   => 'application/java-archive',
  'jav'   => 'text/plain',
  'java'  => 'text/plain',
  'jpeg'  => 'image/jpeg',
  'jpg'   => 'image/jpeg',
  'js'    => 'text/plain',
  'lzh'   => 'application/x-lzh',
  'm'     => 'text/plain',
  'm4a'   => 'audio/mp4a-latm',
  'mid'   => 'audio/midi',
  'midi'  => 'audio/midi',
  'mm'    => 'text/plain',
  'mov'   => 'video/quicktime',
  'mp2'   => 'audio/mpeg',
  'mp3'   => 'audio/mpeg',
  'mp4'   => 'video/mp4',
  'mpeg'  => 'video/mpeg',
  'mpg'   => 'video/mpeg',
  'ogg'   => 'application/ogg',
  'pdf'   => 'application/pdf',
  'php'   => 'text/plain',
  'pict'  => 'image/pict',
  'pl'    => 'text/plain',
  'png'   => 'image/png',
  'ppt'   => 'application/vnd.ms-powerpoint',
  'ps'    => 'application/postscript',
  'py'    => 'text/plain',
  'rb'    => 'text/plain',
  'rdf'   => 'text/plain',
  'rm'    => 'audio/x-pn-realaudio',
  'rtf'   => 'text/rtf',
  'sh'    => 'text/plain',
  'shtml' => 'text/html',
  'snd'   => 'audio/basic',
  'svg'   => 'image/svg+xml',
  'swf'   => 'application/x-shockwave-flash',
  'tar'   => 'application/x-tar',
  'tex'   => 'application/x-tex',
  'tif'   => 'image/tiff',
  'tiff'  => 'image/tiff',
  'txt'   => 'text/plain',
  'vrml'  => 'model/vrml',
  'wav'   => 'audio/x-wav',
  'wbmp'  => 'image/vnd.wap.wbmp',
  'wrl'   => 'model/vrml',
  'xbm'   => 'image/x-xbitmap',
  'xhtml' => 'text/html',
  'xls'   => 'application/vnd.ms-excel',
  'xml'   => 'text/xml',
  'xpm'   => 'image/x-xpixmap',
  'xsl'   => 'text/xsl',
  'zip'   => 'application/zip'
);

if ($trace) {
  open(LOG, ">>$trace");
  print LOG "----------request-------------\n";
  foreach $key (sort keys %ENV) {
    print LOG "$key: $ENV{$key}\n";
  }
  print LOG "\n$content\n";
  close(LOG);
}

sub sanitize {
  my $s = shift;
  $s =~ s/\&/&/g;
  $s =~ s/\"/"/g;
  $s =~ s/\</&lt;/g;
  $s =~ s/\>/&gt;/g;
  $s;
}

sub urlencode {
  my $s = shift;
  $s =~ s/([^a-zA-Z0-9_\.\/-:])/'%'.unpack('H2', $1)/ge;
  $s;
}

sub urldecode {
  my $s = shift;
  $s =~ s/%([A-Fa-f0-9][A-Fa-f0-9])/pack('H2', $1)/ge;
  $s;
}

sub getContentType {
  my $path = shift;
  $path =~ tr/A-Z/a-z/;
  if ($path =~ /\.([^\.]+)$/) {
    if (exists $mimeTypes{$1}) {
      return $mimeTypes{$1};
    }
  }
  'application/octet-stream';
}

sub parse_xml {
  local %xml = ();
  local @xml_path = ();
  local $xml_pcdata = '';
  local %xml_namespace = ();
  local @xml_namespace_stack = ();
  push(@xml_path, 0);
  my $content = shift;
  $content =~ s/\<\?xml\s.*?\?\>//;
  $content =~ s/\<(\/)?([^\s\/>]+)((\s+[^\s=]+\s*=\s*"[^"]+")*)\s*(\/)?\>|([^<>&]+)/&xml_parse_element/ge;
  %xml;
}

sub xml_parse_element {
  if ($6 ne '') {
    $xml_pcdata .= $6;
  } else {
    if ($xml_pcdata ne '') {
      my @path = @xml_path;
      pop(@path);
      my $path = join('.', @path);
      $xml{"$path:#PCDATA"} .= $xml_pcdata;
      $xml_pcdata = '';
    }
    if ($1 eq '/') {
      pop(@xml_path);
      &xml_namespace_pop;
    } else {
      my $empty_element = $5;
      my $attributes = $3;
      my $name = $2;
      &xml_namespace_push;
      push(@xml_path, pop(@xml_path) + 1);
      my $path = join('.', @xml_path);
      local %xml_attributes = ();
      $attributes =~ s/\s+(xmlns:)?([^\s=]+)\s*=\s*"([^"]+)"/&xml_parse_attribute/ge;
      if ($name =~ /([^:]+):(.*)/ && $xml_namespace{$1} ne '') {
        $xml{$path} = $xml_namespace{$1}.$2;
      } else {
        $xml{$path} = $xml_namespace{''}.$name;
      }
      foreach $key (keys %xml_attributes) {
        $xml{"$path:$key"} = $xml_attributes{$key};
      }
      if ($empty_element eq '/') {
        &xml_namespace_pop;
      } else {
        push(@xml_path, 0);
      }
    }
  }
}

sub xml_parse_attribute {
  if ($1 ne '') {
    $xml_namespace{$2} = $3;
  } elsif ($2 eq 'xmlns') {
    $xml_namespace{''} = $3;
  } else {
    $xml_attributes{$2} = $3;
  }
  "";
}

sub xml_namespace_push {
  my @a = ();
  my $key;
  foreach $key (keys %xml_namespace) {
    my $value = $xml_namespace{$key};
    push(@a, "$key=$value");
  }
  push(@xml_namespace_stack, join('&', @a));
}

sub xml_namespace_pop {
  my @a = split(/&/, pop(@xml_namespace_stack));
  %xml_namespace = ();
  foreach (@a) {
    my ($key, $value) = split(/=/, $_, 2);
    $xml_namespace{$key} = $value;
  } 
}

sub check_lock {
  my $path = shift;
  my $recursive = shift;
  my $token;
  $path .= '/';
  foreach $token (keys %lock) {
    if (!$if_tokens{$token}) {
      my ($x, $r, $p) = split(/\t/, $lock{$token});
      if ($p eq $path) {
        return 0;
      } elsif ($r && $path =~ /^$p/) {
        return 0;
      } elsif ($resursive && $p =~ /^$path/) {
        return 0;
      }
    }
  }
  return 1;
}

sub get_lock {
  my $path = shift;
  my $exclusive = shift;
  my $recursive = shift;
  $path .= '/';
  foreach $token (keys %lock) {
    my ($x, $r, $p) = split(/\t/, $lock{$token});
    if ($p eq $path) {
      if ($exclusive || $x) {
        return 0;
      }
    } elsif ($r && $path =~ /^$p/) {
      if ($exclusive || $x) {
        return 0;
      }
    } elsif ($recursive && $p =~ /^$path/) {
      if ($exclusive || $x) {
        return 0;
      }
    }
  }
  $lock{"<$locktoken>"} = "$exclusive\t$recursive\t$path\t";
  $lockUpdated = 1;
}

sub release_lock {
  my $token = shift;
  delete $lock{$token};
  $lockUpdated = 1;
}

sub delTree {
  my $path = shift;
  local @files = ();
  if (-d $root.$path) {
    &listFilesForDelTree($path);
    sub listFilesForDelTree {
      my $path = shift;
      if (-r $root.$path) {
        my $writable = -w $root.$path;
        opendir(D, $root.$path) || die;
        my @f = readdir(D);
        closedir(D);
        my $file;
        foreach $file (@f) {
          if ($file ne '.' && $file ne '..') {
            my $fpath = "$path/$file";
            if (!$writable) {
              my $s_href = &urlencode($script.$path);
              $body .= <<____;
 <response>
  <href>$s_href</href>
  <status>HTTP/1.1 403 Permission Denied</status>
 </response>
____
            } elsif (!&check_lock($fpath)) {
              $s_href = &urlencode($script.$path);
              $body .= <<____;
 <response>
  <href>$s_href</href>
  <status>HTTP/1.1 423 Locked</status>
 </response>
____
            } else {
              if (-d $root.$fpath) {
                &listFilesForDelTree($fpath);
              }
              push(@files, $root.$fpath);
            }
          }
        }
      } else {
        $s_href = &urlencode($script.$path);
        $body .= <<____;
 <response>
  <href>$s_href/</href>
  <status>HTTP/1.1 403 Permission Denied</status>
 </response>
____
      }
    }
  }
  push(@files, $root.$path);
  if ($body ne '') {
    $header{'Status'} = '207 Multi-Status';
    $header{'Content-Type'} = 'text/xml; charset="utf-8"';
    $body = <<____;
<?xml version="1.0" encoding="utf-8"?>
<multistatus xmlns="DAV:">
$body</multistatus>
____
    0;
  } else {
    foreach $f (@files) {
      if (-d $f) {
        rmdir $f || die;
      } else {
        unlink $f || die;
      }
    }
    1;
  }
}

# TODO: 'not' production, etc.
$http_if =~ s/(\<[^>]+\>)/$if_tokens{$1} = 1/ge;

$path =~ s/\/+/\//g;
$path =~ s/\/$//;
$destination = &urldecode($destination);
$destination =~ s/\/$//;

open(LOCK, "+<$lock") || open(LOCK, "+>$lock") || die;
flock(LOCK, 2);
while (<LOCK>) {
  chomp;
  $key = $_;
  $value = <LOCK>;
  chomp $value;
  $lock{$key} = $value;
}

$header{'Status'} = '500 Internal Server Error';

if ($path =~ /[\x00-\x1f\<\>\|]|^\.\.\/|\/\.\.\/|\/\.\.$|\/$/) {
  $header{'Status'} = '403 Forbidden';
} elsif ($method eq 'OPTIONS') {
  $header{'Status'} = '200 OK';
  $header{'Allow'} = 'OPTIONS, GET, HEAD, PUT, DELETE, PROPFIND, PROPPATCH, MKCOL, COPY, MOVE, LOCK, UNLOCK';
  $header{'DAV'} = '1, 2';
} elsif ($method eq 'GET' || $method eq 'HEAD') {
  if (!-e $root.$path) {
    $header{'Status'} = '404 Not Found';
  } elsif (!-r $root.$path) {
    $header{'Status'} = '403 Permission Denied';
  } elsif (-d $root.$path) {
    opendir(D, $root.$path) || die;
    @files = sort readdir(D);
    closedir(D);
    $path .= '/';
    foreach $file (@files) {
      ($dev, $inode, $mode, $numlink, $uid, $gid, $rdev, $size, $atime, $mtime, $ctime) = stat($root.$path.$file);
      ($sec, $min, $hour, $day, $mon, $year, $wday) = gmtime($mtime);
      $t = sprintf("%02d-%s-%4d %02d:%02d", $day, $monthName[$mon], $year + 1900, $hour, $min);
      $s_ref = &urlencode($script.$path.$file);
      $s_file = &sanitize($file);
      if (-d $root.$path.$file) {
        $s_ref .= '/';
        $s_file .= '/';
        $size = '-';
      }
      $body .= <<____;
<tr><td><a href="$s_ref">$s_file</td><td>$t</td><td align="right">$size</td></tr>
____
    }
    $s_path = &sanitize($path);
    $body = <<____;
<html><head><title>Index of $s_path</title></head>
<body><h1>Index of $s_path</h1><hr />
<table>
<thead><tr><th>Name</th><th>Last modified</th><th>Size</th></tr></thead>
<tbody>
$body</tbody></table><hr />
<address style="text-align:right">webdav.cgi (c)2006, yuno</address>
</body></html>
____
    $header{'Status'} = '200 OK';
    $header{'Content-Type'} = 'text/html; charset="utf-8"';
    $header{'Content-Length'} = length($body);
    $header{'Cache-Control'} = 'public';
    if ($method eq 'HEAD') {
      $body = '';
    }
  } elsif (-f $root.$path) {
    ($dev, $inode, $mode, $numlink, $uid, $gid, $rdev, $size, $atime, $mtime, $ctime) = stat($root.$path);
    ($sec, $min, $hour, $day, $mon, $year, $wday) = gmtime($mtime);
    $lastmod = sprintf('%s, %2d %s %04d %02d:%02d:%02d GMT', $wdayName[$wday], $day, $monthName[$mon], $year + 1900, $hour, $min, $sec);
    $header{'Status'} = '200 OK';
    $header{'Content-Type'} = &getContentType($root.$path);
    $header{'Last-Modified'} = $lastmod;
    $header{'ETag'} = "$dev-$inode-$mtime";
    if ($method eq 'HEAD') {
      $header{'Content-Length'} = $size;
    } elsif ($ifModifiedSince eq $lastmod) {
      $header{'Status'} = '304 Not Modified';
    } else {
      if ($ifRange eq '' || $ifRange eq $lastmod) {
        if ($range =~ /^bytes=([0-9]+)-([0-9]+)?$/) {
          $first = $1;
          $last = $2;
          $last = $size - 1 if $last eq '' || $last >= $size;
          if ($first <= $last) {
            $length = $last - $first + 1;
            $header{'Status'} = '206 Partial Content';
            $header{'Content-Range'} = "bytes $first-$last/$size";
            $partial = 1;
          }
        }
      }
      open(F, $root.$path) || die;
      if ($partial) {
        seek(F, $first, 0);
        read(F, $body, $length);
      } else {
        read(F, $body, $size);
      }
      close(F);
      $header{'Content-Length'} = length($body);
      $header{'Cache-Control'} = 'public';
    }
  } else {
    $header{'Status'} = '403 Forbidden';
  }
} elsif ($method eq 'PUT') {
  if (-e $root.$path && !-f $root.$path) {
    $header{'Status'} = '403 Forbidden';
  } elsif ($contentRange ne '') {
    $header{'Status'} = '501 Not Implemented';
  } elsif (!&check_lock($path)) {
    $header{'Status'} = '423 Locked';
  } elsif ($path =~ /(.*)\/[^\/]+$/ && !-w $root.$1) {
    $header{'Status'} = '403 Permission Denied';
  } else {
    $overwrite = -e $root.$path;
    open(F, ">$root$path") || die;
    binmode(F);
    print F $content;
    close(F);
    if (!$overwrite) {
      $header{'Status'} = '201 Created';
      $header{'Location'} = &urlencode($script.$path);
    } else {
      $header{'Status'} = '204 No Content';
    }
  }
} elsif ($method eq 'DELETE') {
  if (!-e $root.$path) {
    $header{'Status'} = '404 Not Found';
  } elsif ($path eq '' || $path eq '/') {
    $header{'Status'} = '403 Permission Denied';
  } elsif ($path =~ /^(.*)\/[^\/]+/ && !-w $root.$1) {
    $header{'Status'} = '403 Permission Denied';
  } elsif (!&check_lock($path)) {
    $header{'Status'} = '423 Locked';
  } elsif (-d $root.$path) {
    if ($depth ne '' && $depth ne 'infinity') {
      $header{'Status'} = '400 Bad Request';
    } elsif (&delTree($path)) {
      $header{'Status'} = '204 No Content';
    }
  } else {
    unlink($root.$path) || die;
    $header{'Status'} = '204 No Content';
  }
} elsif ($method eq 'MKCOL') {
  if ($content ne '') {
    # TODO: MKCOL with initial content
    $header{'Status'} = '501 Not Implemented';
  } elsif (-e $root.$path) {
    $header{'Status'} = '409 Conflict';
  } elsif ($path =~ /^(.*)\/[^\/]+/ && !-w $root.$1) {
    $header{'Status'} = '403 Permission Denied';
  } else {
    mkdir($root.$path) || die;
    $header{'Status'} = '201 Created';
    $header{'Location'} = &urlencode($script.$path.'/');
  }
} elsif ($method eq 'COPY') {
  # TODO: copy method
  $header{'Status'} = '501 Not Implemented';
} elsif ($method eq 'MOVE') {
  if ($depth ne '' && $depth ne 'infinity') {
    $header{'Status'} = '400 Bad Request';
  } elsif (!&check_lock($path)) {
    $header{'Status'} = '423 Locked';
  } elsif ($path =~ /^(.*)\/[^\/]+$/ && !-w $root.$1) {
    $header{'Status'} = '403 Permission Denied';
  } elsif ($destination =~ /^$script/) {
    $destpath = substr($destination, length($script));
    if ($destpath =~ /^(.*)\/[^\/]+$/ && !-w $root.$1) {
      $header{'Status'} = '403 Permission Denied';
    } elsif ($destpath =~ /^(.*)\/[^\/]+$/ && !&check_lock($1)) {
      $header{'Status'} = '423 Locked';
    } elsif (!-e $root.$destpath) {
      rename($root.$path, $root.$destpath) || die;
      $header{'Status'} = '201 Created';
      $header{'Location'} = &urlencode($script.$destpath);
    } elsif ($overwrite eq 'F') {
      $header{'Status'} = '412 Precondifion Failed';
    } elsif (!-w $root.$destpath) {
      $header{'Status'} = '403 Permission Denied';
    } elsif (&delTree($destpath)) {
      rename($root.$path, $root.$destpath) || die;
      $header{'Status'} = '204 No Content';
    }
  } else {
    # TODO: interserver move operation
    $header{'Status'} = '501 Not Implemented';
  }
} elsif ($method eq 'PROPFIND') {
  $depth = 'infinity' if $depth eq '';
  if ($depth ne '0' && $depth ne '1' && $depth ne 'infinity') {
    $header{'Status'} = '400 Bad Request';
  } elsif (!-e $root.$path) {
    $header{'Status'} = '404 Not Found';
  } else {
    $depth = 99999 if $depth eq 'infinity';
    $header{'Status'} = '207 Multi-Status';
    $header{'Content-Type'} = 'text/xml; charset="utf-8"';
    $body = &propfind($path, $depth);
    $body = <<____;
<?xml version="1.0" encoding="utf-8"?>
<multistatus xmlns="DAV:">
$body</multistatus>
____
  }
  sub propfind {
    my $path = shift;
    my $depth = shift;
    my $s_href = &urlencode($script.$path);
    my ($dev, $inode, $mode, $numlink, $uid, $gid, $rdev, $size, $atime, $mtime, $ctime) = stat($root.$path);
    my ($sec, $min, $hour, $day, $mon, $year, $wday) = gmtime($ctime);
    my $s_ctime = sprintf("%04d-%02d-%02dT%02d:%02d:%02dZ", $year + 1900, $mon + 1, $day, $hour, $min, $sec);
    ($sec, $min, $hour, $day, $mon, $year, $wday) = gmtime($mtime);
    $s_mtime = sprintf("%s, %02d %s %04d %02d:%02d:%02d GMT", $wdayName[$wday], $day, $monthName[$mon], $year + 1900, $hour, $min, $sec);
    $path =~ /([^\/]+)$/;
    my $s_name = &sanitize($1);
    if (-d $root.$path) {
      my $status;
      if ($depth == 0 || -r $root.$path) {
        $status = '200 OK';
      } else {
        $status = '403 Permission Denied';
      }
      if ($path eq '') {
        $s_name = &sanitize($rootName);
      }
      # TODO: lock discovery
      # TODO: lock-null resource
      my $body = <<____;
 <response>
  <href>$s_href/</href>
  <propstat>
   <prop>
    <displayname>$s_name</displayname>
    <resourcetype><collection/></resourcetype>
    <creationdate>$s_ctime</creationdate>
    <getlastmodified>$s_mtime</getlastmodified>
    <supportedlock>
     <lockentry>
      <lockscope><exclusive/></lockscope>
      <locktype><write/></locktype>
     </lockentry>
     <lockentry>
      <lockscope><shared/></lockscope>
      <locktype><write/></locktype>
     </lockentry>
    </supportedlock>
    <lockdiscovery/>
   </prop>
   <status>HTTP/1.1 $status</status>
  </propstat>
 </response>
____
      if ($depth > 0 && opendir(D, $root.$path)) {
        my @files = readdir(D);
        closedir(D);
        my $file;
        foreach $file (@files) {
          if ($file ne '.' && $file ne '..') {
            $body .= &propfind("$path/$file", $depth - 1);
          }
        }
      }
      $body;
    } elsif (-f $root.$path) {
      my $s_type = &getContentType($root.$path);
      my $body = <<____;
 <response>
  <href>$s_href</href>
  <propstat>
   <prop>
    <displayname>$s_name</displayname>
    <resourcetype/>
    <creationdate>$s_ctime</creationdate>
    <getlastmodified>$s_mtime</getlastmodified>
    <getcontentlength>$size</getcontentlength>
    <getcontenttype>$s_type</getcontenttype>
    <getetag>$dev-$inode-$mtime</getetag>
    <supportedlock>
     <lockentry>
      <lockscope><exclusive/></lockscope>
      <locktype><write/></locktype>
     </lockentry>
     <lockentry>
      <lockscope><shared/></lockscope>
      <locktype><write/></locktype>
     </lockentry>
    </supportedlock>
   </prop>
   <status>HTTP/1.1 200 OK</status>
  </propstat>
 </response>
____
      $body;
    }
  }
} elsif ($method eq 'PROPPATCH') {
  # TODO: proppatch method
  $header{'Status'} = '501 Not Implemented';
} elsif ($method eq 'LOCK') {
  if ($http_if eq '') {
    %xml = &parse_xml($content);
    $depth = 'infinity' if $depth eq '';
    if ($depth ne '0' && $depth ne 'infinity') {
      $header{'Status'} = '400 Bad Request';
    } elsif ($xml{'1'} ne 'DAV:lockinfo') {
      $header{'Status'} = '400 Bad Request';
    } else {
      for ($i = 1; exists $xml{"1.$i"}; ++$i) {
        if ($xml{"1.$i"} eq 'DAV:lockscope') {
          $lockscope = $xml{"1.$i.1"};
        } elsif ($xml{"1.$i"} eq 'DAV:locktype') {
          $locktype = $xml{"1.$i.1"};
        } elsif ($xml{"1.$i"} eq 'DAV:owner' && $xml{"1.$i.1"} eq 'DAV:href') {
          $lockowner = $xml{"1.$i.1:#PCDATA"};
        }
      }
      if ($locktype ne 'DAV:write') {
        $header{'Status'} = '501 Not Implemented';
      } elsif ($lockscope ne 'DAV:exclusive' && $lockscope ne 'DAV:shared') {
        $header{'Status'} = '501 Not Implemented';
      } else {
        $exclusive = $lockscope eq 'DAV:exclusive';
        $recursive = $depth eq 'infinity';
        if ($locktoken !~ /:/ || exists $lock{$locktoken}) {
          $lockseq = $lock{'seq'}++;
          $locktoken = $script.'/.locktoken/'.crypt(time, $lockseq);
        }
        if (&get_lock($path, $exclusive, $recursive)) {
          $header{'Status'} = '200 OK';
          $header{'Content-Type'} = 'text/xml; charset="utf-8"';
          $s_scope = '<exclusive/>' if $exclusive;
          $s_scope = '<shared/>' unless $exclusive;
          $s_owner = &urlencode($lockowner);
          $s_locktoken = &sanitize($locktoken);
          $body = <<____;
<?xml version="1.0" encoding="utf-8"?>
<prop xmlns="DAV:">
 <lockdiscovery>
  <activelock>
   <locktype><write/></locktype>
   <lockscope>$s_scope</lockscope>
   <depth>$depth</depth>
   <owner><href>$s_owner</href></owner>
   <timeout>Inifinite</timeout>
   <locktoken><href>$s_locktoken</href></locktoken>
  </activelock>
 </lockdiscovery>
</prop>
____
        } else {
          $header{'Status'} = '423 Locked';
        }
      }
    }
  } else {
    # TODO: refreshing lock
    $header{'Status'} = '501 Not Implemented';
  }
} elsif ($method eq 'UNLOCK') {
  if ($locktoken =~ /:/) {
    &release_lock($locktoken);
  }
  $header{'Status'} = '204 No Content';
} else {
  $header{'Status'} = '400 Bad Request';
}

if ($lockUpdated) {
  seek(LOCK, 0, 0);
  truncate(LOCK, 0);
  print LOCK join("\n", %lock);
}
flock(LOCK, 8);
close(LOCK);

if (!exists $header{'Content-Length'} && $body ne '') {
  $header{'Content-Length'} = length($body);
}
if (!exists $header{'Content-Type'} && $header{'Content-Length'} > 0) {
  $header{'Content-Type'} = 'application/octet-stream';
}

if ($trace) {
  open(LOG, ">>$trace");
  print LOG "------response------\n";
  foreach $key (keys %header) {
    $value = $header{$key};
    print LOG "$key: $value\n";
  }
  print LOG "\n$body\n" unless $method eq 'GET';
  close(LOG);
}

binmode(STDOUT);
foreach $key (keys %header) {
  $value = $header{$key};
  print "$key: $value\r\n";
}
print "\r\n$body";
close(STDOUT);

# end of file