71 lines
1.9 KiB
Perl
71 lines
1.9 KiB
Perl
# ==================================================================
|
|
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
|
#
|
|
# GT::CGI::Fh
|
|
# CVS Info :
|
|
# $Id: Fh.pm,v 1.2 2004/01/13 01:35:16 jagerman Exp $
|
|
#
|
|
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
|
# ==================================================================
|
|
#
|
|
# Description:
|
|
# Magic filehandle that prints the name, but is still a filehandle for reads -
|
|
# just like CGI.pm.
|
|
#
|
|
package GT::CGI::Fh;
|
|
# ===================================================================
|
|
use strict 'vars', 'subs';
|
|
use vars qw/$FH/;
|
|
use Fcntl qw/O_RDWR O_EXCL/;
|
|
use overload
|
|
'""' => \&as_string,
|
|
'cmp' => \&compare,
|
|
'fallback' => 1;
|
|
|
|
sub new {
|
|
# -------------------------------------------------------------------
|
|
# Create a new filehandle based on a counter, and the filename.
|
|
#
|
|
my ($pkg, $name, $file, $delete) = @_;
|
|
my $fname = sprintf("FH%05d%s", ++$FH, $name);
|
|
|
|
$fname =~ s/([:'%])/sprintf '%%%02X', ord $1/eg;
|
|
my $fh = \do { local *{$fname}; *{$fname} };
|
|
|
|
sysopen($fh, $file, O_RDWR | O_EXCL, 0600) or die "Can't open file: $file ($!)";
|
|
unlink($file) if $delete;
|
|
bless $fh, $pkg;
|
|
|
|
return $fh;
|
|
}
|
|
|
|
sub as_string {
|
|
# -------------------------------------------------------------------
|
|
# Return the filename, strip off leading junk first.
|
|
#
|
|
my $self = shift;
|
|
my $fn = $$self;
|
|
$fn =~ s/%(..)/ chr(hex($1)) /eg;
|
|
$fn =~ s/^\*GT::CGI::Fh::FH\d{5}//;
|
|
return $fn;
|
|
}
|
|
|
|
sub compare {
|
|
# -------------------------------------------------------------------
|
|
# Do comparisions, uses as_string to get file name first.
|
|
#
|
|
my $self = shift;
|
|
my $value = shift;
|
|
return "$self" cmp $value;
|
|
}
|
|
|
|
DESTROY {
|
|
# -------------------------------------------------------------------
|
|
# Close file handle.
|
|
#
|
|
my $self = shift;
|
|
close $self;
|
|
}
|
|
|
|
1;
|