package WebFS::FileCopy::Put::File;

# Copyright (C) 1998-2001 by Blair Zajac.  All rights reserved.  This
# package is free software; you can redistribute it and/or modify it
# under the same terms as Perl itself.

require 5.004_04;

use strict;
use Exporter;
use Carp qw(cluck);

use vars qw(@ISA $VERSION);

@ISA     = qw(Exporter);
$VERSION = substr q$Revision: 1.04 $, 10;

sub new {
  my ($class, $req) = @_;

  my $uri    = $req->uri;
  my $scheme = $uri->scheme;
  unless ($scheme eq 'file') {
    $@ = $req->give_response(500,
			     "WebFS::FileCopy::Put::File invalid scheme $scheme");
    return;
  }

  my $host = $uri->host;
  if ($host and $host !~ /^localhost$/i) {
    $@ = $req->give_response(400, 'Only file://localhost/ allowed');
    return;
  }

  # Open the file.
  local *FH;
  open(FH, '>' . $uri->file) or do {
    $@ = $req->give_response(401, "$!");
    return;
  };

  # Make sure the file is in binary mode, otherwise copies of binary
  # files on Windows will not work.
  binmode(*FH);

  bless {'req' => $req, 'handle' => *FH}, $class;
}

sub print {
  return unless defined($_[1]);
  print {$_[0]->{handle}} $_[1];
}

sub close {
  my $self = shift;

  my $ret = close($self->{handle});
  $self->{req}->give_response($ret ? 201 : 500);
}

sub DESTROY {
  if ($WebFS::FileCopy::WARN_DESTROY) {
    my $self = shift;
    print STDERR "DESTROYing $self\n";
  }
}

1;