view release on metacpan or  search on metacpan

Wyrd/Services/SAK.pm  view on Meta::CPAN

C<Apache::Wyrd::Interfaces::Setter> when given an array of column names.

=cut

sub set_clause {
	my @items = @_;
	@items = map {$_ . '=$:' . $_} @items;
	return join(", ", @items);
}

=pod

=back

=head2 FILES (:file)

Old-style file routines and file-related methods.

=over

=item (scalarref) C<file_attribute>(scalar, scalar, scalar)

Convert and check a file attribute based on tests.  The tests are 'r'
for read, 'w' for write, 'f' for exists (file) and 'd' for exists
(directory), similar to the builtin -E<lt>fooE<gt> tests of the same
name.  If the file does not exist, but the test is w and not f or d,
this method will check if the item is in a writeable directory.

If the file path under the attribute is not absolute, the relative path
will be calculated first from the current location (of the file in which
the wyrd is located) or from the document root, in that order.

The method returns C<undef> on failure and the resolved path on success,
leaving the attribute intact.

=cut

sub file_attribute {
	my ($self, $attr, $tests) = @_;
	$self->_error("file_attribute() accepts only the r, w,d , and f tests") if ($tests =~ /[^rwdf]/);
	#warn "File is " . $self->{$attr};
	my @paths = ($self->{$attr});
	#warn "File is $paths[0]";
	unless (-e $paths[0]) {
		$paths[0] =~ s#^/##;
		my ($curdir) = ($self->dbl->file_path =~ m#(.+)/([^/]+)#);
		push @paths, "$curdir/$paths[0]";
		my ($rootdir) = ($self->dbl->req->document_root);
		push @paths, "$rootdir/$paths[0]";
	}
	foreach my $path (@paths) {
		#warn "testing $path";
		my $result = 1;
		foreach my $test (split '', $tests) {
			my $write_ok = (-w $path);
			$result = 0 if ($test eq 'w' and not ($write_ok));
			$result = 0 if ($test eq 'r' and not (-r _));
			$result = 0 if ($test eq 'd' and not (-d _));
			$result = 0 if ($test eq 'f' and not (-f _));
		}
		($path) = $path =~ /(.+)/;#untaint
		return $path if ($result);
	}
	#at this point, the tests have failed for all paths.
	#test the special case of a file for writing that does
	#not yet exist
	if (($tests =~ /w/) and ($tests !~ /d|f/)) {
		foreach my $path (@paths) {
			($path) = $path =~ /(.+)/;#untaint
			my ($testdir, @null) = ($path =~ m#(.+)/([^/]+)#);
			if ($tests =~ /r/) {
				return $path if (-d $testdir and -w _ and -r _)
			} else {
				return $path if (-d $testdir and -w _)
			}
		}
	}
	return;
}

=pod

=item (scalarref) C<slurp_file>(scalar)

get whole contents of a file.  The only argument is the whole path and
filename.  A scalarref to the contents of the file is returned.

=cut

sub slurp_file {
	my $file = shift;
	$file = open (FILE, $file);
	if ($file) {
		local $/;
		$file = <FILE>;
		close (FILE);
	}
	return \$file;
}

=pod

=item (scalar) C<spit_file>(scalar, scalar)

Opposite of C<slurp_file>.  The second argument is the contents of the file.
A positive response means the file was successfully written.

=cut

sub spit_file {
	my ($file, $contents) = @_;
	my $success = open (FILE, '>', $file);
	if ($success) {
		print FILE $contents;
		close (FILE);
	}
	return $success;
}

=pod

=back

=head2 HASHES (:hash)

Helpful routines for handling hashes.

=over