view release on metacpan or  search on metacpan

lib/Lim/Util.pm  view on Meta::CPAN

                unlink($filename);
            }
            return;
        }
        unless (Digest::SHA::sha1_base64($content) eq Digest::SHA::sha1_base64($read)) {
            $fh->close;
            unless ($file->isa('File::Temp')) {
                unlink($filename);
            }
            return;
        }
    }
    return $file->isa('File::Temp') ? $file : 1;
}

=item $temp_file = Lim::Util::TempFile

Creates a temporary file. Returns a L<File::Temp> object or undef if there where
problems creating the temporary file.

=cut

sub TempFile {
    my $tmp;

    eval {
        $tmp = File::Temp->new;
    };

    unless ($@) {
        # TODO log error
        return $tmp;
    }
    return;
}

=item $temp_file = Lim::Util::TempFileLikeThis($file)

Creates a temporary file that will have the same owner and mode as the specified
C<$file>. Returns a L<File::Temp> object or undef if the specified file did not
exist or if there where problems creating the temporary file.

=cut

sub TempFileLikeThis {
    my ($file) = @_;

    if (defined $file and -f $file) {
        my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
            $atime,$mtime,$ctime,$blksize,$blocks)
            = stat($file);
        my $tmp;

        eval {
            $tmp = File::Temp->new;
        };

        # TODO log error

        unless ($@) {
            if (chmod($mode, $tmp->filename) and chown($uid, $gid, $tmp->filename)) {
                return $tmp;
            }
        }
    }
    return;
}

=item ($method, $uri) = Lim::Util::URIize($call)

Returns an URI based on the C<$call> given and the corresponding HTTP method to
be used.

Example:

=over 4

use Lim::Util;
($method, $uri) = Lim::Util::URIize('ReadVersion');
print "$method $ur\n";
($method, $uri) = Lim::Util::URIize('CreateOtherCall');
print "$method $ur\n";

=back

Produces:

=over 4

GET /version
PUT /other_call

=back

=cut

sub URIize {
    my @parts = split(/([A-Z][^A-Z]*)/o, $_[0]);
    my ($part, $method, $uri);

    while (scalar @parts) {
        $part = shift(@parts);
        if ($part ne '') {
            last;
        }
    }

    unless (exists $CALL_METHOD{$part}) {
        confess __PACKAGE__, ': No conversion found for ', $part, ' (', $_[0], ')';
    }

    $method = $CALL_METHOD{$part};

    @parts = grep !/^$/o, @parts;
    unless (scalar @parts) {
        confess __PACKAGE__, ': Could not build URI (', $_[0], ')';
    }
    $uri = lc(join('_', @parts));

    return ($method, '/'.$uri);
}