Apache-Wyrd
view release on metacpan or search on metacpan
You should have received a copy of the GNU General Public License along
with Apache::Wyrd (see LICENSE); if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
=cut
sub _init{
my ($dbl, $init) = @_;
#NOTE: Because DBL is tested here for DBL compatibility, it does not need to be tested again anywhere else
#in a Wyrd. If it is defined, it is a DBL.
my $not_hash = (ref($init) ne 'HASH');
if (ref($dbl) and UNIVERSAL::can($dbl, 'verify_dbl_compatibility')) {
$_dbl = $dbl;
$dbl->log_bug("ERROR: Invalid data (non-hashref) apparently given to object as Initial Value -- Ignoring")
if ($not_hash);
}
$init = {} if ($not_hash);
foreach my $level (values %_loglevel) {
$_error_handler{$level} = $_disabled_error_handler;
}
#must test for existence, since a loglevel can be 0 and, therefore, false
$init->{'loglevel'} = ($dbl->loglevel || 1) unless (exists($init->{'loglevel'}));
$init->{'loglevel'} = ($_loglevel{$init->{'loglevel'}} || $init->{'loglevel'} || 0);
for (my $level=0; $init->{'loglevel'} >= $level; $level++) {
$_error_handler{$level} = $_enabled_error_handler;
}
#set the dielevel (level lower than which, execution will terminate. The _raise_exception() method will
Wyrd/Datum.pm view on Meta::CPAN
return $_[1];
}
sub _suggest {
return $_[1];
}
sub _check_value {
#by default, approve everything unless not-null is specified
my ($self, $value, $params) = @_;
return (0, 'Required value missing') if ($params->{'not_null'} and not($value));
return 1;
}
sub _set {
my($self, $value) = @_;
$value = $self->[Apache::Wyrd::Datum::PARAMS]->{_translate_key}->{$value} if ($self->[Apache::Wyrd::Datum::PARAMS]->{translate_key});
$self->[Apache::Wyrd::Datum::VALUE] = $value;
return $self->[Apache::Wyrd::Datum::PARAMS]->{_rev_translate_key}->{$self->[Apache::Wyrd::Datum::VALUE]} if ($self->[Apache::Wyrd::Datum::PARAMS]->{translate_key});
return $value;
}
Wyrd/Datum.pm view on Meta::CPAN
my ($self, $params) = @_;
die("Length was provided to " . &_type . ", but was a null value") unless ($params->{'length'});
die(&_type . " length can be no longer than 255 chars") unless ($params->{'length'} <= 255);
die(&_type . " length must be greater than 0") unless ($params->{'length'} > 0);
return $params;
}
sub _check_value {
my ($self, $value, $params) = @_;
return (0, 'Text is too long') if ($params->{'length'} and (length($value) > $params->{'length'}));
return (0, 'Required value missing') if ($params->{'not_null'} and not($value));
return 1;
}
package Apache::Wyrd::Datum::Enum;
use base qw(Apache::Wyrd::Datum::Char);
sub _type {
return "enum";
}
Wyrd/Datum.pm view on Meta::CPAN
sub _check_params {
my ($self, $params) = @_;
die("enum without arrayref opts") unless (ref($params->{'options'}) eq 'ARRAY');
return $params;
}
sub _check_value {
my($self,$value,$params) = @_;
_raise_exception("Enum value must be scalar") if (ref($value));
unless ($params->{'not_null'}) {
#empty value is always OK unless not-null is set
return 1 if (not($value) and ($value ne '0'));
}
#Compare value to options, ok if a match
return (0, qq("$value" is not a permitted value))
unless (grep {lc($_) eq lc($value)} @{$params->{'options'}});
return 1;
}
package Apache::Wyrd::Datum::Set;
Wyrd/Datum.pm view on Meta::CPAN
sub _check_params {
my ($self, $params) = @_;
die("enum without arrayref opts") unless (ref($params->{'options'}) eq 'ARRAY');
return $params;
}
sub _check_value {
my($self,$value,$params) = @_;
$self->_raise_exception("Set value must be arrayref") if (ref($value) ne 'ARRAY');
unless ($params->{'not_null'}) {
#empty value is always OK unless not-null is set
return 1 if ((scalar(@$value) == 1) and (not($$value[0]) and ($$value[0] ne '0')) or not(scalar(@$value)));
}
#Go through all permutations, checking each against the total
my $ok = 1;
my $test;
foreach my $i (@$value) {
$test = undef;
foreach my $j (@{$params->{'options'}}) {
$test = 1 if (lc($j) eq lc($i));
Wyrd/Datum.pm view on Meta::CPAN
package Apache::Wyrd::Datum::Integer;
use base qw(Apache::Wyrd::Datum::Char);
sub _type {
return "integer";
}
sub _check_value {
my($self,$value,$params) = @_;
unless ($params->{'not_null'}) {
return 1 unless ($value);
}
return (0, 'Value must be a whole number') unless ($value =~ /-?^\d+$/);
return (0, 'Value must be a positive number') if ($value < 0 and not($params->{'signed'}));
return (0, 'Value is too high') if ($value > ('9' x $params->{'length'}) + 0);
return (1, undef);
}
sub _type {
return "integer";
}
Wyrd/Datum.pm view on Meta::CPAN
Apache::Wyrd::Datum - Abstract data-checking objects for Wyrd Input objects
=head1 SYNOPSIS
use Apache::Wyrd::Datum;
my $ives = Apache::Wyrd::Datum::Set->new(
'kits',
{
options => ['kits', 'cats', 'sacks', 'wives'],
not_null => 0
}
);
my ($are_ostriches_ok, $why_not) = $ives->check('ostriches')
my $is_cats = $ives->set('cats');
if ($is_cats) {
print "yes, it can be cats"
} else {
print "no, cats are out"
}
my $suggest_something_then = $ives->suggest;
Wyrd/Input.pm view on Meta::CPAN
=item escape
Escape the HTML of the value, so as to avoid HTML parsing errors.
Default behavior for Inputs who's end-result input tags have this
problem, such as E<lt>input type="text"E<gt>
=item no_fail
Always accept value, even when invalid.
=item not_null
an alias for required.
=item quiet
Do not report error messages, only errors.
=item required
trigger an error if empty
Wyrd/Input.pm view on Meta::CPAN
$self->{'value'} ||= undef;#value will be set by the end if not earlier
$self->{'_error_messages'} ||= [];
my $name = $self->{'name'};
$self->{'param'} ||= $name;
my $type = $self->{'type'};
$self->_parse_options;
#primitives are overriden by instances of Apache::Wyrd::Input
my %params = (
#default params
strict => ($self->_flags->{strict} || undef),
not_null => ($self->_flags->not_null || $self->_flags->required || undef),
options => $self->{'options'}
);
if ($self->_flags->readonly) {
$self->{'readonly'} = 'true';
}
$self->{'_template'} = $self->{'_data'};
if ($name eq '') {
$self->_raise_exception('All Inputs must have a name')
} elsif ($type eq '') {
$self->_raise_exception('All Inputs must have a type')
Wyrd/Services/Index.pm view on Meta::CPAN
$self->close_db;
return "Update of entry $id " . ($self->error ? "unsuccessful." : "successful.");
}
sub purge_entry {
my ($self, $entry) = @_;
my $id = undef;
my $found_entry = undef;
my $not_entry = $self->db->db_get("\x00%$entry", $found_entry);
if ($not_entry) {
$id = $entry;
$self->db->db_get($entry, $found_entry);
$entry = $found_entry;
} else {
$id = $found_entry;
}
#warn "$id and $entry";
unless ($id and $entry) {
return "Entry not found to purge: $entry";
return 1;
Wyrd/Services/Index.pm view on Meta::CPAN
}
# For each item, add id to map
foreach my $item (sort @items) {
#This actually does happen, strangely enough.
unless ($item or ($item =~ /^0+$/o)) {
warn 'null item here';
warn 'but defined' if (defined($item));
}
my $value = undef;
my $not_found = $self->db->db_get("$attribute\%$item", my $data);
my(%entries) = ();
%entries = unpack("n*", $data) unless ($not_found);
$entries{$id} = $unique{$item};
foreach my $item (keys %entries) {
$value .= pack "n", $item;
$value .= pack "n", $entries{$item};
}
#warn($self->translate_packed($attribute) . "\%$item: " . $self->translate_packed($value));
$self->update_key("$attribute\%$item", $value);
}
if ($self->reversemaps) {
my $rev_attribute = $self->attributes->{"_$attribute_name"};
Wyrd/Services/MySQLIndex.pm view on Meta::CPAN
#check that the name is OK
my $name = $entry->index_name;
$self->set_error("Index entries must return non-null for method index_name()") unless ($name);
$self->check_error;
$self->set_error("<DELETED> is an invalid name for index entries ") if ($name eq '<DELETED>');
$self->set_error($name . " is an invalid name for index entries ") if ($name =~ /^.%/s);
$self->check_error;
#everything OK? Start the DB handle and check that it is supposed to be indexed.
$self->read_db;
my ($id, $not_found_flag) = $self->get_id($name);
#If this entry has been set not to index, make sure it is not in the index and return.
if ($entry->no_index) {
if ($not_found_flag) {
#if key is not found
return "yes to no_index and not indexed.";
}
$self->write_db;
my $result = $self->purge_entry($id);
$self->close_db;
return $result;
}
$debug && warn $name . " is new" if ($not_found_flag);
my $current_timestamp = undef; #lexically scoped to reduce multiple timestamp calculations
my $current_digest = undef; #lexically scoped to reduce multiple digest calculations
unless ($entry->force_update) {
my $sh = $self->db->prepare("select id, timestamp, digest from _wyrd_index where name=?");
$sh->execute($name);
my ($id, $timestamp, $digest) = @{$sh->fetchrow_arrayref || []};
$current_timestamp = $entry->index_timestamp;
$debug && warn "Comparing timestamps: $timestamp <-> " . $current_timestamp . " for " . $name;
if ($timestamp eq $current_timestamp) {
$debug && warn "No update needed. Timestamp is $timestamp." ;
Wyrd/Services/MySQLIndex.pm view on Meta::CPAN
}
}
}
#We are sure the object's entry is out-of-date, so it's time to update.
$self->write_db;
#TODO: Add a new way of handling transactions
my %entry = ();
$self->purge_entry($id) unless ($not_found_flag); #necessary to clear out words which will not match
$entry{'name'} = $name;
$entry{'timestamp'} = $current_timestamp;
$entry{'digest'} = $current_digest || $entry->index_digest;
$entry{'title'} = $entry->index_title if ($entry->can('index_title'));
$entry{'keywords'} = $entry->index_keywords if ($entry->can('index_keywords'));
$entry{'description'} = $entry->index_description if ($entry->can('index_description'));
my $field_clause = '(' . join(', ', keys %entry) . ')';
my $value_clause = '('
. join(
Wyrd/Services/MySQLIndex.pm view on Meta::CPAN
}
}
sub get_id {
my ($self, $name) = @_;
my $sh = $self->db->prepare('select id from _wyrd_index where name=?');
$sh->execute($name);
if ($sh->err) {
$self->set_error($sh->errstr);
}
my $not_found = undef;
my $data_ref = $sh->fetchrow_arrayref;
my $id = $data_ref->[0];
unless ($id) {
$not_found = 1;
}
if (wantarray) {
return ($id, $not_found);
}
return $id;
}
sub get_value {
my ($self, $id, $attribute) = @_;
my $sh = $self->db->prepare("select $attribute from _wyrd_index where id=?");
$sh->execute($id);
if ($sh->err) {
$self->set_error($sh->errstr);
( run in 0.613 second using v1.01-cache-2.11-cpan-cc502c75498 )