File::BLOB - A file (with name, and other metadata) you can BLOBify

  # Create a File::BLOB object from data or a filehandle
  $file = File::BLOB->new( 'data'         ); # Copies
  $file = File::BLOB->new( \$data         ); # Doesn't copy
  $file = File::BLOB->new( $filehandle    );

  # Create from an existing file
  $file = File::BLOB->from_file( 'filename.txt' );

  # Create from a file uploaded via CGI
  $file = File::BLOB->from_cgi( $CGI, 'param' );

  # You can assign arbitrary headers/metadata when creating objects
  $file = File::BLOB->new( 'filename.txt',
  	content_type => 'text/plain',
  	filename     => 'myname.txt',
  	owner        => 'ADAMK',
  	);
  if ( $file->get_header('filename') eq 'filename.txt' ) {
  	$file->set_header( 'filename' => 'yourname.txt' );
  }

  # Get or change the content
  if ( $file->get_content =~ /FOO/ ) {
  	my $backup = $file->get_content;
  	$file->set_content( 'data'      );
  	$file->set_content( \$data      );
  	$file->set_content( $filehandle );
  }

  # Freeze to and thaw from a BLOB
  my $blob = $file->freeze;
  $file = File::BLOB->thaw( $blob );

  $file = File::BLOB->new( $data     );
  $file = File::BLOB->new( \$data    );
  $file = File::BLOB->new( $iohandle );
  $file = File::BLOB->new( $data,
  	header   => 'value',
  	filename => 'file.txt',
  	);

  $file = File::BLOB->from_file( "/home/me/some_picture.gif" );
  $file = File::BLOB->from_file( "foo.txt",
  	'content_type' => 'text/plain',
  	'foo'          => 'bar',
  	);

  my $file = File::BLOB->from_cgi( $CGI, 'param' );

  my $data = $file->get_content;
  my $copy = $$data;

  $file->set_content( $data     );
  $file->set_content( \$data    );
  $file->set_content( $iohandle );

  my $name = $file->get_header('filename');

  # Set a header
  $file->set_header('filename', 'foo.txt');

  # Delete a header
  $file->set_header('filename', undef    );

  my $string = $file->freeze;

  my $file = File::BLOB->thaw( $string );

package File::BLOB;

use 5.005;
use strict;
use bytes          ();
use Carp           ();
use IO::File       ();
use Storable       ();
use File::Basename ();
use Params::Util   qw{ _SCALAR _INSTANCE _IDENTIFIER };

# Optional prefork support
eval "use prefork 'File::Type';";

use vars qw{$VERSION};
BEGIN {
	$VERSION = '1.06';
}





#####################################################################
# Constructor and Accessors

sub new {
	my $class = ref $_[0] ? ref shift : shift;

	# Create the basic object
	my $self = bless {}, $class;

	# Set the content (don't copy it yet)
	$self->set_content(shift);

	# Set the headers
	while ( @_ ) {
		$self->set_header(shift, shift);
	}

	# Unless we know the MIME type, find it
	$self->{content_type} ||= $self->_mime_type($self->{content});

	$self;
}

sub from_file {
	my $class  = ref $_[0] ? ref shift : shift;
	my $path   = shift;
	my %params = @_; # Just for use here

	# Basic checks on the filename
	unless ( $path and -e $path ) {
		Carp::croak("Invalid file name or file does not exist");
	}
	unless ( -r _ ) {
		Carp::croak("Insufficient permissions to read file");
	}

	# Find the file name
	my @auto = ();
	unless ( exists $params{filename} ) {
		my $file = File::Basename::basename($path)
			or Carp::croak("Failed to determine file name");
		push @auto, 'filename' => $file;
	}

	# Open the file
	my $handle = IO::File->new($path, "r");
	unless ( $handle ) {
		Carp::croak("Failed to open file: $!");
	}

	$class->new( $handle, @auto, @_ );
}

sub from_cgi {
	my $class = ref $_[0] ? ref shift : shift;
	my $cgi   = _INSTANCE(shift, 'CGI') or Carp::croak(
		'First argument to from_cgi was not a CGI object'
		);
	my $param = shift;
	_SCALAR(\$param) or Carp::croak(
		'Second argument to from_cgi was not a CGI param'
		);

	# Fetch the filehandles
	my @handles = $cgi->upload($param) or return;
	if ( ! wantarray ) {
		# Remove all but the first filehandle
		while ( @handles > 1 ) {
			pop @handles;
		}
	}

	# Convert each of the filehandles to File::BLOB objects,
	# with all headers intact.
	my @objects = ();
	foreach my $fh ( @handles ) {
		my $headers = $cgi->uploadInfo($fh) or Carp::croak(
			"Failed to get headers for upload '$param'"
			);
		my $file = File::BLOB->new( $fh, %$headers ) or Carp::croak(
			"Failed to create File::BLOB for upload '$param'"
			);
		push @objects, $file;
	}

	# Return in either list or scalar context
	wantarray ? @objects : $objects[0];
}





#####################################################################
# Work with the Content

sub get_content {
	$_[0]->{content};
}

sub set_content {
	my $self = shift;
	my $data = shift;

	# Ensure the passed data is a scalar reference
	my $content;
	if ( _SCALAR($data) ) {
		$content = $data;
	} elsif ( _INSTANCE($data, 'IO::Handle') ) {
		# Read in as binary data
		local $/ = undef;
		$data->binmode if $data->can('binmode');
		my $data = $data->getline;
		unless ( defined $data and ! ref $data ) {
			Carp::croak("Failed to get content from filehandle");
		}
		$content = \$data;
	} elsif ( defined $data and ! ref $data ) {
		$content = \$data;
	} else {
		Carp::croak("Invalid parameter to File::BLOB::new");
	}

	# Set the content and content_length
	$self->{content}        = $content;
	$self->{content_length} = bytes::length($$content);

	1;
}

sub get_header {
	my $self = shift;
	my $name = $self->_name(shift);
	return $self->{$name};
}

sub set_header {
	my $self  = shift;
	my $name  = $self->_name(shift);
	@_ or Carp::croak("Did not provide a value for header $name");
	my $value = $self->_value(shift);

	if ( defined $value ) {
		# Set the header
		$self->{$name} = $value;
	} else {
		# Remove the header
		delete $self->{$name};
	}

	1;
}





#####################################################################
# Storable Support

sub freeze {
	my $self = shift;

	# Generate the headers
	my $frozen = '';
	foreach my $name ( sort keys %$self ) {
		next if $name eq 'content';
		$frozen .= "$name: $self->{$name}\012";
	}
	$frozen .= "\012";

	# Add the main content and return
	return ( $frozen . ${$self->{content}} );
}

sub thaw {
	my ($class, $serialized) = @_; # Copy to destroy

	# Parse in the data
	my %headers = ();
	while ( $serialized =~ s/^(.*?)\012//s ) {
		my $header = $1;
		if ( bytes::length($header) ) {
			unless ( $header =~ /^(.+?): (.+)$/s ) {
				Carp::croak("Frozen File::BLOB object is corrupt");
			}
			$headers{lc $1} = $2;
			next;
		}

		# We hit the double-newline. The remainder of
		# the file is the content.
		unless ( defined $headers{content_length} ) {
			Carp::croak("Frozen File::BLOB object is corrupt");
		}
		unless ( $headers{content_length} == bytes::length($serialized) ) {
			Carp::croak("Frozen File::BLOB object is corrupt");
		}

		# Hand off to the constructor
		delete $headers{content_length};
		return $class->new( \$serialized, %headers );
	}

	# This would be bad. It shouldn't happen
	Carp::croak("Frozen File::BLOB object is corrupt");
}





#####################################################################
# File Serialization

sub save {

}

sub read {
	my $class = shift;

	# Check the file
	my $file = shift;
	Carp::croak('You did not specify a file name')          unless $file;
	Carp::croak("File '$file' does not exist")              unless -e $file;
	Carp::croak("'$file' is a directory, not a file")       unless -f _;
	Carp::croak("Insufficient permissions to read '$file'") unless -r _;

	# Open the file and read in the headers
	my %headers = ();
	my $handle  = IO::File->new($file, 'r');
	Carp::croak("Failed to open file $file") unless $handle;
	while ( defined(my $line = $handle->getline) ) {
		chomp($line);
		last if ! length($line);
		unless ( $line =~ /^(\w+):\s*(.+?)\s$/ ) {
			Carp::croak("Illegal header line $line");
		}
		$headers{$1} = $2;
	}

	# Check class
	unless ( $headers{class} eq $class ) {
		Carp::croak("Serialized class mismatch. Expected $class, got $headers{$class}");
	}

	return $class->new( $handle, %headers );
}





#####################################################################
# Support Methods

# Check a name parameter
sub _name {
	my $self  = shift;

	# Check the name is a string
	my $name = shift;
	if ( ! defined $name ) {
		Carp::croak("Header name was an undefined value");
	}
	if ( ref $name ) {
		Carp::croak("Header name cannot be a reference");
	}
	if ( $name eq '' ) {
		Carp::croak("Header name cannot be a null string");
	}

	# The name should be an identifier	
	$name = lc $name;
	unless ( _IDENTIFIER($name) ) {
		Carp::croak("Header name is not in a valid format");
	}
	if ( $name eq 'content' ) { 
		Carp::croak("Header name 'content' is reserved");
	}

	return $name;
}

# Check the value is a string
sub _value {
	my $self  = shift;

	# Check the value is a string
	my $value = shift;
	if ( ! defined $value ) {
		# In this case, it is legal
		return $value;
	}
	if ( ref $value ) {
		Carp::croak("Header value cannot be a reference");
	}
	if ( $value eq '' ) {
		Carp::croak("Header value cannot be a null string");
	}

	# Cannot contain newlines or colons
	if ( $value =~ /\n/s ) {
		Carp::croak("Header value cannot contain newlines");
	}

	return $value;
}

# Takes a SCALAR reference and returns the MIME type
sub _mime_type {
	my $self = shift;
	my $data = _SCALAR(shift) or Carp::croak(
		"Did not provide a SCALAR reference to File::BLOB::_mime_type"
		);
	require File::Type;
	return File::Type->checktype_contents($$data);
}

1;