/usr/share/perl5/UR/Test.pm is in libur-perl 0.430-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 | package UR::Test;
use strict;
use warnings;
require UR;
our $VERSION = "0.43"; # UR $VERSION;
use Test::More;
sub check_properties {
my $o_list = shift;
my %params = @_;
my $skip = delete $params{skip};
if (%params) {
die "odd params passed: " . join(" ", %params);
}
ok(
scalar(@$o_list),
"got " . scalar(@$o_list) . " objects "
. " of type " . ref($o_list->[0])
);
my $cn = ref($o_list->[0]);
my $c = UR::Object::Type->get($cn);
ok($c, "got class meta for $cn");
my @pm =
map { $_->[1] }
sort { $a->[0] cmp $b->[0] }
map { [ $_->property_name, $_ ] }
$c->all_property_metas;
ok(scalar(@pm), "got " . scalar(@pm) . " properties");
if ($skip) {
$skip = { map { $_ => 1 } @$skip };
my @pm_remove;
my @pm_keep;
for my $p (@pm) {
if ($skip->{$p->property_name}) {
push @pm_remove, $p;
}
else {
push @pm_keep, $p;
}
}
if (@pm_remove) {
note(
'skipping ' . (@pm_remove) . " properties: "
. join(", ", map { $_->property_name } @pm_remove)
);
@pm = @pm_keep;
}
}
my (@v,$v, $last_property_name);
for my $pm (@pm) {
my $p = $pm->property_name;
next if defined($last_property_name) and $p eq $last_property_name;
$last_property_name = $p;
my $is_mutable = $pm->is_mutable;
my $is_many = $pm->is_many;
my %errors;
#diag($p);
for my $o (@$o_list) {
eval {
if ($is_many) {
@v = $o->$p();
if ($is_mutable) {
#$o->$p([]);
#$o->$p(\@v);
}
}
else {
my $v = $o->$p();
if ($is_mutable) {
#$o->$p(undef);
#$o->$p($v);
}
}
};
if ($@) {
my ($e) = split(/\n/,$@);
my $a = $errors{$e} ||= [];
push @$a, $o;
}
}
my $msg;
if (%errors) {
for my $error (keys %errors) {
my $objects = $errors{$error};
$msg .= 'on ' . scalar(@$objects) . ' of ' . scalar(@$o_list) . "objects: " . $error;
chomp $msg;
$msg .= "\n";
}
}
ok(!$msg, "property check: $p") or diag $msg;
}
}
1;
|