;
}
chomp(@files);
for my $file (@files) {
next if (-d $file);
next if ($file =~ /.bak\d+/);
print "Handling $file\n";
my $bak = $file . ".bak$$";
print `mv '$file' '$bak'`;
print `grep -- '$find' '$bak'`;
#print `cat $bak | sed 's/$find/$replace/g' > $file`;
my $IN;
my $OUT;
open($IN,$bak) or warn "can't open $bak!" && next;
open($OUT,">$file") or die;
while (<$IN>)
{
$_ =~ s/$find/$replace/g;
print $OUT $_;
}
close $OUT;
close $IN;
print `diff $bak $file`;
print `rm $bak`;
print "\n";
}
#print "\\rm `find * | grep .bak$$\n";
update-pod.sh 100775 023532 023421 206 12544604516 16265 0 ustar 00abrummet gsc 000000 000000 UR-0.44/dist-maint #!/usr/bin/env bash
cd ..
rm -rf pod
cd lib/UR
ur update pod -i .. -o ../../pod ur UR::Namespace::Command
cd ../..
rm -rf pod/ur-old*
update-ur-all.sh 100775 023532 023421 360 12544604516 16700 0 ustar 00abrummet gsc 000000 000000 UR-0.44/dist-maint #!/usr/bin/env bash
cat MANIFEST \
| grep ^lib \
| grep '\.pm$' \
| grep -v 'lib/above.pm' \
| grep -v 'lib/UR.pm' \
| grep -v 'lib/UR/All.pm' \
| perl -ne 'chomp; s|^lib/||; s|\.pm$||; s|/|::|g; print "use $_;\n";'
update-version.pl 100775 023532 023421 1046 12544604516 17214 0 ustar 00abrummet gsc 000000 000000 UR-0.44/dist-maint #!/usr/bin/env perl
use strict;
use warnings;
my $new = shift;
die "please supply the new version number N.NN\n" unless $new;
my $old = shift;
$old ||= ($new - 0.01);
print "updating version from $old to $new\n";
my $cmd = qq{cd ..; dist-maint/findreplace '$old"; # UR \\\$VERSION' '$new"; # UR \$VERSION' `grep -rn '# UR \\\$VERSION' lib/ | sed s/:.*//`};
print $cmd,"\n";
system $cmd;
$cmd = qq{cd ..; dist-maint/findreplace ' version $old' ' version $new' `grep -rn 'This document describes ' lib/ | sed s/:.*//`};
print $cmd,"\n";
system $cmd;
common.yml 100664 023532 023421 633 12544604516 15174 0 ustar 00abrummet gsc 000000 000000 UR-0.44/gmt-web ---
layout: sub
menu:
- text: Overview
href: index.html
- text: Documentation
href: documentation.html
- text: Install
href: install.html
module_details:
name: 'UR'
exe_name: ur
gmt_pkg_name: ur
debian_pkg_name: libur-perl
icon: res/images/icon_48.png
icon_16: res/images/icon_16.png
download_link: install.html
github_url: https://github.com/genome/UR
documentation.html 100664 023532 023421 27354 12544604516 20443 0 ustar 00abrummet gsc 000000 000000 UR-0.44/gmt-web/content UR User Manual
UR::Manual::Overview - UR from Ten Thousand Feet
Standard software languages provide a facility for making objects. Those
objects have certain characteristics which are different with UR objects.
A standard object in most languages:
- exists only as long as the program which created it has a reference to it
- requires that the developer manage organizing the
object(s) into a structure
to support any searching required
- handles persistence between processes explicitly, by saving or loading the object to external storage
- references other objects only if explicitly linked to those objects
- acts as a functional software device, but any meaning associated with the object is implied by how it is used
Regular objects like those described above are the building blocks of most software.
In many cases, however, they are often used for a second, higher-level
purpose: defining entities in the domain model of the problem area the
software addresses. UR objects are tailored to represent domain model
entities well. In some sense, UR objects follow many of the design principles
present in relational databases, and as such mapping to a database for UR
objects is trivial, and can be done in complex ways.
UR objects differ from a standard object in the following key ways:
- the object exists after creation until explicitly deleted, or the transaction it is in rolled-back
- managing loaded objects is done automatically by a Context object, which handles queries, saving, lazy-loading and caching
- it is possible to query for an object by specifying the class and the matching characteristics
- the object can reference other objects which are not loaded in the current process, and be referenced by objects not in the current process
- the object is a particular truth-assertion in the context in which it exists
UR's primary reason for existing is to function as an ORM. That is, managing
how to store instances of objects in memory of a running program with more
persistant storage in a relational database, and retrieve them later. It
handles the common cases where each table is implemented by a class their
columns are properties of the classes; retrieving objects by arbitrary
properties; creating, updating and deleting objects with enforced database
constraints; and named relationships between classes.
It can also handle more complicated things like:
- classes for things which are not database entities at all
- derived classes where the data spans multiple tables between the parent and child classes
- loading an object through a parent class and having it automatically reblessed into the appropriate subclass
- properties with no DB column behind them
- calculated properties with a formula behind them
- inheritance hierarchies that may have tables missing at some or all stages
- meta-data about Properties, Classes and the relationships between them
With UR, every object you create is made a part of the current ``Context''.
Conceptually, the Context is the lens by which your application views the
data that exists in the world. At one level, you can think of the current
context as an in-memory transaction. All changes to the object are tracked
by the context. The Context knows how to map objects to their storage
locations, called Data Sources. Saving your changes is simply a matter of
asking the current context to commit.
The Context can also reverse the saving process, and map a request for an
object to a query of external storage. Requests for objects go through the
Context, are loaded from outside as needed, and are returned to the caller
after being made part of the current context's transaction.
Objects never reference each other by actual Perl reference internally,
instead they use the referent's ID. Accessors on an object which return
another object send the ID through the context to get the object back,
allowing the context to load the referenced object only when it is actually
needed. This means that your objects can hook together until references
span an entire database schema, and pulling one object from the database
will not load the entire database into memory.
The context handles caching, and by default will cache everything it
touches. This means that you can ask for the same thing multiple times,
and only the first request will actually hit the underlying database.
It also means that requests for objects which map to the same ID will return
the exact same instance of the object.
The net effect is that each process's context is an in-memory database. All
object creation, deletion, and change is occurring directly to that database.
For objects configured to have external persistence, this database manages
itself as a ``diff'' vs. the external database, allowing it to simulate
representing all UR data everywhere, while only actually tracking what is needed.
- database queries don't repeat themselves again and again
- you never write insert/update/delete statements, or work out constraint order yourself
- allows you to write methods which address an object individually, with ways to avoid many individual database queries
- explicitly clearing the cache is less complex than explicitly managing the caching of data
- the cache grows until you explicitly clear it, or allow the Context to prune the cache by setting object count limits explicitly
- there is CPU overhead checking the cache if you really are always going directly to the database
At the top of every module implementing a UR class is a block of code that
defines the class to explicitly spell out its inheritance, properties and
types, constraints, relationships to other classes and where the persistent
storage is located. It's meant to be easy to read and edit, if necessary. If
the class is backed by a database table, then it can also maintain itself.
Besides the object instances representing data used by the program, the UR
system has other objects representing metadata about the classes (class
information, properties, relationships, etc), database entities (databases,
tables, columns, constraints, etc), transactions, data sources, etc. All the
metadata is accessable through the same API as any of the database-backed
data.
For classes backed by the database, after a schema change (like adding tables
or columns, altering types or constraints), a command-line tool can
automatically detect the change and alter the class definition in the Perl
module to keep the metadata in sync with the database.
At the simplest level, most entities have a 'doc' metadata attribute to
attach some kind of documentation to. There's also a set of tools that can
be run from the command line or a web browser to view the documentation. It
can also be used to browse through the class and database metadata, and
generate diagrams about the metadata.
If a retrieval from the database is likely to result in the generation of
tons of objects, you can choose to get them back in a list and keep them all
in memory, or get back a special Iterator object that the program can use to
get back objects in batches.
UR has a central command-line tool that cam be used to manipulate the
metadata in different ways. Setting up namespaces, creating data sources,
syncing classes with schemas, accessing documentation, etc.
There is also a framework for creating classes that represent command line
tools, their parameters and results, and makes it easy to create tools
through the Command Pattern.
Given these classes:
PathThing/Path.pm
use strict;
use warnings;
use PathThing; # The application's UR::Namespace module
class PathThing::Path {
id_by => 'path_id',
has => [
desc => { is => 'String' },
length => { is => 'Integer' },
],
data_source => 'PathThing::DataSource::TheDB',
table_name => 'PATHS',
};
PathThing/Node.pm
class PathThing::Node {
id_by => 'node_id',
has => [
left_path => { is => 'PathThing::Path', id_by => 'left_path_id' },
left_path_desc => { via => 'left_path', to => 'desc' },
left_path_length => { via => 'left_path', to => 'length' },
right_path => { is => 'PathThing::Path', id_by => 'right_path_id' },
right_path_desc => { via => 'right_path', to => 'desc' },
right_path_length => { via => 'right_path', to => 'length' },
map_coord_x => { is => 'Integer' },
map_coord_y => { is => 'String' },
],
data_source => 'PathThing::DataSource::TheDB',
table_name => 'NODES',
};
For a script like this one:
use PathThing::Node;
my @results = PathThing::Node->get(
right_path_desc => 'over the river',
left_path_desc => 'through the woods',
right_path_length => 10,
);
It will generate SQL like this:
select NODES.NODE_ID, NODES.LEFT_PATH_ID, NODES.RIGHT_PATH_ID,
NODES.MAP_COORD_X, NODES.MAP_COORD_Y,
left_path_1.PATH_ID, left_path_1.DESC, left_path_1.LENGTH
right_path_1.PATH_ID, right_path_1.DESC, right_path_1.LENGTH
from NODES
join PATHS left_path_1 on NODES.LEFT_PATH_ID = left_path_1.PATH_ID
join PATHS right_path_1 on NODES.RIGHT_PATH_ID = right_path1.PATH_ID
where left_path_1.DESC = 'through the woods'
and right_path_1.DESC = 'over the river',
and right_path_1.LENGTH = 10
And for every row returned by the query, a PathThing::Node and two
PathThing::Path objects will be instantiated and stored in the Context's
cache. @results will contain a list of matching PathThing::Node objects.
index.html 100664 023532 023421 2716 12544604516 16654 0 ustar 00abrummet gsc 000000 000000 UR-0.44/gmt-web/content Introduction
UR is a Class Framework and Object/Relational Mapper (ORM) for Perl.
After installing, run the "ur" command for a list of options.
As a Class Framework, it starts with the familiar Perl meme of the blessed
hash reference as the basis for object instances, and builds upon that
with a more formal way to describe classes and their properties, object
caching, and metadata about the classes and the ways they connect to each
other.
As an ORM, it aims to relieve the developer from having to think about the
SQL behind any particular request, instead using the class structure and
its metadata as a guide for where the data will be found. Behind the scenes,
the RDBMS portion can handle JOINs (both INNER and OUTER) representing
inheritance and indirect properties, multi-column primary and foreign keys,
and iterators. It does its best to only query the database for information
you've directly asked for, and to not query the database for something that
has been loaded before. Oracle, SQLite, MySQL and PostgreSQL are all
supported.
Additionally, UR can use files or collections of files as if they were
tables in a database, as well as internally handling the equivalent of an
SQL join between two or more databases if that's what the query and class
structure indicates.
UR.pm contains more introductory POD documentation. UR::Manual has a short
list of documentation you're likely to want to see next.
install.md 100664 023532 023421 335 12544604516 16622 0 ustar 00abrummet gsc 000000 000000 UR-0.44/gmt-web/content {% include install/download.html %}
It is also availabe from [CPAN](http://search.cpan.org/search?mode=all&query=UR).
{% include install/github.html %}
{% include install/help.html %}
{% include install/manuals.html %}
icon_16.png 100664 023532 023421 1274 12544604516 20657 0 ustar 00abrummet gsc 000000 000000 UR-0.44/gmt-web/content/res/images ‰PNG
IHDR ‘h6 tEXtSoftware Adobe ImageReadyqÉe< ^IDATxÚdRAOAÞ™Ù]¶»•VÛhL[MÅH0èÅVƒ!ñ` iLüpóÀ ðÀÅ 'âÕp=6)7Â¥mê¦!F!à¡`imKÙÝñ›Ý£“ÙÙyoÞ7ïûÞ²½ýñðð@ùo!|ßçÜó}SUc´R©¨WWÃR©L¡”à ›pE ç<5‘-<}vtôcˆN篢Ãh!äÄV¢‰ð¸òж''ïõz—ºnø¾ƒœ4`"hd29ÓÅA WÆÆ&4MK&“ñx’sßq< д€ %‹Ï_¬®¾[[[O¥²ŽF^*uÓ4ÍlöV>?ϘfY×X±øªÙ< HÛÎçrw±Ÿ}b‘BaqfƆ‰™LveåÍÉÉ/5Ì 5SZ*}]XXŠÇâÜãÅâ[x@2\Ã`iÑÊ9wvv>é#ºa¸^Çqz½Þ`0À bP=ú„ð<øžÚívq ÛuÝV«Õn·v»,˲íG H›Nßît.`NO?H${zzÚl6Êå/ƒ~G!
<œ+አbnn~|<%ùQö ÎÏÏÊåÏŒù×oŒÂéºür0l4š J\W–P×õ°Í€õûýF£ŠÛ¢Q÷<¡i ~Ù1ü66ÖÓé;Ë˯mû1A‹‚$mÓ„øظ^¦i²W”1bYæYëxsó}½^c^jÈa,l(b䟄ñi¯#µh0b±ØÔÔ}èDåÁŠ|‘êÞÞn½Þ4ŒèÒÒËZí[µZA™ÛíßÕÊwtLmpâ-¹ÿ (6&Ë$ñ;£ IEND®B`‚ icon_48.png 100664 023532 023421 5430 12544604516 20662 0 ustar 00abrummet gsc 000000 000000 UR-0.44/gmt-web/content/res/images ‰PNG
IHDR 0 0 Ø`nÐ tEXtSoftware Adobe ImageReadyqÉe<
ºIDATxÚ¬YkoTÇ>3ç¬wïÆÆcǦ$(¡uqŒk7\$¨BÓÒ
JÕP ä&"Iå2 ZUíçü¤6R$ÚðÅJZQL
X ‚ « u pk Q‚ñ ³öî™é3óÎÌÎ.kC¥ ËÙsöÌå™÷ú¼cvòä ‡‡ÿ| Mª¦¾é^ˆ¼Gêã+¾}™ßÔ×åË—£……ô©S§M'Ù ¬.ÞýãþfQßÒ¶À@#49XÞ è gfæ£àkj 42¡ï¥•Ð88c’ðXpÒÍ£ qÎ-ð1X©±€È#ï k³@ˆ@¯§nðcYYy*µ¢´tEyyiMMíâââÈÈ—ÓÓ s•’7ÊðEš'T †×š™N
5Iï_}õІ
›²Ùl Ç¢˜žžžœš›šzà-!ýíEO´SßJò„ëɲ¨Ö„ î2™ŒÐ
o§¦¦ª«ëÉÎ4$A[ÓŠ
Œ„ T²å±èo_,À¼ X®ûÁœYÔÕ‚=`m|Èr£(*[VñèѬ ÂœQ•1ßb蛶kod–XîQk‘ ¨/a&Ò+*ª`4˜ŸóÖ«¨¨¨¬¬¬®^9??§!¨qZË$[O —҉_è}«]Ʊ’<®±þÒOÂ:õÄHý›É’äXܶ0 Ë`äåå+WÖIA³=Ôó«ÆÉËlcî†j"½WžçIÆP´çïÁ,à¤ÙòŠÊH·Õø ¥R) jjjI”¤„±G# ¡¶"}@,ÿ†4,!1¬©©¹·÷òòJg½¹ ê®®¤ÂC`
CõA&h
bªª®
ò§±zæË:£/aä çíìì:rä7ë×oxíµw[ð‹öh¥=}5jÔ7²¬¼‚"¢`©›ªª*`ª£!Y|²4P]HBÌwâqwdéû÷ 8xð-’hMMMoï/;:¾_6†D¸sAYÖÖT:G¶%ôµ´´v½®íYmšÂì[W¯]¤¶K»è"H
+‹üü ÝqB»5Œc_ye_[Û³ ~x Ñù¦µrY[[O")ˆjÐZuuuc㚺ºúññ¯ K: , nÚ´9Ü»÷CC7œ·@’ü‘2€d¤ÍÍ-}}¿~ï½ãŸ}vÄ€äÕÞÞ¹yó–P7?‘¢0J&Kššš:;»éíøø}ÈìêÕ!
(Ô*ËFzR¢×à‚ÁÁO¶o¹¡¡h ³AÃb ±!ô¾ýö‘3=ÿ³»wïÙµëûx…žxE{°ƒ¬……fQg
«ÑÙDêeš¦O¼áĉ? =ú[Œ¤”ä7¬MÂûáž}{÷ý äkdIbnÎ।Q¹à+ˆ™0(4ôèÌ&|µ-Á”æÐéÖáK—Îwwï0 ç1 @ʵL†9»ñé¢M6—æ H!9RÎÄÊÈ(!Ù˜a›ýý tv¾”L&…%§~ã–ÄhæÁ`·£`yæ³^'µüd^0Ò£À&S‚Éô÷ÿÉ…ðeןÿ³¹Ìà$ÌimòL‚Ü^*GUO»wï.ùüS¬°\ Ÿ”ú?r ‘\„ÀÇY>‘$îåjtŽßÿ¸ ‡Š¶ ¢'¶ü.Ne†d8f.,¯&‘¹Â!¸~ýêààù¼…Ÿ¢a6ðÆôBzaa10_Q¹)®§
ØT"Ò¸:1®\äȉ7¸páܶm;É·—%¾R
¤Ó
‡"²RHòÊʪÙÙD)&Ó§—…ã›7¯Ð””„Q"$4Šl1GQLxsGB2“*HT
œãر76oîÙ²eëš5Í°Pª+žFk˜ ‚
!¨pà BSH‰@Ñ ÌªÃ5D“щb¨%Ãx]|ùòù‹Ï>÷܆[_†ÓAý‹û%ÒcÈ(‚CFóó3©TI¨5Eÿì1ƒfË}œî¥â…6†QP"¦ ŒT,• ðŸÝ¾=‚²¦ºzå®ïýøÛí/¼×I‰EQ’K§ …º4Õõ³a,Z¡MÃÌ £ÈÜI ºuÌÅ´TR¦©
Ó³èÊ.ÁDÓÓ>øóñcÇ~ÕßâîÝ;EC€(Ž³ ¸qr=8{òù¤?1'f¨xB™s˜Ô^›Ð
Aâôé¿ôõ½D½²t"Áµg³ KsväªDNì6Çáx ÅTÑ€z3&]Q– C£L&»”„¨^‘ Á¸°iË¢Ic* Ñ+é Ž1ªbè 1òÍÂVt±="âäŠxYJàT.VUU»s‘;Â
tþ’Kuõ‹å\#ùþápèónºNMM,Iæ9á*/¯XU¿Ú„¯HÅþµœ ]±‡Á¾Ê¤åªêÊMy˜1tÐàªIƒšóTªtÊ 7-éùî.{þGʯÃÔ¼zÛÌÆéj1êLWÊejtÓ‡MÂRD… aéðá#MMÍô¢¨%ÑYݺu0c&«Pòl¬‹x:½×¨b]7xš¢ò_ºKªí¬èäÖž=ªŽxsèÐ;;vì„ÕZùÓ+Hö0#uMMmOÏÎÁÁ„8̾±ƒ¥Þ°ÿ÷ˆŽ 6Ç7"K‡
TßØ?PÈ8«ÎØð~íÚÖÇûÖ®mñÍ;Ò§†˜mÛ¶ûÚµKéôCò}¢ “« H›èðägcs"¨Ãd48øñ_ÚLäÚÛ_liÙ40ðq~ùý„†t6??ÏXÍ•+Ÿj…Þé`®$w–E£q‡‚X õÚÿ Æ
mï¾õdÏ IEND®B`‚ Command.pm 100664 023532 023421 323 12544604516 14275 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib package Command;
use strict;
use warnings;
use UR;
our $VERSION = "0.44"; # UR $VERSION;
UR::Object::Type->define(
class_name => __PACKAGE__,
is_abstract => 1,
subclassify_by_version => 1,
);
1;
Common.pm 100664 023532 023421 10332 12544604516 15566 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/Command package Command::Common;
use strict;
use warnings;
use UR;
# Once roles exist this should probably be a role.
class Command::Common {
is_abstract => 1,
valid_signals => [qw(error_die)],
};
sub create {
my $class = shift;
my ($rule,%extra) = $class->define_boolexpr(@_);
my @params_list = $rule->params_list;
my $self = $class->SUPER::create(@params_list, %extra);
return unless $self;
# set non-optional boolean flags to false.
# TODO: rename that property meta method if it is not ONLY used for shell args
for my $property_meta ($self->_shell_args_property_meta) {
my $property_name = $property_meta->property_name;
if (!$property_meta->is_optional and !defined($self->$property_name)) {
if (defined $property_meta->data_type and $property_meta->data_type =~ /Boolean/i) {
$self->$property_name(0);
}
}
}
return $self;
}
sub shortcut {
my $self = shift;
return unless $self->can('_shortcut_body');
my $result = $self->_shortcut_body;
$self->result($result);
return $result;
}
sub execute {
# This is a wrapper for real execute() calls.
# All execute() methods are turned into _execute_body at class init,
# so this will get direct control when execute() is called.
my $self = shift;
#TODO handle calls to SUPER::execute() from another execute().
# handle calls as a class method
my $was_called_as_class_method = 0;
if (ref($self)) {
if ($self->is_executed) {
Carp::confess("Attempt to re-execute an already executed command.");
}
}
else {
# called as class method
# auto-create an instance and execute it
$self = $self->create(@_);
return unless $self;
$was_called_as_class_method = 1;
}
# handle __errors__ objects before execute
if (my @problems = $self->__errors__) {
for my $problem (@problems) {
my @properties = $problem->properties;
$self->error_message("Property " .
join(',', map { "'$_'" } @properties) .
': ' . $problem->desc);
}
my $command_name = $self->command_name;
$self->error_message("Please see '$command_name --help' for more information.");
$self->delete() if $was_called_as_class_method;
return;
}
my $result = eval { $self->_execute_body(@_); };
my $error = $@;
if ($error or not $result) {
my %error_data;
$error_data{die_message} = defined($error) ? $error:'';
$error_data{error_message} = defined($self->error_message) ? $self->error_message:'';
$error_data{error_package} = defined($self->error_package) ? $self->error_package:'';
$error_data{error_file} = defined($self->error_file) ? $self->error_file:'';
$error_data{error_subroutine} = defined($self->error_subroutine) ? $self->error_subroutine:'';
$error_data{error_line} = defined($self->error_line) ? $self->error_line:'';
$self->__signal_observers__('error_die', %error_data);
die $error if $error;
}
$self->is_executed(1);
$self->result($result);
return $self if $was_called_as_class_method;
return $result;
}
sub _execute_body {
# default implementation in the base class
# Override "execute" or "_execute_body" to implement the body of the command.
# See above for details of internal implementation.
my $self = shift;
my $class = ref($self) || $self;
if ($class eq __PACKAGE__) {
die "The execute() method is not defined for $_[0]!";
}
return 1;
}
# Translates a true/false value from the command module's execute()
# from Perl (where positive means success), to shell (where 0 means success)
# Also, execute() could return a negative value; this is converted to
# positive and used as the shell exit code. NOTE: This means execute()
# returning 0 and -1 mean the same thing
sub exit_code_for_return_value {
my $self = shift;
my $return_value = shift;
if (! $return_value) {
$return_value = 1;
} elsif ($return_value < 0) {
$return_value = 0 - $return_value;
} else {
$return_value = 0
}
return $return_value;
}
Shell.pm 100664 023532 023421 124543 12544604516 17176 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/Command/Dispatch package Command::V2; # additional methods to dispatch from a command-line
use strict;
use warnings;
use IO::File;
use List::MoreUtils;
# instead of tacking these methods onto general Command::V2 objects
# they could be put on the Command::Shell class, which is a wrapper/adaptor Command for translating from
# command-line shell to purely functional commands.
# old entry point
# new cmds will call Command::Shell->run("MyClass",@ARGV)
# which goes straight into _cmdline_run for now...
sub execute_with_shell_params_and_exit {
my $class = shift;
if (@_) {
die "No params expected for execute_with_shell_params_and_exit()!";
}
my @argv = @ARGV;
@ARGV = ();
my $exit_code = $class->_cmdline_run(@argv);
exit $exit_code;
}
sub _cmdline_run {
# This automatically parses command-line options and "does the right thing":
# TODO: abstract out all dispatchers for commands into a given API
my $class = shift;
my @argv = @_;
$Command::entry_point_class ||= $class;
$Command::entry_point_bin ||= File::Basename::basename($0);
if ($ENV{COMP_CWORD}) {
require Getopt::Complete;
my @spec = $class->resolve_option_completion_spec();
my $options = Getopt::Complete::Options->new(@spec);
$options->handle_shell_completion;
die "error: failed to exit after handling shell completion!";
}
my $exit_code;
eval {
$exit_code = $class->_execute_with_shell_params_and_return_exit_code(@argv);
UR::Context->commit or die "Failed to commit!: " . UR::Context->error_message();
};
if ($@) {
$class->error_message($@);
UR::Context->rollback or die "Failed to rollback changes after failed commit!!!\n";
$exit_code = 255 unless ($exit_code);
}
return $exit_code;
}
sub _execute_with_shell_params_and_return_exit_code {
my $class = shift;
my @argv = @_;
my $original_cmdline = join("\0",$0,@argv);
# make --foo=bar equivalent to --foo bar
@argv = map { ($_ =~ /^(--\w+?)\=(.*)/) ? ($1,$2) : ($_) } @argv;
my ($delegate_class, $params, $errors) = $class->resolve_class_and_params_for_argv(@argv);
my $exit_code;
if ($errors and @$errors) {
$delegate_class->dump_status_messages(1);
$delegate_class->dump_warning_messages(1);
$delegate_class->dump_error_messages(1);
for my $error (@$errors) {
$delegate_class->error_message(join(' ', $error->property_names) . ": " . $error->desc);
}
$exit_code = 1;
}
else {
my $rv = $class->_execute_delegate_class_with_params($delegate_class,$params,$original_cmdline);
$exit_code = $delegate_class->exit_code_for_return_value($rv);
}
return $exit_code;
}
sub _execute_delegate_class_with_params {
# this is called by both the shell dispatcher and http dispatcher for now
my ($class, $delegate_class, $params, $original_cmdline) = @_;
unless ($delegate_class) {
$class->dump_status_messages(1);
$class->dump_warning_messages(1);
$class->dump_error_messages(1);
$class->dump_usage_messages(1);
$class->dump_debug_messages(0);
$class->usage_message($class->help_usage_complete_text);
return;
}
$delegate_class->dump_status_messages(1);
$delegate_class->dump_warning_messages(1);
$delegate_class->dump_error_messages(1);
$delegate_class->dump_usage_messages(1);
$delegate_class->dump_debug_messages(0);
# FIXME There should be a better check for params that are there because they came from the
# command line, and params that exist for infrastructural purposes. 'original_command_line'
# won't ever be given on the command line and shouldn't count toward the next test.
# maybe check the is_input properties...
if ( !defined($params) ) {
my $command_name = $delegate_class->command_name;
$delegate_class->status_message($delegate_class->help_usage_complete_text);
$delegate_class->error_message("Please specify valid params for '$command_name'.");
return;
}
if ( $params->{help} ) {
$delegate_class->usage_message($delegate_class->help_usage_complete_text);
return 1;
}
$params->{'original_command_line'} = $original_cmdline if (defined $original_cmdline);
my $command_object = $delegate_class->create(%$params);
unless ($command_object) {
# The delegate class should have emitted an error message.
# This is just in case the developer is sloppy, and the user will think the task did not fail.
print STDERR "Exiting.\n";
return;
}
$command_object->dump_status_messages(1);
$command_object->dump_warning_messages(1);
$command_object->dump_error_messages(1);
$command_object->dump_debug_messages($command_object->debug);
if ($command_object->debug) {
UR::ModuleBase->dump_debug_messages($command_object->debug);
}
my $rv = $command_object->execute($params);
if ($command_object->__errors__) {
$command_object->delete;
}
return $rv;
}
sub resolve_class_and_params_for_argv {
# This is used by execute_with_shell_params_and_exit, but might be used within an application.
my $self = shift;
my @argv = @_;
my ($params_hash,@spec) = $self->_shell_args_getopt_specification;
unless (grep { /^help\W/ } @spec) {
push @spec, "help!";
}
my @error_tags;
# Thes nasty GetOptions modules insist on working on
# the real @ARGV, while we like a little more flexibility.
# Not a problem in Perl. :) (which is probably why it was never fixed)
local @ARGV;
@ARGV = @argv;
do {
# GetOptions also likes to emit warnings instead of return a list of errors :(
my @errors;
my $rv;
{
local $SIG{__WARN__} = sub { push @errors, @_ };
## Change the pattern to be '--', '-' followed by a non-digit, or '+'.
## This s the effect of treating a negative number as a value of an option.
## This means that we won't be allowed to have an option named, say, -1.
## But since command modules' properties have to be allowable function names,
## and "1" is not a valid function name, it's not really a problem
#Getopt::Long::Configure('prefix_pattern=--|-(?!\D)|\+');
$rv = GetOptions($params_hash,@spec);
}
unless ($rv) {
for my $error (@errors) {
$self->error_message($error);
}
return($self, undef);
}
};
# Q: Is there a standard getopt spec for capturing non-option paramters?
# Perhaps that's not getting "options" :)
# A: Yes. Use '<>'. But we need to process this anyway, so it won't help us.
if (my @names = $self->_bare_shell_argument_names) {
for (my $n=0; $n < @ARGV; $n++) {
my $name = $names[$n];
unless ($name) {
$self->error_message("Unexpected bare arguments: @ARGV[$n..$#ARGV]!");
return($self, undef);
}
my $value = $ARGV[$n];
my $meta = $self->__meta__->property_meta_for_name($name);
if ($meta->is_many and $n == $#names) {
# slurp the rest
$params_hash->{$name} = [@ARGV[$n..$#ARGV]];
last;
}
else {
$params_hash->{$name} = $value;
}
}
}
if (@ARGV and not $self->_bare_shell_argument_names) {
## argv but no names
$self->error_message("Unexpected bare arguments: @ARGV!");
return($self, undef);
}
for my $key (keys %$params_hash) {
# handle any has-many comma-sep values
my $value = $params_hash->{$key};
if (ref($value)) {
my @new_value;
for my $v (@$value) {
my @parts = split(/,\s*/,$v);
push @new_value, @parts;
}
@$value = @new_value;
} elsif ($value eq q('') or $value eq q("")) {
# Handle the special values '' and "" to mean undef/NULL
$params_hash->{$key} = '';
}
# turn dashes into underscores
my $new_key = $key;
next unless ($new_key =~ tr/-/_/);
if (exists $params_hash->{$new_key} && exists $params_hash->{$key}) {
# this corrects a problem where is_many properties badly interact
# with bare args leaving two entries in the hash like:
# a-bare-opt => [], a_bare_opt => ['with','vals']
delete $params_hash->{$key};
next;
}
$params_hash->{$new_key} = delete $params_hash->{$key};
}
# futher work is looking for errors, and may display them
# if help is set, return now
# we might have returned sooner, but having full info available
# allows for dynamic help
if ($params_hash->{help}) {
return ($self, $params_hash);
}
##
my $params = $params_hash;
my $class = $self->class;
if (my @errors = $self->_errors_from_missing_parameters($params)) {
return ($class, $params, \@errors);
}
unless (@_) {
return ($class, $params);
}
# should this be moved up into the methods which are only called
# directly from the shell, or is it okay everywhere in this module to
# presume we're a direct cmdline call? -ssmith
local $ENV{UR_COMMAND_DUMP_STATUS_MESSAGES} = (!exists($ENV{UR_COMMAND_DUMP_STATUS_MESSAGES})
or $ENV{UR_COMMAND_DUMP_STATUS_MESSAGES});
my @params_to_resolve = $self->_params_to_resolve($params);
for my $p (@params_to_resolve) {
my $param_arg_str = join(',', @{$p->{value}});
my $pmeta = $self->__meta__->property($p->{name});
my @params;
eval {
@params = $self->resolve_param_value_from_cmdline_text($p);
};
if ($@) {
push @error_tags, UR::Object::Tag->create(
type => 'invalid',
properties => [$p->{name}],
desc => "Errors while resolving from $param_arg_str: $@",
);
}
if (@params and $params[0]) {
if ($pmeta->{'is_many'}) {
$params->{$p->{name}} = \@params;
}
else {
$params->{$p->{name}} = $params[0];
}
}
else {
push @error_tags, UR::Object::Tag->create(
type => 'invalid',
properties => [$p->{name}],
desc => "Problem resolving from $param_arg_str.",
);
}
}
if (@error_tags) {
return ($class, undef, \@error_tags);
}
else {
return ($class, $params);
}
}
sub resolve_option_completion_spec {
my $class = shift;
my @completion_spec = $class->_shell_args_getopt_complete_specification;
no warnings;
unless (grep { /^help\W/ } @completion_spec) {
push @completion_spec, "help!" => undef;
}
return \@completion_spec
}
sub _errors_from_missing_parameters {
my ($self, $params) = @_;
my $class_meta = $self->__meta__;
my @all_property_metas = $class_meta->properties();
my @specified_property_metas = grep { exists $params->{$_->property_name} } @all_property_metas;
my %specified_property_metas = map { $_->property_name => $_ } @specified_property_metas;
my %set_indirectly;
my @todo = @specified_property_metas;
while (my $property_meta = shift @todo) {
if (my $via = $property_meta->via) {
if (not $property_meta->is_mutable) {
my $list = $set_indirectly{$via} ||= [];
push @$list, $property_meta;
}
unless ($specified_property_metas{$via}) {
my $via_meta = $specified_property_metas{$via} = $class_meta->property($via);
push @specified_property_metas, $via_meta;
push @todo, $via_meta;
}
}
elsif (my $id_by = $property_meta) {
my $list = $set_indirectly{$id_by} ||= [];
push @$list, $property_meta;
unless ($specified_property_metas{$id_by}) {
my $id_by_meta = $specified_property_metas{$id_by} = $class_meta->property($id_by);
push @specified_property_metas, $id_by_meta;
push @todo, $id_by_meta;
}
}
}
# TODO: this should use @all_property_metas, and filter down to is_param and is_input
# This old code just ignores things inherited from a base class.
# We will need to be careful fixing this because it could add checks to tools which
# work currently and lead to unexpected failures.
my @property_names;
if (my $has = $class_meta->{has}) {
@property_names = List::MoreUtils::uniq(keys %$has);
}
my @property_metas = map { $class_meta->property_meta_for_name($_); } @property_names;
my @error_tags;
for my $property_meta (@property_metas) {
my $pn = $property_meta->property_name;
next if $property_meta->is_optional;
next if $property_meta->implied_by;
next if defined $property_meta->default_value;
next if defined $params->{$pn};
next if $set_indirectly{$pn};
if (my $via = $property_meta->via) {
if ($params->{$via} or $set_indirectly{$via}) {
next;
}
}
my $arg = $pn;
$arg =~ s/_/-/g;
$arg = "--$arg";
if ($property_meta->is_output and not $property_meta->is_input and not $property_meta->is_param) {
if ($property_meta->_data_type_as_class_name->__meta__->data_source
and not $property_meta->_data_type_as_class_name->isa("UR::Value")
) {
# outputs with a data source do not need a specification
# on the cmdline to "store" them after execution
next;
}
elsif ($property_meta->is_calculated) {
# outputs that are calculated don't need to be specified on
# the command line
next;
}
else {
push @error_tags, UR::Object::Tag->create(
type => 'invalid',
properties => [$pn],
desc => "Output requires specified destination: " . $arg . "."
);
}
}
else {
$DB::single = 1;
push @error_tags, UR::Object::Tag->create(
type => 'invalid',
properties => [$pn],
desc => "Missing required parameter: " . $arg . "."
);
}
}
return @error_tags;
}
sub _params_to_resolve {
my ($self, $params) = @_;
my @params_to_resolve;
if ($params) {
my $cmeta = $self->__meta__;
my @params_will_require_verification;
my @params_may_require_verification;
for my $param_name (keys %$params) {
my $pmeta = $cmeta->property($param_name);
unless ($pmeta) {
# This message was a die after a next, so I guess it isn't supposed to be fatal?
$self->warning_message("No metadata for property '$param_name'");
next;
}
my $param_type = $pmeta->data_type;
next unless($self->_can_resolve_type($param_type));
my $param_arg = $params->{$param_name};
if (my $arg_type = ref($param_arg)) {
next if $arg_type eq $param_type; # param is already the right type
if ($arg_type ne 'ARRAY') {
$self->error_message("no handler for property '$param_name' with argument type " . ref($param_arg));
next;
}
} else {
$param_arg = [$param_arg];
}
next unless (@$param_arg);
my $resolve_info = {
name => $param_name,
class => $param_type,
value => $param_arg,
};
push(@params_to_resolve, $resolve_info);
my $require_user_verify = $pmeta->{'require_user_verify'};
if ( defined($require_user_verify) ) {
push @params_will_require_verification, "'$param_name'" if ($require_user_verify);
} else {
push @params_may_require_verification, "'$param_name'";
}
}
my @adverbs = ('will', 'may');
my @params_adverb_require_verification = (
\@params_will_require_verification,
\@params_may_require_verification,
);
for (my $i = 0; $i < @adverbs; $i++) {
my $adverb = $adverbs[$i];
my @param_adverb_require_verification = @{$params_adverb_require_verification[$i]};
next unless (@param_adverb_require_verification);
if (@param_adverb_require_verification > 1) {
$param_adverb_require_verification[-1] = 'and ' . $param_adverb_require_verification[-1];
}
my $param_str = join(', ', @param_adverb_require_verification);
$self->status_message($param_str . " $adverb require verification...");
}
}
return @params_to_resolve;
}
sub _can_resolve_type {
my ($self, $type) = @_;
return 0 unless($type);
my $non_classes = 0;
if (ref($type) ne 'ARRAY') {
$non_classes = $type !~ m/::/;
} else {
$non_classes = scalar grep { ! m/::/ } @$type;
}
return $non_classes == 0;
}
sub _shell_args_property_meta {
my $self = shift;
my $class_meta = $self->__meta__;
# Find which property metas match the rules. We have to do it this way
# because just calling 'get_all_property_metas()' will product multiple matches
# if a property is overridden in a child class
my ($rule, %extra) = UR::Object::Property->define_boolexpr(@_);
my %seen;
my (@positional,@required_input,@required_param,@optional_input,@optional_param, @output);
my @property_meta = $class_meta->properties();
PROP:
foreach my $property_meta (@property_meta) {
my $property_name = $property_meta->property_name;
next if $seen{$property_name}++;
next unless $rule->evaluate($property_meta);
next unless $property_meta->can("is_param") and ($property_meta->is_param or $property_meta->is_input or $property_meta->is_output);
if (%extra) {
no warnings;
for my $key (keys %extra) {
if ($property_meta->$key ne $extra{$key}) {
next PROP;
}
}
}
next if $property_name eq 'id';
next if $property_name eq 'result';
next if $property_name eq 'is_executed';
next if $property_name eq 'original_command_line';
next if $property_name =~ /^_/;
next if $property_meta->implied_by;
next if $property_meta->is_calculated;
# Kept commented out from UR's Command.pm, I believe is_output is a workflow property
# and not something we need to exclude (counter to the old comment below).
#next if $property_meta->{is_output}; # TODO: This was breaking the G::M::T::Annotate::TranscriptVariants annotator. This should probably still be here but temporarily roll back
next if $property_meta->is_transient;
next if $property_meta->is_constant;
if (($property_meta->is_delegated) || (defined($property_meta->data_type) and $property_meta->data_type =~ /::/)) {
next unless($self->can('resolve_param_value_from_cmdline_text'));
}
else {
next unless($property_meta->is_mutable);
}
if ($property_meta->{shell_args_position}) {
push @positional, $property_meta;
}
elsif ($property_meta->is_optional) {
if ($property_meta->is_input or $property_meta->is_output) {
push @optional_input, $property_meta;
}
elsif ($property_meta->is_param) {
push @optional_param, $property_meta;
}
}
else {
if ($property_meta->is_input or $property_meta->is_output) {
push @required_input, $property_meta;
}
elsif ($property_meta->is_param) {
push @required_param, $property_meta;
}
}
}
my @result;
@result = (
(sort { $a->position_in_module_header cmp $b->position_in_module_header } @required_param),
(sort { $a->position_in_module_header cmp $b->position_in_module_header } @optional_param),
(sort { $a->position_in_module_header cmp $b->position_in_module_header } @required_input),
(sort { $a->position_in_module_header cmp $b->position_in_module_header } @optional_input),
(sort { $a->shell_args_position <=> $b->shell_args_position } @positional),
);
return @result;
}
sub _shell_arg_name_from_property_meta {
my ($self, $property_meta,$singularize) = @_;
my $property_name = ($singularize ? $property_meta->singular_name : $property_meta->property_name);
my $param_name = $property_name;
$param_name =~ s/_/-/g;
return $param_name;
}
sub _shell_arg_getopt_qualifier_from_property_meta {
my ($self, $property_meta) = @_;
my $many = ($property_meta->is_many ? '@' : '');
if (defined($property_meta->data_type) and $property_meta->data_type =~ /Boolean/) {
return '!' . $many;
}
#elsif ($property_meta->is_optional) {
# return ':s' . $many;
#}
else {
return '=s' . $many;
}
}
sub _shell_arg_usage_string_from_property_meta {
my ($self, $property_meta) = @_;
my $string = $self->_shell_arg_name_from_property_meta($property_meta);
if ($property_meta->{shell_args_position}) {
$string = uc($string);
}
if ($property_meta->{shell_args_position}) {
if ($property_meta->is_optional) {
$string = "[$string]";
}
}
else {
$string = "--$string";
if (defined($property_meta->data_type) and $property_meta->data_type =~ /Boolean/) {
$string = "[$string]";
}
else {
if ($property_meta->is_many) {
$string .= "=?[,?]";
}
else {
$string .= '=?';
}
if ($property_meta->is_optional) {
$string = "[$string]";
}
}
}
return $string;
}
sub _shell_arg_getopt_specification_from_property_meta {
my ($self,$property_meta) = @_;
my $arg_name = $self->_shell_arg_name_from_property_meta($property_meta);
return (
$arg_name . $self->_shell_arg_getopt_qualifier_from_property_meta($property_meta),
#this prevents defaults from being used for is_many properties
#($property_meta->is_many ? ($arg_name => []) : ())
);
}
sub _shell_arg_getopt_complete_specification_from_property_meta {
my ($self,$property_meta) = @_;
my $arg_name = $self->_shell_arg_name_from_property_meta($property_meta);
my $completions = $property_meta->valid_values;
if ($completions) {
if (ref($completions) eq 'ARRAY') {
$completions = [ @$completions ];
}
}
else {
my $type = $property_meta->data_type;
my @complete_as_files = (
'File','FilePath','Filesystem','FileSystem','FilesystemPath','FileSystemPath',
'Text','String',
);
my @complete_as_directories = (
'Directory','DirectoryPath','Dir','DirPath',
);
if (!defined($type)) {
$completions = 'files';
}
else {
for my $pattern (@complete_as_files) {
if (!$type || $type eq $pattern) {
$completions = 'files';
last;
}
}
for my $pattern (@complete_as_directories) {
if ( $type && $type eq $pattern) {
$completions = 'directories';
last;
}
}
}
}
return (
$arg_name . $self->_shell_arg_getopt_qualifier_from_property_meta($property_meta),
$completions,
# ($property_meta->is_many ? ($arg_name => []) : ())
);
}
sub _shell_args_getopt_specification {
my $self = shift;
my @getopt;
my @params;
for my $meta ($self->_shell_args_property_meta) {
my ($spec, @params_addition) = $self->_shell_arg_getopt_specification_from_property_meta($meta);
push @getopt,$spec;
push @params, @params_addition;
}
@getopt = sort @getopt;
return { @params}, @getopt;
}
sub _shell_args_getopt_complete_specification {
my $self = shift;
my @getopt;
for my $meta ($self->_shell_args_property_meta) {
my ($spec, $completions) = $self->_shell_arg_getopt_complete_specification_from_property_meta($meta);
push @getopt, $spec, $completions;
}
return @getopt;
}
sub _bare_shell_argument_names {
my $self = shift;
my $meta = $self->__meta__;
my @ordered_names =
map { $_->property_name }
sort { $a->{shell_args_position} <=> $b->{shell_args_position} }
grep { $_->{shell_args_position} }
$self->_shell_args_property_meta();
return @ordered_names;
}
#
# Logic to turn command-line text into objects for parameter/input values
#
our %ALTERNATE_FROM_CLASS = ();
# This will prevent infinite loops during recursion.
our %SEEN_FROM_CLASS = ();
our $MESSAGE;
sub resolve_param_value_from_cmdline_text {
my ($self, $param_info) = @_;
my $param_name = $param_info->{name};
my $param_class = $param_info->{class};
my @param_args = @{$param_info->{value}};
my $param_str = join(',', @param_args);
if (ref($param_class) eq 'ARRAY') {
my @param_class = @$param_class;
if (@param_class > 1) {
die 'Multiple data types on command arguments are not supported.';
} else {
$param_class = $param_class[0];
}
}
my $param_resolve_message = "Resolving parameter '$param_name' from command argument '$param_str'...";
my $pmeta = $self->__meta__->property($param_name);
my $require_user_verify = $pmeta->{'require_user_verify'};
my @results;
my $bx = eval { UR::BoolExpr->resolve_for_string($param_class, $param_str) };
my $bx_error = $@;
if ($bx) {
@results = $param_class->get($bx);
if (@results > 1 && !defined($require_user_verify)) {
$require_user_verify = 1;
}
} else {
for my $arg (@param_args) {
%SEEN_FROM_CLASS = ();
# call resolve_param_value_from_text without a via_method to "bootstrap" recursion
my @arg_results = $self->resolve_param_value_from_text($arg, $param_class);
if (@arg_results != 1 && !defined($require_user_verify)) {
$require_user_verify = 1;
}
push @results, @arg_results;
}
}
if (@results) {
# the ALTERNATE_FROM_CLASS stuff leads to non $param_class objects in results
@results = List::MoreUtils::uniq(@results);
@results = grep { $_->isa($param_class) } @results;
$self->status_message($param_resolve_message . " found " . @results);
}
else {
if ($bx_error) {
$self->status_message($bx_error);
}
$self->status_message($param_resolve_message . " none found.");
}
return unless (@results);
my $limit_results_method = "_limit_results_for_$param_name";
if ( $self->can($limit_results_method) ) {
@results = $self->$limit_results_method(@results);
return unless (@results);
}
@results = List::MoreUtils::uniq(@results);
if ($require_user_verify) {
if (!$pmeta->{'is_many'} && @results > 1) {
$MESSAGE .= "\n" if ($MESSAGE);
$MESSAGE .= "'$param_name' expects only one result.";
if ($ENV{UR_NO_REQUIRE_USER_VERIFY}) {
die "$MESSAGE\n";
}
}
@results = $self->_get_user_verification_for_param_value($param_name, @results);
}
while (!$pmeta->{'is_many'} && @results > 1) {
$MESSAGE .= "\n" if ($MESSAGE);
$MESSAGE .= "'$param_name' expects only one result, not many!";
@results = $self->_get_user_verification_for_param_value($param_name, @results);
}
if (wantarray) {
return @results;
}
elsif (not defined wantarray) {
return;
}
elsif (@results > 1) {
Carp::confess("Multiple matches found!");
}
else {
return $results[0];
}
}
sub resolve_param_value_from_text {
my ($self, $param_arg, $param_class, $via_method) = @_;
unless ($param_class) {
$param_class = $self->class;
}
$SEEN_FROM_CLASS{$param_class} = 1;
my @results;
# try getting BoolExpr, otherwise fallback on '_resolve_param_value_from_text_by_name_or_id' parser
eval { @results = $self->_resolve_param_value_from_text_by_bool_expr($param_class, $param_arg); };
Carp::croak($@) if ($@ and $@ !~ m/Not a valid BoolExpr/);
if (!@results && !$@) {
# no result and was valid BoolExpr then we don't want to break it apart because we
# could query enormous amounts of info
return;
}
# the first param_arg is all param_args to try BoolExpr so skip if it has commas
if (!@results && $param_arg !~ /,/) {
my @results_by_string;
if ($param_class->can('_resolve_param_value_from_text_by_name_or_id')) {
@results_by_string = $param_class->_resolve_param_value_from_text_by_name_or_id($param_arg);
}
else {
@results_by_string = $self->_resolve_param_value_from_text_by_name_or_id($param_class, $param_arg);
}
push @results, @results_by_string;
}
# if we still don't have any values then try via alternate class
if (!@results && $param_arg !~ /,/) {
@results = $self->_resolve_param_value_via_related_class_method($param_class, $param_arg, $via_method);
}
if ($via_method) {
@results = map { $_->$via_method } @results;
}
if (wantarray) {
return @results;
}
elsif (not defined wantarray) {
return;
}
elsif (@results > 1) {
Carp::confess("Multiple matches found!");
}
else {
return $results[0];
}
}
sub _resolve_param_value_via_related_class_method {
my ($self, $param_class, $param_arg, $via_method) = @_;
my @results;
my $via_class;
if (exists($ALTERNATE_FROM_CLASS{$param_class})) {
$via_class = $param_class;
}
else {
for my $class (keys %ALTERNATE_FROM_CLASS) {
if ($param_class->isa($class)) {
if ($via_class) {
$self->error_message("Found additional via_class $class but already found $via_class!");
}
$via_class = $class;
}
}
}
if ($via_class) {
my @from_classes = sort keys %{$ALTERNATE_FROM_CLASS{$via_class}};
while (@from_classes && !@results) {
my $from_class = shift @from_classes;
my @methods = @{$ALTERNATE_FROM_CLASS{$via_class}{$from_class}};
my $method;
if (@methods > 1 && !$via_method && !$ENV{UR_NO_REQUIRE_USER_VERIFY}) {
$self->status_message("Trying to find $via_class via $from_class...\n");
my $method_choices;
for (my $i = 0; $i < @methods; $i++) {
$method_choices .= ($i + 1) . ": " . $methods[$i];
$method_choices .= " [default]" if ($i == 0);
$method_choices .= "\n";
}
$method_choices .= (scalar(@methods) + 1) . ": none\n";
$method_choices .= "Which method would you like to use?";
my $response = $self->_ask_user_question($method_choices, 0, '\d+', 1, '#');
if ($response =~ /^\d+$/) {
$response--;
if ($response == @methods) {
$method = undef;
}
elsif ($response >= 0 && $response <= $#methods) {
$method = $methods[$response];
}
else {
$self->error_message("Response was out of bounds, exiting...");
exit;
}
$ALTERNATE_FROM_CLASS{$via_class}{$from_class} = [$method];
}
elsif (!$response) {
$self->status_message("Exiting...");
}
}
else {
$method = $methods[0];
}
unless($SEEN_FROM_CLASS{$from_class}) {
#$self->debug_message("Trying to find $via_class via $from_class->$method...");
@results = eval {$self->resolve_param_value_from_text($param_arg, $from_class, $method)};
}
} # END for my $from_class (@from_classes)
} # END if ($via_class)
return @results;
}
sub _resolve_param_value_from_text_by_bool_expr {
my ($self, $param_class, $arg) = @_;
my @results;
my $bx = eval {
UR::BoolExpr->resolve_for_string($param_class, $arg);
};
if ($bx) {
@results = $param_class->get($bx);
}
else {
die "Not a valid BoolExpr";
}
#$self->debug_message("B: $param_class '$arg' " . scalar(@results));
return @results;
}
sub _try_get_by_id {
my ($self, $param_class, $str) = @_;
my $class_meta = $param_class->__meta__;
my @id_property_names = $class_meta->id_property_names;
if (@id_property_names == 0) {
die "Failed to determine ID property names for class ($param_class).";
} elsif (@id_property_names == 1) {
my $id_data_type = $class_meta->property_meta_for_name($id_property_names[0])->_data_type_as_class_name || '';
# Validate $str, if possible, to prevent warnings from database if $str does not fit column type.
if ($id_data_type->isa('UR::Value::Number')) { # Oracle's Number data type includes floats but we just use integers for numeric IDs
return ($str =~ /^[+-]?\d+$/);
}
}
return 1;
}
sub _resolve_param_value_from_text_by_name_or_id {
my ($self, $param_class, $str) = @_;
my (@results);
if ($self->_try_get_by_id($param_class, $str)) {
@results = eval { $param_class->get($str) };
}
if (!@results && $param_class->can('name')) {
@results = $param_class->get(name => $str);
unless (@results) {
@results = $param_class->get("name like" => "$str");
}
}
return @results;
}
sub _get_user_verification_for_param_value {
my ($self, $param_name, @list) = @_;
my $n_list = scalar(@list);
if ($n_list > 200 && !$ENV{UR_NO_REQUIRE_USER_VERIFY}) {
my $response = $self->_ask_user_question("Would you [v]iew all $n_list item(s) for '$param_name', (p)roceed, or e(x)it?", 0, '[v]|p|x', 'v');
if(!$response || $response eq 'x') {
$self->status_message("Exiting...");
exit;
}
return @list if($response eq 'p');
}
my @new_list;
while (!@new_list) {
@new_list = $self->_get_user_verification_for_param_value_drilldown($param_name, @list);
}
my @ids = map { $_->id } @new_list;
$self->status_message("The IDs for your selection are:\n" . join(',', @ids) . "\n\n");
return @new_list;
}
sub _get_user_verification_for_param_value_drilldown {
my ($self, $param_name, @results) = @_;
my $n_results = scalar(@results);
my $pad = length($n_results);
# Allow an environment variable to be set to disable the require_user_verify attribute
return @results if ($ENV{UR_NO_REQUIRE_USER_VERIFY});
return if (@results == 0);
my @dnames = map {$_->__display_name__} grep { $_->can('__display_name__') } @results;
my $max_dname_length = @dnames ? length((sort { length($b) <=> length($a) } @dnames)[0]) : 0;
my @statuses = map {$_->status || 'missing_status'} grep { $_->can('status') } @results;
my $max_status_length = @statuses ? length((sort { length($b) <=> length($a) } @statuses)[0]) : 0;
my @results_with_display_name_and_class = map { [ $_->__display_name__, $_->class, $_ ] } @results;
@results = map { $_->[2] }
sort { $a->[1] cmp $b->[1] }
sort { $a->[0] cmp $b->[0] }
@results_with_display_name_and_class;
my @classes = List::MoreUtils::uniq(map {$_->class} @results);
my $response;
my @caller = caller(1);
while (!$response) {
$self->status_message("\n");
# TODO: Replace this with lister?
for (my $i = 1; $i <= $n_results; $i++) {
my $param = $results[$i - 1];
my $num = $self->_pad_string($i, $pad);
my $msg = "$num:";
$msg .= ' ' . $self->_pad_string($param->__display_name__, $max_dname_length, 'suffix');
my $status = ' ';
if ($param->can('status')) {
$status = $param->status || 'missing_status';
}
$msg .= "\t" . $self->_pad_string($status, $max_status_length, 'suffix');
$msg .= "\t" . $param->class if (@classes > 1);
$self->status_message($msg);
}
if ($MESSAGE) {
$MESSAGE = "\n" . '*'x80 . "\n" . $MESSAGE . "\n" . '*'x80 . "\n";
$self->status_message($MESSAGE);
$MESSAGE = '';
}
my $pretty_values = '(c)ontinue, (h)elp, e(x)it';
my $valid_values = '\*|c|h|x|[-+]?[\d\-\., ]+';
if ($caller[3] =~ /_trim_list_from_response/) {
$pretty_values .= ', (b)ack';
$valid_values .= '|b';
}
$response = $self->_ask_user_question("Please confirm the above items for '$param_name' or modify your selection.", 0, $valid_values, 'h', $pretty_values.', or specify item numbers to use');
if (lc($response) eq 'h' || !$self->_validate_user_response_for_param_value_verification($response)) {
$MESSAGE .= "\n" if ($MESSAGE);
$MESSAGE .=
"Help:\n".
"* Specify which elements to keep by listing them, e.g. '1,3,12' would keep\n".
" items 1, 3, and 12.\n".
"* Begin list with a minus to remove elements, e.g. '-1,3,9' would remove\n".
" items 1, 3, and 9.\n".
"* Ranges can be used, e.g. '-11-17, 5' would remove items 11 through 17 and\n".
" remove item 5.";
$response = '';
}
}
if (lc($response) eq 'x') {
$self->status_message("Exiting...");
exit;
}
elsif (lc($response) eq 'b') {
return;
}
elsif (lc($response) eq 'c' | $response eq '*') {
return @results;
}
elsif ($response =~ /^[-+]?[\d\-\., ]+$/) {
@results = $self->_trim_list_from_response($response, $param_name, @results);
return @results;
}
else {
die $self->error_message("Conditional exception, should not have been reached!");
}
}
sub terminal_input_filehandle {
my $self = shift;
my $fh = IO::File->new('/dev/tty', 'r');
unless ($fh) {
Carp::carp("Couldn't open /dev/tty for terminal input: $!\n Using STDIN...");
$fh = *STDIN;
}
return $fh;
}
sub _ask_user_question {
my $self = shift;
my $question = shift;
my $timeout = shift;
my $valid_values = shift || "yes|no";
my $default_value = shift || undef;
my $pretty_valid_values = shift || $valid_values;
$valid_values = lc($valid_values);
my $input;
$timeout = 60 unless(defined($timeout));
local $SIG{ALRM} = sub { print STDERR "Exiting, failed to reply to question '$question' within '$timeout' seconds.\n"; exit; };
print STDERR "\n$question\n";
print STDERR "Reply with $pretty_valid_values: ";
unless ($self->_can_interact_with_user) {
print STDERR "\n";
die $self->error_message("Attempting to ask user question but cannot interact with user!");
}
my $terminal = $self->terminal_input_filehandle();
alarm($timeout) if ($timeout);
chomp($input = $terminal->getline());
alarm(0) if ($timeout);
print STDERR "\n";
if(lc($input) =~ /^$valid_values$/) {
return lc($input);
}
elsif ($default_value) {
return $default_value;
}
else {
$self->error_message("'$input' is an invalid answer to question '$question'\n\n");
return;
}
}
sub _validate_user_response_for_param_value_verification {
my ($self, $response_text) = @_;
$response_text = substr($response_text, 1) if ($response_text =~ /^[+-]/);
my @response = split(/[\s\,]/, $response_text);
for my $response (@response) {
if ($response =~ /^[xbc*]$/) {
return 1;
}
if ($response !~ /^(\d+)([-\.]+(\d+))?$/) {
$MESSAGE .= "\n" if ($MESSAGE);
$MESSAGE .= "ERROR: Invalid list provided ($response)";
return 0;
}
if ($3 && $1 && $3 < $1) {
$MESSAGE .= "\n" if ($MESSAGE);
$MESSAGE .= "ERROR: Inverted range provided ($1-$3)";
return 0;
}
}
return 1;
}
sub _trim_list_from_response {
my ($self, $response_text, $param_name, @list) = @_;
my $method;
if ($response_text =~ /^[+-]/) {
$method = substr($response_text, 0, 1);
$response_text = substr($response_text, 1);
}
else {
$method = '+';
}
my @response = split(/[\s\,]/, $response_text);
my %indices;
@indices{0..$#list} = 0..$#list if ($method eq '-');
for my $response (@response) {
$response =~ /^(\d+)([-\.]+(\d+))?$/;
my $low = $1; $low--;
my $high = $3 || $1; $high--;
die if ($high < $low);
if ($method eq '+') {
@indices{$low..$high} = $low..$high;
}
else {
delete @indices{$low..$high};
}
}
#$self->debug_message("Indices: " . join(',', sort(keys %indices)));
my @new_list = $self->_get_user_verification_for_param_value_drilldown($param_name, @list[sort keys %indices]);
unless (@new_list) {
@new_list = $self->_get_user_verification_for_param_value_drilldown($param_name, @list);
}
return @new_list;
}
sub _pad_string {
my ($self, $str, $width, $pos) = @_;
$str = '' if ! defined $str;
my $padding = $width - length($str);
$padding = 0 if ($padding < 0);
if ($pos && $pos eq 'suffix') {
return $str . ' 'x$padding;
}
else {
return ' 'x$padding . $str;
}
}
sub _can_interact_with_user {
my $self = shift;
if ( -t STDERR ) {
return 1;
}
else {
return 0;
}
}
1;
DynamicSubCommands.pm 100664 023532 023421 17410 12544604516 20062 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/Command package Command::DynamicSubCommands;
use strict;
use warnings;
use UR;
class Command::DynamicSubCommands {
is => 'Command',
is_abstract => 1,
};
sub _init_subclass {
my $subclass = shift;
my $meta = $subclass->__meta__;
if (grep { $_ eq __PACKAGE__ } $meta->parent_class_names) {
my $delegating_class_name = $subclass;
eval "sub ${subclass}::_delegating_class_name { '$delegating_class_name' }";
}
return 1;
}
sub __extend_namespace__ {
# auto generate sub-classes at the time of first reference
my ($self,$ext) = @_;
my $meta = $self->SUPER::__extend_namespace__($ext);
return $meta if $meta;
unless ($self->can('_sub_commands_from')) {
die "Class " . $self->class . " does not implement _sub_commands_from()!\n"
. "This method should return the namespace to use a reference "
. "for defining sub-commands."
}
my $ref_class = $self->_sub_commands_from;
my $target_class_name = join('::', $ref_class, $ext);
my $target_class_meta = UR::Object::Type->get($target_class_name);
if ($target_class_meta and $target_class_name->isa($ref_class)) {
my $subclass_name = join('::', $self->class, $ext);
my $subclass = $self->_build_sub_command($subclass_name, $self->class, $target_class_name);
my $meta = $subclass->__meta__;
return $meta;
}
return;
}
sub _build_all_sub_commands {
my ($class) = @_;
unless ($class->can('_sub_commands_from')) {
die "Class $class does not implement _sub_commands_from()!\n"
. "This method should return the namespace to use a reference "
. "for defining sub-commands."
}
my $ref_class = $class->_sub_commands_from;
my $delegating_class_name = $class;
my $module = $ref_class;
$module =~ s/::/\//g;
$module .= '.pm';
my $base_path = $INC{$module};
unless ($base_path) {
if (UR::Object::Type->get($ref_class)) {
$base_path = $INC{$module};
}
unless ($base_path) {
die "Failed to find the path for ref class $ref_class!";
}
}
$base_path =~ s/$module//;
my $ref_path = $ref_class;
$ref_path =~ s/::/\//g;
my $full_ref_path = $base_path . '/' . $ref_path;
my @target_paths = glob("$full_ref_path/*.pm");
my @target_class_names;
for my $target_path (@target_paths) {
my $target = $target_path;
$target =~ s#$base_path\/$ref_path/##;
$target =~ s/\.pm//;
my $target_class_name = $ref_class . '::' . $target;
my $target_meta = UR::Object::Type->get($target_class_name);
next unless $target_meta;
next unless $target_class_name->isa($ref_class);
push @target_class_names, $target => $target_class_name;
}
my %target_classes = @target_class_names;
my @subclasses;
for my $target (sort keys %target_classes) {
my $target_class_name = $target_classes{$target};
my $class_name = $delegating_class_name . '::' . $target;
# skip commands which have a module
my $module_name = $class_name;
$module_name =~ s|::|/|g;
$module_name .= '.pm';
if (my @matches = grep { -e $_ . '/' . $module_name } @INC) {
my $c = UR::Object::Type->get($class_name);
push @subclasses, $class_name;
next;
}
my @new_class_names = $class->_build_sub_command($class_name,$delegating_class_name,$target_class_name);
for my $new_class_name (@new_class_names) {
eval "sub ${new_class_name}::_target_class_name { '$target_class_name' }";
push @subclasses, $new_class_name;
}
}
return @subclasses;
}
sub _build_sub_command {
my ($self,$class_name,$delegating_class_name,$reference_class_name) = @_;
class {$class_name} {
is => $delegating_class_name,
doc => '',
};
return $class_name;
}
sub sub_command_dirs {
my $class = ref($_[0]) || $_[0];
return ( $class eq $class->_delegating_class_name ? 1 : 0 );
}
sub sub_command_classes {
my $class = shift;
unless(exists $class->__meta__->{_sub_commands}) {
my @subclasses = $class->_build_all_sub_commands;
$class->__meta__->{_sub_commands} = \@subclasses;
}
return @{ $class->__meta__->{_sub_commands} };
}
sub _target_class_name { undef }
1;
=pod
=head1 NAME
Command::DynamicSubCommands - auto-generate sub-commands based on other classes
=head1 SYNOPSIS
# given that these classes exist:
# Acme::Task::Foo
# Acme::Task::Bar
# in Acme/Worker/Command/DoTask.pm:
class Acme::Worker::Command::DoTask {
is => 'Command::DynamicSubCommands',
has => [
param1 => { is => 'Text' },
param2 => { is => 'Text' },
]
};
sub _sub_commands_from { 'Acme::Task' }
sub execute {
my $self = shift;
print "this command " . ref($self) . " applies to " . $self->_target_class_name;
return 1;
}
# the class above will discover them at compile,
# and auto-generate these subclasses of itself:
# Acme::Worker::Command::DoTask::Foo
# Acme::Worker::Command::DoTask::Bar
# in the shell...
#
# $ acme worker do-task
# foo
# bar
#
# $ acme worker do-task foo --param1 aaa --param2 bbb
# this command Acme::Worker::Command::DoTask::Foo applies to Acme::Task::Foo
#
# $ acme worker do-task bar --param1 ccc --param2 ddd
# this command Acme::Worker::Command::DoTask::Bar applies to Acme::Task::Bar
=head1 DESCRIPTION
This module helps you avoid writing boilerplate commands.
When a command has a set of sub-commands which are meant to be derived from another
group of classes, this module lets you auto-generate those sub-commands at run
time.
=head1 REQUIRED ABSTRACT METHOD
=over 4
=item _sub_commands_from
$base_namespace = Acme::Order::Command->_sub_commands_from();
# 'Acme::Task
Returns the namespace from which target classes will be discovered, and
sub-commands will be generated.
=back
=head1 PRIVATE API
=over 4
=item _target_class_name
$c= Acme::Order::Command::Purchasing->_target_class_name;
# 'Acme::Task::Foo'
The name of some class under the _sub_commands_from() namespace.
This value is set during execute, revealing which sub-command the caller is using.
=back
=head1 OPTIONAL OVERRIDES
=over 4
=item _build_sub_commmand
This can be overridden to customize the sub-command construction.
By default, each target under _sub_commands_from will result in
a call to this method. The default implementation is below:
my $self = shift;
my ($suggested_class_name,$delegator_class_name,$target_class_name) = @_;
class {$suggested_class_name} {
is => $delegator_class_name,
sub_classify_by => 'class',
has_constant => [
_target_class_name => { value => $target_class_name },
]
};
return ($suggested_class_name);
Note that the class in question may be on the filesystem, and not need
to be created. The return list can include more than one class name,
or zero class names.
=item _build_all_sub_commands
This is called once for any class which inherits from Command::DynamicSubCommands.
It generates the sub-commands as needed, and returns a list.
By default it resolves the target classes, and calls _build_sub_command
It can be overridden to customize behavior, or filter results. Be sure
to call @cmds = $self->SUPER::_build_all_sub_commands() if you want
to get the default commands in addition to overriding.
=back
The sub-commands need not be 1:1 with the target classes, though this is the default.
The sub-commands need not inherit from the Command::DynamicSubCommands base command
which generates them, though this is the default.
=cut
Shell.pm 100664 023532 023421 7117 12544604516 15374 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/Command package Command::Shell;
use strict;
use warnings;
use Command::V2;
class Command::Shell {
is => 'Command::V2',
is_abstract => 1,
subclassify_by => "_shell_command_subclass",
has_input => [
delegate_type => { is => 'Text', shell_args_position => 1,
doc => 'the class name of the command to be executed' },
argv => { is => 'Text', is_many => 1, is_optional => 1, shell_args_position => 2,
doc => 'list of command-line arguments to be translated into parameters' },
],
has_transient => [
delegate => { is => 'Command',
doc => 'the command which this adaptor wraps' },
_shell_command_subclass => { calculate_from => ['delegate_type'],
calculate =>
sub {
my $delegate_type = shift;
my $subclass = $delegate_type . "::Shell";
eval "$subclass->class";
if ($@) {
my $new_subclass = UR::Object::Type->define(
class_name => $subclass,
is => __PACKAGE__
);
die "Failed to fabricate subclass $subclass!" unless $new_subclass;
}
return $subclass;
},
},
],
has_output => [
exit_code => => { is => 'Number',
doc => 'the exit code to be returned to the shell', }
],
doc => 'an adaptor to create and run commands as specified from a standard command-line shell (bash)'
};
sub help_synopsis {
return <run("Foo",@ARGV);
The run() static method will construct the appropriate Command::Shell object, have it build its delegate,
run the delegate's execution method in an in-memory transaction sandbox, and capture an exit code.
If the correct environment variables are set, it will respond to a bash tab-completion request, such that
the "foo" script can be used as a self-completer.
EOS
}
sub run {
my $class = shift;
my $delegate_type = shift;
my @argv = @_;
my $cmd = $class->create(delegate_type => $delegate_type, argv => \@argv);
#print STDERR "created $cmd\n";
$cmd->execute;
my $exit_code = $cmd->exit_code;
$cmd->delete;
return $exit_code;
}
sub execute {
my $self = shift;
my $delegate_type = $self->delegate_type;
eval "use above '$delegate_type'";
if ($@) {
my $t = UR::Object::Type->get($delegate_type);
unless ($t) {
die "Failure to use delegate class $delegate_type!:\n$@";
}
}
my @argv = $self->argv;
my $exit_code = $delegate_type->_cmdline_run(@argv);
$self->exit_code($exit_code);
return 1;
}
# TODO: migrate all methods in Command::V2 which live in the Command::Dispatch::Shell module to this package
# Methods which address $self to get to shell-specific things still call $self
# Methods which address $self to get to the underlying command should instead call $self->delegate
1;
SubCommandFactory.pm 100664 023532 023421 7256 12544604516 17711 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/Command package Command::SubCommandFactory;
use strict;
use warnings;
use UR;
class Command::SubCommandFactory {
is => 'Command::Tree',
is_abstract => 1,
doc => 'Base class for commands that delegate to sub-commands that may need to be dynamically created',
};
sub _init_subclass {
my $subclass = shift;
my $meta = $subclass->__meta__;
if (grep { $_ eq __PACKAGE__ } $meta->parent_class_names) {
my $delegating_class_name = $subclass;
eval "sub ${subclass}::_delegating_class_name { '$delegating_class_name' }";
}
return 1;
}
sub _build_sub_command_mapping {
my ($class) = @_;
unless ($class->can('_sub_commands_from')) {
die "Class $class does not implement _sub_commands_from()!\n"
. "This method should return the namespace to use a reference "
. "for defining sub-commands."
}
my $ref_class = $class->_sub_commands_from;
my @inheritance;
if ($class->can('_sub_commands_inherit_from') and defined $class->_sub_commands_inherit_from) {
@inheritance = $class->_sub_commands_inherit_from();
}
else {
@inheritance = $class;
}
my $module = $ref_class;
$module =~ s/::/\//g;
$module .= '.pm';
my $base_path = $INC{$module};
unless ($base_path) {
if (UR::Object::Type->get($ref_class)) {
$base_path = $INC{$module};
}
unless ($base_path) {
die "Failed to find the path for ref class $ref_class!";
}
}
$base_path =~ s/$module//;
my $ref_path = $ref_class;
$ref_path =~ s/::/\//g;
my $full_ref_path = $base_path . '/' . $ref_path;
my @target_paths = glob("$full_ref_path/*.pm");
my @target_class_names;
for my $target_path (@target_paths) {
my $target = $target_path;
$target =~ s#$base_path\/$ref_path/##;
$target =~ s/\.pm//;
my $target_base_class = $class->_target_base_class;
my $target_class_name = $target_base_class . '::' . $target;
my $target_meta = UR::Object::Type->get($target_class_name);
next unless $target_meta;
next unless $target_class_name->isa($target_base_class);
push @target_class_names, $target => $target_class_name;
}
my %target_classes = @target_class_names;
# Create a mapping of command names to command classes, and either find or
# create those command classes
my $mapping;
for my $target (sort keys %target_classes) {
my $target_class_name = $target_classes{$target};
my $command_class_name = $class . '::' . $target;
my $command_module_name = $command_class_name;
$command_module_name =~ s|::|/|g;
$command_module_name .= '.pm';
# If the command class already exists, load it. Otherwise, create one.
if (grep { -e $_ . '/' . $command_module_name } @INC) {
UR::Object::Type->get($command_class_name);
}
else {
$class->_build_sub_command($command_class_name, @inheritance);
}
# Created commands need to know where their parameters came from
no warnings 'redefine';
eval "sub ${command_class_name}::_target_class_name { '$target_class_name' }";
use warnings;
my $command_name = $class->_command_name_for_class_word($target);
$mapping->{$command_name} = $command_class_name;
}
return $mapping;
}
sub _build_sub_command {
my ($self, $class_name, @inheritance) = @_;
class {$class_name} {
is => \@inheritance,
doc => '',
};
return $class_name;
}
sub _target_base_class { return $_[0]->_sub_commands_from; }
sub _target_class_name { undef }
sub _sub_commands_inherit_from { undef }
1;
Test.pm 100664 023532 023421 172 12544604516 15216 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/Command use strict;
use warnings;
use UR;
use Command;
package Command::Test;
class Command::Test{
is => 'Command',
};
1;
Echo.pm 100664 023532 023421 1320 12544604516 16110 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/Command/Test use strict;
use warnings;
use UR;
use Command;
package Command::Test::Echo;
class Command::Test::Echo {
is => 'Command',
has => [
in => { is => 'Text' },
out => { is => 'Text', is_output => 1, is_optional => 1 },
],
doc => 'echo the input back, and die or fail if those words appear in the input',
};
sub execute {
my $self = shift;
print "job " . $self->id . " started at " . $self->__context__->now . "\n";
print STDERR "test error!\n";
for (1..10) {
print $self->in,"\n";
sleep 1;
}
if ($self->in =~ /fail/) {
return;
}
elsif ($self->in =~ /die/) {
die $self->in;
}
$self->out($self->in);
return 1;
}
1;
Tree1.pm 100664 023532 023421 270 12544604516 16175 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/Command/Test use strict;
use warnings;
use UR;
use Command;
package Command::Test::Tree1;
class Command::Test::Tree1 {
is => 'Command',
doc => 'more exciting operations are here'
};
1;
Echo1.pm 100664 023532 023421 1104 12544604516 17151 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/Command/Test/Tree1 use strict;
use warnings;
use UR;
use Command;
package Command::Test::Tree1::Echo1;
class Command::Test::Tree1::Echo1 {
is => 'Command',
has => [
in => { is => 'Text' },
out => { is => 'Text', is_output => 1, is_optional => 1 },
],
doc => 'test command 1 to echo output1',
};
sub execute {
my $self = shift;
for (1..6) {
print $self->in,"\n";
sleep 1;
}
if ($self->in =~ /fail/) {
return;
}
elsif ($self->in =~ /die/) {
die $self->in;
}
$self->out($self->in);
return 1;
}
1;
Echo2.pm 100664 023532 023421 1103 12544604516 17151 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/Command/Test/Tree1 use strict;
use warnings;
use UR;
use Command;
package Command::Test::Tree1::Echo2;
class Command::Test::Tree1::Echo2 {
is => 'Command',
has => [
in => { is => 'Text' },
out => { is => 'Text', is_output => 1, is_optional => 1 },
],
doc => 'test command 2 to echo output',
};
sub execute {
my $self = shift;
for (1..6) {
print $self->in,"\n";
sleep 1;
}
if ($self->in =~ /fail/) {
return;
}
elsif ($self->in =~ /die/) {
die $self->in;
}
$self->out($self->in);
return 1;
}
1;
Tree.pm 100664 023532 023421 40245 12544604516 15243 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/Command package Command::Tree;
use strict;
use warnings;
use UR;
use File::Basename qw/basename/;
our $VERSION = "0.44"; # UR $VERSION;
class Command::Tree {
is => 'Command::V2',
is_abstract => 1,
doc => 'base class for commands which delegate to sub-commands',
};
sub resolve_class_and_params_for_argv {
# This is used by execute_with_shell_params_and_exit, but might be used within an application.
my $self = shift;
my @argv = @_;
if ( $argv[0] and $argv[0] !~ /^\-/
and my $class_for_sub_command = $self->class_for_sub_command($argv[0]) ) {
# delegate
shift @argv;
return $class_for_sub_command->resolve_class_and_params_for_argv(@argv);
}
elsif ( @argv == 1 and $argv[0] =~ /^(\-)?\-h(elp)?$/ ) { # HELP ME!
return ($self, { help => 1 });
}
else {
# error
return ($self,undef);
}
}
sub resolve_option_completion_spec {
my $class = shift;
my @completion_spec;
my @sub = eval { $class->sub_command_names };
if ($@) {
$class->warning_message("Couldn't load class $class: $@\nSkipping $class...");
return;
}
for my $sub (@sub) {
my $sub_class = $class->class_for_sub_command($sub);
my $sub_tree = $sub_class->resolve_option_completion_spec() if defined($sub_class);
# Hack to fix several broken commands, this should be removed once commands are fixed.
# If the commands were not broken then $sub_tree will always exist.
# Basically if $sub_tree is undef then we need to remove '>' to not break the OPTS_SPEC
if ($sub_tree) {
push @completion_spec, '>' . $sub => $sub_tree;
}
else {
if (defined $sub_class) {
print "WARNING: $sub has sub_class $sub_class of ($class) but could not resolve option completion spec for it.\n".
"Setting $sub to non-delegating command, investigate to correct tab completion.\n";
} else {
print "WARNING: $sub has no sub_class so could not resolve option completion spec for it.\n".
"Setting $sub to non-delegating command, investigate to correct tab completion.\n";
}
push @completion_spec, $sub => undef;
}
}
push @completion_spec, "help!" => undef;
return \@completion_spec
}
sub help_brief {
my $self = shift;
if (my $doc = $self->__meta__->doc) {
return $doc;
}
else {
my @parents = $self->__meta__->ancestry_class_metas;
for my $parent (@parents) {
if (my $doc = $parent->doc) {
return $doc;
}
}
return "";
}
}
sub doc_help {
my $self = shift;
my $command_name = $self->command_name;
my $text;
# show the list of sub-commands
$text = sprintf(
"Sub-commands for %s:\n%s",
Term::ANSIColor::colored($command_name, 'bold'),
$self->help_sub_commands,
);
return $text;
}
sub doc_manual {
my $self = shift;
my $pod = $self->_doc_name_version;
my $manual = $self->_doc_manual_body;
my $help = $self->help_detail;
if ($manual or $help) {
$pod .= "=head1 DESCRIPTION:\n\n";
my $txt = $manual || $help;
if ($txt =~ /^\=/) {
# pure POD
$pod .= $manual;
}
else {
$txt =~ s/\n/\n\n/g;
$pod .= $txt;
#$pod .= join('', map { " $_\n" } split ("\n",$txt)) . "\n";
}
}
my $sub_commands = $self->help_sub_commands(brief => 1);
$pod .= "=head1 SUB-COMMANDS\n\n" . $sub_commands . "\n\n";
$pod .= $self->_doc_footer();
$pod .= "\n\n=cut\n\n";
return "\n$pod";
}
sub sorted_sub_command_classes {
no warnings;
my @c = map { [ $_->sub_command_sort_position, $_ ] } shift->sub_command_classes;
return map { $_->[1] }
sort {
($a->[0] <=> $b->[0])
||
($a->[0] cmp $b->[0])
}
@c;
}
sub sorted_sub_command_names {
my $class = shift;
my @sub_command_classes = $class->sorted_sub_command_classes;
my @sub_command_names = map { $_->command_name_brief } @sub_command_classes;
return @sub_command_names;
}
sub sub_commands_table {
my $class = shift;
my @sub_command_names = $class->sorted_sub_command_names;
my $max_length = 0;
for (@sub_command_names) {
$max_length = length($_) if ($max_length < length($_));
}
$max_length ||= 79;
my $col_spacer = '_'x$max_length;
my $n_cols = floor(80/$max_length);
my $n_rows = ceil(@sub_command_names/$n_cols);
my @tb_rows;
for (my $i = 0; $i < @sub_command_names; $i += $n_cols) {
my $end = $i + $n_cols - 1;
$end = $#sub_command_names if ($end > $#sub_command_names);
push @tb_rows, [@sub_command_names[$i..$end]];
}
my @col_alignment;
for (my $i = 0; $i < $n_cols; $i++) {
push @col_alignment, { sample => "&$col_spacer" };
}
my $tb = Text::Table->new(@col_alignment);
$tb->load(@tb_rows);
return $tb;
}
sub _categorize_sub_commands {
my $class = shift;
my @sub_command_classes = $class->sorted_sub_command_classes;
my %categories;
my @order;
for my $sub_command_class (@sub_command_classes) {
next if $sub_command_class->_is_hidden_in_docs();
my $category = $sub_command_class->sub_command_category || '';
unless (exists $categories{$category}) {
if ($category) {
push(@order, $category)
} else {
unshift(@order, '');
}
$categories{$category} = [];
}
push(@{$categories{$category}}, $sub_command_class);
}
return (\@order, \%categories);
}
sub help_sub_commands {
my ($self, %params) = @_;
my ($order, $categories) = $self->_categorize_sub_commands(@_);
my $command_name_method = 'command_name_brief';
no warnings;
local $Text::Wrap::columns = 60;
my @full_data;
for my $category (@$order) {
my $sub_commands_within_this_category = $categories->{$category};
my @data = map {
my @rows = split("\n",Text::Wrap::wrap('', ' ', $_->help_brief));
chomp @rows;
(
[
$_->$command_name_method,
($_->isa('Command::Tree') ? '...' : ''), #$_->_shell_args_usage_string_abbreviated,
$rows[0],
],
map {
[
'',
' ',
$rows[$_],
]
} (1..$#rows)
);
}
@$sub_commands_within_this_category;
if ($category) {
# add a space between categories
push @full_data, ['','',''] if @full_data;
if ($category =~ /\D/) {
# non-numeric categories show their category as a header
$category .= ':' if $category =~ /\S/;
push @full_data,
[
Term::ANSIColor::colored(uc($category), 'blue'),
'',
''
];
}
else {
# numeric categories just sort
}
}
push @full_data, @data;
}
my @max_width_found = (0,0,0);
for (@full_data) {
for my $c (0..2) {
$max_width_found[$c] = length($_->[$c]) if $max_width_found[$c] < length($_->[$c]);
}
}
my @colors = (qw/ red bold /);
my $text = '';
for my $row (@full_data) {
for my $c (0..2) {
$text .= ' ';
$text .= $colors[$c] ? Term::ANSIColor::colored($row->[$c], $colors[$c]) : $row->[$c];
$text .= ' ';
$text .= ' ' x ($max_width_found[$c]-length($row->[$c]));
}
$text .= "\n";
}
return $text;
}
sub doc_sub_commands {
my $self = shift;
my ($order, $categories) = $self->_categorize_sub_commands(@_);
my $text = "";
my $indent_lvl = 4;
for my $category (@$order) {
my $category_name = ($category ? uc $category : "GENERAL");
$text .= "=head2 $category_name\n\n";
for my $cmd (@{$categories->{$category}}) {
$text .= "=over $indent_lvl\n\n";
my $name = $cmd->command_name_brief;
my $link = $cmd->command_name;
$link =~ s/ /-/g;
my $description = $cmd->help_brief;
$text .= "=item B>\n\n=over 2\n\n=item $description\n\n=back\n\n";
$text .= "=back\n\nE<10>\n\n";
}
}
return $text;
}
#
# The following methods build allow a command to determine its
# sub-commands, if there are any.
#
# This is for cases in which the Foo::Bar command delegates to
# Foo::Bar::Baz, Foo::Bar::Buz or Foo::Bar::Doh, depending on its paramters.
sub sub_command_dirs {
my $class = shift;
my $subdir = ref($class) || $class;
$subdir =~ s|::|\/|g;
my @dirs = grep { -d $_ } map { $_ . '/' . $subdir } @INC;
return @dirs;
}
sub sub_command_classes {
my $class = shift;
my $mapping = $class->_build_sub_command_mapping;
return values %$mapping;
}
# For compatability with Command::V1-based callers
sub is_sub_command_delegator {
return scalar(shift->sub_command_classes);
}
sub command_tree_source_classes {
# override in subclass if you want different sources
my $class = shift;
return $class;
}
sub _build_sub_command_mapping {
my $class = shift;
$class = ref($class) || $class;
my @source_classes = $class->command_tree_source_classes;
my $mapping;
do {
no strict 'refs';
$mapping = ${ $class . '::SUB_COMMAND_MAPPING'};
if (ref($mapping) eq 'HASH') {
return $mapping;
}
};
for my $source_class (@source_classes) {
# check if this class is valid
eval{ $source_class->class; };
if ( $@ ) {
warn $@;
}
# for My::Foo::Command::* commands and sub-trees
my $subdir = $source_class;
$subdir =~ s|::|\/|g;
# for My::Foo::*::Command sub-trees
my $source_class_above = $source_class;
$source_class_above =~ s/::Command//;
my $subdir2 = $source_class_above;
$subdir2 =~ s|::|/|g;
# check everywhere
for my $lib (@INC) {
my $subdir_full_path = $lib . '/' . $subdir;
# find My::Foo::Command::*
if (-d $subdir_full_path) {
my @files = glob($subdir_full_path . '/*');
for my $file (@files) {
my $basename = basename($file);
$basename =~ s/.pm$// or next;
my $sub_command_class_name = $source_class . '::' . $basename;
my $sub_command_class_meta = UR::Object::Type->get($sub_command_class_name);
unless ($sub_command_class_meta) {
local $SIG{__DIE__};
local $SIG{__WARN__};
# until _use_safe is refactored to be permissive, use directly...
print ">> $sub_command_class_name\n";
eval "use $sub_command_class_name";
}
$sub_command_class_meta = UR::Object::Type->get($sub_command_class_name);
next unless $sub_command_class_name->isa("Command");
next if $sub_command_class_meta->is_abstract;
next if $sub_command_class_name eq $class;
my $name = $source_class->_command_name_for_class_word($basename);
$mapping->{$name} = $sub_command_class_name;
}
}
# find My::Foo::*::Command
$subdir_full_path = $lib . '/' . $subdir2;
my $pattern = $subdir_full_path . '/*/Command.pm';
my @paths = glob($pattern);
for my $file (@paths) {
next unless defined $file;
next unless length $file;
next unless -f $file;
my $last_word = File::Basename::basename($file);
$last_word =~ s/.pm$// or next;
my $dir = File::Basename::dirname($file);
my $second_to_last_word = File::Basename::basename($dir);
my $sub_command_class_name = $source_class_above . '::' . $second_to_last_word . '::' . $last_word;
next unless $sub_command_class_name->isa('Command');
next if $sub_command_class_name->__meta__->is_abstract;
next if $sub_command_class_name eq $class;
my $basename = $second_to_last_word;
$basename =~ s/.pm$//;
my $name = $source_class->_command_name_for_class_word($basename);
$mapping->{$name} = $sub_command_class_name;
}
}
}
return $mapping;
}
sub sub_command_names {
my $class = shift;
my $mapping = $class->_build_sub_command_mapping;
return keys %$mapping;
}
sub _try_command_class_named {
my $self = shift;
my $sub_class = join('::', @_);
my $meta = UR::Object::Type->get($sub_class); # allow in memory classes
unless ( $meta ) {
eval "use $sub_class;";
if ($@) {
if ($@ =~ /^Can't locate .*\.pm in \@INC/) {
#die "Failed to find $sub_class! $class_for_sub_command.pm!\n$@";
return;
}
else {
my @msg = split("\n",$@);
pop @msg;
pop @msg;
$self->error_message("$sub_class failed to compile!:\n@msg\n\n");
return;
}
}
}
elsif (my $isa = $sub_class->isa("Command")) {
if (ref($isa)) {
# dumb modules (Test::Class) mess with the standard isa() API
if ($sub_class->SUPER::isa("Command")) {
return $sub_class;
}
else {
return;
}
}
return $sub_class;
}
else {
return;
}
}
sub class_for_sub_command {
my $self = shift;
my $class = ref($self) || $self;
my $sub_command = shift;
return if $sub_command =~ /^\-/; # If it starts with a "-", then it's a command-line option
# First attempt is to convert $sub_command into a camel-case module name
# and just try loading it
my $name_for_sub_command = join("", map { ucfirst($_) } split(/-/, $sub_command));
my @class_name_parts = (split(/::/,$class), $name_for_sub_command);
my $sub_command_class = $self->_try_command_class_named(@class_name_parts);
return $sub_command_class if $sub_command_class;
# Remove "Command" if it's embedded in the middle and try inserting it in other places, starting at the end
@class_name_parts = ( ( map { $_ eq 'Command' ? () : $_ } @class_name_parts) , 'Command');
for(my $i = $#class_name_parts; $i > 0; $i--) {
$sub_command_class = $self->_try_command_class_named(@class_name_parts);
return $sub_command_class if $sub_command_class;
$class_name_parts[$i] = $class_name_parts[$i-1];
$class_name_parts[$i-1] = 'Command';
}
# Didn't find it yet. Try exhaustively loading all the command modules under $class
my $mapping = $class->_build_sub_command_mapping;
if (my $sub_command_class = $mapping->{$sub_command}) {
return $sub_command_class;
} else {
return;
}
}
my $depth = 0;
sub __extend_namespace__ {
my ($self,$ext) = @_;
my $meta = $self->SUPER::__extend_namespace__($ext);
return $meta if $meta;
$depth++;
if ($depth>1) {
$depth--;
return;
}
my $class = Command::Tree::class_for_sub_command((ref $self || $self), $self->_command_name_for_class_word($ext));
return $class->__meta__ if $class;
return;
}
1;
__END__
=pod
=head1 NAME
Command::Tree -base class for commands which delegate to a list of sub-commands
=head1 DESCRIPTION
# in Foo.pm
class Foo { is => 'Command::Tree' };
# in Foo/Cmd1.pm
class Foo::Cmd1 { is => 'Command' };
# in Foo/Cmd2.pm
class Foo::Cmd2 { is => 'Command' };
# in the shell
$ foo
cmd1
cmd2
$ foo cmd1
$ foo cmd2
=cut
V1.pm 100664 023532 023421 133747 12544604516 14664 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/Command package Command::V1;
use strict;
use warnings;
use UR;
use Data::Dumper;
use File::Basename;
use Getopt::Long;
use Term::ANSIColor qw();
require Text::Wrap;
our $VERSION = "0.44"; # UR $VERSION;
UR::Object::Type->define(
class_name => __PACKAGE__,
is => ['Command', 'Command::Common'],
is_abstract => 1,
attributes_have => [
is_input => { is => 'Boolean', is_optional => 1 },
is_output => { is => 'Boolean', is_optional => 1 },
is_param => { is => 'Boolean', is_optional => 1 },
shell_args_position => { is => 'Integer', is_optional => 1,
doc => 'when set, this property is a positional argument when run from a shell' },
],
has_optional => [
debug => { is => 'Boolean', doc => 'enable debug messages' },
is_executed => { is => 'Boolean' },
result => { is => 'Scalar', is_output => 1 },
original_command_line => { is => 'String', doc => 'null-byte separated list of command and arguments when run via execute_with_shell_params_and_exit'},
],
);
# This is changed with "local" where used in some places
$Text::Wrap::columns = 100;
# Required for color output
eval {
binmode STDOUT, ":utf8";
binmode STDERR, ":utf8";
};
sub _init_subclass {
# Each Command subclass has an automatic wrapper around execute().
# This ensures it can be called as a class or instance method,
# and that proper handling occurs around it.
my $subclass_name = $_[0];
no strict;
no warnings;
if ($subclass_name->can('execute')) {
# NOTE: manipulating %{ $subclass_name . '::' } directly causes ptkdb to segfault perl
my $new_symbol = "${subclass_name}::_execute_body";
my $old_symbol = "${subclass_name}::execute";
*$new_symbol = *$old_symbol;
undef *$old_symbol;
}
else {
#print "no execute in $subclass_name\n";
}
if($subclass_name->can('shortcut')) {
my $new_symbol = "${subclass_name}::_shortcut_body";
my $old_symbol = "${subclass_name}::shortcut";
*$new_symbol = *$old_symbol;
undef *$old_symbol;
}
return 1;
}
#
# Standard external interface for shell dispatchers
#
# TODO: abstract out all dispatchers for commands into a given API
sub execute_with_shell_params_and_exit {
# This automatically parses command-line options and "does the right thing":
my $class = shift;
if (@_) {
die
qq|
No params expected for execute_with_shell_params_and_exit().
Usage:
#!/usr/bin/env perl
use My::Command;
My::Command->execute_with_shell_params_and_exit;
|;
}
$Command::entry_point_class ||= $class;
$Command::entry_point_bin ||= File::Basename::basename($0);
if ($ENV{COMP_CWORD}) {
require Getopt::Complete;
my @spec = $class->resolve_option_completion_spec();
my $options = Getopt::Complete::Options->new(@spec);
$options->handle_shell_completion;
die "error: failed to exit after handling shell completion!";
}
my @argv = @ARGV;
@ARGV = ();
my $exit_code;
eval {
$exit_code = $class->_execute_with_shell_params_and_return_exit_code(@argv);
UR::Context->commit or die "Failed to commit!: " . UR::Context->error_message();
};
if ($@) {
$class->error_message($@);
UR::Context->rollback or die "Failed to rollback changes after failed commit!!!\n";
$exit_code = 255 unless ($exit_code);
}
exit $exit_code;
}
sub _execute_with_shell_params_and_return_exit_code {
my $class = shift;
my @argv = @_;
my $original_cmdline = join("\0",$0,@argv);
# make --foo=bar equivalent to --foo bar
@argv = map { ($_ =~ /^(--\w+?)\=(.*)/) ? ($1,$2) : ($_) } @argv;
my ($delegate_class, $params,$error_tag_list) = $class->resolve_class_and_params_for_argv(@argv);
my $rv;
if ($error_tag_list and @$error_tag_list) {
$class->error_message("There were problems resolving some command-line parameters:\n\t"
. join("\n\t",
map { my($props,$type,$desc) = @$_{'properties','type','desc'};
"Property '" . join("','",@$props) . "' ($type): $desc" }
@$error_tag_list));
} else {
$rv = $class->_execute_delegate_class_with_params($delegate_class,$params,$original_cmdline);
}
my $exit_code = $delegate_class->exit_code_for_return_value($rv);
return $exit_code;
}
# this is called by both the shell dispatcher and http dispatcher for now
sub _execute_delegate_class_with_params {
my ($class, $delegate_class, $params, $original_cmdline) = @_;
unless ($delegate_class) {
$class->usage_message($class->help_usage_complete_text);
return;
}
$delegate_class->dump_status_messages(1);
$delegate_class->dump_warning_messages(1);
$delegate_class->dump_error_messages(1);
$delegate_class->dump_usage_messages(1);
$delegate_class->dump_debug_messages(0);
if ( $delegate_class->is_sub_command_delegator && !defined($params) ) {
my $command_name = $delegate_class->command_name;
$delegate_class->status_message($delegate_class->help_usage_complete_text);
$delegate_class->error_message("Please specify a valid sub-command for '$command_name'.");
return;
}
if ( $params->{help} ) {
$delegate_class->usage_message($delegate_class->help_usage_complete_text);
return 1;
}
$params->{'original_command_line'} = $original_cmdline if (defined $original_cmdline);
my $command_object = $delegate_class->create(%$params);
unless ($command_object) {
# The delegate class should have emitted an error message.
# This is just in case the developer is sloppy, and the user will think the task did not fail.
print STDERR "Exiting.\n";
return;
}
$command_object->dump_status_messages(1);
$command_object->dump_warning_messages(1);
$command_object->dump_error_messages(1);
$command_object->dump_debug_messages($command_object->debug);
if ($command_object->debug) {
UR::ModuleBase->dump_debug_messages($command_object->debug);
}
my $rv = $command_object->execute($params);
if ($command_object->__errors__) {
$command_object->delete;
}
return $rv;
}
#
# Methods to override in concrete subclasses.
#
# Override "execute" or "_execute_body" to implement the body of the command.
# See above for details of internal implementation.
# By default, there are no bare arguments.
sub _bare_shell_argument_names {
my $self = shift;
my $meta = $self->__meta__;
my @ordered_names =
map { $_->property_name }
sort { $a->{shell_args_position} <=> $b->{shell_args_position} }
grep { $_->{shell_args_position} }
$self->_shell_args_property_meta();
return @ordered_names;
}
sub help_brief {
my $self = shift;
if (my $doc = $self->__meta__->doc) {
return $doc;
}
else {
my @parents = $self->__meta__->ancestry_class_metas;
for my $parent (@parents) {
if (my $doc = $parent->doc) {
return $doc;
}
}
if ($self->is_sub_command_delegator) {
return "";
}
else {
return "no description!!!: define 'doc' in $self";
}
}
}
sub help_synopsis {
my $self = shift;
return '';
}
sub help_detail {
my $self = shift;
return "!!! define help_detail() in module " . ref($self) || $self . "!";
}
sub sub_command_category {
return;
}
sub sub_command_sort_position {
# override to do something besides alpha sorting by name
return '9999999999 ' . $_[0]->command_name_brief;
}
#
# Self reflection
#
sub is_abstract {
# Override when writing an subclass which is also abstract.
my $self = shift;
my $class_meta = $self->__meta__;
return $class_meta->is_abstract;
}
sub is_executable {
my $self = shift;
if ($self->can("_execute_body") eq __PACKAGE__->can("_execute_body")) {
return;
}
elsif ($self->is_abstract) {
return;
}
else {
return 1;
}
}
sub is_sub_command_delegator {
my $self = shift;
if (scalar($self->sub_command_dirs)) {
return 1;
}
else {
return;
}
}
sub _time_now {
# return the current time in context
# this may not be the real time in selected cases
shift->__context__->now;
}
sub color_command_name {
my $text = shift;
my $colored_text = [];
my @COLOR_TEMPLATES = ('red', 'bold red', 'magenta', 'bold magenta');
my @parts = split(/\s+/, $text);
for(my $i = 0 ; $i < @parts ; $i++ ){
push @$colored_text, ($i < @COLOR_TEMPLATES) ? Term::ANSIColor::colored($parts[$i], $COLOR_TEMPLATES[$i]) : $parts[$i];
}
return join(' ', @$colored_text);
}
sub _base_command_class_and_extension {
my $self = shift;
my $class = ref($self) || $self;
return ($class =~ /^(.*)::([^\:]+)$/);
}
sub _command_name_for_class_word {
my $self = shift;
my $s = shift;
$s =~ s/_/-/g;
$s =~ s/^([A-Z])/\L$1/; # ignore first capital because that is assumed
$s =~ s/([A-Z])/-$1/g; # all other capitals prepend a dash
$s =~ s/([a-zA-Z])([0-9])/$1$2/g; # treat number as begining word
$s = lc($s);
return $s;
}
sub command_name {
my $self = shift;
my $class = ref($self) || $self;
my $prepend = '';
if (defined($Command::entry_point_class) and $class =~ /^($Command::entry_point_class)(::.+|)$/) {
$prepend = $Command::entry_point_bin;
$class = $2;
if ($class =~ s/^:://) {
$prepend .= ' ';
}
}
my @words = grep { $_ ne 'Command' } split(/::/,$class);
my $n = join(' ', map { $self->_command_name_for_class_word($_) } @words);
return $prepend . $n;
}
sub command_name_brief {
my $self = shift;
my $class = ref($self) || $self;
my @words = grep { $_ ne 'Command' } split(/::/,$class);
my $n = join(' ', map { $self->_command_name_for_class_word($_) } $words[-1]);
return $n;
}
#
# Methods to transform shell args into command properties
#
my $_resolved_params_from_get_options = {};
sub _resolved_params_from_get_options {
return $_resolved_params_from_get_options;
}
sub resolve_option_completion_spec {
my $class = shift;
my @completion_spec;
if ($class->is_sub_command_delegator) {
my @sub = eval { $class->sub_command_names};
if ($@) {
$class->warning_message("Couldn't load class $class: $@\nSkipping $class...");
return;
}
for my $sub (@sub) {
my $sub_class = $class->class_for_sub_command($sub);
my $sub_tree = $sub_class->resolve_option_completion_spec() if defined($sub_class);
# Hack to fix several broken commands, this should be removed once commands are fixed.
# If the commands were not broken then $sub_tree will always exist.
# Basically if $sub_tree is undef then we need to remove '>' to not break the OPTS_SPEC
if ($sub_tree) {
push @completion_spec, '>' . $sub => $sub_tree;
}
else {
print "WARNING: $sub has sub_class $sub_class of ($class) but could not resolve option completion spec for it.\n".
"Setting $sub to non-delegating command, investigate to correct tab completion.\n";
push @completion_spec, $sub => undef;
}
}
push @completion_spec, "help!" => undef;
}
else {
my $params_hash;
@completion_spec = $class->_shell_args_getopt_complete_specification;
no warnings;
unless (grep { /^help\W/ } @completion_spec) {
push @completion_spec, "help!" => undef;
}
}
return \@completion_spec
}
sub resolve_class_and_params_for_argv {
# This is used by execute_with_shell_params_and_exit, but might be used within an application.
my $self = shift;
my @argv = @_;
if ($self->is_sub_command_delegator) {
if ( $argv[0] and $argv[0] !~ /^\-/
and my $class_for_sub_command = $self->class_for_sub_command($argv[0]) ) {
# delegate
shift @argv;
return $class_for_sub_command->resolve_class_and_params_for_argv(@argv);
}
if (@argv) {
# this has sub-commands, and is also executable
# fall through to the execution_logic...
}
else {
#$self->error_message(
# 'Bad command "' . $sub_command . '"'
# , "\ncommands:"
# , $self->help_sub_commands
#);
return ($self,undef);
}
}
my ($params_hash,@spec) = $self->_shell_args_getopt_specification;
unless (grep { /^help\W/ } @spec) {
push @spec, "help!";
}
# Thes nasty GetOptions modules insist on working on
# the real @ARGV, while we like a little more flexibility.
# Not a problem in Perl. :) (which is probably why it was never fixed)
local @ARGV;
@ARGV = @argv;
do {
# GetOptions also likes to emit warnings instead of return a list of errors :(
my @errors;
local $SIG{__WARN__} = sub { push @errors, @_ };
## Change the pattern to be '--', '-' followed by a non-digit, or '+'.
## This s the effect of treating a negative number as a value of an option.
## This means that we won't be allowed to have an option named, say, -1.
## But since command modules' properties have to be allowable function names,
## and "1" is not a valid function name, it's not really a problem
#Getopt::Long::Configure('prefix_pattern=--|-(?!\D)|\+');
unless (GetOptions($params_hash,@spec)) {
Carp::croak( join("\n", @errors) );
}
};
# Q: Is there a standard getopt spec for capturing non-option paramters?
# Perhaps that's not getting "options" :)
# A: Yes. Use '<>'. But we need to process this anyway, so it won't help us.
if (my @names = $self->_bare_shell_argument_names) {
for (my $n=0; $n < @ARGV; $n++) {
my $name = $names[$n];
unless ($name) {
$self->error_message("Unexpected bare arguments: @ARGV[$n..$#ARGV]!");
return($self, undef);
}
my $value = $ARGV[$n];
my $meta = $self->__meta__->property_meta_for_name($name);
if ($meta->is_many) {
if ($n == $#names) {
# slurp the rest
$params_hash->{$name} = [@ARGV[$n..$#ARGV]];
last;
}
else {
die "has-many property $name is not last in bare_shell_argument_names for $self?!";
}
}
else {
$params_hash->{$name} = $value;
}
}
} elsif (@ARGV) {
## argv but no names
$self->error_message("Unexpected bare arguments: @ARGV!");
return($self, undef);
}
for my $key (keys %$params_hash) {
# handle any has-many comma-sep values
my $value = $params_hash->{$key};
if (ref($value)) {
my @new_value;
for my $v (@$value) {
my @parts = split(/,\s*/,$v);
push @new_value, @parts;
}
@$value = @new_value;
} elsif ($value eq q('') or $value eq q("")) {
# Handle the special values '' and "" to mean undef/NULL
$params_hash->{$key} = '';
}
# turn dashes into underscores
my $new_key = $key;
next unless ($new_key =~ tr/-/_/);
if (exists $params_hash->{$new_key} && exists $params_hash->{$key}) {
# this corrects a problem where is_many properties badly interact
# with bare args leaving two entries in the hash like:
# a-bare-opt => [], a_bare_opt => ['with','vals']
delete $params_hash->{$key};
next;
}
$params_hash->{$new_key} = delete $params_hash->{$key};
}
$_resolved_params_from_get_options = $params_hash;
return $self, $params_hash;
}
#
# Methods which let the command auto-document itself.
#
sub help_usage_complete_text {
my $self = shift;
my $command_name = $self->command_name;
my $text;
if (not $self->is_executable) {
# no execute implemented
if ($self->is_sub_command_delegator) {
# show the list of sub-commands
$text = sprintf(
"Sub-commands for %s:\n%s",
Term::ANSIColor::colored($command_name, 'bold'),
$self->help_sub_commands,
);
}
else {
# developer error
my (@sub_command_dirs) = $self->sub_command_dirs;
if (grep { -d $_ } @sub_command_dirs) {
$text .= "No execute() implemented in $self, and no sub-commands found!"
}
else {
$text .= "No execute() implemented in $self, and no directory of sub-commands found!"
}
}
}
else {
# standard: update this to do the old --help format
my $synopsis = $self->help_synopsis;
my $required_args = $self->help_options(is_optional => 0);
my $optional_args = $self->help_options(is_optional => 1);
my $sub_commands = $self->help_sub_commands(brief => 1) if $self->is_sub_command_delegator;
$text = sprintf(
"\n%s\n%s\n\n%s%s%s%s%s\n",
Term::ANSIColor::colored('USAGE', 'underline'),
Text::Wrap::wrap(
' ',
' ',
Term::ANSIColor::colored($self->command_name, 'bold'),
$self->_shell_args_usage_string || '',
),
( $synopsis
? sprintf("%s\n%s\n", Term::ANSIColor::colored("SYNOPSIS", 'underline'), $synopsis)
: ''
),
( $required_args
? sprintf("%s\n%s\n", Term::ANSIColor::colored("REQUIRED ARGUMENTS", 'underline'), $required_args)
: ''
),
( $optional_args
? sprintf("%s\n%s\n", Term::ANSIColor::colored("OPTIONAL ARGUMENTS", 'underline'), $optional_args)
: ''
),
sprintf(
"%s\n%s\n",
Term::ANSIColor::colored("DESCRIPTION", 'underline'),
Text::Wrap::wrap(' ', ' ', $self->help_detail || '')
),
( $sub_commands
? sprintf("%s\n%s\n", Term::ANSIColor::colored("SUB-COMMANDS", 'underline'), $sub_commands)
: ''
),
);
}
return $text;
}
sub doc_sections {
my $self = shift;
my @sections;
my $command_name = $self->command_name;
my $version = do { no strict; ${ $self->class . '::VERSION' } };
my $help_brief = $self->help_brief;
my $datetime = $self->__context__->now;
my $sub_commands = $self->help_sub_commands(brief => 1) if $self->is_sub_command_delegator;
my ($date,$time) = split(' ',$datetime);
push(@sections, UR::Doc::Section->create(
title => "NAME",
content => "$command_name" . ($help_brief ? " - $help_brief" : ""),
format => "pod",
));
push(@sections, UR::Doc::Section->create(
title => "VERSION",
content => "This document " # separated to trick the version updater
. "describes $command_name "
. ($version ? "version $version " : "")
. "($date at $time)",
format => "pod",
));
if ($sub_commands) {
push(@sections, UR::Doc::Section->create(
title => "SUB-COMMANDS",
content => $sub_commands,
format => 'pod',
));
} else {
my $synopsis = $self->command_name . ' ' . $self->_shell_args_usage_string . "\n\n" . $self->help_synopsis;
if ($synopsis) {
push(@sections, UR::Doc::Section->create(
title => "SYNOPSIS",
content => $synopsis,
format => 'pod'
));
}
my $required_args = $self->help_options(is_optional => 0, format => "pod");
if ($required_args) {
push(@sections, UR::Doc::Section->create(
title => "REQUIRED ARGUMENTS",
content => "=over\n\n$required_args\n\n=back\n\n",
format => 'pod'
));
}
my $optional_args = $self->help_options(is_optional => 1, format => "pod");
if ($optional_args) {
push(@sections, UR::Doc::Section->create(
title => "OPTIONAL ARGUMENTS",
content => "=over\n\n$optional_args\n\n=back\n\n",
format => 'pod'
));
}
push(@sections, UR::Doc::Section->create(
title => "DESCRIPTION",
content => join('', map { " $_\n" } split ("\n",$self->help_detail)),
format => 'pod',
));
}
return @sections;
}
sub help_usage_command_pod {
my $self = shift;
my $command_name = $self->command_name;
my $pod;
if (0) { # (not $self->is_executable)
# no execute implemented
if ($self->is_sub_command_delegator) {
# show the list of sub-commands
$pod = "Commands:\n" . $self->help_sub_commands;
}
else {
# developer error
my (@sub_command_dirs) = $self->sub_command_dirs;
if (grep { -d $_ } @sub_command_dirs) {
$pod .= "No execute() implemented in $self, and no sub-commands found!"
}
else {
$pod .= "No execute() implemented in $self, and no directory of sub-commands found!"
}
}
}
else {
# standard: update this to do the old --help format
my $synopsis = $self->command_name . ' ' . $self->_shell_args_usage_string . "\n\n" . $self->help_synopsis;
my $required_args = $self->help_options(is_optional => 0, format => "pod");
my $optional_args = $self->help_options(is_optional => 1, format => "pod");
my $sub_commands = $self->help_sub_commands(brief => 1) if $self->is_sub_command_delegator;
my $help_brief = $self->help_brief;
my $version = do { no strict; ${ $self->class . '::VERSION' } };
$pod =
"\n=pod"
. "\n\n=head1 NAME"
. "\n\n"
. $self->command_name
. ($help_brief ? " - " . $self->help_brief : '')
. "\n\n";
if ($version) {
$pod .=
"\n\n=head1 VERSION"
. "\n\n"
. "This document " # separated to trick the version updater
. "describes " . $self->command_name . " version " . $version . '.'
. "\n\n";
}
if ($sub_commands) {
$pod .=
(
$sub_commands
? "=head1 SUB-COMMANDS\n\n" . $sub_commands . "\n\n"
: ''
)
}
else {
$pod .=
(
$synopsis
? "=head1 SYNOPSIS\n\n" . $synopsis . "\n\n"
: ''
)
. (
$required_args
? "=head1 REQUIRED ARGUMENTS\n\n=over\n\n" . $required_args . "\n\n=back\n\n"
: ''
)
. (
$optional_args
? "=head1 OPTIONAL ARGUMENTS\n\n=over\n\n" . $optional_args . "\n\n=back\n\n"
: ''
)
. "=head1 DESCRIPTION:\n\n"
. join('', map { " $_\n" } split ("\n",$self->help_detail))
. "\n";
}
$pod .= "\n\n=cut\n\n";
}
return "\n$pod";
}
sub help_header {
my $class = shift;
return sprintf("%s - %-80s\n",
$class->command_name
,$class->help_brief
)
}
sub help_options {
my $self = shift;
my %params = @_;
my $format = delete $params{format};
my @property_meta = $self->_shell_args_property_meta(%params);
my @data;
my $max_name_length = 0;
for my $property_meta (@property_meta) {
my $param_name = $self->_shell_arg_name_from_property_meta($property_meta);
if ($property_meta->{shell_args_position}) {
$param_name = uc($param_name);
}
#$param_name = "--$param_name";
my $doc = $property_meta->doc;
my $valid_values = $property_meta->valid_values;
my $example_values = $property_meta->example_values;
unless ($doc) {
# Maybe a parent class has documentation for this property
eval {
foreach my $ancestor_class_meta ( $property_meta->class_meta->ancestry_class_metas ) {
my $ancestor_property_meta = $ancestor_class_meta->property_meta_for_name($property_meta->property_name);
if ($ancestor_property_meta and $doc = $ancestor_property_meta->doc) {
last;
}
}
};
}
if (!$doc) {
if (!$valid_values) {
$doc = "(undocumented)";
}
else {
$doc = '';
}
}
if ($valid_values) {
$doc .= "\nvalid values:\n";
for my $v (@$valid_values) {
$doc .= " " . $v . "\n";
$max_name_length = length($v)+2 if $max_name_length < length($v)+2;
}
chomp $doc;
}
if ($example_values && @$example_values) {
$doc .= "\nexample" . (@$example_values > 1 and 's') . ":\n";
$doc .= join(', ',
map { ref($_) ? Data::Dumper->new([$_])->Terse(1)->Dump() : $_ } @$example_values
);
chomp($doc);
}
$max_name_length = length($param_name) if $max_name_length < length($param_name);
my $param_type = $property_meta->data_type || '';
if (defined($param_type) and $param_type !~ m/::/) {
$param_type = ucfirst(lc($param_type));
}
my $default_value;
if (defined($default_value = $property_meta->default_value)
|| defined(my $calculated_default = $property_meta->calculated_default)
) {
unless (defined $default_value) {
$default_value = $calculated_default->()
}
if ($param_type eq 'Boolean') {
$default_value = $default_value ? "'true'" : "'false' (--no$param_name)";
} elsif ($property_meta->is_many && ref($default_value) eq 'ARRAY') {
if (@$default_value) {
$default_value = "('" . join("','",@$default_value) . "')";
} else {
$default_value = "()";
}
} else {
$default_value = "'$default_value'";
}
$default_value = "\nDefault value $default_value if not specified";
}
push @data, [$param_name, $param_type, $doc, $default_value];
if ($param_type eq 'Boolean') {
push @data, ['no'.$param_name, $param_type, "Make $param_name 'false'" ];
}
}
my $text = '';
for my $row (@data) {
if (defined($format) and $format eq 'pod') {
$text .= "\n=item " . $row->[0] . ($row->[1]? ' I<' . $row->[1] . '>' : '') . "\n\n" . $row->[2] . "\n". ($row->[3]? $row->[3] . "\n" : '');
}
elsif (defined($format) and $format eq 'html') {
$text .= "\n\t
" . $row->[0] . ($row->[1]? ' ' . $row->[1] . '' : '') . "
" . $row->[2] . ($row->[3]? "
" . $row->[3] : '') . "
\n";
}
else {
$text .= sprintf(
" %s\n%s\n",
Term::ANSIColor::colored($row->[0], 'bold') . " " . $row->[1],
Text::Wrap::wrap(
" ", # 1st line indent,
" ", # all other lines indent,
$row->[2],
$row->[3] || '',
),
);
}
}
return $text;
}
sub sorted_sub_command_classes {
no warnings;
my @c = shift->sub_command_classes;
my @commands_with_position = map { [ $_->sub_command_sort_position, $_ ] } @c;
my @sorted = sort { $a->[0] <=> $b->[0]
||
$a->[0] cmp $b->[0]
}
@commands_with_position;
return map { $_->[1] } @sorted;
}
sub sorted_sub_command_names {
my $class = shift;
my @sub_command_classes = $class->sorted_sub_command_classes;
my @sub_command_names = map { $_->command_name_brief } @sub_command_classes;
return @sub_command_names;
}
sub sub_commands_table {
my $class = shift;
my @sub_command_names = $class->sorted_sub_command_names;
my $max_length = 0;
for (@sub_command_names) {
$max_length = length($_) if ($max_length < length($_));
}
$max_length ||= 79;
my $col_spacer = '_'x$max_length;
my $n_cols = floor(80/$max_length);
my $n_rows = ceil(@sub_command_names/$n_cols);
my @tb_rows;
for (my $i = 0; $i < @sub_command_names; $i += $n_cols) {
my $end = $i + $n_cols - 1;
$end = $#sub_command_names if ($end > $#sub_command_names);
push @tb_rows, [@sub_command_names[$i..$end]];
}
my @col_alignment;
for (my $i = 0; $i < $n_cols; $i++) {
push @col_alignment, { sample => "&$col_spacer" };
}
my $tb = Text::Table->new(@col_alignment);
$tb->load(@tb_rows);
return $tb;
}
sub help_sub_commands {
my $class = shift;
my %params = @_;
my $command_name_method = 'command_name_brief';
#my $command_name_method = ($params{brief} ? 'command_name_brief' : 'command_name');
my @sub_command_classes = $class->sorted_sub_command_classes;
my %categories;
my @categories;
for my $sub_command_class (@sub_command_classes) {
my $category = $sub_command_class->sub_command_category;
$category = '' if not defined $category;
next if $sub_command_class->_is_hidden_in_docs();
my $sub_commands_within_category = $categories{$category};
unless ($sub_commands_within_category) {
if (defined $category and length $category) {
push @categories, $category;
}
else {
unshift @categories,'';
}
$sub_commands_within_category = $categories{$category} = [];
}
push @$sub_commands_within_category,$sub_command_class;
}
no warnings;
local $Text::Wrap::columns = 60;
my $full_text = '';
my @full_data;
for my $category (@categories) {
my $sub_commands_within_this_category = $categories{$category};
my @data = map {
my @rows = split("\n",Text::Wrap::wrap('', ' ', $_->help_brief));
chomp @rows;
(
[
$_->$command_name_method,
$_->_shell_args_usage_string_abbreviated,
$rows[0],
],
map {
[
'',
' ',
$rows[$_],
]
} (1..$#rows)
);
}
@$sub_commands_within_this_category;
if ($category) {
# add a space between categories
push @full_data, ['','',''] if @full_data;
if ($category =~ /\D/) {
# non-numeric categories show their category as a header
$category .= ':' if $category =~ /\S/;
push @full_data,
[
Term::ANSIColor::colored(uc($category), 'blue'),
'',
''
];
}
else {
# numeric categories just sort
}
}
push @full_data, @data;
}
my @max_width_found = (0,0,0);
for (@full_data) {
for my $c (0..2) {
$max_width_found[$c] = length($_->[$c]) if $max_width_found[$c] < length($_->[$c]);
}
}
my @colors = (qw/ red bold /);
my $text = '';
for my $row (@full_data) {
for my $c (0..2) {
$text .= ' ';
$text .= Term::ANSIColor::colored($row->[$c], $colors[$c]),
$text .= ' ';
$text .= ' ' x ($max_width_found[$c]-length($row->[$c]));
}
$text .= "\n";
}
return $text;
}
sub _is_hidden_in_docs { return; }
#
# Methods which transform command properties into shell args (getopt)
#
sub _shell_args_property_meta {
my $self = shift;
my $class_meta = $self->__meta__;
# Find which property metas match the rules. We have to do it this way
# because just calling 'get_all_property_metas()' will product multiple matches
# if a property is overridden in a child class
my $rule = UR::Object::Property->define_boolexpr(@_);
my %seen;
my (@positional,@required,@optional);
foreach my $property_meta ( $class_meta->get_all_property_metas() ) {
my $property_name = $property_meta->property_name;
next if $seen{$property_name}++;
next unless $rule->evaluate($property_meta);
next if $property_name eq 'id';
next if $property_name eq 'result';
next if $property_name eq 'is_executed';
next if $property_name eq 'original_command_line';
next if $property_name =~ /^_/;
next if defined($property_meta->data_type) and $property_meta->data_type =~ /::/;
next if not $property_meta->is_mutable;
next if $property_meta->is_delegated;
next if $property_meta->is_calculated;
# next if $property_meta->{is_output}; # TODO: This was breaking the G::M::T::Annotate::TranscriptVariants annotator. This should probably still be here but temporarily roll back
next if $property_meta->is_transient;
next if $property_meta->is_constant;
if ($property_meta->{shell_args_position}) {
push @positional, $property_meta;
}
elsif ($property_meta->is_optional) {
push @optional, $property_meta;
}
else {
push @required, $property_meta;
}
}
my @result;
@required = map { [ $_->property_name, $_ ] } @required;
@optional = map { [ $_->property_name, $_ ] } @optional;
@positional = map { [ $_->{shell_args_position}, $_ ] } @positional;
@result = (
(sort { $a->[0] cmp $b->[0] } @required),
(sort { $a->[0] cmp $b->[0] } @optional),
(sort { $a->[0] <=> $b->[0] } @positional),
);
return map { $_->[1] } @result;
}
sub _shell_arg_name_from_property_meta {
my ($self, $property_meta,$singularize) = @_;
my $property_name = ($singularize ? $property_meta->singular_name : $property_meta->property_name);
my $param_name = $property_name;
$param_name =~ s/_/-/g;
return $param_name;
}
sub _shell_arg_getopt_qualifier_from_property_meta {
my ($self, $property_meta) = @_;
my $many = ($property_meta->is_many ? '@' : '');
if (defined($property_meta->data_type) and $property_meta->data_type =~ /Boolean/) {
return '!' . $many;
}
#elsif ($property_meta->is_optional) {
# return ':s' . $many;
#}
else {
return '=s' . $many;
}
}
sub _shell_arg_usage_string_from_property_meta {
my ($self, $property_meta) = @_;
my $string = $self->_shell_arg_name_from_property_meta($property_meta);
if ($property_meta->{shell_args_position}) {
$string = uc($string);
}
if ($property_meta->{shell_args_position}) {
if ($property_meta->is_optional) {
$string = "[$string]";
}
}
else {
$string = "--$string";
if (defined($property_meta->data_type) and $property_meta->data_type =~ /Boolean/) {
$string = "[$string]";
}
else {
if ($property_meta->is_many) {
$string .= "=?[,?]";
}
else {
$string .= '=?';
}
if ($property_meta->is_optional) {
$string = "[$string]";
}
}
}
return $string;
}
sub _shell_arg_getopt_specification_from_property_meta {
my ($self,$property_meta) = @_;
my $arg_name = $self->_shell_arg_name_from_property_meta($property_meta);
return (
$arg_name . $self->_shell_arg_getopt_qualifier_from_property_meta($property_meta),
($property_meta->is_many ? ($arg_name => []) : ())
);
}
sub _shell_arg_getopt_complete_specification_from_property_meta {
my ($self,$property_meta) = @_;
my $arg_name = $self->_shell_arg_name_from_property_meta($property_meta);
my $completions = $property_meta->valid_values;
if ($completions) {
if (ref($completions) eq 'ARRAY') {
$completions = [ @$completions ];
}
}
else {
my $type = $property_meta->data_type;
my @complete_as_files = (
'File','FilePath','Filesystem','FileSystem','FilesystemPath','FileSystemPath',
'Text','String',
);
my @complete_as_directories = (
'Directory','DirectoryPath','Dir','DirPath',
);
if (!defined($type)) {
$completions = 'files';
}
else {
for my $pattern (@complete_as_files) {
if (!$type || $type eq $pattern) {
$completions = 'files';
last;
}
}
for my $pattern (@complete_as_directories) {
if ( $type && $type eq $pattern) {
$completions = 'directories';
last;
}
}
}
}
return (
$arg_name . $self->_shell_arg_getopt_qualifier_from_property_meta($property_meta),
$completions,
# ($property_meta->is_many ? ($arg_name => []) : ())
);
}
sub _shell_args_getopt_specification {
my $self = shift;
my @getopt;
my @params;
for my $meta ($self->_shell_args_property_meta) {
my ($spec, @params_addition) = $self->_shell_arg_getopt_specification_from_property_meta($meta);
push @getopt,$spec;
push @params, @params_addition;
}
@getopt = sort @getopt;
return { @params}, @getopt;
}
sub _shell_args_getopt_complete_specification {
my $self = shift;
my @getopt;
for my $meta ($self->_shell_args_property_meta) {
my ($spec, $completions) = $self->_shell_arg_getopt_complete_specification_from_property_meta($meta);
push @getopt, $spec, $completions;
}
return @getopt;
}
sub _shell_args_usage_string {
my $self = shift;
if ($self->is_executable) {
return join(
" ",
map {
$self->_shell_arg_usage_string_from_property_meta($_)
} $self->_shell_args_property_meta()
);
}
elsif ($self->is_sub_command_delegator) {
my @names = $self->sub_command_names;
return "[" . join("|",@names) . "] ..."
}
else {
return "(no execute or sub commands implemented)"
}
return "";
}
sub _shell_args_usage_string_abbreviated {
my $self = shift;
if ($self->is_sub_command_delegator) {
return "...";
}
else {
my $detailed = $self->_shell_args_usage_string;
if (length($detailed) <= 20) {
return $detailed;
}
else {
return substr($detailed,0,17) . '...';
}
}
}
#
# The following methods build allow a command to determine its
# sub-commands, if there are any.
#
# This is for cases in which the Foo::Bar command delegates to
# Foo::Bar::Baz, Foo::Bar::Buz or Foo::Bar::Doh, depending on its paramters.
sub sub_command_dirs {
my $class = shift;
my $module = ref($class) || $class;
$module =~ s/::/\//g;
# multiple dirs is not working quite yet
#my @paths = grep { -d $_ } map { "$_/$module" } @INC;
#return @paths;
$module .= '.pm';
my $path = $INC{$module};
unless ($path) {
return;
}
$path =~ s/.pm$//;
unless (-d $path) {
return;
}
return $path;
}
sub sub_command_classes {
my $class = shift;
my @paths = $class->sub_command_dirs;
return unless @paths;
@paths =
grep { s/\.pm$// }
map { glob("$_/*") }
grep { -d $_ }
grep { defined($_) and length($_) }
@paths;
return unless @paths;
my @classes =
grep {
($_->is_sub_command_delegator or !$_->__meta__->is_abstract)
}
grep { $_ and $_->isa('Command') }
map { $class->class_for_sub_command($_) }
map { s/_/-/g; $_ }
map { basename($_) }
@paths;
return @classes;
}
sub sub_command_names {
my $class = shift;
my @sub_command_classes = $class->sub_command_classes;
my @sub_command_names = map { $_->command_name_brief } @sub_command_classes;
return @sub_command_names;
}
sub class_for_sub_command {
my $self = shift;
my $class = ref($self) || $self;
my $sub_command = shift;
return if $sub_command =~ /^\-/;
my $sub_class = join("", map { ucfirst($_) } split(/-/, $sub_command));
$sub_class = $class . "::" . $sub_class;
my $meta = UR::Object::Type->get($sub_class); # allow in memory classes
unless ( $meta ) {
eval "use $sub_class;";
if ($@) {
if ($@ =~ /^Can't locate .*\.pm in \@INC/) {
#die "Failed to find $sub_class! $class_for_sub_command.pm!\n$@";
return;
}
else {
my @msg = split("\n",$@);
pop @msg;
pop @msg;
$self->error_message("$sub_class failed to compile!:\n@msg\n\n");
return;
}
}
}
elsif (my $isa = $sub_class->isa("Command")) {
if (ref($isa)) {
# dumb modules (Test::Class) mess with the standard isa() API
if ($sub_class->SUPER::isa("Command")) {
return $sub_class;
}
else {
return;
}
}
return $sub_class;
}
else {
return;
}
}
# Run the given command-line with stdout and stderr redirected to /dev/null
sub system_inhibit_std_out_err {
my($self,$cmdline) = @_;
open my $oldout, ">&STDOUT" or die "Can't dup STDOUT: $!";
open my $olderr, ">&", \*STDERR or die "Can't dup STDERR: $!";
open(STDOUT,'>/dev/null');
open(STDERR,'>/dev/null');
my $ec = system ( $cmdline );
open STDOUT, ">&", $oldout or die "Can't dup \$oldout: $!";
open STDERR, ">&", $olderr or die "Can't dup \$olderr: $!";
return $ec;
}
sub parent_command_class {
my $class = shift;
$class = ref($class) if ref($class);
my @components = split("::", $class);
return if @components == 1;
my $parent = join("::", @components[0..$#components-1]);
return $parent if $parent->can("command_name");
return;
}
1;
__END__
=pod
=head1 NAME
Command - base class for modules implementing the command pattern
=head1 SYNOPSIS
use TopLevelNamespace;
class TopLevelNamespace::SomeObj::Command {
is => 'Command',
has => [
someobj => { is => 'TopLevelNamespace::SomeObj', id_by => 'some_obj_id' },
verbose => { is => 'Boolean', is_optional => 1 },
],
};
sub execute {
my $self = shift;
if ($self->verbose) {
print "Working on id ",$self->some_obj_id,"\n";
}
my $result = $someobj->do_something();
if ($self->verbose) {
print "Result was $result\n";
}
return $result;
}
sub help_brief {
return 'Call do_something on a SomeObj instance';
}
sub help_synopsis {
return 'cmd --some_obj_id 123 --verbose';
}
sub help_detail {
return 'This command performs a FooBarBaz transform on a SomObj object instance by calling its do_something method.';
}
# Another part of the code
my $cmd = TopLevelNamespace::SomeObj::Command->create(some_obj_id => $some_obj->id);
$cmd->execute();
=head1 DESCRIPTION
The Command module is a base class for creating other command modules
implementing the Command Pattern. These modules can be easily reused in
applications or loaded and executed dynamicaly in a command-line program.
Each Command subclass represents a reusable work unit. The bulk of the
module's code will likely be in the execute() method. execute() will
usually take only a single argument, an instance of the Command subclass.
=head1 Command-line use
Creating a top-level Command module called, say TopLevelNamespace::Command,
and a script called tln_cmd that looks like:
#!/usr/bin/perl
use TopLevelNamespace;
TopLevelNamespace::Command->execute_with_shell_params_and_exit();
gives you an instant command-line tool as an interface to the hierarchy of
command modules at TopLevelNamespace::Command.
For example:
> tln_cmd foo bar --baz 1 --qux
will create an instance of TopLevelNamespace::Command::Foo::Bar (if that
class exists) with params baz => 1 and qux => 1, assumming qux is a boolean
property, call execute() on it, and translate the return value from execute()
into the appropriate notion of a shell return value, meaning that if
execute() returns true in the Perl sense, then the script returns 0 - true in
the shell sense.
The infrastructure takes care of turning the command line parameters into
parameters for create(). Params designated as is_optional are, of course,
optional and non-optional parameters that are missing will generate an error.
--help is an implicit param applicable to all Command modules. It generates
some hopefully useful text based on the documentation in the class definition
(the 'doc' attributes you can attach to a class and properties), and the
strings returned by help_detail(), help_brief() and help_synopsis().
=head1 TODO
This documentation needs to be fleshed out more. There's a lot of special
things you can do with Command modules that isn't mentioned here yet.
=cut
V2.pm 100664 023532 023421 24674 12544604516 14643 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/Command package Command::V2;
use strict;
use warnings;
use UR;
use Data::Dumper;
use File::Basename;
use Getopt::Long;
use Command::View::DocMethods;
use Command::Dispatch::Shell;
our $VERSION = "0.44"; # UR $VERSION;
our $entry_point_class;
our $entry_point_bin;
UR::Object::Type->define(
class_name => __PACKAGE__,
is => ['Command', 'Command::Common'],
is_abstract => 1,
subclass_description_preprocessor => 'Command::V2::_preprocess_subclass_description',
attributes_have => [
is_param => { is => 'Boolean', is_optional => 1 },
is_input => { is => 'Boolean', is_optional => 1 },
is_output => { is => 'Boolean', is_optional => 1 },
shell_args_position => { is => 'Integer', is_optional => 1,
doc => 'when set, this property is a positional argument when run from a shell' },
completion_handler => { is => 'MethodName', is_optional => 1,
doc => 'to supply auto-completions for this parameter, call this class method' },
require_user_verify => { is => 'Boolean', is_optional => 1,
doc => 'when expanding user supplied values: 0 = never verify, 1 = always verify, undef = determine automatically', },
],
has_optional => [
debug => { is => 'Boolean', doc => 'enable debug messages' },
is_executed => { is => 'Boolean' },
result => { is => 'Scalar', is_output => 1 },
original_command_line => { is => 'String', doc => 'null-byte separated list of command and arguments when run via execute_with_shell_params_and_exit'},
_total_command_count => { is => 'Integer', default => 0, is_transient => 1 },
_command_errors => {
is => 'HASH',
doc => 'Values can be an array ref is multiple errors occur during a command\'s execution',
default => {},
is_transient => 1,
},
],
);
sub _is_hidden_in_docs { return; }
sub _preprocess_subclass_description {
my ($class, $desc) = @_;
while (my ($prop_name, $prop_desc) = each(%{ $desc->{has} })) {
unless (
$prop_desc->{'is_param'}
or $prop_desc->{'is_input'}
or $prop_desc->{'is_transient'}
or $prop_desc->{'is_calculated'},
or $prop_desc->{'is_output'}
) {
$prop_desc->{'is_param'} = 1;
}
}
return $desc;
}
sub _init_subclass {
# Each Command subclass has an automatic wrapper around execute().
# This ensures it can be called as a class or instance method,
# and that proper handling occurs around it.
my $subclass_name = $_[0];
no strict;
no warnings;
if ($subclass_name->can('execute')) {
# NOTE: manipulating %{ $subclass_name . '::' } directly causes ptkdb to segfault perl
my $new_symbol = "${subclass_name}::_execute_body";
my $old_symbol = "${subclass_name}::execute";
*$new_symbol = *$old_symbol;
undef *$old_symbol;
}
else {
#print "no execute in $subclass_name\n";
}
if($subclass_name->can('shortcut')) {
my $new_symbol = "${subclass_name}::_shortcut_body";
my $old_symbol = "${subclass_name}::shortcut";
*$new_symbol = *$old_symbol;
undef *$old_symbol;
}
my @p = $subclass_name->__meta__->properties();
my @e;
for my $p (@p) {
next if $p->property_name eq 'id';
next if $p->class_name eq __PACKAGE__;
next unless $p->class_name->isa('Command');
unless ($p->is_input or $p->is_output or $p->is_param or $p->is_transient or $p->is_calculated) {
my $modname = $subclass_name;
$modname =~ s|::|/|g;
$modname .= '.pm';
push @e, $modname . " property " . $p->property_name . " must be input, output, param, transient, or calculated!";
}
}
if (@e) {
for (@e) {
$subclass_name->error_message($_);
}
die "command classes like $subclass_name have properties without is_input/output/param/transient/calculated set!";
}
return 1;
}
sub __errors__ {
my ($self,@property_names) = @_;
my @errors1 =($self->SUPER::__errors__);
if ($self->is_executed) {
return @errors1;
}
# for Commands which have not yet been executed,
# only consider errors on inputs or params
my $meta = $self->__meta__;
my @errors2;
ERROR:
for my $e (@errors1) {
for my $p ($e->properties) {
my $pm = $meta->property($p);
if ($pm->is_input or $pm->is_param) {
push @errors2, $e;
next ERROR;
}
}
}
return @errors2;
}
# For compatability with Command::V1 callers
sub is_sub_command_delegator {
return;
}
sub _wrapper_has {
my ($class, $new_class_base) = @_;
$new_class_base ||= __PACKAGE__;
my $command_meta = $class->__meta__;
my @properties = $command_meta->properties();
my %has;
for my $property (@properties) {
my %desc;
next unless $property->can("is_param") and $property->can("is_input") and $property->can("is_output");
my $name = $property->property_name;
next if $new_class_base->can($name);
if ($property->is_param) {
$desc{is_param} = 1;
}
elsif ($property->is_input) {
$desc{is_input} = 1;
}
#elsif ($property->can("is_metric") and $property->is_metric) {
# $desc{is_metric} = 1;
#}
#elsif ($property->can("is_output") and $property->is_output) {
# $desc{is_output} = 1;
#}
else {
next;
}
$has{$name} = \%desc;
$desc{is} = $property->data_type;
$desc{doc} = $property->doc;
$desc{is_many} = $property->is_many;
$desc{is_optional} = $property->is_optional;
}
return %has;
}
sub display_command_summary_report {
my $self = shift;
my $total_count = $self->_total_command_count;
my %command_errors = %{$self->_command_errors};
if (keys %command_errors) {
$self->status_message("\n\nErrors Summary:");
for my $key (keys %command_errors) {
my $errors = $command_errors{$key};
$errors = [$errors] unless (ref($errors) and ref($errors) eq 'ARRAY');
my @errors = @{$errors};
print "$key: \n";
for my $error (@errors) {
$error = $self->truncate_error_message($error);
print "\t- $error\n";
}
}
}
if ($total_count > 1) {
my $error_count = scalar(keys %command_errors);
$self->status_message("\n\nCommand Summary:");
$self->status_message(" Successful: " . ($total_count - $error_count));
$self->status_message(" Errors: " . $error_count);
$self->status_message(" Total: " . $total_count);
}
}
sub append_error {
my $self = shift;
my $key = shift || die;
my $error = shift || die;
my $command_errors = $self->_command_errors;
push @{$command_errors->{$key}}, $error;
$self->_command_errors($command_errors);
return 1;
}
sub truncate_error_message {
my $self = shift;
my $error = shift || die;
# truncate errors so they are actually a summary
($error) = split("\n", $error);
# meant to truncate a callstack as this is meant for user/high-level
$error =~ s/\ at\ \/.*//;
return $error;
}
1;
__END__
=pod
=head1 NAME
Command - base class for modules implementing the command pattern
=head1 SYNOPSIS
use TopLevelNamespace;
class TopLevelNamespace::SomeObj::Command {
is => 'Command',
has => [
someobj => { is => 'TopLevelNamespace::SomeObj', id_by => 'some_obj_id' },
verbose => { is => 'Boolean', is_optional => 1 },
],
};
sub execute {
my $self = shift;
if ($self->verbose) {
print "Working on id ",$self->some_obj_id,"\n";
}
my $result = $someobj->do_something();
if ($self->verbose) {
print "Result was $result\n";
}
return $result;
}
sub help_brief {
return 'Call do_something on a SomeObj instance';
}
sub help_synopsis {
return 'cmd --some_obj_id 123 --verbose';
}
sub help_detail {
return 'This command performs a FooBarBaz transform on a SomObj object instance by calling its do_something method.';
}
# Another part of the code
my $cmd = TopLevelNamespace::SomeObj::Command->create(some_obj_id => $some_obj->id);
$cmd->execute();
=head1 DESCRIPTION
The Command module is a base class for creating other command modules
implementing the Command Pattern. These modules can be easily reused in
applications or loaded and executed dynamicaly in a command-line program.
Each Command subclass represents a reusable work unit. The bulk of the
module's code will likely be in the execute() method. execute() will
usually take only a single argument, an instance of the Command subclass.
=head1 Command-line use
Creating a top-level Command module called, say TopLevelNamespace::Command,
and a script called tln_cmd that looks like:
#!/usr/bin/perl
use TopLevelNamespace;
TopLevelNamespace::Command->execute_with_shell_params_and_exit();
gives you an instant command-line tool as an interface to the hierarchy of
command modules at TopLevelNamespace::Command.
For example:
> tln_cmd foo bar --baz 1 --qux
will create an instance of TopLevelNamespace::Command::Foo::Bar (if that
class exists) with params baz => 1 and qux => 1, assumming qux is a boolean
property, call execute() on it, and translate the return value from execute()
into the appropriate notion of a shell return value, meaning that if
execute() returns true in the Perl sense, then the script returns 0 - true in
the shell sense.
The infrastructure takes care of turning the command line parameters into
parameters for create(). Params designated as is_optional are, of course,
optional and non-optional parameters that are missing will generate an error.
--help is an implicit param applicable to all Command modules. It generates
some hopefully useful text based on the documentation in the class definition
(the 'doc' attributes you can attach to a class and properties), and the
strings returned by help_detail(), help_brief() and help_synopsis().
=head1 TODO
This documentation needs to be fleshed out more. There's a lot of special
things you can do with Command modules that isn't mentioned here yet.
=cut
V2Deprecated.pm 100664 023532 023421 17213 12544604516 16613 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/Command package Command::V2; # additional methods to dispatch from a command-line
use strict;
use warnings;
sub sorted_sub_command_classes {
no warnings;
my @c = shift->sub_command_classes;
my @commands_with_position = map { [ $_->sub_command_sort_position, $_ ] } @c;
return map { $_->[1] }
sort { ($a->[0] <=> $b->[0])
||
($a->[0] cmp $b->[0])
}
@commands_with_position;
}
sub sorted_sub_command_names {
my $class = shift;
my @sub_command_classes = $class->sorted_sub_command_classes;
my @sub_command_names = map { $_->command_name_brief } @sub_command_classes;
return @sub_command_names;
}
sub sub_commands_table {
my $class = shift;
my @sub_command_names = $class->sorted_sub_command_names;
my $max_length = 0;
for (@sub_command_names) {
$max_length = length($_) if ($max_length < length($_));
}
$max_length ||= 79;
my $col_spacer = '_'x$max_length;
my $n_cols = floor(80/$max_length);
my $n_rows = ceil(@sub_command_names/$n_cols);
my @tb_rows;
for (my $i = 0; $i < @sub_command_names; $i += $n_cols) {
my $end = $i + $n_cols - 1;
$end = $#sub_command_names if ($end > $#sub_command_names);
push @tb_rows, [@sub_command_names[$i..$end]];
}
my @col_alignment;
for (my $i = 0; $i < $n_cols; $i++) {
push @col_alignment, { sample => "&$col_spacer" };
}
my $tb = Text::Table->new(@col_alignment);
$tb->load(@tb_rows);
return $tb;
}
sub help_sub_commands {
my $class = shift;
my %params = @_;
my $command_name_method = 'command_name_brief';
#my $command_name_method = ($params{brief} ? 'command_name_brief' : 'command_name');
my @sub_command_classes = $class->sorted_sub_command_classes;
my %categories;
my @categories;
for my $sub_command_class (@sub_command_classes) {
my $category = $sub_command_class->sub_command_category;
$category = '' if not defined $category;
next if $sub_command_class->_is_hidden_in_docs();
my $sub_commands_within_category = $categories{$category};
unless ($sub_commands_within_category) {
if (defined $category and length $category) {
push @categories, $category;
}
else {
unshift @categories,'';
}
$sub_commands_within_category = $categories{$category} = [];
}
push @$sub_commands_within_category,$sub_command_class;
}
no warnings;
local $Text::Wrap::columns = 60;
my $full_text = '';
my @full_data;
for my $category (@categories) {
my $sub_commands_within_this_category = $categories{$category};
my @data = map {
my @rows = split("\n",Text::Wrap::wrap('', ' ', $_->help_brief));
chomp @rows;
(
[
$_->$command_name_method,
$_->_shell_args_usage_string_abbreviated,
$rows[0],
],
map {
[
'',
' ',
$rows[$_],
]
} (1..$#rows)
);
}
@$sub_commands_within_this_category;
if ($category) {
# add a space between categories
push @full_data, ['','',''] if @full_data;
if ($category =~ /\D/) {
# non-numeric categories show their category as a header
$category .= ':' if $category =~ /\S/;
push @full_data,
[
Term::ANSIColor::colored(uc($category), 'blue'),
'',
''
];
}
else {
# numeric categories just sort
}
}
push @full_data, @data;
}
my @max_width_found = (0,0,0);
for (@full_data) {
for my $c (0..2) {
$max_width_found[$c] = length($_->[$c]) if $max_width_found[$c] < length($_->[$c]);
}
}
my @colors = (qw/ red bold /);
my $text = '';
for my $row (@full_data) {
for my $c (0..2) {
$text .= ' ';
$text .= Term::ANSIColor::colored($row->[$c], $colors[$c]),
$text .= ' ';
$text .= ' ' x ($max_width_found[$c]-length($row->[$c]));
}
$text .= "\n";
}
#$DB::single = 1;
return $text;
}
sub sub_command_dirs {
my $class = shift;
my $subdir = ref($class) || $class;
$subdir =~ s|::|\/|g;
my @dirs = grep { -d $_ } map { $_ . '/' . $subdir } @INC;
return @dirs;
}
sub sub_command_classes {
my $class = shift;
my $mapping = $class->_build_sub_command_mapping;
return values %$mapping;
}
sub _build_sub_command_mapping {
my $class = shift;
$class = ref($class) || $class;
my $mapping;
do {
no strict 'refs';
$mapping = ${ $class . '::SUB_COMMAND_MAPPING'};
};
unless (defined $mapping) {
my $subdir = $class;
$subdir =~ s|::|\/|g;
for my $lib (@INC) {
my $subdir_full_path = $lib . '/' . $subdir;
next unless -d $subdir_full_path;
my @files = glob($subdir_full_path . '/*');
next unless @files;
for my $file (@files) {
my $basename = basename($file);
$basename =~ s/.pm$//;
my $sub_command_class_name = $class . '::' . $basename;
my $sub_command_class_meta = UR::Object::Type->get($sub_command_class_name);
unless ($sub_command_class_meta) {
local $SIG{__DIE__};
local $SIG{__WARN__};
eval "use $sub_command_class_name";
}
$sub_command_class_meta = UR::Object::Type->get($sub_command_class_name);
next unless $sub_command_class_name->isa("Command");
next if $sub_command_class_meta->is_abstract;
my $name = $class->_command_name_for_class_word($basename);
$mapping->{$name} = $sub_command_class_name;
}
}
}
return $mapping;
}
sub sub_command_names {
my $class = shift;
my $mapping = $class->_build_sub_command_mapping;
return keys %$mapping;
}
sub class_for_sub_command
{
my $self = shift;
my $class = ref($self) || $self;
my $sub_command = shift;
return if $sub_command =~ /^\-/;
my $sub_class = join("", map { ucfirst($_) } split(/-/, $sub_command));
$sub_class = $class . "::" . $sub_class;
my $meta = UR::Object::Type->get($sub_class); # allow in memory classes
unless ( $meta ) {
eval "use $sub_class;";
if ($@) {
if ($@ =~ /^Can't locate .*\.pm in \@INC/) {
#die "Failed to find $sub_class! $class_for_sub_command.pm!\n$@";
return;
}
else {
my @msg = split("\n",$@);
pop @msg;
pop @msg;
$self->error_message("$sub_class failed to compile!:\n@msg\n\n");
return;
}
}
}
elsif (my $isa = $sub_class->isa("Command")) {
if (ref($isa)) {
# dumb modules (Test::Class) mess with the standard isa() API
if ($sub_class->SUPER::isa("Command")) {
return $sub_class;
}
else {
return;
}
}
return $sub_class;
}
else {
return;
}
}
1;
1;
DocMethods.pm 100664 023532 023421 46273 12544604516 17316 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/Command/View package Command::V2; # additional methods to produce documentation, TODO: turn into a real view
use strict;
use warnings;
use Term::ANSIColor qw();
use Pod::Simple::Text;
require Text::Wrap;
# This is changed with "local" where used in some places
$Text::Wrap::columns = 100;
# Required for color output
eval {
binmode STDOUT, ":utf8";
binmode STDERR, ":utf8";
};
sub help_brief {
my $self = shift;
if (my $doc = $self->__meta__->doc) {
return $doc;
}
else {
my @parents = $self->__meta__->ancestry_class_metas;
for my $parent (@parents) {
if (my $doc = $parent->doc) {
return $doc;
}
}
return "no description!!!: define 'doc' in the class definition for "
. $self->class;
}
}
sub help_synopsis {
my $self = shift;
return '';
}
sub help_detail {
my $self = shift;
return "!!! define help_detail() in module " . ref($self) || $self . "!";
}
sub sub_command_category {
return;
}
sub sub_command_sort_position {
# override to do something besides alpha sorting by name
return '9999999999 ' . $_[0]->command_name_brief;
}
# LEGACY: poorly named
sub help_usage_command_pod {
return shift->doc_manual(@_);
}
# LEGACY: poorly named
sub help_usage_complete_text {
shift->doc_help(@_)
}
sub doc_help {
my $self = shift;
my $command_name = $self->command_name;
my $text;
my $extra_help = '';
my @extra_help = $self->_additional_help_sections;
while (@extra_help) {
my $title = shift @extra_help || '';
my $content = shift @extra_help || '';
$extra_help .= sprintf(
"%s\n\n%s\n",
Term::ANSIColor::colored($title, 'underline'),
_pod2txt($content)
),
}
# standard: update this to do the old --help format
my $synopsis = $self->help_synopsis;
my $required_inputs = $self->help_options(is_optional => 0, is_input => 1);
my $required_outputs = $self->help_options(is_optional => 0, is_output => 1);
my $required_params = $self->help_options(is_optional => 0, is_param => 1);
my $optional_inputs = $self->help_options(is_optional => 1, is_input => 1);
my $optional_outputs = $self->help_options(is_optional => 1, is_output => 1);
my $optional_params = $self->help_options(is_optional => 1, is_param => 1);
my @parts;
push @parts, Term::ANSIColor::colored('USAGE', 'underline');
push @parts,
Text::Wrap::wrap(
' ',
' ',
Term::ANSIColor::colored($self->command_name, 'bold'),
$self->_shell_args_usage_string || '',
);
push @parts,
( $synopsis
? sprintf("%s\n%s\n", Term::ANSIColor::colored("SYNOPSIS", 'underline'), $synopsis)
: ''
);
push @parts,
( $required_inputs
? sprintf("%s\n%s\n", Term::ANSIColor::colored("REQUIRED INPUTS", 'underline'), $required_inputs)
: ''
);
push @parts,
( $required_params
? sprintf("%s\n%s\n", Term::ANSIColor::colored("REQUIRED PARAMS", 'underline'), $required_params)
: ''
);
push @parts,
( $optional_inputs
? sprintf("%s\n%s\n", Term::ANSIColor::colored("OPTIONAL INPUTS", 'underline'), $optional_inputs)
: ''
);
push @parts,
( $optional_params
? sprintf("%s\n%s\n", Term::ANSIColor::colored("OPTIONAL PARAMS", 'underline'), $optional_params)
: ''
);
push @parts,
( $required_outputs
? sprintf("%s\n%s\n", Term::ANSIColor::colored("REQUIRED OUTPUTS", 'underline'), $required_outputs)
: ''
);
push @parts,
( $optional_outputs
? sprintf("%s\n%s\n", Term::ANSIColor::colored("OPTIONAL OUTPUTS", 'underline'), $optional_outputs)
: ''
);
push @parts,
sprintf(
"%s\n%s\n",
Term::ANSIColor::colored("DESCRIPTION", 'underline'),
_pod2txt($self->help_detail || '')
);
push @parts,
( $extra_help ? $extra_help : '' );
$text = sprintf(
"\n%s\n%s\n\n%s%s%s%s%s%s%s%s%s\n",
@parts
);
return $text;
}
sub parent_command_class {
my $class = shift;
$class = ref($class) if ref($class);
my @components = split("::", $class);
return if @components == 1;
my $parent = join("::", @components[0..$#components-1]);
return $parent if $parent->can("command_name");
return;
}
sub doc_sections {
my $self = shift;
my @sections;
my $command_name = $self->command_name;
my $version = do { no strict; ${ $self->class . '::VERSION' } };
my $help_brief = $self->help_brief;
my $datetime = $self->__context__->now;
my ($date,$time) = split(' ',$datetime);
push(@sections, UR::Doc::Section->create(
title => "NAME",
content => "$command_name" . ($help_brief ? " - $help_brief" : ""),
format => "pod",
));
push(@sections, UR::Doc::Section->create(
title => "VERSION",
content => "This document " # separated to trick the version updater
. "describes $command_name "
. ($version ? "version $version " : "")
. "($date at $time)",
format => "pod",
));
my $synopsis = $self->command_name . ' ' . $self->_shell_args_usage_string . "\n\n" . $self->help_synopsis;
if ($synopsis) {
push(@sections, UR::Doc::Section->create(
title => "SYNOPSIS",
content => $synopsis,
format => 'pod'
));
}
my $required_args = $self->help_options(is_optional => 0, format => "pod");
if ($required_args) {
push(@sections, UR::Doc::Section->create(
title => "REQUIRED ARGUMENTS",
content => "=over\n\n$required_args\n\n=back\n\n",
format => 'pod'
));
}
my $optional_args = $self->help_options(is_optional => 1, format => "pod");
if ($optional_args) {
push(@sections, UR::Doc::Section->create(
title => "OPTIONAL ARGUMENTS",
content => "=over\n\n$optional_args\n\n=back\n\n",
format => 'pod'
));
}
my $manual = $self->_doc_manual_body || $self->help_detail;
push(@sections, UR::Doc::Section->create(
title => "DESCRIPTION",
content => $manual,
format => 'pod',
));
my @extra_help = $self->_additional_help_sections;
while (@extra_help) {
my $title = shift @extra_help || '';
my $content = shift @extra_help || '';
push (@sections, UR::Doc::Section->create(
title => $title,
content => $content,
format => 'pod'
));
}
if ($self->can("doc_sub_commands")) {
my $sub_commands = $self->doc_sub_commands(brief => 1);
if ($sub_commands) {
push(@sections, UR::Doc::Section->create(
title => "SUB-COMMANDS",
content => $sub_commands,
format => "pod",
));
}
}
my @footer_section_methods = (
'LICENSE' => '_doc_license',
'AUTHORS' => '_doc_authors',
'CREDITS' => '_doc_credits',
'BUGS' => '_doc_bugs',
'SEE ALSO' => '_doc_see_also'
);
while (@footer_section_methods) {
my $header = shift @footer_section_methods;
my $method = shift @footer_section_methods;
my @txt = $self->$method;
next if (@txt == 0 or (@txt == 1 and not $txt[0]));
my $content;
if (@txt == 1) {
$content = $txt[0];
} else {
$content = join("\n", @txt);
}
push(@sections, UR::Doc::Section->create(
title => $header,
content => $content,
format => "pod",
));
}
return @sections;
}
sub doc_sub_commands {
my $self = shift;
return;
}
sub doc_manual {
my $self = shift;
my $pod = $self->_doc_name_version;
my $synopsis = $self->command_name . ' ' . $self->_shell_args_usage_string . "\n\n" . $self->help_synopsis;
my $required_args = $self->help_options(is_optional => 0, format => "pod");
my $optional_args = $self->help_options(is_optional => 1, format => "pod");
$pod .=
(
$synopsis
? "=head1 SYNOPSIS\n\n" . $synopsis . "\n\n"
: ''
)
. (
$required_args
? "=head1 REQUIRED ARGUMENTS\n\n=over\n\n" . $required_args . "\n\n=back\n\n"
: ''
)
. (
$optional_args
? "=head1 OPTIONAL ARGUMENTS\n\n=over\n\n" . $optional_args . "\n\n=back\n\n"
: ''
);
my $manual = $self->_doc_manual_body;
my $help = $self->help_detail;
if ($manual or $help) {
$pod .= "=head1 DESCRIPTION:\n\n";
my $txt = $manual || $help;
if ($txt =~ /^\=/) {
# pure POD
$pod .= $manual;
}
else {
$txt =~ s/\n/\n\n/g;
$pod .= $txt;
#$pod .= join('', map { " $_\n" } split ("\n",$txt)) . "\n";
}
}
$pod .= $self->_doc_footer();
$pod .= "\n\n=cut\n\n";
return "\n$pod";
}
sub _doc_name_version {
my $self = shift;
my $command_name = $self->command_name;
my $pod;
# standard: update this to do the old --help format
my $synopsis = $self->command_name . ' ' . $self->_shell_args_usage_string . "\n\n" . $self->help_synopsis;
my $help_brief = $self->help_brief;
my $version = do { no strict; ${ $self->class . '::VERSION' } };
my $datetime = $self->__context__->now;
my ($date,$time) = split(' ',$datetime);
$pod =
"\n=pod"
. "\n\n=head1 NAME"
. "\n\n"
. $self->command_name
. ($help_brief ? " - " . $self->help_brief : '')
. "\n\n";
$pod .=
"\n\n=head1 VERSION"
. "\n\n"
. "This document " # separated to trick the version updater
. "describes " . $self->command_name;
if ($version) {
$pod .= " version " . $version . " ($date at $time).\n\n";
}
else {
$pod .= " ($date at $time)\n\n";
}
return $pod;
}
sub _doc_manual_body {
return '';
}
sub help_header {
my $class = shift;
return sprintf("%s - %-80s\n",
$class->command_name
,$class->help_brief
)
}
sub help_options {
my $self = shift;
my %params = @_;
my $format = delete $params{format};
my @property_meta = $self->_shell_args_property_meta(%params);
my @data;
my $max_name_length = 0;
for my $property_meta (@property_meta) {
my $param_name = $self->_shell_arg_name_from_property_meta($property_meta);
if ($property_meta->{shell_args_position}) {
$param_name = uc($param_name);
}
#$param_name = "--$param_name";
my $doc = $property_meta->doc;
my $valid_values = $property_meta->valid_values;
my $example_values = $property_meta->example_values;
unless ($doc) {
# Maybe a parent class has documentation for this property
eval {
foreach my $ancestor_class_meta ( $property_meta->class_meta->ancestry_class_metas ) {
my $ancestor_property_meta = $ancestor_class_meta->property_meta_for_name($property_meta->property_name);
if ($ancestor_property_meta and $doc = $ancestor_property_meta->doc) {
last;
}
}
};
}
if (!$doc) {
if (!$valid_values) {
$doc = "(undocumented)";
}
else {
$doc = '';
}
}
if ($valid_values) {
$doc .= "\nvalid values:\n";
for my $v (@$valid_values) {
$doc .= " " . $v . "\n";
$max_name_length = length($v)+2 if $max_name_length < length($v)+2;
}
chomp $doc;
}
if ($example_values && @$example_values) {
$doc .= "\nexample" . (@$example_values > 1 and 's') . ":\n";
$doc .= join(', ',
map { ref($_) ? Data::Dumper->new([$_])->Terse(1)->Dump() : $_ } @$example_values
);
chomp($doc);
}
$max_name_length = length($param_name) if $max_name_length < length($param_name);
my $param_type = $property_meta->data_type || '';
if (defined($param_type) and $param_type !~ m/::/) {
$param_type = ucfirst(lc($param_type));
}
my $default_value;
if (defined($default_value = $property_meta->default_value)
|| defined(my $calculated_default = $property_meta->calculated_default)
) {
unless (defined $default_value) {
$default_value = $calculated_default->()
}
if ($param_type eq 'Boolean') {
$default_value = $default_value ? "'true'" : "'false' (--no$param_name)";
} elsif ($property_meta->is_many && ref($default_value) eq 'ARRAY') {
if (@$default_value) {
$default_value = "('" . join("','",@$default_value) . "')";
} else {
$default_value = "()";
}
} else {
$default_value = "'$default_value'";
}
$default_value = "\nDefault value $default_value if not specified";
}
push @data, [$param_name, $param_type, $doc, $default_value];
if ($param_type eq 'Boolean') {
push @data, ['no'.$param_name, $param_type, "Make $param_name 'false'" ];
}
}
my $text = '';
for my $row (@data) {
if (defined($format) and $format eq 'pod') {
$text .= "\n=item " . $row->[0] . ($row->[1]? ' I<' . $row->[1] . '>' : '') . "\n\n" . $row->[2] . "\n". ($row->[3]? $row->[3] . "\n" : '');
}
elsif (defined($format) and $format eq 'html') {
$text .= "\n\t
" . $row->[0] . ($row->[1]? ' ' . $row->[1] . '' : '') . "
" . $row->[2] . ($row->[3]? "
" . $row->[3] : '') . "
\n";
}
else {
$text .= sprintf(
" %s\n%s\n",
Term::ANSIColor::colored($row->[0], 'bold'), # . " " . $row->[1],
Text::Wrap::wrap(
" ", # 1st line indent,
" ", # all other lines indent,
$row->[2],
$row->[3] || '',
),
);
}
}
return $text;
}
sub _doc_footer {
my $self = shift;
my $pod = '';
my @method_header_map = (
'LICENSE' => '_doc_license',
'AUTHORS' => '_doc_authors',
'CREDITS' => '_doc_credits',
'BUGS' => '_doc_bugs',
'SEE ALSO' => '_doc_see_also'
);
while (@method_header_map) {
my $header = shift @method_header_map;
my $method = shift @method_header_map;
my @txt = $self->$method;
next if (@txt == 0 or (@txt == 1 and not $txt[0]));
if (@txt == 1) {
my @lines = split("\n",$txt[0]);
$pod .= "=head1 $header\n\n"
. join(" \n", @lines)
. "\n\n";
}
else {
$pod .= "=head1 $header\n\n"
. join("\n ",@txt);
$pod .= "\n\n";
}
}
return $pod;
}
sub _doc_license {
return '';
}
sub _doc_authors {
return ();
}
sub _doc_credits {
return '';
}
sub _doc_bugs {
return '';
}
sub _doc_see_also {
return ();
}
sub _shell_args_usage_string {
my $self = shift;
return eval {
if ( $self->isa('Command::Tree') ) {
return '...';
}
elsif ($self->can("_execute_body") eq __PACKAGE__->can("_execute_body")) {
return '(no execute!)';
}
elsif ($self->__meta__->is_abstract) {
return '(no sub commands!)';
}
else {
return join(
" ",
map {
$self->_shell_arg_usage_string_from_property_meta($_)
} $self->_shell_args_property_meta()
);
}
};
}
sub _shell_args_usage_string_abbreviated {
my $self = shift;
my $detailed = $self->_shell_args_usage_string;
if (length($detailed) <= 20) {
return $detailed;
}
else {
return substr($detailed,0,17) . '...';
}
}
sub sub_command_mapping {
my ($self, $class) = @_;
return if !$class;
no strict 'refs';
my $mapping = ${ $class . '::SUB_COMMAND_MAPPING'};
if (ref($mapping) eq 'HASH') {
return $mapping;
} else {
return;
}
};
sub command_name {
my $self = shift;
my $class = ref($self) || $self;
my $prepend = '';
# There can be a hash in the command entry point class that maps
# root level tools to classes so they can be in a different location
# ...this bit of code considers that misdirection:
my $entry_point_class = $Command::entry_point_class;
my $mapping = $self->sub_command_mapping($entry_point_class);
for my $k (%$mapping) {
my $v = $mapping->{$k};
if ($v && $v eq $class) {
my @words = grep { $_ ne 'Command' } split(/::/,$class);
return join(' ', $self->_command_name_for_class_word($words[0]), $k);
}
}
if (defined($entry_point_class) and $class =~ /^($entry_point_class)(::.+|)$/) {
$prepend = $Command::entry_point_bin;
$class = $2;
if ($class =~ s/^:://) {
$prepend .= ' ';
}
}
my @words = grep { $_ ne 'Command' } split(/::/,$class);
my $n = join(' ', map { $self->_command_name_for_class_word($_) } @words);
return $prepend . $n;
}
sub command_name_brief {
my $self = shift;
my $class = ref($self) || $self;
my @words = grep { $_ ne 'Command' } split(/::/,$class);
my $n = join(' ', map { $self->_command_name_for_class_word($_) } $words[-1]);
return $n;
}
sub color_command_name {
my $text = shift;
my $colored_text = [];
my @COLOR_TEMPLATES = ('red', 'bold red', 'magenta', 'bold magenta');
my @parts = split(/\s+/, $text);
for(my $i = 0 ; $i < @parts ; $i++ ){
push @$colored_text, ($i < @COLOR_TEMPLATES) ? Term::ANSIColor::colored($parts[$i], $COLOR_TEMPLATES[$i]) : $parts[$i];
}
return join(' ', @$colored_text);
}
sub _base_command_class_and_extension {
my $self = shift;
my $class = ref($self) || $self;
return ($class =~ /^(.*)::([^\:]+)$/);
}
sub _command_name_for_class_word {
my $self = shift;
my $s = shift;
$s =~ s/_/-/g;
$s =~ s/^([A-Z])/\L$1/; # ignore first capital because that is assumed
$s =~ s/([A-Z])/-$1/g; # all other capitals prepend a dash
$s =~ s/([a-zA-Z])([0-9])/$1$2/g; # treat number as begining word
$s = lc($s);
return $s;
}
sub _pod2txt {
my $txt = shift;
my $output = '';
my $parser = Pod::Simple::Text->new;
$parser->no_errata_section(1);
$parser->output_string($output);
$parser->parse_string_document("=pod\n\n$txt");
return $output;
}
sub _additional_help_sections {
return;
}
1;
callcount.pm 100664 023532 023421 5145 12544604516 15771 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/Devel
package Devel::callsfrom;
use Data::Dumper;
# From perldoc perlvar
# Debugger flags, so you can see what we turn on below.
#
# 0x01 Debug subroutine enter/exit.
#
# 0x02 Line-by-line debugging.
#
# 0x04 Switch off optimizations.
#
# 0x08 Preserve more data for future interactive inspections.
#
# 0x10 Keep info about source lines on which a subroutine is defined.
#
# 0x20 Start with single-step on.
#
# 0x40 Use subroutine address instead of name when reporting.
#
# 0x80 Report "goto &subroutine" as well.
#
# 0x100 Provide informative "file" names for evals based on the place they were com-
# piled.
#
# 0x200 Provide informative names to anonymous subroutines based on the place they
# were compiled.
#
# 0x400 Debug assertion subroutines enter/exit.
#
BEGIN { $^P |= (0x01 | 0x80 | 0x100 | 0x200); };
#BEGIN { $^P |= (0x004 | 0x100 ); };
sub import { }
package DB;
# Any debugger needs to have a sub DB. It doesn't need to do anything.
sub DB{};
# We want to track how deep our subroutines go
our $CALL_DEPTH = 0;
our %CALLED;
our $CALL_WATCH = $ENV{CALL_WATCH};
sub sub {
local $DB::CALL_DEPTH = $DB::CALL_DEPTH+1;
no strict;
no warnings;
my @c0 = caller(0);
my @c1 = caller(-1);
my ($pkg,$file,$line) = @c1;
my $csub = $c0[3] || '-';
my $caller = join(",", $file,$line,$pkg,$csub);
print STDERR ((' ' x $DB::CALL_DEPTH) . $DB::sub{$DB::sub} . ' > ' . $DB::sub . "(@_) : " . $caller . "\n") if $CALL_WATCH;
$DB::CALLED{$DB::sub}{$caller}++;
&{$DB::sub};
}
END {
use strict;
use warnings;
my %counts;
for my $sub (keys %DB::sub) {
my $cases = $DB::CALLED{$sub};
my @callers = keys %$cases;
my $call_count = scalar(@callers);
$counts{$call_count}{$sub} = $cases;
}
my @counts = keys %counts;
my $call_min = $ENV{CALL_MIN};
if (defined $call_min) {
@counts = grep { $_ >= $call_min } @counts;
}
my $call_max = $ENV{CALL_MAX};
if (defined $call_max) {
@counts = grep { $_ <= $call_max } @counts;
}
my $fh;
if (my $fname = $ENV{CALL_COUNT_OUTFILE}) {
open($fh,">$fname");
unless ($fh) { die "failed to open outfile for call count for $0!" };
}
else {
open($fh,">$0.callcount");
$fh or die "failed to open output file $0.callcount: $!";
}
for my $c (sort { $a <=> $b } @counts) {
my $subs = $counts{$c};
for my $sub (sort keys %$subs) {
my $cases = $subs->{$sub};
my @calls = sort keys %$cases;
print $fh join("\t",$c, $sub,$DB::sub{$sub},@calls),"\n";
}
}
}
1;
UR.pm 100664 023532 023421 102271 12544604516 13332 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib package UR;
# The UR module is itself a "UR::Namespace", besides being the root
# module which bootstraps the system. The class definition itself
# is made at the bottom of the file.
use strict;
use warnings FATAL => 'all';
# Set the version at compile time, since some other modules borrow it.
our $VERSION = "0.44"; # UR $VERSION
# Ensure we get detailed errors while starting up.
# This is disabled at the bottom of the module.
use Carp;
$SIG{__DIE__} = \&Carp::confess;
# Ensure that, if the application changes directory, we do not
# change where we load modules while running.
use Cwd;
my @PERL5LIB = ($ENV{PERL5LIB} ? split(':', $ENV{PERL5LIB}) : ());
for my $dir (@INC, @PERL5LIB) {
next unless -d $dir;
$dir = Cwd::abs_path($dir) || $dir;
}
$ENV{PERL5LIB} = join(':', @PERL5LIB);
# Also need to fix modules that were already loaded, so that when
# a namespace is loaded the path will not change out from
# underneath it.
for my $module (keys %INC) {
$INC{$module} = Cwd::abs_path($INC{$module});
}
# UR supports several environment variables, found under UR/ENV
# Any UR_* variable which is set but does NOT corresponde to a module found will cause an exit
# (a hedge against typos such as UR_DBI_NO_COMMMMIT=1 leading to unexpected behavior)
for my $e (keys %ENV) {
next unless substr($e,0,3) eq 'UR_';
eval "use UR::Env::$e";
if ($@) {
my $path = __FILE__;
$path =~ s/.pm$//;
my @files = glob($path . '/Env/*');
my @vars = map { /UR\/Env\/(.*).pm/; $1 } @files;
print STDERR "Environment variable $e set to $ENV{$e} but there were errors using UR::Env::$e:\n"
. "Available variables:\n\t"
. join("\n\t",@vars)
. "\n";
exit 1;
}
}
# These two dump info about used modules and libraries at program exit.
END {
if ($ENV{UR_USED_LIBS}) {
print STDERR "Used library include paths (\@INC):\n";
for my $lib (@INC) {
print STDERR "$lib\n";
}
print STDERR "\n";
}
if ($ENV{UR_USED_MODS}) {
print STDERR "Used modules and paths (\%INC):\n";
for my $mod (sort keys %INC) {
if ($ENV{UR_USED_MODS} > 1) {
print STDERR "$mod => $INC{$mod}\n";
} else {
print STDERR "$mod\n";
}
}
print STDERR "\n";
}
if ($ENV{UR_DBI_SUMMARIZE_SQL}) {
UR::DBI::print_sql_summary();
}
}
#Class::AutoloadCAN must be used before Class::Autouse, or the can methods will break in confusing ways.
use Class::AutoloadCAN;
use Class::Autouse;
BEGIN {
my $v = $Class::Autouse::VERSION;
unless (($v =~ /^\d+\.?\d*$/ && $v >= 2.0)
or $v eq '1.99_02'
or $v eq '1.99_04') {
die "UR requires Class::Autouse 2.0 or greater (or 1.99_02 or 1.99_04)!!";
}
};
# Regular deps
use Date::Format;
#
# Because UR modules execute code when compiling to define their classes,
# and require each other for that code to execute, there are bootstrapping
# problems.
#
# Everything which is part of the core framework "requires" UR
# which, of course, executes AFTER it has compiled its SUBS,
# but BEFORE it defines its class.
#
# Everything which _uses_ the core of the framework "uses" its namespace,
# either the specific top-level namespace module, or "UR" itself for components/extensions.
#
require UR::Exit;
require UR::Util;
require UR::DBI::Report; # this is used by UR::DBI
require UR::DBI; # this needs a new name, and need only be used by UR::DataSource::RDBMS
require UR::ModuleBase; # this should be switched to a role
require UR::ModuleConfig; # used by ::Time, and also ::Lock ::Daemon
require UR::Object::Iterator;
require UR::Context::AutoUnloadPool;
require UR::DeletedRef;
require UR::Object;
require UR::Object::Type;
require UR::Object::Ghost;
require UR::Object::Property;
require UR::Observer;
require UR::BoolExpr::Util;
require UR::BoolExpr; # has meta
require UR::BoolExpr::Template; # has meta
require UR::BoolExpr::Template::PropertyComparison; # has meta
require UR::BoolExpr::Template::Composite; # has meta
require UR::BoolExpr::Template::And; # has meta
require UR::BoolExpr::Template::Or; # has meta
require UR::Object::Index;
#
# Define core metadata.
#
# This is done outside of the actual modules since the define() method
# uses all of the modules themselves to do its work.
#
UR::Object::Type->define(
class_name => 'UR::Object',
is => [], # the default is to inherit from UR::Object, which is circular, so we explicitly say nothing
is_abstract => 1,
composite_id_separator => "\t",
id_by => [
id => { is => 'Scalar', doc => 'unique identifier' }
],
id_generator => '-urinternal',
);
UR::Object::Type->define(
class_name => "UR::Object::Index",
id_by => ['indexed_class_name','indexed_property_string'],
has => ['indexed_class_name','indexed_property_string'],
is_transactional => 0,
);
UR::Object::Type->define(
class_name => 'UR::Object::Ghost',
is_abstract => 1,
);
UR::Object::Type->define(
class_name => 'UR::Entity',
extends => ['UR::Object'],
is_abstract => 1,
);
UR::Object::Type->define(
class_name => 'UR::Entity::Ghost',
extends => ['UR::Object::Ghost'],
is_abstract => 1,
);
# MORE METADATA CLASSES
# For bootstrapping reasons, the properties with default values also need to be listed in
# %class_property_defaults defined in UR::Object::Type::Initializer. If you make changes
# to default values, please keep these in sync.
UR::Object::Type->define(
class_name => 'UR::Object::Type',
doc => 'class/type meta-objects for UR',
id_by => 'class_name',
sub_classification_method_name => '_resolve_meta_class_name',
is_abstract => 1,
has => [
class_name => { is => 'Text', len => 256, is_optional => 1,
doc => 'the name for the class described' },
properties => {
is_many => 1,
# this is calculated instead of a regular relationship
# so we can do appropriate inheritance filtering.
# We need an isa operator and its converse
# in order to be fully declarative internally here
calculate => 'shift->_properties(@_);',
doc => 'property meta-objects for the class'
},
id_properties => { is_many => 1,
calculate => q( grep { defined $_->is_id } shift->_properties(@_) ),
doc => 'meta-objects for the ID properties of the class' },
doc => { is => 'Text', len => 1024, is_optional => 1,
doc => 'a one-line description of the class/type' },
is_abstract => { is => 'Boolean', default_value => 0,
doc => 'abstract classes must be subclassified into a concreate class at create/load time' },
is_final => { is => 'Boolean', default_value => 0,
doc => 'further subclassification is prohibited on final classes' },
is_transactional => { is => 'Boolean', default_value => 1, is_optional => 1,
doc => 'non-transactional objects are left out of in-memory transactions' },
is_singleton => { is => 'Boolean', default_value => 0,
doc => 'singleton classes have only one instance, or have each instance fall into a distinct subclass' },
namespace => { is => 'Text', len => 256, is_optional => 1,
doc => 'the first "word" in the class name, which points to a UR::Namespace' },
schema_name => { is => 'Text', len => 256, is_optional => 1,
doc => 'an arbitrary grouping for classes for which instances share a common storage system' },
data_source_id => { is => 'Text', len => 256, is_optional => 1,
doc => 'for classes which persist beyond their current process, the identifier for their storage manager' },
#data_source_meta => { is => 'UR::DataSource', id_by => 'data_source_id', is_optional => 1, },
generated => { is => 'Boolean', is_transient => 1, default_value => 0,
doc => 'an internal flag set when the class meta has fabricated accessors and methods in the class namespace' },
meta_class_name => { is => 'Text',
doc => 'even meta-classess have a meta-class' },
composite_id_separator => { is => 'Text', len => 2 , default_value => "\t", is_optional => 1,
doc => 'for classes whose objects have a multi-value "id", this overrides using a "\t" to compose/decompose' },
valid_signals => { is => 'ARRAY', is_optional => 1,
doc => 'List of non-standard signal names observers can bind to ' },
# details used by the managment of the "real" entity outside of the app (persistence)
table_name => { is => 'Text', len => undef, is_optional => 1,
doc => 'for classes with a data source, this specifies the table or equivalent data structure which holds instances' },
select_hint => { is => 'Text', len => 1024 , is_optional => 1,
doc => 'used to optimize access to underlying storage (database specific)' },
join_hint => { is => 'Text', len => 1024 , is_optional => 1,
doc => 'used to optimize access to underlying storage when this class is part of a join (database specific)' },
id_generator => { is => 'Text', len => 256, is_optional => 1,
doc => 'override the default choice for generating new object IDs' },
# different ways of handling subclassing at object load time
subclassify_by => { is => 'Text', len => 256, is_optional => 1,
doc => 'when set, the method specified will return the name of a specific subclass into which the object should go' },
subclass_description_preprocessor => { is => 'MethodName', len => 255, is_optional => 1,
doc => 'a method which should pre-process the class description of sub-classes before construction' },
sub_classification_method_name => { is => 'Text', len => 256, is_optional => 1,
doc => 'like subclassify_by, but examines whole objects not a single property' },
use_parallel_versions => { is => 'Boolean', is_optional => 1, default_value => 0,
doc => 'inheriting from the is class will redirect to a ::V? module implemeting a specific version' },
# obsolete/internal
type_name => { is => 'Text', len => 256, is_deprecated => 1, is_optional => 1 },
er_role => { is => 'Text', len => 256, is_optional => 1, default_value => 'entity' },
source => { is => 'Text', len => 256 , default_value => 'data dictionary', is_optional => 1 }, # This is obsolete and should be removed later
sub_classification_meta_class_name => { is => 'Text', len => 1024 , is_optional => 1,
doc => 'obsolete' },
first_sub_classification_method_name => { is => 'Text', len => 256, is_optional => 1,
doc => 'cached value to handle a complex inheritance hierarchy with storage at some levels but not others' },
### Relationships with the other meta-classes (used internally) ###
# UR::Namespaces are singletons referenced through their name
namespace_meta => { is => 'UR::Namespace', id_by => 'namespace' },
is => { is => 'ARRAY', is_mutable => 0, doc => 'List of the parent class names' },
# linking to the direct parents, and the complete ancestry
parent_class_metas => { is => 'UR::Object::Type', id_by => 'is',
doc => 'The list of UR::Object::Type objects for the classes that are direct parents of this class' },#, is_many => 1 },
parent_class_names => { via => 'parent_class_metas', to => 'class_name', is_many => 1 },
parent_meta_class_names => { via => 'parent_class_metas', to => 'meta_class_name', is_many => 1 },
ancestry_meta_class_names => { via => 'ancestry_class_metas', to => 'meta_class_name', is_many => 1 },
ancestry_class_metas => { is => 'UR::Object::Type', id_by => 'is', where => [-recurse => [class_name => 'is']],
doc => 'Climb the ancestry tree and return the class objects for all of them' },
ancestry_class_names => { via => 'ancestry_class_metas', to => 'class_name', is_many => 1 },
# This one isn't useful on its own, but is used to build the all_* accessors below
all_class_metas => { is => 'UR::Object::Type', calculate => 'return ($self, $self->ancestry_class_metas)' },
# Properties defined on this class, parent classes, etc.
# There's also a property_meta_by_name() method defined in the class
direct_property_metas => { is => 'UR::Object::Property', reverse_as => 'class_meta', is_many => 1 },
direct_property_names => { via => 'direct_property_metas', to => 'property_name', is_many => 1 },
direct_id_property_metas => { is => 'UR::Object::Property', reverse_as => 'class_meta', where => [ 'is_id true' => 1, -order_by => 'is_id' ], is_many => 1 },
direct_id_property_names => { via => 'direct_id_property_metas', to => 'property_name', is_many => 1 },
ancestry_property_metas => { via => 'ancestry_class_metas', to => 'direct_property_metas', is_many => 1 },
ancestry_property_names => { via => 'ancestry_class_metas', to => 'direct_property_names', is_many => 1 },
ancestry_id_property_metas => { via => 'ancestry_class_metas', to => 'direct_id_property_metas', is_many => 1 },
ancestry_id_property_names => { via => 'ancestry_id_property_metas', to => 'property_name', is_many => 1 },
all_property_metas => { via => 'all_class_metas', to => 'direct_property_metas', is_many => 1 },
all_property_names => { via => 'all_property_metas', to => 'property_name', is_many => 1 },
all_id_property_metas => { via => 'all_class_metas', to => 'direct_id_property_metas', is_many => 1 },
all_id_property_names => { via => 'all_id_property_metas', to => 'property_name', is_many => 1 },
direct_id_by_property_metas => { via => 'direct_property_metas', to => '__self__', where => ['id_by true' => 1], is_many => 1, doc => "Properties with 'id_by' metadata, ie. direct object accessor properties" } ,
all_id_by_property_metas => { via => 'all_class_metas', to => 'direct_id_by_property_metas', is_many => 1},
direct_reverse_as_property_metas => { via => 'direct_property_metas', to => '__self__', where => ['reverse_as true' => 1], is_many => 1, doc => "Properties with 'reverse_as' metadata, ie. indirect object accessor properties" },
all_reverse_as_property_metas => { via => 'all_class_metas', to => 'direct_reverse_as_property_metas', is_many => 1},
# Datasource related stuff
direct_column_names => { via => 'direct_property_metas', to => 'column_name', is_many => 1, where => [column_name => { operator => 'true' }] },
direct_id_column_names => { via => 'direct_id_property_metas', to => 'column_name', is_many => 1, where => [column_name => { operator => 'true'}] },
ancestry_column_names => { via => 'ancestry_class_metas', to => 'direct_column_names', is_many => 1 },
ancestry_id_column_names => { via => 'ancestry_class_metas', to => 'direct_id_column_names', is_many => 1 },
# Are these *columnless* properties actually necessary? The user could just use direct_property_metas(column_name => undef)
direct_columnless_property_metas => { is => 'UR::Object::Property', reverse_as => 'class_meta', where => [column_name => undef], is_many => 1 },
direct_columnless_property_names => { via => 'direct_columnless_property_metas', to => 'property_name', is_many => 1 },
ancestry_columnless_property_metas => { via => 'ancestry_class_metas', to => 'direct_columnless_property_metas', is_many => 1 },
ancestry_columnless_property_names => { via => 'ancestry_columnless_property_metas', to => 'property_name', is_many => 1 },
ancestry_table_names => { via => 'ancestry_class_metas', to => 'table_name', is_many => 1 },
all_table_names => { via => 'all_class_metas', to => 'table_name', is_many => 1 },
all_column_names => { via => 'all_class_metas', to => 'direct_column_names', is_many => 1 },
all_id_column_names => { via => 'all_class_metas', to => 'direct_id_column_names', is_many => 1 },
all_columnless_property_metas => { via => 'all_class_metas', to => 'direct_columnless_property_metas', is_many => 1 },
all_columnless_property_names => { via => 'all_class_metas', to => 'direct_columnless_property_names', is_many => 1 },
],
);
UR::Object::Type->define(
class_name => 'UR::Object::Property',
id_properties => [
class_name => { is => 'Text', len => 256 },
property_name => { is => 'Text', len => 256 },
],
has_optional => [
property_type => { is => 'Text', len => 256 , is_optional => 1},
column_name => { is => 'Text', len => 256, is_optional => 1 },
data_length => { is => 'Text', len => 32, is_optional => 1 },
data_type => { is => 'Text', len => 256, is_optional => 1 },
calculated_default => { is_optional => 1 },
default_value => { is_optional => 1 },
valid_values => { is => 'ARRAY', is_optional => 1, },
example_values => { is => 'ARRAY', is_optional => 1, doc => 'example valid values; used to generate help text for Commands' },
doc => { is => 'Text', len => 1000, is_optional => 1 },
is_id => { is => 'Integer', default_value => undef, doc => 'denotes this is an ID property of the class, and ranks them' },
is_optional => { is => 'Boolean' , default_value => 0},
is_transient => { is => 'Boolean' , default_value => 0},
is_constant => { is => 'Boolean' , default_value => 0}, # never changes
is_mutable => { is => 'Boolean' , default_value => 1}, # can be changed explicitly via accessor (cannot be constant)
is_volatile => { is => 'Boolean' , default_value => 0}, # changes w/o a signal: (cannot be constant or transactional)
is_classwide => { is => 'Boolean' , default_value => 0},
is_delegated => { is => 'Boolean' , default_value => 0},
is_calculated => { is => 'Boolean' , default_value => 0},
is_transactional => { is => 'Boolean' , default_value => 1}, # STM works on these, and the object can possibly save outside the app
is_abstract => { is => 'Boolean' , default_value => 0},
is_concrete => { is => 'Boolean' , default_value => 1},
is_final => { is => 'Boolean' , default_value => 0},
is_many => { is => 'Boolean' , default_value => 0},
is_aggregate => { is => 'Boolean' , default_value => 0},
is_deprecated => { is => 'Boolean', default_value => 0},
is_numeric => { calculate_from => ['data_type'], },
id_by => { is => 'ARRAY', is_optional => 1},
id_class_by => { is => 'Text', is_optional => 1},
is_undocumented => { is => 'Boolean', is_optional => 1, doc => 'do not show in documentation to users' },
doc_position => { is => 'Number', is_optional => 1, doc => 'override the sort position within documentation' },
access_as => { is => 'Text', is_optional => 1, doc => 'when id_class_by is set, and this is set to "auto", primitives will return as their ID instead of boxed' },
order_by => { is => 'ARRAY', is_optional => 1},
specify_by => { is => 'Text', is_optional => 1},
reverse_as => { is => 'ARRAY', is_optional => 1 },
implied_by => { is => 'Text' , is_optional => 1},
via => { is => 'Text' , is_optional => 1 },
to => { is => 'Text' , is_optional => 1},
where => { is => 'ARRAY', is_optional => 1},
calculate => { is => 'Text' , is_optional => 1},
calculate_from => { is => 'ARRAY' , is_optional => 1},
calculate_perl => { is => 'Perl' , is_optional => 1},
calculate_sql => { is => 'SQL' , is_optional => 1},
calculate_js => { is => 'JavaScript' , is_optional => 1},
constraint_name => { is => 'Text' , is_optional => 1},
is_legacy_eav => { is => 'Boolean' , is_optional => 1},
is_dimension => { is => 'Boolean', is_optional => 1},
is_specified_in_module_header => { is => 'Boolean', default_value => 0 },
position_in_module_header => { is => 'Integer', is_optional => 1, doc => "Line in the class definition source's section this property appears" },
singular_name => { is => 'Text' },
plural_name => { is => 'Text' },
class_meta => { is => 'UR::Object::Type', id_by => 'class_name' },
r_class_meta => { is => 'UR::Object::Type', id_by => 'data_type' },
],
unique_constraints => [
{ properties => [qw/property_name class_name/], sql => 'SUPER_FAKE_O4' },
],
);
UR::Object::Type->define(
class_name => 'UR::Object::Property::Calculated::From',
id_properties => [qw/class_name calculated_property_name source_property_name/],
);
require UR::Singleton;
require UR::Namespace;
UR::Object::Type->define(
class_name => 'UR',
extends => ['UR::Namespace'],
);
require UR::Context;
UR::Object::Type->initialize_bootstrap_classes;
require Command;
$UR::initialized = 1;
require UR::Change;
require UR::Context::Root;
require UR::Context::Process;
require UR::Object::Tag;
do {
UR::Context->_initialize_for_current_process();
};
require UR::ModuleLoader; # signs us up with Class::Autouse
require UR::Value::Iterator;
require UR::Object::View;
require UR::Object::Join;
sub main::ur_core {
print STDERR "Dumping rules and templates to ./ur_core.stor...\n";
my $dump;
unless(open($dump, ">ur_core.stor")) {
print STDERR "Can't open ur_core.stor for writing: $!";
exit;
}
store_fd([
$UR::Object::rule_templates,
$UR::Object::rules,
],
$dump);
close $dump;
exit();
}
1;
__END__
=pod
=head1 NAME
UR - rich declarative transactional objects
=head1 VERSION
This document describes UR version 0.44
=head1 SYNOPSIS
use UR;
## no database
class Foo { is => 'Bar', has => [qw/prop1 prop2 prop3/] };
$o1 = Foo->create(prop1 => 111, prop2 => 222, prop3 => 333);
@o = Foo->get(prop2 => 222, prop1 => [101,111,121], 'prop3 between' => [200, 400]);
# returns one object
$o1->delete;
@o = Foo->get(prop2 => 222, prop1 => [101,111,121], 'prop3 between' => [200, 400]);
# returns zero objects
@o = Foo->get(prop2 => 222, prop1 => [101,111,121], 'prop3 between' => [200, 400]);
# returns one object again
## database
class Animal {
has => [
favorite_food => { is => 'Text', doc => "what's yummy?" },
],
data_source => 'MyDB1',
table_name => 'Animal'
};
class Cat {
is => 'Animal',
has => [
feet => { is => 'Number', default_value => 4 },
fur => { is => 'Text', valid_values => [qw/fluffy scruffy/] },
],
data_source => 'MyDB1',
table_name => 'Cat'
};
Cat->create(feet => 4, fur => 'fluffy', favorite_food => 'taters');
@cats = Cat->get(favorite_food => ['taters','sea bass']);
$c = $cats[0];
print $c->feet,"\n";
$c->fur('scruffy');
UR::Context->commit();
=head1 DESCRIPTION
UR is a class framework and object/relational mapper for Perl. It starts
with the familiar Perl meme of the blessed hash reference as the basis for
object instances, and extends its capabilities with ORM (object-relational
mapping) capabilities, object cache, in-memory transactions, more formal
class definitions, metadata, documentation system, iterators, command line
tools, etc.
UR can handle multiple column primary and foreign keys, SQL joins involving
class inheritance and relationships, and does its best to avoid querying
the database unless the requested data has not been loaded before. It has
support for SQLite, Oracle, Mysql and Postgres databases, and the ability
to use a text file as a table.
UR uses the same syntax to define non-persistent objects, and supports
in-memory transactions for both.
=head1 DOCUMENTATION
=head2 Manuals
L - command line interface
L - UR from Ten Thousand Feet
L - Getting started with UR
L - Slides for a presentation on UR
L - Recepies for getting stuff working
L - UR's metadata system
L - Defining classes
=head2 Basic Entities
L - Pretty much everything is-a UR::Object
L - Metadata class for Classes
L - Metadata class for Properties
L - Manage packages and classes
L - Software transactions and More!
L - How and where to get data
=head1 QUICK TUTORIAL
First create a Namespace class for your application, Music.pm:
package Music;
use UR;
class Music {
is => 'UR::Namespace'
};
1;
Next, define a data source representing your database, Music/DataSource/DB1.pm
package Music::DataSource::DB1;
use Music;
class Music::DataSource::DB1 {
is => ['UR::DataSource::MySQL', 'UR::Singleton'],
has_constant => [
server => { value => 'database=music' },
owner => { value => 'music' },
login => { value => 'mysqluser' },
auth => { value => 'mysqlpasswd' },
]
};
or to get something going quickly, SQLite has smart defaults...
class Music::DataSource::DB1 {
is => ['UR::DataSource::SQLite', 'UR::Singleton'],
};
Create a class to represent artists, who have many CDs, in Music/Artist.pm
package Music::Artist;
use Music;
class Music::Artist {
id_by => 'artist_id',
has => [
name => { is => 'Text' },
cds => { is => 'Music::Cd', is_many => 1, reverse_as => 'artist' }
],
data_source => 'Music::DataSource::DB1',
table_name => 'ARTIST',
};
Create a class to represent CDs, in Music/Cd.pm
package Music::Cd;
use Music;
class Music::Cd {
id_by => 'cd_id',
has => [
artist => { is => 'Music::Artist', id_by => 'artist_id' },
title => { is => 'Text' },
year => { is => 'Integer' },
artist_name => { via => 'artist', to => 'name' },
],
data_source => 'Music::DataSource::DB1',
table_name => 'CD',
};
If the database does not exist, you can run this to generate the tables and columns from the classes you've written
(very experimental):
$ cd Music
$ ur update schema
If the database existed already, you could have done this to get it to write the last 2 classes for you:
$ cd Music;
$ ur update classes
Regardless, if the classes and database tables are present, you can then use these classes in your application code:
# Using the namespace enables auto-loading of modules upon first attempt to call a method
use Music;
# This would get back all Artist objects:
my @all_artists = Music::Artist->get();
# After the above, further requests would be cached
# if that set were large though, you might want to iterate gradually:
my $artist_iter = Music::Artist->create_iterator();
# Get the first object off of the iterator
my $first_artist = $artist_iter->next();
# Get all the CDs published in 2007 for the first artist
my @cds_2007 = Music::Cd->get(year => 2007, artist => $first_artist);
# Use non-equality operators:
my @some_cds = Music::Cd->get(
'year between' => ['2004','2009']
);
# This will use a JOIN with the ARTISTS table internally to filter
# the data in the database. @some_cds will contain Music::Cd objects.
# As a side effect, related Artist objects will be loaded into the cache
@some_cds = Music::Cd->get(
year => '2007',
'artist_name like' => 'Bob%'
);
# These values would be cached...
my @artists_for_some_cds = map { $_->artist } @some_cds;
# This will use a join to prefetch Artist objects related to the
# objects that match the filter
my @other_cds = Music::Cd->get(
'title like' => '%White%',
-hints => ['artist']
);
my $other_artist_0 = $other_cds[0]->artist; # already loaded so no query
# create() instantiates a new object in the current "context", but does not save
# it in the database. It will autogenerate its own cd_id:
my $new_cd = Music::Cd->create(
title => 'Cool Album',
year => 2009
);
# Assign it to an artist; fills in the artist_id field of $new_cd
$first_artist->add_cd($new_cd);
# Save all changes in the current transaction back to the database(s)
# which are behind the changed objects.
UR::Context->current->commit;
=head1 Environment Variables
UR uses several environment variables to do things like run with
database commits disabled, watching SQL queries run, examine query plans,
and control cache size, etc.
These make development and debugging fast and easy.
See L for details.
=head1 DEPENDENCIES
Class::Autouse
Cwd
Data::Dumper
Date::Format
DBI
File::Basename
FindBin
FreezeThaw
Path::Class
Scalar::Util
Sub::Installer
Sub::Name
Sys::Hostname
Text::Diff
Time::HiRes
XML::Simple
=head1 AUTHORS
UR was built by the software development team at the McDonnell Genome
Institute at Washington University School of Medicine (Richard K. Wilson, PI).
Incarnations of it run laboratory automation and analysis systems
for high-throughput genomics.
Anthony Brummett brummett@cpan.org
Nathan Nutter
Josh McMichael
Eric Clark
Ben Oberkfell
Eddie Belter
Feiyu Du
Adam Dukes
Brian Derickson
Craig Pohl
Gabe Sanderson
Todd Hepler
Jason Walker
James Weible
Indraniel Das
Shin Leong
Ken Swanson
Scott Abbott
Alice Diec
William Schroeder
Shawn Leonard
Lynn Carmichael
Amy Hawkins
Michael Kiwala
Kevin Crouse
Mark Johnson
Kyung Kim
Jon Schindler
Justin Lolofie
Jerome Peirick
Ryan Richt
John Osborne
Chris Harris
Philip Kimmey
Robert Long
Travis Abbott
Matthew Callaway
James Eldred
Scott Smith sakoht@cpan.org
David Dooling
=head1 LICENCE AND COPYRIGHT
Copyright (C) 2002-2015 Washington University in St. Louis, MO.
This sofware is licensed under the same terms as Perl itself.
See the LICENSE file in this distribution.
=pod
All.pm 100664 023532 023421 21224 12544604516 14020 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR package UR::All;
use strict;
use warnings;
our $VERSION = "0.44"; # UR $VERSION;
BEGIN { require above; };
use UR;
use Command;
use Command::DynamicSubCommands;
use Command::Test;
use Command::Test::Echo;
use Command::Test::Tree1;
use Command::Test::Tree1::Echo1;
use Command::Test::Tree1::Echo2;
use Command::Tree;
use Command::V1;
use Command::V2;
use Devel::callcount;
use UR::BoolExpr;
use UR::BoolExpr::Template;
use UR::BoolExpr::Template::And;
use UR::BoolExpr::Template::Composite;
use UR::BoolExpr::Template::Or;
use UR::BoolExpr::Template::PropertyComparison;
use UR::BoolExpr::Template::PropertyComparison::Between;
use UR::BoolExpr::Template::PropertyComparison::Equals;
use UR::BoolExpr::Template::PropertyComparison::False;
use UR::BoolExpr::Template::PropertyComparison::GreaterOrEqual;
use UR::BoolExpr::Template::PropertyComparison::GreaterThan;
use UR::BoolExpr::Template::PropertyComparison::In;
use UR::BoolExpr::Template::PropertyComparison::LessOrEqual;
use UR::BoolExpr::Template::PropertyComparison::LessThan;
use UR::BoolExpr::Template::PropertyComparison::Like;
use UR::BoolExpr::Template::PropertyComparison::Matches;
use UR::BoolExpr::Template::PropertyComparison::NotEquals;
use UR::BoolExpr::Template::PropertyComparison::NotIn;
use UR::BoolExpr::Template::PropertyComparison::NotLike;
use UR::BoolExpr::Template::PropertyComparison::True;
use UR::BoolExpr::Util;
use UR::Change;
use UR::Context;
use UR::Context::DefaultRoot;
use UR::Context::ObjectFabricator;
use UR::Context::Process;
use UR::Context::Root;
use UR::Context::Transaction;
use UR::DataSource;
use UR::DataSource::Code;
use UR::DataSource::CSV;
use UR::DataSource::Default;
use UR::DataSource::File;
use UR::DataSource::FileMux;
use UR::DataSource::Meta;
BEGIN {
eval { require DBD::mysql };
require UR::DataSource::MySQL unless $@;
}
BEGIN {
eval { require DBD::Oracle };
require UR::DataSource::Oracle unless $@;
}
BEGIN {
eval { require DBD::Pg };
require UR::DataSource::Pg unless $@;
}
use UR::DataSource::RDBMS;
use UR::DataSource::RDBMS::BitmapIndex;
use UR::DataSource::RDBMS::Entity;
use UR::DataSource::RDBMS::FkConstraint;
use UR::DataSource::RDBMS::FkConstraintColumn;
use UR::DataSource::RDBMS::PkConstraintColumn;
use UR::DataSource::RDBMS::Table;
use UR::DataSource::RDBMS::Table::View::Default::Text;
use UR::DataSource::RDBMS::TableColumn;
use UR::DataSource::RDBMS::TableColumn::View::Default::Text;
use UR::DataSource::RDBMS::UniqueConstraintColumn;
use UR::DataSource::SQLite;
use UR::DataSource::ValueDomain;
use UR::DBI;
use UR::Debug;
use UR::DeletedRef;
use UR::Env::UR_COMMAND_DUMP_STATUS_MESSAGES;
use UR::Env::UR_CONTEXT_BASE;
use UR::Env::UR_CONTEXT_CACHE_SIZE_HIGHWATER;
use UR::Env::UR_CONTEXT_CACHE_SIZE_LOWWATER;
use UR::Env::UR_CONTEXT_MONITOR_QUERY;
use UR::Env::UR_CONTEXT_ROOT;
use UR::Env::UR_DBI_DUMP_STACK_ON_CONNECT;
use UR::Env::UR_DBI_EXPLAIN_SQL_CALLSTACK;
use UR::Env::UR_DBI_EXPLAIN_SQL_IF;
use UR::Env::UR_DBI_EXPLAIN_SQL_MATCH;
use UR::Env::UR_DBI_EXPLAIN_SQL_SLOW;
use UR::Env::UR_DBI_MONITOR_DML;
use UR::Env::UR_DBI_MONITOR_EVERY_FETCH;
use UR::Env::UR_DBI_MONITOR_SQL;
use UR::Env::UR_DBI_NO_COMMIT;
use UR::Env::UR_DEBUG_OBJECT_PRUNING;
use UR::Env::UR_DEBUG_OBJECT_RELEASE;
use UR::Env::UR_IGNORE;
use UR::Env::UR_NR_CPU;
use UR::Env::UR_STACK_DUMP_ON_DIE;
use UR::Env::UR_STACK_DUMP_ON_WARN;
use UR::Env::UR_TEST_QUIET;
use UR::Env::UR_USE_ANY;
use UR::Env::UR_USE_DUMMY_AUTOGENERATED_IDS;
use UR::Env::UR_USED_LIBS;
use UR::Env::UR_USED_MODS;
use UR::Exit;
use UR::ModuleBase;
use UR::ModuleBuild;
use UR::ModuleConfig;
use UR::ModuleLoader;
use UR::Namespace;
use UR::Namespace::Command;
use UR::Namespace::Command::Base;
use UR::Namespace::Command::Define;
use UR::Namespace::Command::Define::Class;
use UR::Namespace::Command::Define::Datasource;
use UR::Namespace::Command::Define::Datasource::File;
use UR::Namespace::Command::Define::Datasource::Mysql;
use UR::Namespace::Command::Define::Datasource::Oracle;
use UR::Namespace::Command::Define::Datasource::Pg;
use UR::Namespace::Command::Define::Datasource::Rdbms;
use UR::Namespace::Command::Define::Datasource::RdbmsWithAuth;
use UR::Namespace::Command::Define::Datasource::Sqlite;
use UR::Namespace::Command::Define::Db;
use UR::Namespace::Command::Define::Namespace;
use UR::Namespace::Command::Show::Properties;
use UR::Namespace::Command::Show::Schema;
use UR::Namespace::Command::Init;
use UR::Namespace::Command::List;
use UR::Namespace::Command::List::Classes;
use UR::Namespace::Command::List::Modules;
use UR::Namespace::Command::List::Objects;
use UR::Namespace::Command::Old;
use UR::Namespace::Command::Old::DiffRewrite;
use UR::Namespace::Command::Old::DiffUpdate;
use UR::Namespace::Command::Old::ExportDbicClasses;
use UR::Namespace::Command::Old::Info;
use UR::Namespace::Command::Old::Redescribe;
use UR::Namespace::Command::RunsOnModulesInTree;
use UR::Namespace::Command::Sys;
use UR::Namespace::Command::Sys::ClassBrowser;
use UR::Namespace::Command::Test;
use UR::Namespace::Command::Test::Callcount;
use UR::Namespace::Command::Test::Callcount::List;
use UR::Namespace::Command::Test::Compile;
use UR::Namespace::Command::Test::Eval;
use UR::Namespace::Command::Test::Run;
use UR::Namespace::Command::Test::TrackObjectRelease;
use UR::Namespace::Command::Test::Use;
use UR::Namespace::Command::Test::Window;
use UR::Namespace::Command::Update;
use UR::Namespace::Command::Update::ClassDiagram;
use UR::Namespace::Command::Update::ClassesFromDb;
use UR::Namespace::Command::Update::Pod;
use UR::Namespace::Command::Update::RenameClass;
use UR::Namespace::Command::Update::RewriteClassHeader;
use UR::Namespace::Command::Update::SchemaDiagram;
use UR::Namespace::Command::Update::TabCompletionSpec;
use UR::Object;
use UR::Object::Accessorized;
use UR::Object::Command::FetchAndDo;
use UR::Object::Command::List;
use UR::Object::Command::List::Style;
use UR::Object::Ghost;
use UR::Object::Index;
use UR::Object::Iterator;
use UR::Object::Property;
use UR::Object::Property::View::Default::Text;
use UR::Object::Property::View::DescriptionLineItem::Text;
use UR::Object::Property::View::ReferenceDescription::Text;
use UR::Object::Set;
use UR::Object::Set::View::Default::Json;
use UR::Object::Tag;
use UR::Object::Type;
use UR::Object::Type::AccessorWriter;
use UR::Object::Type::AccessorWriter::Product;
use UR::Object::Type::AccessorWriter::Sum;
use UR::Object::Type::Initializer;
use UR::Object::Type::InternalAPI;
use UR::Object::Type::ModuleWriter;
use UR::Object::Type::View::Default::Text;
use UR::Object::Value;
use UR::Object::View;
use UR::Object::View::Aspect;
use UR::Object::View::Default::Gtk;
use UR::Object::View::Default::Gtk2;
use UR::Object::View::Default::Json;
use UR::Object::View::Default::Text;
use UR::Object::View::Lister::Text;
use UR::Object::View::Toolkit;
use UR::Object::View::Toolkit::Text;
use UR::ObjectDeprecated;
use UR::ObjectV001removed;
use UR::ObjectV04removed;
use UR::Observer;
use UR::DBI::Report;
use UR::Service::RPC::Executer;
use UR::Service::RPC::Message;
use UR::Service::RPC::Server;
use UR::Service::RPC::TcpConnectionListener;
use UR::Singleton;
use UR::Util;
use UR::Value;
use UR::Value::ARRAY;
use UR::Value::Blob;
use UR::Value::CSV;
use UR::Value::DateTime;
use UR::Value::Decimal;
use UR::Value::DirectoryPath;
use UR::Value::FilePath;
use UR::Value::FilesystemPath;
use UR::Value::FOF;
use UR::Value::HASH;
use UR::Value::Integer;
use UR::Value::Iterator;
use UR::Value::Number;
use UR::Value::PerlReference;
use UR::Value::SCALAR;
use UR::Value::Set;
use UR::Value::Text;
use UR::Value::URL;
use UR::Vocabulary;
# optional elements
if (eval "use Net::HTTPServer") {
my $rv = eval "UR::Namespace::View::SchemaBrowser::CgiApp;"
&& eval "use UR::Namespace::View::SchemaBrowser::CgiApp::Base;"
&& eval "use UR::Namespace::View::SchemaBrowser::CgiApp::Class;"
&& eval "use UR::Namespace::View::SchemaBrowser::CgiApp::File;"
&& eval "use UR::Namespace::View::SchemaBrowser::CgiApp::Index;"
&& eval "use UR::Namespace::View::SchemaBrowser::CgiApp::Schema;"
&& eval "use UR::Service::JsonRpcServer;";
die $@ unless ($rv);
}
if (eval "use Xml::LibXSLT") {
my $rv = eval "use UR::Object::View::Default::Html;"
&& eval "use UR::Object::View::Default::Xsl;"
&& eval "use UR::Object::Set::View::Default::Xml;"
&& eval "use UR::Object::View::Default::Xml;"
&& eval "use UR::Object::Type::View::Default::Xml;"
;
die $@ unless ($rv);
}
1;
__END__
=pod
=head1 NAME
UR::All
=head1 SYNOPSIS
use UR::All;
=head1 DESCRIPTION
This module exists to let software preload everything in the distribution
It is slower than "use UR", but is good for things like FastCGI servers.
=cut
BoolExpr.pm 100664 023532 023421 140725 12544604516 15072 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR package UR::BoolExpr;
use warnings;
use strict;
use List::MoreUtils qw(uniq);
use List::Util qw(first);
use Scalar::Util qw(blessed);
require UR;
use Carp;
our @CARP_NOT = ('UR::Context');
our $VERSION = "0.44"; # UR $VERSION;;
# readable stringification
use overload ('""' => '__display_name__');
use overload ('==' => sub { $_[0] . '' eq $_[1] . '' } );
use overload ('eq' => sub { $_[0] . '' eq $_[1] . '' } );
UR::Object::Type->define(
class_name => 'UR::BoolExpr',
composite_id_separator => $UR::BoolExpr::Util::id_sep,
id_by => [
template_id => { type => 'Blob' },
value_id => { type => 'Blob' },
],
has => [
template => { is => 'UR::BoolExpr::Template', id_by => 'template_id' },
subject_class_name => { via => 'template' },
logic_type => { via => 'template' },
logic_detail => { via => 'template' },
num_values => { via => 'template' },
is_normalized => { via => 'template' },
is_id_only => { via => 'template' },
has_meta_options => { via => 'template' },
],
is_transactional => 0,
);
# for performance
sub UR::BoolExpr::Type::resolve_composite_id_from_ordered_values {
shift;
return join($UR::BoolExpr::Util::id_sep,@_);
}
# only respect the first delimiter instead of splitting
sub UR::BoolExpr::Type::resolve_ordered_values_from_composite_id {
my ($self,$id) = @_;
my $pos = index($id,$UR::BoolExpr::Util::id_sep);
return (substr($id,0,$pos), substr($id,$pos+1));
}
sub template {
my $self = $_[0];
return $self->{template} ||= $self->__template;
}
sub flatten {
my $self = shift;
return $self->{flatten} if exists $self->{flatten};
my $flat = $self->template->_flatten_bx($self);
$self->{flatten} = $flat;
Scalar::Util::weaken($self->{flatten}) if $self == $flat;
return $flat;
}
sub reframe {
my $self = shift;
my $in_terms_of = shift;
return $self->{reframe}{$in_terms_of} if $self->{reframe}{$in_terms_of};
my $reframe = $self->template->_reframe_bx($self, $in_terms_of);
$self->{reframe}{$in_terms_of} = $reframe;
Scalar::Util::weaken($self->{reframe}{$in_terms_of}) if $self == $reframe;
return $reframe;
}
# override the UR/system display name
# this is used in stringification overload
sub __display_name__ {
my $self = shift;
my %b = $self->_params_list;
my $s = Data::Dumper->new([\%b])->Terse(1)->Indent(0)->Useqq(1)->Sortkeys(1)->Dump;
$s =~ s/\n/ /gs;
$s =~ s/^\s*{//;
$s =~ s/\}\s*$//;
$s =~ s/\"(\w+)\" \=\> / $1 => /g;
return __PACKAGE__ . '=(' . $self->subject_class_name . ':' . $s . ')';
}
# The primary function: evaluate a subject object as matching the rule or not.
sub evaluate {
my $self = shift;
my $subject = shift;
my $template = $self->template;
my @values = $self->values;
return $template->evaluate_subject_and_values($subject,@values);
}
# Behind the id properties:
sub template_and_values {
my $self = shift;
my ($template_id, $value_id) = UR::BoolExpr::Type->resolve_ordered_values_from_composite_id($self->id);
return (UR::BoolExpr::Template->get($template_id), UR::BoolExpr::Util::value_id_to_values($value_id));
}
# Returns true if the rule represents a subset of the things the other
# rule would match. It returns undef if the answer is not known, such as
# when one of the values is a list and we didn't go to the trouble of
# searching the list for a matching value
sub is_subset_of {
my($self, $other_rule) = @_;
return 0 unless (ref($other_rule) and $self->isa(ref $other_rule));
my $my_template = $self->template;
my $other_template = $other_rule->template;
unless ($my_template->isa("UR::BoolExpr::Template::And")
and $other_template->isa("UR::BoolExpr::Template::And")) {
Carp::confess("This method currently works only on ::And expressions. Update to handle ::Or, ::PropertyComparison, and templates of mismatched class!");
}
return unless ($my_template->is_subset_of($other_template));
my $values_match = 1;
foreach my $prop ( $other_template->_property_names ) {
my $my_operator = $my_template->operator_for($prop) || '=';
my $other_operator = $other_template->operator_for($prop) || '=';
my $my_value = $self->value_for($prop);
my $other_value = $other_rule->value_for($prop);
# If either is a list of values, return undef
return undef if (ref($my_value) || ref($other_value));
no warnings 'uninitialized';
$values_match = undef if ($my_value ne $other_value);
}
return $values_match;
}
sub values {
my $self = shift;
if ($self->{values}) {
return @{ $self->{values}}
}
my $value_id = $self->value_id;
return unless defined($value_id) and length($value_id);
my @values;
@values = UR::BoolExpr::Util::value_id_to_values($value_id);
if (my $hard_refs = $self->{hard_refs}) {
for my $n (keys %$hard_refs) {
$values[$n] = $hard_refs->{$n};
}
}
$self->{values} = \@values;
return @values;
}
sub value_for_id {
my $self = shift;
my $t = $self->template;
my $position = $t->id_position;
return unless defined $position;
return $self->value_for_position($position);
}
sub specifies_value_for {
my $self = shift;
my $rule_template = $self->template;
return $rule_template->specifies_value_for(@_);
}
sub value_for {
my $self = shift;
my $property_name = shift;
# TODO: refactor to be more efficient
my $template = $self->template;
my $h = $self->legacy_params_hash;
my $v;
if (exists $h->{$property_name}) {
# normal case
$v = $h->{$property_name};
my $tmpl_pos = $template->value_position_for_property_name($property_name);
if (exists $self->{'hard_refs'}->{$tmpl_pos}) {
$v = $self->{'hard_refs'}->{$tmpl_pos}; # It was stored during resolve() as a hard ref
}
elsif ($self->_value_is_old_style_operator_and_value($v)) {
$v = $v->{'value'}; # It was old style operator/value hash
}
} else {
# No value found under that name... try decomposing the id
return if $property_name eq 'id';
my $id_value = $self->value_for('id');
my $class_meta = $self->subject_class_name->__meta__();
my @id_property_values = $class_meta->get_composite_id_decomposer->($id_value);
my @id_property_names = $class_meta->id_property_names;
for (my $i = 0; $i < @id_property_names; $i++) {
if ($id_property_names[$i] eq $property_name) {
$v = $id_property_values[$i];
last;
}
}
}
return $v;
}
sub value_for_position {
my ($self, $pos) = @_;
return ($self->values)[$pos];
}
sub operator_for {
my $self = shift;
my $t = $self->template;
return $t->operator_for(@_);
}
sub underlying_rules {
my $self = shift;
unless (exists $self->{'_underlying_rules'}) {
my @values = $self->values;
$self->{'_underlying_rules'} = [ $self->template->get_underlying_rules_for_values(@values) ];
}
return @{ $self->{'_underlying_rules'} };
}
# De-compose the rule back into its original form.
sub params_list {
# This is the reverse of the bulk of resolve.
# It returns the params in list form, directly coercable into a hash if necessary.
# $r = UR::BoolExpr->resolve($c1,@p1);
# ($c2, @p2) = ($r->subject_class_name, $r->params_list);
my $self = shift;
my $template = $self->template;
my @values_sorted = $self->values;
return $template->params_list_for_values(@values_sorted);
}
# TODO: replace these with the logical set operations
# FIXME: the name is confusing b/c it doesn't mutate the object, it returns a different object
sub add_filter {
my $self = shift;
return __PACKAGE__->resolve($self->subject_class_name, $self->params_list, @_);
}
# TODO: replace these with the logical set operations
# FIXME: the name is confusing b/c it doesn't mutate the object, it returns a different object
sub remove_filter {
my $self = shift;
my $property_name = shift;
my @params_list = $self->params_list;
my @new_params_list;
for (my $n=0; $n<=$#params_list; $n+=2) {
my $key = $params_list[$n];
if ($key =~ /^$property_name\b/) {
next;
}
my $value = $params_list[$n+1];
push @new_params_list, $key, $value;
}
return __PACKAGE__->resolve($self->subject_class_name, @new_params_list);
}
# as above, doesn't mutate, just returns a different bx
sub sub_classify {
my ($self,$subclass_name) = @_;
my ($t,@v) = $self->template_and_values();
return $t->sub_classify($subclass_name)->get_rule_for_values(@v);
}
# flyweight constructor
# like regular UR::Value objects, but kept separate from the cache but kept
# out of the regular transaction cache so they alwasy vaporize when derefed
sub get {
my $rule_id = pop;
unless (exists $UR::Object::rules->{$rule_id}) {
my $pos = index($rule_id,$UR::BoolExpr::Util::id_sep);
my ($template_id,$value_id) = (substr($rule_id,0,$pos), substr($rule_id,$pos+1));
my $rule = { id => $rule_id, template_id => $template_id, value_id => $value_id };
bless ($rule, "UR::BoolExpr");
$UR::Object::rules->{$rule_id} = $rule;
Scalar::Util::weaken($UR::Object::rules->{$rule_id});
return $rule;
}
return $UR::Object::rules->{$rule_id};
}
# because these are weakened
sub DESTROY {
delete $UR::Object::rules->{$_[0]->{id}};
}
sub flatten_hard_refs {
my $self = $_[0];
return $self if not $self->{hard_refs};
my $subject_class_name = $self->subject_class_name;
my $meta = $subject_class_name->__meta__;
my %params = $self->_params_list;
my $changes = 0;
for my $key (keys %params) {
my $value = $params{$key};
if (ref($value) and Scalar::Util::blessed($value) and $value->isa("UR::Object")) {
my ($property_name, $op) = ($key =~ /^(\S+)\s*(.*)/);
my $pmeta = $meta->property($property_name);
my $final_pmeta = $pmeta->final_property_meta();
my @possible_data_types = uniq grep { $_ } map { $_->data_type } ($pmeta, $final_pmeta);
unless (@possible_data_types) {
# this might not be possible at runtime
croak sprintf 'unable to determine data type for property: %s', $property_name;
}
my $data_type = first { $value->isa($_) } @possible_data_types;
unless ($data_type) {
croak sprintf 'value type, %s, is incompatible with: %s', $value->class, join(', ', @possible_data_types);
}
my $value2 = eval {
$data_type->get($value->id)
};
unless ($value2) {
croak sprintf 'unable to retrieve a %s by value ID: %s', $data_type, $value->id;
}
unless ($value2 eq $value) {
croak sprintf 'retrieved duplicate %s with ID, %s,', $data_type, $value->id;
}
# safe to re-represent as .id
my $new_key = $property_name . '.id';
$new_key .= ' ' . $op if $op;
delete $params{$key};
$params{$new_key} = $value->id;
$changes++;
}
}
if ($changes) {
return $self->resolve_normalized($subject_class_name, %params);
} else {
return $self;
}
}
sub resolve_normalized {
my $class = shift;
my ($unnormalized_rule, @extra) = $class->resolve(@_);
my $normalized_rule = $unnormalized_rule->normalize();
return if !defined(wantarray);
return ($normalized_rule,@extra) if wantarray;
if (@extra) {
no warnings;
my $rule_class = $normalized_rule->subject_class_name;
Carp::confess("Extra params for class $rule_class found: @extra\n");
}
return $normalized_rule;
}
sub resolve_for_template_id_and_values {
my ($class,$template_id, @values) = @_;
my $value_id = UR::BoolExpr::Util::values_to_value_id(@values);
my $rule_id = $class->__meta__->resolve_composite_id_from_ordered_values($template_id,$value_id);
$class->get($rule_id);
}
# Return true if it's a hashref that specifies the old-style operator/value
# like property => { operator => '=', value => 1 }
# FYI, the new way to do this is:
# 'property =' => 1
sub _value_is_old_style_operator_and_value {
my($class,$value) = @_;
return (ref($value) eq 'HASH')
&&
(exists($value->{'operator'}))
&&
(exists($value->{'value'}))
&&
( (keys(%$value) == 2)
||
((keys(%$value) == 3)
&& exists($value->{'escape'}))
);
}
my $resolve_depth;
sub resolve {
$resolve_depth++;
Carp::confess("Deep recursion in UR::BoolExpr::resolve()!") if $resolve_depth > 10;
# handle the case in which we've already processed the params into a boolexpr
if ( @_ == 3 and ref($_[2]) and ref($_[2])->isa("UR::BoolExpr") ) {
$resolve_depth--;
return $_[2];
}
my $class = shift;
my $subject_class = shift;
Carp::confess("Can't resolve BoolExpr: expected subject class as arg 2, got '$subject_class'") if not $subject_class;
# support for legacy passing of hashref instead of object or list
# TODO: eliminate the need for this
my @in_params;
if ($subject_class->isa('UR::Value::PerlReference') and $subject_class eq 'UR::Value::' . ref($_[0])) {
@in_params = @_;
}
elsif (ref($_[0]) eq "HASH") {
@in_params = %{$_[0]};
}
else {
@in_params = @_;
}
if (defined($in_params[0]) and $in_params[0] eq '-or') {
shift @in_params;
my @sub_queries = @{ shift @in_params };
my @meta_params;
for (my $i = 0; $i < @in_params; $i += 2 ) {
if ($in_params[$i] =~ m/^-/) {
push @meta_params, $in_params[$i], $in_params[$i+1];
}
}
my $bx = UR::BoolExpr::Template::Or->_compose(
$subject_class,
\@sub_queries,
\@meta_params,
);
$resolve_depth--;
return $bx;
}
if (@in_params == 1) {
unshift @in_params, "id";
}
elsif (@in_params % 2 == 1) {
Carp::carp("Odd number of params while creating $class: (",join(',',@in_params),")");
}
# split the params into keys and values
# where an operator is on the right-side, it is moved into the key
my $count = @in_params;
my (@keys,@values,@constant_values,$key,$value,$property_name,$operator,@hard_refs);
for(my $n = 0; $n < $count;) {
$key = $in_params[$n++];
$value = $in_params[$n++];
unless (defined $key) {
Carp::croak("Can't resolve BoolExpr: undef is an invalid key/property name. Args were: ".join(', ',@in_params));
}
if (UR::BoolExpr::Util::is_meta_param($key)) {
# these are keys whose values live in the rule template
push @keys, $key;
push @constant_values, $value;
next;
}
if ($key =~ m/^(_id_only|_param_key|_unique|__get_serial|_change_count)$/) {
# skip the pair: legacy/internal cruft
next;
}
my $pos = index($key,' ');
if ($pos != -1) {
# the key is "propname op"
$property_name = substr($key,0,$pos);
$operator = substr($key,$pos+1);
if (substr($operator,0,1) eq ' ') {
$operator =~ s/^\s+//;
}
}
else {
# the key is "propname"
$property_name = $key;
$operator = '';
}
if (my $ref = ref($value)) {
if ( (not $operator) and ($ref eq "HASH")) {
if ( $class->_value_is_old_style_operator_and_value($value)) {
# the key => { operator => $o, value => $v } syntax
# cannot be used with a value type of HASH
$operator = defined($value->{operator})
? lc($value->{operator})
: '';
if (exists $value->{escape}) {
$operator .= "-" . $value->{escape}
}
$key .= " " . $operator;
$value = $value->{value};
$ref = ref($value);
}
else {
# the HASH is a value for the specified param
push @hard_refs, scalar(@values), $value;
}
}
if ($ref eq "ARRAY") {
if (not $operator) {
# key => [] is the same as "key in" => []
$operator = 'in';
$key .= ' in';
}
elsif ($operator eq 'not') {
# "key not" => [] is the same as "key not in"
$operator .= ' in';
$key .= ' in';
}
foreach my $val (@$value) {
if (ref($val)) {
# when there are any refs in the arrayref
# we must keep the arrayerf contents
# to reconstruct effectively
push @hard_refs, scalar(@values), $value;
last;
}
}
} # done handling ARRAY value
} # done handling ref values
push @keys, $key;
push @values, $value;
}
# the above uses no class metadata
# this next section uses class metadata
# it should be moved into the normalization layer
my $subject_class_meta = eval { $subject_class->__meta__ };
if ($@) {
Carp::croak("Can't get class metadata for $subject_class. Is it a valid class name?\nErrors were: $@");
}
unless ($subject_class_meta) {
Carp::croak("No class metadata for $subject_class?!");
}
my $subject_class_props =
$subject_class_meta->{'cache'}{'UR::BoolExpr::resolve'} ||=
{ map {$_, 1} ( $subject_class_meta->all_property_type_names) };
my($kn, $vn, $cn, $complex_values) = (0,0,0,0);
my ($op,@extra,@xadd_keys,@xadd_values,@xremove_keys,@xremove_values,@extra_key_pos,@extra_value_pos,
@swap_key_pos,@swap_key_value);
for my $value (@values) {
$key = $keys[$kn++];
if (UR::BoolExpr::Util::is_meta_param($key)) {
$cn++;
redo;
}
else {
$vn++;
}
my $pos = index($key,' ');
if ($pos != -1) {
# "propname op"
$property_name = substr($key,0,$pos);
$operator = substr($key,$pos+1);
if (substr($operator,0,1) eq ' ') {
$operator =~ s/^\s+//;
}
}
else {
# "propname"
$property_name = $key;
$operator = '';
}
# account for the case where this parameter does
# not match an actual property
my $base_property_name = $property_name;
$base_property_name =~ s/[.-].+//;
if (!exists $subject_class_props->{$base_property_name}) {
if (substr($property_name,0,1) eq '_') {
warn "ignoring $property_name in $subject_class bx construction!"
}
else {
push @extra_key_pos, $kn-1;
push @extra_value_pos, $vn-1;
next;
}
}
my $ref = ref($value);
if($ref) {
$complex_values = 1;
if ($ref eq "ARRAY" and $operator ne 'between' and $operator ne 'not between') {
my $data_type;
my $is_many;
if ($UR::initialized) {
my $property_meta = $subject_class_meta->property_meta_for_name($property_name);
unless (defined $property_meta) {
push @extra_key_pos, $kn-1;
push @extra_value_pos, $vn-1;
next;
}
$data_type = $property_meta->data_type;
$is_many = $property_meta->is_many;
}
else {
if (exists $subject_class_meta->{has}{$property_name}) {
$data_type = $subject_class_meta->{has}{$property_name}{data_type};
$is_many = $subject_class_meta->{has}{$property_name}{is_many};
}
}
$data_type ||= '';
if ($data_type eq 'ARRAY') {
# ensure we re-constitute the original array not a copy
push @hard_refs, $vn-1, $value;
push @swap_key_pos, $vn-1;
push @swap_key_value, $property_name;
}
elsif (not $is_many) {
no warnings;
# sort and replace
# note that in perl5.10 and above strings like "inf*" have a numeric value
# causing this kind of sorting to do surprising things. Hopefully looks_like_number()
# does the right thing with these.
#
# undef/null sorts at the end
my $sorter = sub { if (! defined($a)) { return 1 }
if (! defined($b)) { return -1}
return $a cmp $b; };
$value = [ sort $sorter @$value ];
# Remove duplicates from the list
my $last = $value;
for (my $i = 0; $i < @$value;) {
if ($last eq $value->[$i]) {
splice(@$value, $i, 1);
}
else {
$last = $value->[$i++];
}
}
# push @swap_key_pos, $vn-1;
# push @swap_key_value, $property_name;
}
else {
# disable: break 47, enable: break 62
#push @swap_key_pos, $vn-1;
#push @swap_key_value, $property_name;
}
}
elsif (blessed($value)) {
my $property_meta = $subject_class_meta->property_meta_for_name($property_name);
unless ($property_meta) {
for my $class_name ($subject_class_meta->ancestry_class_names) {
my $class_object = $class_name->__meta__;
$property_meta = $subject_class_meta->property_meta_for_name($property_name);
last if $property_meta;
}
unless ($property_meta) {
Carp::croak("No property metadata for $subject_class property '$property_name'");
}
}
if ($property_meta->id_by or $property_meta->reverse_as) {
my $property_meta = $subject_class_meta->property_meta_for_name($property_name);
unless ($property_meta) {
Carp::croak("No property metadata for $subject_class property '$property_name'");
}
my @joins = $property_meta->get_property_name_pairs_for_join();
for my $join (@joins) {
# does this really work for >1 joins?
my ($my_method, $their_method) = @$join;
push @xadd_keys, $my_method;
push @xadd_values, $value->$their_method;
}
# TODO: this may need to be moved into the above get_property_name_pairs_for_join(),
# but the exact syntax for expressing that this is part of the join is unclear.
if (my $id_class_by = $property_meta->id_class_by) {
push @xadd_keys, $id_class_by;
push @xadd_values, ref($value);
}
push @xremove_keys, $kn-1;
push @xremove_values, $vn-1;
}
elsif ($property_meta->is_valid_storage_for_value($value)) {
push @hard_refs, $vn-1, $value;
}
elsif ($value->can($property_name)) {
# TODO: stop suporting foo_id => $foo, since you can do foo=>$foo, and foo_id=>$foo->id
# Carp::cluck("using $property_name => \$obj to get $property_name => \$obj->$property_name is deprecated...");
$value = $value->$property_name;
}
else {
$operator = 'eq' unless $operator;
$DB::single = 1;
print $value->isa($property_meta->_data_type_as_class_name),"\n";
print $value->isa($property_meta->_data_type_as_class_name),"\n";
Carp::croak("Invalid data type in rule. A value of type " . ref($value) . " cannot be used in class $subject_class property '$property_name' with operator $operator!");
}
# end of handling a value which is an arrayref
}
elsif ($ref ne 'HASH') {
# other reference, code, etc.
push @hard_refs, $vn-1, $value;
}
}
}
push @keys, @xadd_keys;
push @values, @xadd_values;
if (@swap_key_pos) {
@keys[@swap_key_pos] = @swap_key_value;
}
if (@extra_key_pos) {
push @xremove_keys, @extra_key_pos;
push @xremove_values, @extra_value_pos;
for (my $n = 0; $n < @extra_key_pos; $n++) {
push @extra, $keys[$extra_key_pos[$n]], $values[$extra_value_pos[$n]];
}
}
if (@xremove_keys) {
my $write_key_idx = 0;
for (my($read_key_idx, $xremove_key_idx) = (0,0);
$read_key_idx < @keys;
$read_key_idx++
) {
if ($xremove_key_idx < @xremove_keys
and
$read_key_idx == $xremove_keys[$xremove_key_idx]
) {
$xremove_key_idx++;
next;
}
$keys[$write_key_idx++] = $keys[$read_key_idx];
}
$#keys = $write_key_idx-1;
}
if (@xremove_values) {
if (@hard_refs) {
# shift the numbers down to account for positional removals
for (my $n = 0; $n < @hard_refs; $n+=2) {
my $ref_pos = $hard_refs[$n];
for my $rem_pos (@xremove_values) {
if ($rem_pos < $ref_pos) {
$hard_refs[$n] -= 1;
#print "$n from $ref_pos to $hard_refs[$n]\n";
$ref_pos = $hard_refs[$n];
}
elsif ($rem_pos == $ref_pos) {
$hard_refs[$n] = '';
$hard_refs[$n+1] = undef;
}
}
}
}
my $write_value_idx = 0;
for(my($read_value_idx, $xremove_value_idx) = (0,0);
$read_value_idx < @values;
$read_value_idx++
) {
if ($xremove_value_idx < @xremove_values
and
$read_value_idx == $xremove_values[$xremove_value_idx]
) {
$xremove_value_idx++;
next;
}
$values[$write_value_idx++] = $values[$read_value_idx];
}
$#values = $write_value_idx-1;
}
my $template;
if (@constant_values) {
$template = UR::BoolExpr::Template::And->_fast_construct(
$subject_class,
\@keys,
\@constant_values,
);
}
else {
$template = $subject_class_meta->{cache}{"UR::BoolExpr::resolve"}{"template for class and keys without constant values"}{"$subject_class @keys"}
||= UR::BoolExpr::Template::And->_fast_construct(
$subject_class,
\@keys,
\@constant_values,
);
}
my $value_id = UR::BoolExpr::Util::values_to_value_id(@values);
my $rule_id = join($UR::BoolExpr::Util::id_sep,$template->{id},$value_id);
my $rule = __PACKAGE__->get($rule_id); # flyweight constructor
$rule->{template} = $template;
$rule->{values} = \@values;
$vn = 0;
$cn = 0;
my @list;
for my $key (@keys) {
push @list, $key;
if (UR::BoolExpr::Util::is_meta_param($key)) {
push @list, $constant_values[$cn++];
}
else {
push @list, $values[$vn++];
}
}
$rule->{_params_list} = \@list;
if (@hard_refs) {
$rule->{hard_refs} = { @hard_refs };
delete $rule->{hard_refs}{''};
}
$resolve_depth--;
if (wantarray) {
return ($rule, @extra);
}
elsif (@extra && defined wantarray) {
Carp::confess("Unknown parameters in rule for $subject_class: " . join(",", map { defined($_) ? "'$_'" : "(undef)" } @extra));
}
else {
return $rule;
}
}
sub _params_list {
my $list = $_[0]->{_params_list} ||= do {
my $self = $_[0];
my $template = $self->template;
$self->values unless $self->{values};
my @list;
# are method calls really too expensive here?
my $template_class = ref($template);
if ($template_class eq 'UR::BoolExpr::Template::And') {
my ($k,$v,$c) = ($template->{_keys}, $self->{values}, $template->{_constant_values});
my $vn = 0;
my $cn = 0;
for my $key (@$k) {
push @list, $key;
if (UR::BoolExpr::Util::is_meta_param($key)) {
push @list, $c->[$cn++];
}
else {
push @list, $v->[$vn++];
}
}
}
elsif ($template_class eq 'UR::BoolExpr::Template::Or') {
my @sublist;
my @u = $self->underlying_rules();
for my $u (@u) {
my @p = $u->_params_list;
push @sublist, \@p;
}
@list = (-or => \@sublist);
}
elsif ($template_class->isa("UR::BoolExpr::PropertyComparison")) {
@list = ($template->logic_detail => [@{$self->{values}}]);
}
\@list;
};
return @$list;
}
sub normalize {
my $self = shift;
my $rule_template = $self->template;
if ($rule_template->{is_normalized}) {
return $self;
}
my @unnormalized_values = $self->values();
my $normalized = $rule_template->get_normalized_rule_for_values(@unnormalized_values);
return unless defined $normalized;
if (my $special = $self->{hard_refs}) {
$normalized->{hard_refs} = $rule_template->_normalize_non_ur_values_hash($special);
}
return $normalized;
}
# a handful of places still use this
sub legacy_params_hash {
my $self = shift;
# See if we have one already.
my $params_array = $self->{legacy_params_array};
return { @$params_array } if $params_array;
# Make one by starting with the one on the rule template
my $rule_template = $self->template;
my $params = { %{$rule_template->legacy_params_hash}, $self->params_list };
# If the template has a _param_key, fill it in.
if (exists $params->{_param_key}) {
$params->{_param_key} = $self->id;
}
# This was cached above and will return immediately on the next call.
# Note: the caller should copy this reference before making changes.
$self->{legacy_params_array} = [ %$params ];
return $params;
}
my $LOADED_BXPARSE = 0;
sub resolve_for_string {
my ($class, $subject_class_name, $filter_string, $usage_hints_string, $order_string, $page_string) = @_;
unless ($LOADED_BXPARSE) {
eval { require UR::BoolExpr::BxParser };
if ($@) {
Carp::croak("resolve_for_string() can't load UR::BoolExpr::BxParser: $@");
}
$LOADED_BXPARSE=1;
}
#$DB::single=1;
#my $tree = UR::BoolExpr::BxParser::parse($filter_string, tokdebug => 1, yydebug => 7);
my($tree, $remaining_strref) = UR::BoolExpr::BxParser::parse($filter_string);
unless ($tree) {
Carp::croak("resolve_for_string() couldn't parse string \"$filter_string\"");
}
push @$tree, '-hints', [split(',',$usage_hints_string) ] if ($usage_hints_string);
push @$tree, '-order_by', [split(',',$order_string) ] if ($order_string);
push @$tree, '-page', [split(',',$page_string) ] if ($page_string);
my ($bx, @extra);
if(wantarray) {
($bx, @extra) = UR::BoolExpr->resolve($subject_class_name, @$tree);
} else {
$bx = UR::BoolExpr->resolve($subject_class_name, @$tree);
}
unless ($bx) {
Carp::croak("Can't create BoolExpr on $subject_class_name from params generated from string "
. $filter_string . " which parsed as:\n"
. Data::Dumper::Dumper($tree));
}
if ($$remaining_strref) {
Carp::croak("Trailing input after the parsable end of the filter string: '". $$remaining_strref."'");
}
if(wantarray) {
return ($bx, @extra);
} else {
return $bx;
}
}
sub _resolve_from_filter_array {
my $class = shift;
my $subject_class_name = shift;
my $filters = shift;
my $usage_hints = shift;
my $order = shift;
my $page = shift;
my @rule_filters;
my @keys;
my @values;
for my $fdata (@$filters) {
my $rule_filter;
# rule component
my $key = $fdata->[0];
my $value;
# process the operator
if ($fdata->[1] =~ /^!?(:|@|between|in)$/i) {
my @list_parts;
my @range_parts;
if ($fdata->[1] eq "@") {
# file path
my $fh = IO::File->new($fdata->[2]);
unless ($fh) {
die "Failed to open file $fdata->[2]: $!\n";
}
@list_parts = $fh->getlines;
chomp @list_parts;
$fh->close;
}
else {
@list_parts = split(/\//,$fdata->[2]);
@range_parts = split(/-/,$fdata->[2]);
}
if (@list_parts > 1) {
my $op = ($fdata->[1] =~ /^!/ ? 'not in' : 'in');
# rule component
if (substr($key, -3, 3) ne ' in') {
$key = join(' ', $key, $op);
}
$value = \@list_parts;
$rule_filter = [$fdata->[0],$op,\@list_parts];
}
elsif (@range_parts >= 2) {
if (@range_parts > 2) {
if (@range_parts % 2) {
die "The \":\" operator expects a range sparated by a single dash: @range_parts ." . "\n";
}
else {
my $half = (@range_parts)/2;
$a = join("-",@range_parts[0..($half-1)]);
$b = join("-",@range_parts[$half..$#range_parts]);
}
}
elsif (@range_parts == 2) {
($a,$b) = @range_parts;
}
else {
die 'The ":" operator expects a range sparated by a dash.' . "\n";
}
$key = $fdata->[0] . " between";
$value = [$a, $b];
$rule_filter = [$fdata->[0], "between", [$a, $b] ];
}
else {
die 'The ":" operator expects a range sparated by a dash, or a slash-separated list.' . "\n";
}
}
# this accounts for cases where value is null
elsif (length($fdata->[2])==0) {
if ($fdata->[1] eq "=") {
$key = $fdata->[0];
$value = undef;
$rule_filter = [ $fdata->[0], "=", undef ];
}
else {
$key = $fdata->[0] . " !=";
$value = undef;
$rule_filter = [ $fdata->[0], "!=", undef ];
}
}
else {
$key = $fdata->[0] . ($fdata->[1] and $fdata->[1] ne '='? ' ' . $fdata->[1] : '');
$value = $fdata->[2];
$rule_filter = [ @$fdata ];
}
push @keys, $key;
push @values, $value;
}
if ($usage_hints or $order or $page) {
# todo: incorporate hints in a smarter way
my %p;
for my $key (@keys) {
$p{$key} = shift @values;
}
return $class->resolve(
$subject_class_name,
%p,
($usage_hints ? (-hints => $usage_hints) : () ),
($order ? (-order => $order) : () ),
($page ? (-page => $page) : () ),
);
}
else {
return UR::BoolExpr->_resolve_from_subject_class_name_keys_and_values(
subject_class_name => $subject_class_name,
keys => \@keys,
values=> \@values,
);
}
}
sub _resolve_from_subject_class_name_keys_and_values {
my $class = shift;
my %params = @_;
my $subject_class_name = $params{subject_class_name};
my @values = @{ $params{values} || [] };
my @constant_values = @{ $params{constant_values} || [] };
my @keys = @{ $params{keys} || [] };
die "unexpected params: " . Data::Dumper::Dumper(\%params) if %params;
my $value_id = UR::BoolExpr::Util::values_to_value_id(@values);
my $constant_value_id = UR::BoolExpr::Util::values_to_value_id(@constant_values);
my $template_id = $subject_class_name . '/And/' . join(",",@keys) . "/" . $constant_value_id;
my $rule_id = join($UR::BoolExpr::Util::id_sep,$template_id,$value_id);
my $rule = __PACKAGE__->get($rule_id);
$rule->{values} = \@values;
return $rule;
}
1;
=pod
=head1 NAME
UR::BoolExpr - a "where clause" for objects
=head1 SYNOPSIS
my $o = Acme::Employee->create(
ssn => '123-45-6789',
name => 'Pat Jones',
status => 'active',
start_date => UR::Context->current->now,
payroll_category => 'hourly',
boss => $other_employee,
);
my $bx = Acme::Employee->define_boolexpr(
'payroll_category' => 'hourly',
'status' => ['active','terminated'],
'name like' => '%Jones',
'ssn matches' => '\d{3}-\d{2}-\d{4}',
'start_date between' => ['2009-01-01','2009-02-01'],
'boss.name in' => ['Cletus Titus', 'Mitzy Mayhem'],
);
$bx->evaluate($o); # true
$bx->specifies_value_for('payroll_category') # true
$bx->value_for('payroll_cagtegory') # 'hourly'
$o->payroll_category('salary');
$bx->evaluate($o); # false
# these could take either a boolean expression, or a list of params
# from which it will generate one on-the-fly
my $set = Acme::Employee->define_set($bx); # same as listing all of the params
my @matches = Acme::Employee->get($bx); # same as above, but returns the members
my $bx2 = $bx->reframe('boss');
#'employees.payroll_category' => 'hourly',
#'employees.status' => ['active','terminated'],
#'employees.name like' => '%Jones',
#'employees.ssn matches' => '\d{3}-\d{2}-\d{4}',
#'employees.start_date between' => ['2009-01-01','2009-02-01'],
#'name in' => ['Cletus Titus', 'Mitzy Mayhem'],
my $bx3 = $bx->flatten();
# any indirection in the params takes the form a.b.c at the lowest level
# also 'payroll_category' might become 'pay_history.category', and 'pay_history.is_current' => 1 is added to the list
# if this parameter has that as a custom filter
=head1 DESCRIPTION
A UR::BoolExpr object captures a set of match criteria for some class of object.
Calls to get(), create(), and define_set() all use this internally to objectify
their parameters. If given a boolean expression object directly they will use it.
Otherwise they will construct one from the parameters given.
They have a 1:1 correspondence within the WHERE clause in an SQL statement where
RDBMS persistance is used. They also imply the FROM clause in these cases,
since the query properties control which joins must be included to return
the matching object set.
=head1 REFLECTION
The data used to create the boolean expression can be re-extracted:
my $c = $r->subject_class_name;
# $c eq "GSC::Clone"
my @p = $r->params_list;
# @p = four items
my %p = $r->params_list;
# %p = two key value pairs
=head1 TEMPLATE SUBCLASSES
The template behind the expression can be of type ::Or, ::And or ::PropertyComparison.
These classes handle all of the operating logic for the expressions.
Each of those classes incapsulates 0..n of the next type in the list. All templates
simplify to this level. See L for details.
=head1 CONSTRUCTOR
=over 4
my $bx = UR::BoolExpr->resolve('Some::Class', property_1 => 'value_1', ... property_n => 'value_n');
my $bx1 = Some::Class->define_boolexpr(property_1 => value_1, ... property_n => 'value_n');
my $bx2 = Some::Class->define_boolexpr('property_1 >' => 12345);
my $bx3 = UR::BoolExpr->resolve_for_string(
'Some::Class',
'property_1 = value_1 and ( property_2 < value_2 or property_3 = value_3 )',
);
Returns a UR::BoolExpr object that can be used to perform tests on the given class and
properties. The default comparison for each property is equality. The third example shows
using greater-than operator for property_1. The last example shows constructing a
UR::BoolExpr from a string containing properties, operators and values joined with
'and' and 'or', with parentheses indicating precedence.
=back
C can parse simple and complicated expressions. A simple expression
is a property name followed by an operator followed by a value. The property name can be
a series of properties joined by dots (.) to indicate traversal of multiple layers of
indirect properties. Values that include spaces, characters that look like operators,
commas, or other special characters should be enclosed in quotes.
The parser understands all the same operators the underlying C method understands:
=, <, >, <=, >=, "like", "between" and "in". Operators may be prefixed by a bang (!) or the
word "not" to negate the operator. The "like" operator understands the SQL wildcards % and _.
Values for the "between" operator should be separated by a minus (-). Values for the "in"
operator should begin with a left bracket, end with a right bracket, and have commas between
them. For example:
name_property in [Bob,Fred,Joe]
Simple expressions may be joined together with the words "and" and "or" to form a more
complicated expression. "and" has higher precedence than "or", and parentheses can
surround sub-expressions to indicate the requested precedence. For example:
((prop1 = foo or prop2 = 1) and (prop2 > 10 or prop3 like 'Yo%')) or prop4 in [1,2,3]
In general, whitespace is insignificant. The strings "prop1 = 1" is parsed the same as
"prop1=1". Spaces inside quoted value strings are preserved. For backward compatibility
with the deprecated string parser, bare words that appear after the operators =,<,>,<=
and >= which are separated by one or more spaces is treated as if it had quotes around
the list of words starting with the first character of the first word and ending with
the last character of the last word, meaning that spaces at the start and end of the
list are trimmed.
Specific ordering may be requested by putting an "order by" clause at the end, and is the
same as using a -order argument to resolve():
score > 10 order by name,score.
Likewise, grouping and Set construction is indicated with a "group by" clause:
score > 10 group by color
=head1 METHODS
=over 4
=item evaluate
$bx->evaluate($object)
Returns true if the given object satisfies the BoolExpr
=item template_and_values
($template, @values) = $bx->template_and_values();
Returns the UR::BoolExpr::Template and list of the values for the given BoolExpr
=item is_subset_of
$bx->is_subset_of($other_bx)
Returns true if the set of objects that matches this BoolExpr is a subset of
the set of objects that matches $other_bx. In practice this means:
* The subject class of $bx isa the subject class of $other_bx
* all the properties from $bx also appear in $other_bx
* the operators and values for $bx's properties match $other_bx
=item values
@values = $bx->values
Return a list of the values from $bx. The values will be in the same order
the BoolExpr was created from
=item value_for_id
$id = $bx->value_for_id
If $bx's properties include all the ID properties of its subject class,
C returns that value. Otherwise, it returns the empty list.
If the subject class has more than one ID property, this returns the value
of the composite ID.
=item specifies_value_for
$bx->specifies_value_for('property_name');
Returns true if the filter list of $bx includes the given property name
=item value_for
my $value = $bx->value_for('property_name');
Return the value for the given property
=item operator_for
my $operator = $bx->operator_for('property_name');
Return a string for the operator of the given property. A value of '' (the
empty string) means equality ("="). Other possible values inclue '<', '>',
'<=', '>=', 'between', 'true', 'false', 'in', 'not <', 'not >', etc.
=item normalize
$bx2 = $bx->normalize;
A boolen expression can be changed in incidental ways and still be equivalent.
This method converts the expression into a normalized form so that it can be
compared to other normalized expressions without incidental differences
affecting the comparision.
=item flatten
$bx2 = $bx->flatten();
Transforms a boolean expression into a functional equivalent where
indirect properties are turned into property chains.
For instance, in a class with
a => { is => "A", id_by => "a_id" },
b => { via => "a", to => "bb" },
c => { via => "b", to => "cc" },
An expression of:
c => 1234
Becomes:
a.bb.cc => 1234
In cases where one of the indirect properties includes a "where" clause,
the flattened expression would have an additional value for each element:
a => { is => "A", id_by => "a_id" },
b => { via => "a", to => "bb" },
c => { via => "b", where ["xx" => 5678], to => "cc" },
An expression of:
c => 1234
Becomes:
a.bb.cc => 1234
a.bb.xx => 5678
=item reframe
$bx = Acme::Order->define_boolexpr(status => 'active');
$bx2 = $bx->reframe('customer');
The above will turn a query for orders which are active into a query for
customers with active orders, presuming an Acme::Order has a property called
"customer" with a defined relationship to another class.
=back
=head1 INTERNAL STRUCTURE
A boolean expression (or "rule") has an "id", which completely describes the rule in stringified form,
and a method called evaluate($o) which tests the rule on a given object.
The id is composed of two parts:
- A template_id.
- A value_id.
Nearly all real work delegates to the template to avoid duplication of cached details.
The template_id embeds several other properties, for which the rule delegates to it:
- subject_class_name, objects of which the rule can be applied-to
- subclass_name, the subclass of rule (property comparison, and, or "or")
- the body of the rule either key-op-val, or a list of other rules
For example, the rule GSC::Clone name=x,chromosome>y:
- the template_id embeds:
subject_class_name = GSC::Clone
subclass_name = UR::BoolExpr::And
and the key-op pairs in sorted order: "chromosome>,name="
- the value_id embeds the x,y values in a special format
=head1 EXAMPLES
my $bool = $x->evaluate($obj);
my $t = GSC::Clone->template_for_params(
"status =",
"chromosome []",
"clone_name like",
"clone_size between"
);
my @results = $t->get_matching_objects(
"active",
[2,4,7],
"Foo%",
[100000,200000]
);
my $r = $t->get_rule($v1,$v2,$v3);
my $t = $r->template;
my @results = $t->get_matching_objects($v1,$v2,$v3);
my @results = $r->get_matching_objects();
@r = $r->underlying_rules();
for (@r) {
print $r->evaluate($c1);
}
my $rt = $r->template();
my @rt = $rt->get_underlying_rule_templates();
$r = $rt->get_rule_for_values(@v);
$r = UR::BoolExpr->resolve_for_string(
'My::Class',
'name=Bob and (score=10 or score < 5)',
);
=head1 SEE ALSO
UR(3), UR::Object(3), UR::Object::Set(3), UR::BoolExpr::Template(3)
=cut
BxParser.pm 100664 023532 023421 120032 12544604516 16605 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/BoolExpr ####################################################################
#
# This file was generated using Parse::Yapp version 1.05.
#
# Don't edit this file, use source file instead.
#
# ANY CHANGE MADE HERE WILL BE LOST !
#
####################################################################
package UR::BoolExpr::BxParser;
use vars qw ( @ISA );
use strict;
@ISA= qw ( UR::BoolExpr::BxParser::Yapp::Driver );
#Included Parse/Yapp/Driver.pm file----------------------------------------
{
#
# Module UR::BoolExpr::BxParser::Yapp::Driver
#
# This module is part of the Parse::Yapp package available on your
# nearest CPAN
#
# Any use of this module in a standalone parser make the included
# text under the same copyright as the Parse::Yapp module itself.
#
# This notice should remain unchanged.
#
# (c) Copyright 1998-2001 Francois Desarmenien, all rights reserved.
# (see the pod text in Parse::Yapp module for use and distribution rights)
#
package UR::BoolExpr::BxParser::Yapp::Driver;
require 5.004;
use strict;
use vars qw ( $VERSION $COMPATIBLE $FILENAME );
$VERSION = '1.05'; # No BumpVersion
$COMPATIBLE = '0.07';
$FILENAME=__FILE__;
use Carp;
#Known parameters, all starting with YY (leading YY will be discarded)
my(%params)=(YYLEX => 'CODE', 'YYERROR' => 'CODE', YYVERSION => '',
YYRULES => 'ARRAY', YYSTATES => 'ARRAY', YYDEBUG => '');
#Mandatory parameters
my(@params)=('LEX','RULES','STATES');
sub new {
my($class)=shift;
my($errst,$nberr,$token,$value,$check,$dotpos);
my($self)={ ERROR => \&_Error,
ERRST => \$errst,
NBERR => \$nberr,
TOKEN => \$token,
VALUE => \$value,
DOTPOS => \$dotpos,
STACK => [],
DEBUG => 0,
CHECK => \$check };
_CheckParams( [], \%params, \@_, $self );
exists($$self{VERSION})
and $$self{VERSION} < $COMPATIBLE
and croak "Yapp driver version $VERSION ".
"incompatible with version $$self{VERSION}:\n".
"Please recompile parser module.";
ref($class)
and $class=ref($class);
bless($self,$class);
}
sub YYParse {
my($self)=shift;
my($retval);
_CheckParams( \@params, \%params, \@_, $self );
if($$self{DEBUG}) {
_DBLoad();
$retval = eval '$self->_DBParse()';#Do not create stab entry on compile
$@ and die $@;
}
else {
$retval = $self->_Parse();
}
$retval
}
sub YYData {
my($self)=shift;
exists($$self{USER})
or $$self{USER}={};
$$self{USER};
}
sub YYErrok {
my($self)=shift;
${$$self{ERRST}}=0;
undef;
}
sub YYNberr {
my($self)=shift;
${$$self{NBERR}};
}
sub YYRecovering {
my($self)=shift;
${$$self{ERRST}} != 0;
}
sub YYAbort {
my($self)=shift;
${$$self{CHECK}}='ABORT';
undef;
}
sub YYAccept {
my($self)=shift;
${$$self{CHECK}}='ACCEPT';
undef;
}
sub YYError {
my($self)=shift;
${$$self{CHECK}}='ERROR';
undef;
}
sub YYSemval {
my($self)=shift;
my($index)= $_[0] - ${$$self{DOTPOS}} - 1;
$index < 0
and -$index <= @{$$self{STACK}}
and return $$self{STACK}[$index][1];
undef; #Invalid index
}
sub YYCurtok {
my($self)=shift;
@_
and ${$$self{TOKEN}}=$_[0];
${$$self{TOKEN}};
}
sub YYCurval {
my($self)=shift;
@_
and ${$$self{VALUE}}=$_[0];
${$$self{VALUE}};
}
sub YYExpect {
my($self)=shift;
keys %{$self->{STATES}[$self->{STACK}[-1][0]]{ACTIONS}}
}
sub YYLexer {
my($self)=shift;
$$self{LEX};
}
#################
# Private stuff #
#################
sub _CheckParams {
my($mandatory,$checklist,$inarray,$outhash)=@_;
my($prm,$value);
my($prmlst)={};
while(($prm,$value)=splice(@$inarray,0,2)) {
$prm=uc($prm);
exists($$checklist{$prm})
or croak("Unknow parameter '$prm'");
ref($value) eq $$checklist{$prm}
or croak("Invalid value for parameter '$prm'");
$prm=unpack('@2A*',$prm);
$$outhash{$prm}=$value;
}
for (@$mandatory) {
exists($$outhash{$_})
or croak("Missing mandatory parameter '".lc($_)."'");
}
}
sub _Error {
print "Parse error.\n";
}
sub _DBLoad {
{
no strict 'refs';
exists(${__PACKAGE__.'::'}{_DBParse})#Already loaded ?
and return;
}
my($fname)=__FILE__;
my(@drv);
open(DRV,"<$fname") or die "Report this as a BUG: Cannot open $fname";
while() {
/^\s*sub\s+_Parse\s*{\s*$/ .. /^\s*}\s*#\s*_Parse\s*$/
and do {
s/^#DBG>//;
push(@drv,$_);
}
}
close(DRV);
$drv[0]=~s/_P/_DBP/;
eval join('',@drv);
}
#Note that for loading debugging version of the driver,
#this file will be parsed from 'sub _Parse' up to '}#_Parse' inclusive.
#So, DO NOT remove comment at end of sub !!!
sub _Parse {
my($self)=shift;
my($rules,$states,$lex,$error)
= @$self{ 'RULES', 'STATES', 'LEX', 'ERROR' };
my($errstatus,$nberror,$token,$value,$stack,$check,$dotpos)
= @$self{ 'ERRST', 'NBERR', 'TOKEN', 'VALUE', 'STACK', 'CHECK', 'DOTPOS' };
#DBG> my($debug)=$$self{DEBUG};
#DBG> my($dbgerror)=0;
#DBG> my($ShowCurToken) = sub {
#DBG> my($tok)='>';
#DBG> for (split('',$$token)) {
#DBG> $tok.= (ord($_) < 32 or ord($_) > 126)
#DBG> ? sprintf('<%02X>',ord($_))
#DBG> : $_;
#DBG> }
#DBG> $tok.='<';
#DBG> };
$$errstatus=0;
$$nberror=0;
($$token,$$value)=(undef,undef);
@$stack=( [ 0, undef ] );
$$check='';
while(1) {
my($actions,$act,$stateno);
$stateno=$$stack[-1][0];
$actions=$$states[$stateno];
#DBG> print STDERR ('-' x 40),"\n";
#DBG> $debug & 0x2
#DBG> and print STDERR "In state $stateno:\n";
#DBG> $debug & 0x08
#DBG> and print STDERR "Stack:[".
#DBG> join(',',map { $$_[0] } @$stack).
#DBG> "]\n";
if (exists($$actions{ACTIONS})) {
defined($$token)
or do {
($$token,$$value)=&$lex($self);
#DBG> $debug & 0x01
#DBG> and print STDERR "Need token. Got ".&$ShowCurToken."\n";
};
$act= exists($$actions{ACTIONS}{$$token})
? $$actions{ACTIONS}{$$token}
: exists($$actions{DEFAULT})
? $$actions{DEFAULT}
: undef;
}
else {
$act=$$actions{DEFAULT};
#DBG> $debug & 0x01
#DBG> and print STDERR "Don't need token.\n";
}
defined($act)
and do {
$act > 0
and do { #shift
#DBG> $debug & 0x04
#DBG> and print STDERR "Shift and go to state $act.\n";
$$errstatus
and do {
--$$errstatus;
#DBG> $debug & 0x10
#DBG> and $dbgerror
#DBG> and $$errstatus == 0
#DBG> and do {
#DBG> print STDERR "**End of Error recovery.\n";
#DBG> $dbgerror=0;
#DBG> };
};
push(@$stack,[ $act, $$value ]);
$$token ne '' #Don't eat the eof
and $$token=$$value=undef;
next;
};
#reduce
my($lhs,$len,$code,@sempar,$semval);
($lhs,$len,$code)=@{$$rules[-$act]};
#DBG> $debug & 0x04
#DBG> and $act
#DBG> and print STDERR "Reduce using rule ".-$act." ($lhs,$len): ";
$act
or $self->YYAccept();
$$dotpos=$len;
unpack('A1',$lhs) eq '@' #In line rule
and do {
$lhs =~ /^\@[0-9]+\-([0-9]+)$/
or die "In line rule name '$lhs' ill formed: ".
"report it as a BUG.\n";
$$dotpos = $1;
};
@sempar = $$dotpos
? map { $$_[1] } @$stack[ -$$dotpos .. -1 ]
: ();
$semval = $code ? &$code( $self, @sempar )
: @sempar ? $sempar[0] : undef;
splice(@$stack,-$len,$len);
$$check eq 'ACCEPT'
and do {
#DBG> $debug & 0x04
#DBG> and print STDERR "Accept.\n";
return($semval);
};
$$check eq 'ABORT'
and do {
#DBG> $debug & 0x04
#DBG> and print STDERR "Abort.\n";
return(undef);
};
#DBG> $debug & 0x04
#DBG> and print STDERR "Back to state $$stack[-1][0], then ";
$$check eq 'ERROR'
or do {
#DBG> $debug & 0x04
#DBG> and print STDERR
#DBG> "go to state $$states[$$stack[-1][0]]{GOTOS}{$lhs}.\n";
#DBG> $debug & 0x10
#DBG> and $dbgerror
#DBG> and $$errstatus == 0
#DBG> and do {
#DBG> print STDERR "**End of Error recovery.\n";
#DBG> $dbgerror=0;
#DBG> };
push(@$stack,
[ $$states[$$stack[-1][0]]{GOTOS}{$lhs}, $semval ]);
$$check='';
next;
};
#DBG> $debug & 0x04
#DBG> and print STDERR "Forced Error recovery.\n";
$$check='';
};
#Error
$$errstatus
or do {
$$errstatus = 1;
&$error($self);
$$errstatus # if 0, then YYErrok has been called
or next; # so continue parsing
#DBG> $debug & 0x10
#DBG> and do {
#DBG> print STDERR "**Entering Error recovery.\n";
#DBG> ++$dbgerror;
#DBG> };
++$$nberror;
};
$$errstatus == 3 #The next token is not valid: discard it
and do {
$$token eq '' # End of input: no hope
and do {
#DBG> $debug & 0x10
#DBG> and print STDERR "**At eof: aborting.\n";
return(undef);
};
#DBG> $debug & 0x10
#DBG> and print STDERR "**Dicard invalid token ".&$ShowCurToken.".\n";
$$token=$$value=undef;
};
$$errstatus=3;
while( @$stack
and ( not exists($$states[$$stack[-1][0]]{ACTIONS})
or not exists($$states[$$stack[-1][0]]{ACTIONS}{error})
or $$states[$$stack[-1][0]]{ACTIONS}{error} <= 0)) {
#DBG> $debug & 0x10
#DBG> and print STDERR "**Pop state $$stack[-1][0].\n";
pop(@$stack);
}
@$stack
or do {
#DBG> $debug & 0x10
#DBG> and print STDERR "**No state left on stack: aborting.\n";
return(undef);
};
#shift the error token
#DBG> $debug & 0x10
#DBG> and print STDERR "**Shift \$error token and go to state ".
#DBG> $$states[$$stack[-1][0]]{ACTIONS}{error}.
#DBG> ".\n";
push(@$stack, [ $$states[$$stack[-1][0]]{ACTIONS}{error}, undef ]);
}
#never reached
croak("Error in driver logic. Please, report it as a BUG");
}#_Parse
#DO NOT remove comment
1;
}
#End of include--------------------------------------------------
sub new {
my($class)=shift;
ref($class)
and $class=ref($class);
my($self)=$class->SUPER::new( yyversion => '1.05',
yystates =>
[
{#State 0
ACTIONS => {
'LEFT_PAREN' => 4,
'BETWEEN_WORD' => 11,
'ASC_WORD' => 1,
'DESC_WORD' => 2,
'IDENTIFIER' => 3,
'NOT_WORD' => 6,
'LIKE_WORD' => 8,
'FALSE_WORD' => 9,
'TRUE_WORD' => 12,
'IN_WORD' => 13
},
DEFAULT => -1,
GOTOS => {
'boolexpr' => 5,
'expr' => 10,
'keyword_as_value' => 7,
'property' => 15,
'condition' => 14
}
},
{#State 1
DEFAULT => -66
},
{#State 2
DEFAULT => -65
},
{#State 3
DEFAULT => -29
},
{#State 4
ACTIONS => {
'ASC_WORD' => 1,
'LEFT_PAREN' => 4,
'IDENTIFIER' => 3,
'DESC_WORD' => 2,
'NOT_WORD' => 6,
'LIKE_WORD' => 8,
'FALSE_WORD' => 9,
'BETWEEN_WORD' => 11,
'TRUE_WORD' => 12,
'IN_WORD' => 13
},
GOTOS => {
'expr' => 16,
'keyword_as_value' => 7,
'condition' => 14,
'property' => 15
}
},
{#State 5
ACTIONS => {
'' => 17,
'OFFSET' => 18,
'ORDER_BY' => 20,
'GROUP_BY' => 19,
'LIMIT' => 21
}
},
{#State 6
DEFAULT => -64
},
{#State 7
DEFAULT => -30
},
{#State 8
DEFAULT => -62
},
{#State 9
DEFAULT => -68
},
{#State 10
ACTIONS => {
'AND' => 22,
'OR' => 23
},
DEFAULT => -2
},
{#State 11
DEFAULT => -63
},
{#State 12
DEFAULT => -67
},
{#State 13
DEFAULT => -61
},
{#State 14
DEFAULT => -7
},
{#State 15
ACTIONS => {
'DOUBLEEQUAL_SIGN' => 24,
'NOT_BANG' => 33,
'NOT_WORD' => 34,
'COLON' => 25,
'LIKE_WORD' => 35,
'OPERATORS' => 26,
'EQUAL_SIGN' => 36,
'FALSE_WORD' => 37,
'BETWEEN_WORD' => 29,
'TILDE' => 38,
'TRUE_WORD' => 40,
'IN_WORD' => 41,
'IS_NOT_NULL' => 44,
'IS_NULL' => 32
},
GOTOS => {
'operator' => 28,
'like_operator' => 30,
'an_operator' => 31,
'in_operator' => 39,
'null_op_word' => 27,
'boolean_op_word' => 43,
'between_operator' => 42,
'negation' => 45
}
},
{#State 16
ACTIONS => {
'AND' => 22,
'OR' => 23,
'RIGHT_PAREN' => 46
}
},
{#State 17
DEFAULT => 0
},
{#State 18
ACTIONS => {
'INTEGER' => 47
}
},
{#State 19
ACTIONS => {
'ASC_WORD' => 1,
'IDENTIFIER' => 3,
'DESC_WORD' => 2,
'NOT_WORD' => 6,
'LIKE_WORD' => 8,
'FALSE_WORD' => 9,
'BETWEEN_WORD' => 11,
'TRUE_WORD' => 12,
'IN_WORD' => 13
},
GOTOS => {
'keyword_as_value' => 7,
'group_by_list' => 48,
'property' => 49
}
},
{#State 20
ACTIONS => {
'ASC_WORD' => 1,
'IDENTIFIER' => 3,
'DESC_WORD' => 2,
'NOT_WORD' => 6,
'MINUS' => 50,
'LIKE_WORD' => 8,
'FALSE_WORD' => 9,
'BETWEEN_WORD' => 11,
'TRUE_WORD' => 12,
'IN_WORD' => 13
},
GOTOS => {
'order_by_list' => 53,
'order_by_property' => 51,
'keyword_as_value' => 7,
'property' => 52
}
},
{#State 21
ACTIONS => {
'INTEGER' => 54
}
},
{#State 22
ACTIONS => {
'ASC_WORD' => 1,
'IDENTIFIER' => 3,
'DESC_WORD' => 2,
'LEFT_PAREN' => 4,
'NOT_WORD' => 6,
'LIKE_WORD' => 8,
'FALSE_WORD' => 9,
'BETWEEN_WORD' => 11,
'TRUE_WORD' => 12,
'IN_WORD' => 13
},
GOTOS => {
'expr' => 55,
'keyword_as_value' => 7,
'condition' => 14,
'property' => 15
}
},
{#State 23
ACTIONS => {
'ASC_WORD' => 1,
'IDENTIFIER' => 3,
'DESC_WORD' => 2,
'LEFT_PAREN' => 4,
'NOT_WORD' => 6,
'LIKE_WORD' => 8,
'FALSE_WORD' => 9,
'BETWEEN_WORD' => 11,
'TRUE_WORD' => 12,
'IN_WORD' => 13
},
GOTOS => {
'expr' => 56,
'keyword_as_value' => 7,
'condition' => 14,
'property' => 15
}
},
{#State 24
DEFAULT => -45
},
{#State 25
ACTIONS => {
'WHITESPACE' => 58
},
DEFAULT => -27,
GOTOS => {
'optional_spaces' => 59,
'spaces' => 57
}
},
{#State 26
DEFAULT => -43
},
{#State 27
DEFAULT => -20
},
{#State 28
ACTIONS => {
'WHITESPACE' => 58
},
DEFAULT => -27,
GOTOS => {
'optional_spaces' => 60,
'spaces' => 57
}
},
{#State 29
DEFAULT => -58
},
{#State 30
ACTIONS => {
'WORD' => 61,
'DOUBLEQUOTE_STRING' => 62,
'MINUS' => 63,
'BETWEEN_WORD' => 11,
'REAL' => 67,
'INTEGER' => 68,
'ASC_WORD' => 1,
'IDENTIFIER' => 69,
'DESC_WORD' => 2,
'NOT_WORD' => 6,
'LIKE_WORD' => 8,
'AND' => 73,
'FALSE_WORD' => 9,
'TRUE_WORD' => 12,
'IN_WORD' => 13,
'OR' => 74,
'SINGLEQUOTE_STRING' => 75
},
GOTOS => {
'number' => 64,
'value' => 71,
'keyword_as_value' => 70,
'single_value' => 72,
'like_value' => 66,
'subsequent_value_part' => 65
}
},
{#State 31
DEFAULT => -39
},
{#State 32
DEFAULT => -23
},
{#State 33
DEFAULT => -42
},
{#State 34
DEFAULT => -41
},
{#State 35
DEFAULT => -46
},
{#State 36
DEFAULT => -44
},
{#State 37
DEFAULT => -22
},
{#State 38
DEFAULT => -48
},
{#State 39
ACTIONS => {
'LEFT_BRACKET' => 76
},
GOTOS => {
'set' => 77
}
},
{#State 40
DEFAULT => -21
},
{#State 41
DEFAULT => -51
},
{#State 42
ACTIONS => {
'WORD' => 61,
'DOUBLEQUOTE_STRING' => 62,
'MINUS' => 63,
'BETWEEN_WORD' => 11,
'REAL' => 67,
'INTEGER' => 68,
'ASC_WORD' => 1,
'IDENTIFIER' => 69,
'DESC_WORD' => 2,
'NOT_WORD' => 6,
'LIKE_WORD' => 8,
'AND' => 73,
'FALSE_WORD' => 9,
'TRUE_WORD' => 12,
'IN_WORD' => 13,
'OR' => 74,
'SINGLEQUOTE_STRING' => 75
},
GOTOS => {
'between_value' => 78,
'number' => 64,
'keyword_as_value' => 70,
'single_value' => 79,
'subsequent_value_part' => 65
}
},
{#State 43
DEFAULT => -19
},
{#State 44
DEFAULT => -25
},
{#State 45
ACTIONS => {
'DOUBLEEQUAL_SIGN' => 24,
'COLON' => 80,
'LIKE_WORD' => 84,
'OPERATORS' => 26,
'EQUAL_SIGN' => 36,
'BETWEEN_WORD' => 81,
'TILDE' => 85,
'IN_WORD' => 86,
'IS_NULL' => 83
},
GOTOS => {
'an_operator' => 82
}
},
{#State 46
DEFAULT => -10
},
{#State 47
DEFAULT => -6
},
{#State 48
DEFAULT => -4
},
{#State 49
ACTIONS => {
'AND' => 87
},
DEFAULT => -37
},
{#State 50
ACTIONS => {
'ASC_WORD' => 1,
'IDENTIFIER' => 3,
'DESC_WORD' => 2,
'NOT_WORD' => 6,
'LIKE_WORD' => 8,
'FALSE_WORD' => 9,
'BETWEEN_WORD' => 11,
'TRUE_WORD' => 12,
'IN_WORD' => 13
},
GOTOS => {
'keyword_as_value' => 7,
'property' => 88
}
},
{#State 51
ACTIONS => {
'AND' => 89
},
DEFAULT => -35
},
{#State 52
ACTIONS => {
'ASC_WORD' => 90,
'DESC_WORD' => 91
},
DEFAULT => -31
},
{#State 53
DEFAULT => -3
},
{#State 54
DEFAULT => -5
},
{#State 55
ACTIONS => {
'AND' => 22
},
DEFAULT => -8
},
{#State 56
ACTIONS => {
'AND' => 22,
'OR' => 23
},
DEFAULT => -9
},
{#State 57
DEFAULT => -28
},
{#State 58
DEFAULT => -26
},
{#State 59
ACTIONS => {
'WORD' => 61,
'DOUBLEQUOTE_STRING' => 62,
'MINUS' => 63,
'BETWEEN_WORD' => 11,
'REAL' => 67,
'INTEGER' => 68,
'ASC_WORD' => 1,
'IDENTIFIER' => 69,
'DESC_WORD' => 2,
'NOT_WORD' => 6,
'LIKE_WORD' => 8,
'AND' => 73,
'FALSE_WORD' => 9,
'TRUE_WORD' => 12,
'IN_WORD' => 13,
'OR' => 74,
'SINGLEQUOTE_STRING' => 75
},
GOTOS => {
'between_value' => 93,
'number' => 64,
'keyword_as_value' => 70,
'old_syntax_in_value' => 92,
'single_value' => 94,
'subsequent_value_part' => 65
}
},
{#State 60
ACTIONS => {
'WORD' => 61,
'DOUBLEQUOTE_STRING' => 62,
'MINUS' => 63,
'BETWEEN_WORD' => 11,
'REAL' => 67,
'INTEGER' => 68,
'ASC_WORD' => 1,
'IDENTIFIER' => 69,
'DESC_WORD' => 2,
'NOT_WORD' => 6,
'LIKE_WORD' => 8,
'AND' => 73,
'FALSE_WORD' => 9,
'TRUE_WORD' => 12,
'IN_WORD' => 13,
'OR' => 74,
'SINGLEQUOTE_STRING' => 75
},
GOTOS => {
'number' => 64,
'value' => 95,
'keyword_as_value' => 70,
'single_value' => 72,
'subsequent_value_part' => 65
}
},
{#State 61
DEFAULT => -73
},
{#State 62
DEFAULT => -74
},
{#State 63
ACTIONS => {
'INTEGER' => 97,
'REAL' => 96
}
},
{#State 64
DEFAULT => -72
},
{#State 65
DEFAULT => -81
},
{#State 66
DEFAULT => -12
},
{#State 67
DEFAULT => -85
},
{#State 68
DEFAULT => -84
},
{#State 69
DEFAULT => -71
},
{#State 70
DEFAULT => -76
},
{#State 71
DEFAULT => -50
},
{#State 72
ACTIONS => {
'WORD' => 61,
'DOUBLEQUOTE_STRING' => 62,
'MINUS' => 63,
'BETWEEN_WORD' => 11,
'REAL' => 67,
'INTEGER' => 68,
'ASC_WORD' => 1,
'IDENTIFIER' => 69,
'DESC_WORD' => 2,
'NOT_WORD' => 6,
'LIKE_WORD' => 8,
'WHITESPACE' => 58,
'FALSE_WORD' => 9,
'TRUE_WORD' => 12,
'IN_WORD' => 13,
'SINGLEQUOTE_STRING' => 75
},
DEFAULT => -70,
GOTOS => {
'number' => 64,
'keyword_as_value' => 70,
'subsequent_values_list' => 100,
'spaces' => 99,
'subsequent_value_part' => 98
}
},
{#State 73
DEFAULT => -82
},
{#State 74
DEFAULT => -83
},
{#State 75
DEFAULT => -75
},
{#State 76
ACTIONS => {
'WORD' => 61,
'DOUBLEQUOTE_STRING' => 62,
'MINUS' => 63,
'BETWEEN_WORD' => 11,
'REAL' => 67,
'INTEGER' => 68,
'ASC_WORD' => 1,
'IDENTIFIER' => 69,
'DESC_WORD' => 2,
'NOT_WORD' => 6,
'LIKE_WORD' => 8,
'AND' => 73,
'FALSE_WORD' => 9,
'TRUE_WORD' => 12,
'IN_WORD' => 13,
'OR' => 74,
'SINGLEQUOTE_STRING' => 75
},
GOTOS => {
'set_body' => 101,
'number' => 64,
'value' => 102,
'keyword_as_value' => 70,
'single_value' => 72,
'subsequent_value_part' => 65
}
},
{#State 77
DEFAULT => -13
},
{#State 78
DEFAULT => -16
},
{#State 79
ACTIONS => {
'MINUS' => 103
}
},
{#State 80
ACTIONS => {
'WHITESPACE' => 58
},
DEFAULT => -27,
GOTOS => {
'optional_spaces' => 104,
'spaces' => 57
}
},
{#State 81
DEFAULT => -59
},
{#State 82
DEFAULT => -40
},
{#State 83
DEFAULT => -24
},
{#State 84
DEFAULT => -47
},
{#State 85
DEFAULT => -49
},
{#State 86
DEFAULT => -52
},
{#State 87
ACTIONS => {
'ASC_WORD' => 1,
'IDENTIFIER' => 3,
'DESC_WORD' => 2,
'NOT_WORD' => 6,
'LIKE_WORD' => 8,
'FALSE_WORD' => 9,
'BETWEEN_WORD' => 11,
'TRUE_WORD' => 12,
'IN_WORD' => 13
},
GOTOS => {
'keyword_as_value' => 7,
'group_by_list' => 105,
'property' => 49
}
},
{#State 88
DEFAULT => -32
},
{#State 89
ACTIONS => {
'ASC_WORD' => 1,
'IDENTIFIER' => 3,
'DESC_WORD' => 2,
'NOT_WORD' => 6,
'MINUS' => 50,
'LIKE_WORD' => 8,
'FALSE_WORD' => 9,
'BETWEEN_WORD' => 11,
'TRUE_WORD' => 12,
'IN_WORD' => 13
},
GOTOS => {
'order_by_list' => 106,
'order_by_property' => 51,
'keyword_as_value' => 7,
'property' => 52
}
},
{#State 90
DEFAULT => -34
},
{#State 91
DEFAULT => -33
},
{#State 92
DEFAULT => -14
},
{#State 93
DEFAULT => -17
},
{#State 94
ACTIONS => {
'IN_DIVIDER' => 107,
'MINUS' => 103
}
},
{#State 95
DEFAULT => -11
},
{#State 96
DEFAULT => -87
},
{#State 97
DEFAULT => -86
},
{#State 98
ACTIONS => {
'WORD' => 61,
'DOUBLEQUOTE_STRING' => 62,
'MINUS' => 63,
'BETWEEN_WORD' => 11,
'REAL' => 67,
'INTEGER' => 68,
'ASC_WORD' => 1,
'IDENTIFIER' => 69,
'DESC_WORD' => 2,
'NOT_WORD' => 6,
'LIKE_WORD' => 8,
'WHITESPACE' => 58,
'FALSE_WORD' => 9,
'TRUE_WORD' => 12,
'IN_WORD' => 13,
'SINGLEQUOTE_STRING' => 75
},
DEFAULT => -77,
GOTOS => {
'number' => 64,
'keyword_as_value' => 70,
'subsequent_values_list' => 108,
'spaces' => 99,
'subsequent_value_part' => 98
}
},
{#State 99
ACTIONS => {
'WORD' => 61,
'DOUBLEQUOTE_STRING' => 62,
'MINUS' => 63,
'BETWEEN_WORD' => 11,
'REAL' => 67,
'INTEGER' => 68,
'ASC_WORD' => 1,
'IDENTIFIER' => 69,
'DESC_WORD' => 2,
'NOT_WORD' => 6,
'LIKE_WORD' => 8,
'WHITESPACE' => 58,
'FALSE_WORD' => 9,
'TRUE_WORD' => 12,
'IN_WORD' => 13,
'SINGLEQUOTE_STRING' => 75
},
DEFAULT => -80,
GOTOS => {
'number' => 64,
'keyword_as_value' => 70,
'subsequent_values_list' => 109,
'spaces' => 99,
'subsequent_value_part' => 98
}
},
{#State 100
DEFAULT => -69
},
{#State 101
ACTIONS => {
'RIGHT_BRACKET' => 110
}
},
{#State 102
ACTIONS => {
'SET_SEPARATOR' => 111
},
DEFAULT => -57
},
{#State 103
ACTIONS => {
'WORD' => 61,
'DOUBLEQUOTE_STRING' => 62,
'MINUS' => 63,
'BETWEEN_WORD' => 11,
'REAL' => 67,
'INTEGER' => 68,
'ASC_WORD' => 1,
'IDENTIFIER' => 69,
'DESC_WORD' => 2,
'NOT_WORD' => 6,
'LIKE_WORD' => 8,
'AND' => 73,
'FALSE_WORD' => 9,
'TRUE_WORD' => 12,
'IN_WORD' => 13,
'OR' => 74,
'SINGLEQUOTE_STRING' => 75
},
GOTOS => {
'number' => 64,
'keyword_as_value' => 70,
'single_value' => 112,
'subsequent_value_part' => 65
}
},
{#State 104
ACTIONS => {
'WORD' => 61,
'DOUBLEQUOTE_STRING' => 62,
'MINUS' => 63,
'BETWEEN_WORD' => 11,
'REAL' => 67,
'INTEGER' => 68,
'ASC_WORD' => 1,
'IDENTIFIER' => 69,
'DESC_WORD' => 2,
'NOT_WORD' => 6,
'LIKE_WORD' => 8,
'AND' => 73,
'FALSE_WORD' => 9,
'TRUE_WORD' => 12,
'IN_WORD' => 13,
'OR' => 74,
'SINGLEQUOTE_STRING' => 75
},
GOTOS => {
'between_value' => 114,
'number' => 64,
'keyword_as_value' => 70,
'old_syntax_in_value' => 113,
'single_value' => 94,
'subsequent_value_part' => 65
}
},
{#State 105
DEFAULT => -38
},
{#State 106
DEFAULT => -36
},
{#State 107
ACTIONS => {
'WORD' => 61,
'DOUBLEQUOTE_STRING' => 62,
'MINUS' => 63,
'BETWEEN_WORD' => 11,
'REAL' => 67,
'INTEGER' => 68,
'ASC_WORD' => 1,
'IDENTIFIER' => 69,
'DESC_WORD' => 2,
'NOT_WORD' => 6,
'LIKE_WORD' => 8,
'AND' => 73,
'FALSE_WORD' => 9,
'TRUE_WORD' => 12,
'IN_WORD' => 13,
'OR' => 74,
'SINGLEQUOTE_STRING' => 75
},
GOTOS => {
'number' => 64,
'keyword_as_value' => 70,
'old_syntax_in_value' => 115,
'single_value' => 116,
'subsequent_value_part' => 65
}
},
{#State 108
DEFAULT => -78
},
{#State 109
DEFAULT => -79
},
{#State 110
DEFAULT => -55
},
{#State 111
ACTIONS => {
'WORD' => 61,
'DOUBLEQUOTE_STRING' => 62,
'MINUS' => 63,
'BETWEEN_WORD' => 11,
'REAL' => 67,
'INTEGER' => 68,
'ASC_WORD' => 1,
'IDENTIFIER' => 69,
'DESC_WORD' => 2,
'NOT_WORD' => 6,
'LIKE_WORD' => 8,
'AND' => 73,
'FALSE_WORD' => 9,
'TRUE_WORD' => 12,
'IN_WORD' => 13,
'OR' => 74,
'SINGLEQUOTE_STRING' => 75
},
GOTOS => {
'set_body' => 117,
'number' => 64,
'value' => 102,
'keyword_as_value' => 70,
'single_value' => 72,
'subsequent_value_part' => 65
}
},
{#State 112
DEFAULT => -60
},
{#State 113
DEFAULT => -15
},
{#State 114
DEFAULT => -18
},
{#State 115
DEFAULT => -53
},
{#State 116
ACTIONS => {
'IN_DIVIDER' => 107
},
DEFAULT => -54
},
{#State 117
DEFAULT => -56
}
],
yyrules =>
[
[#Rule 0
'$start', 2, undef
],
[#Rule 1
'boolexpr', 0,
sub
#line 10 "BxParser.yp"
{ [] }
],
[#Rule 2
'boolexpr', 1,
sub
#line 11 "BxParser.yp"
{ UR::BoolExpr::BxParser->_simplify($_[1]) }
],
[#Rule 3
'boolexpr', 3,
sub
#line 12 "BxParser.yp"
{ [@{$_[1]}, '-order', $_[3]] }
],
[#Rule 4
'boolexpr', 3,
sub
#line 13 "BxParser.yp"
{ [@{$_[1]}, '-group', $_[3]] }
],
[#Rule 5
'boolexpr', 3,
sub
#line 14 "BxParser.yp"
{ [@{$_[1]}, '-limit', $_[3]] }
],
[#Rule 6
'boolexpr', 3,
sub
#line 15 "BxParser.yp"
{ [@{$_[1]}, '-offset', $_[3]] }
],
[#Rule 7
'expr', 1,
sub
#line 18 "BxParser.yp"
{ $_[1] }
],
[#Rule 8
'expr', 3,
sub
#line 19 "BxParser.yp"
{ UR::BoolExpr::BxParser->_and($_[1], $_[3]) }
],
[#Rule 9
'expr', 3,
sub
#line 20 "BxParser.yp"
{ UR::BoolExpr::BxParser->_or($_[1], $_[3]) }
],
[#Rule 10
'expr', 3,
sub
#line 21 "BxParser.yp"
{ $_[2] }
],
[#Rule 11
'condition', 4,
sub
#line 24 "BxParser.yp"
{ [ "$_[1] $_[2]" => $_[4] ] }
],
[#Rule 12
'condition', 3,
sub
#line 25 "BxParser.yp"
{ [ "$_[1] $_[2]" => $_[3] ] }
],
[#Rule 13
'condition', 3,
sub
#line 26 "BxParser.yp"
{ [ "$_[1] $_[2]" => $_[3] ] }
],
[#Rule 14
'condition', 4,
sub
#line 27 "BxParser.yp"
{ [ "$_[1] in" => $_[4] ] }
],
[#Rule 15
'condition', 5,
sub
#line 28 "BxParser.yp"
{ [ "$_[1] $_[2] in" => $_[5] ] }
],
[#Rule 16
'condition', 3,
sub
#line 29 "BxParser.yp"
{ [ "$_[1] $_[2]" => $_[3] ] }
],
[#Rule 17
'condition', 4,
sub
#line 30 "BxParser.yp"
{ [ "$_[1] between" => $_[4] ] }
],
[#Rule 18
'condition', 5,
sub
#line 31 "BxParser.yp"
{ [ "$_[1] $_[2] between" => $_[5] ] }
],
[#Rule 19
'condition', 2,
sub
#line 32 "BxParser.yp"
{ [ "$_[1] $_[2]" => 1 ] }
],
[#Rule 20
'condition', 2,
sub
#line 33 "BxParser.yp"
{ [ "$_[1] $_[2]" => undef ] }
],
[#Rule 21
'boolean_op_word', 1,
sub
#line 36 "BxParser.yp"
{ $_[1] }
],
[#Rule 22
'boolean_op_word', 1,
sub
#line 37 "BxParser.yp"
{ $_[1] }
],
[#Rule 23
'null_op_word', 1,
sub
#line 40 "BxParser.yp"
{ '=' }
],
[#Rule 24
'null_op_word', 2,
sub
#line 41 "BxParser.yp"
{ "!=" }
],
[#Rule 25
'null_op_word', 1,
sub
#line 42 "BxParser.yp"
{ '!=' }
],
[#Rule 26
'spaces', 1,
sub
#line 45 "BxParser.yp"
{ $_[1] }
],
[#Rule 27
'optional_spaces', 0,
sub
#line 48 "BxParser.yp"
{ undef }
],
[#Rule 28
'optional_spaces', 1,
sub
#line 49 "BxParser.yp"
{ undef }
],
[#Rule 29
'property', 1,
sub
#line 52 "BxParser.yp"
{ $_[1] }
],
[#Rule 30
'property', 1,
sub
#line 53 "BxParser.yp"
{ $_[1] }
],
[#Rule 31
'order_by_property', 1,
sub
#line 56 "BxParser.yp"
{ $_[1 ] }
],
[#Rule 32
'order_by_property', 2,
sub
#line 57 "BxParser.yp"
{ '-'.$_[2] }
],
[#Rule 33
'order_by_property', 2,
sub
#line 58 "BxParser.yp"
{ '-'.$_[1] }
],
[#Rule 34
'order_by_property', 2,
sub
#line 59 "BxParser.yp"
{ $_[1] }
],
[#Rule 35
'order_by_list', 1,
sub
#line 62 "BxParser.yp"
{ [ $_[1]] }
],
[#Rule 36
'order_by_list', 3,
sub
#line 63 "BxParser.yp"
{ [$_[1], @{$_[3]}] }
],
[#Rule 37
'group_by_list', 1,
sub
#line 66 "BxParser.yp"
{ [ $_[1] ] }
],
[#Rule 38
'group_by_list', 3,
sub
#line 67 "BxParser.yp"
{ [$_[1], @{$_[3]}] }
],
[#Rule 39
'operator', 1,
sub
#line 70 "BxParser.yp"
{ $_[1] }
],
[#Rule 40
'operator', 2,
sub
#line 71 "BxParser.yp"
{ "$_[1] $_[2]" }
],
[#Rule 41
'negation', 1,
sub
#line 74 "BxParser.yp"
{ 'not' }
],
[#Rule 42
'negation', 1,
sub
#line 75 "BxParser.yp"
{ 'not' }
],
[#Rule 43
'an_operator', 1,
sub
#line 78 "BxParser.yp"
{ $_[1] }
],
[#Rule 44
'an_operator', 1,
sub
#line 79 "BxParser.yp"
{ '=' }
],
[#Rule 45
'an_operator', 1,
sub
#line 80 "BxParser.yp"
{ '=' }
],
[#Rule 46
'like_operator', 1,
sub
#line 83 "BxParser.yp"
{ 'like' }
],
[#Rule 47
'like_operator', 2,
sub
#line 84 "BxParser.yp"
{ "$_[1] like" }
],
[#Rule 48
'like_operator', 1,
sub
#line 85 "BxParser.yp"
{ 'like' }
],
[#Rule 49
'like_operator', 2,
sub
#line 86 "BxParser.yp"
{ "$_[1] like" }
],
[#Rule 50
'like_value', 1,
sub
#line 89 "BxParser.yp"
{ $_[1] =~ m/\%/ ? $_[1] : '%' . $_[1] . '%' }
],
[#Rule 51
'in_operator', 1,
sub
#line 92 "BxParser.yp"
{ 'in' }
],
[#Rule 52
'in_operator', 2,
sub
#line 93 "BxParser.yp"
{ "$_[1] in" }
],
[#Rule 53
'old_syntax_in_value', 3,
sub
#line 96 "BxParser.yp"
{ [ $_[1], @{$_[3]} ] }
],
[#Rule 54
'old_syntax_in_value', 3,
sub
#line 97 "BxParser.yp"
{ [ $_[1], $_[3] ] }
],
[#Rule 55
'set', 3,
sub
#line 100 "BxParser.yp"
{ $_[2] }
],
[#Rule 56
'set_body', 3,
sub
#line 103 "BxParser.yp"
{ [ $_[1], @{$_[3]} ] }
],
[#Rule 57
'set_body', 1,
sub
#line 104 "BxParser.yp"
{ [ $_[1] ] }
],
[#Rule 58
'between_operator', 1,
sub
#line 107 "BxParser.yp"
{ 'between' }
],
[#Rule 59
'between_operator', 2,
sub
#line 108 "BxParser.yp"
{ "$_[1] between" }
],
[#Rule 60
'between_value', 3,
sub
#line 111 "BxParser.yp"
{ [ $_[1], $_[3] ] }
],
[#Rule 61
'keyword_as_value', 1,
sub
#line 114 "BxParser.yp"
{ $_[1] }
],
[#Rule 62
'keyword_as_value', 1,
sub
#line 115 "BxParser.yp"
{ $_[1] }
],
[#Rule 63
'keyword_as_value', 1,
sub
#line 116 "BxParser.yp"
{ $_[1] }
],
[#Rule 64
'keyword_as_value', 1,
sub
#line 117 "BxParser.yp"
{ $_[1] }
],
[#Rule 65
'keyword_as_value', 1,
sub
#line 118 "BxParser.yp"
{ $_[1] }
],
[#Rule 66
'keyword_as_value', 1,
sub
#line 119 "BxParser.yp"
{ $_[1] }
],
[#Rule 67
'keyword_as_value', 1,
sub
#line 120 "BxParser.yp"
{ $_[1] }
],
[#Rule 68
'keyword_as_value', 1,
sub
#line 121 "BxParser.yp"
{ $_[1] }
],
[#Rule 69
'value', 2,
sub
#line 124 "BxParser.yp"
{ $_[1].$_[2] }
],
[#Rule 70
'value', 1,
sub
#line 125 "BxParser.yp"
{ $_[1] }
],
[#Rule 71
'subsequent_value_part', 1,
sub
#line 128 "BxParser.yp"
{ $_[1] }
],
[#Rule 72
'subsequent_value_part', 1,
sub
#line 129 "BxParser.yp"
{ $_[1] }
],
[#Rule 73
'subsequent_value_part', 1,
sub
#line 130 "BxParser.yp"
{ $_[1] }
],
[#Rule 74
'subsequent_value_part', 1,
sub
#line 131 "BxParser.yp"
{ ($_[1] =~ m/^"(.*?)"$/)[0]; }
],
[#Rule 75
'subsequent_value_part', 1,
sub
#line 132 "BxParser.yp"
{ ($_[1] =~ m/^'(.*?)'$/)[0]; }
],
[#Rule 76
'subsequent_value_part', 1,
sub
#line 133 "BxParser.yp"
{ $_[1] }
],
[#Rule 77
'subsequent_values_list', 1,
sub
#line 136 "BxParser.yp"
{ $_[1] }
],
[#Rule 78
'subsequent_values_list', 2,
sub
#line 137 "BxParser.yp"
{ $_[1].$_[2] }
],
[#Rule 79
'subsequent_values_list', 2,
sub
#line 138 "BxParser.yp"
{ $_[1].$_[2] }
],
[#Rule 80
'subsequent_values_list', 1,
sub
#line 139 "BxParser.yp"
{ '' }
],
[#Rule 81
'single_value', 1,
sub
#line 142 "BxParser.yp"
{ $_[1] }
],
[#Rule 82
'single_value', 1,
sub
#line 143 "BxParser.yp"
{ $_[1] }
],
[#Rule 83
'single_value', 1,
sub
#line 144 "BxParser.yp"
{ $_[1] }
],
[#Rule 84
'number', 1,
sub
#line 148 "BxParser.yp"
{ $_[1] + 0 }
],
[#Rule 85
'number', 1,
sub
#line 149 "BxParser.yp"
{ $_[1] + 0 }
],
[#Rule 86
'number', 2,
sub
#line 150 "BxParser.yp"
{ 0 - $_[2] }
],
[#Rule 87
'number', 2,
sub
#line 151 "BxParser.yp"
{ 0 - $_[2] }
]
],
@_);
bless($self,$class);
}
#line 154 "BxParser.yp"
package UR::BoolExpr::BxParser;
use strict;
use warnings;
sub _error {
my @expect = $_[0]->YYExpect;
my $tok = $_[0]->YYData->{INPUT};
my $match = $_[0]->YYData->{MATCH};
my $string = $_[0]->YYData->{STRING};
my $err = qq(Can't parse expression "$string"\n Syntax error near token $tok '$match');
my $rem = $_[0]->YYData->{REMAINING};
$err .= ", remaining text: '$rem'" if $rem;
$err .= "\nExpected one of: " . join(", ", @expect) . "\n";
Carp::croak($err);
}
my %token_states = (
'DEFAULT' => [
WHITESPACE => qr{\s+},
AND => [ qr{and}i, 'DEFAULT'],
OR => [ qr{or}i, 'DEFAULT' ],
BETWEEN_WORD => qr{between},
LIKE_WORD => qr{like},
IN_WORD => qr{in},
NOT_WORD => qr{not},
DESC_WORD => qr{desc},
ASC_WORD => qr{asc},
TRUE_WORD => qr{true},
FALSE_WORD => qr{false},
LIMIT => qr{limit},
OFFSET => qr{offset},
IDENTIFIER => qr{[a-zA-Z_][a-zA-Z0-9_.]*},
MINUS => qr{-},
INTEGER => qr{\d+},
REAL => qr{\d*\.\d+|\d+\.\d*},
WORD => [ qr{[%\+\.\/\w][\+\-\.%\w\/]*}, # also allow / for pathnames, - for hyphenated names, % for like wildcards
'dont_gobble_spaces' ],
DOUBLEQUOTE_STRING => qr{"(?:\\.|[^"])*"},
SINGLEQUOTE_STRING => qr{'(?:\\.|[^'])*'},
LEFT_PAREN => [ qr{\(}, 'DEFAULT' ],
RIGHT_PAREN => [ qr{\)}, 'DEFAULT' ],
LEFT_BRACKET => [ qr{\[}, 'set_contents'],
RIGHT_BRACKET => [qr{\]}, 'DEFAULT' ],
NOT_BANG => qr{!},
EQUAL_SIGN => [ qr{=}, 'dont_gobble_spaces' ],
DOUBLEEQUAL_SIGN => [ qr{=>}, 'dont_gobble_spaces' ],
OPERATORS => [ qr{<=|>=|<|>}, 'dont_gobble_spaces' ],
AND => [ qr{,}, 'DEFAULT' ],
COLON => [ qr{:}, 'after_colon_value' ],
TILDE => qr{~},
ORDER_BY => qr{order by},
GROUP_BY => qr{group by},
IS_NULL => qr{is null|is undef},
IS_NOT_NULL => qr{is not null|is not undef},
],
'set_contents' => [
SET_SEPARATOR => qr{,}, # Depending on state, can be either AND or SET_SEPARATOR
WORD => qr{[%\+\.\w\:][\+\.\:%\w]*}, # also allow / for pathnames, - for hyphenated names, % for like wildcards
RIGHT_BRACKET => [qr{\]}, 'DEFAULT' ],
],
'after_colon_value' => [
INTEGER => qr{\d+},
REAL => qr{\d*\.\d+|\d+\.\d*},
IN_DIVIDER => qr{\/},
#WORD => qr{\w+}, # Override WORD in DEFAULT to disallow /
WORD => qr{[%\+\.\w\:][\+\.\:%\w]*}, # Override WORD in DEFAULT to disallow /
DOUBLEQUOTE_STRING => qr{"(?:\\.|[^"])*"},
SINGLEQUOTE_STRING => qr{'(?:\\.|[^'])*'},
WHITESPACE => [qr{\s+}, 'DEFAULT'],
],
'dont_gobble_spaces' => [
AND => [ qr{and}, 'DEFAULT'],
OR => [ qr{or}, 'DEFAULT' ],
LIMIT => [qr{limit}, 'DEFAULT'],
OFFSET => [qr{offset}, 'DEFAULT'],
INTEGER => qr{\d+},
REAL => qr{\d*\.\d+|\d+\.\d*},
WORD => qr{[%\+\.\/\w][\+\-\.\:%\w\/]*}, # also allow / for pathnames, - for hyphenated names, % for like wildcards
ORDER_BY => [qr{order by}, 'DEFAULT'],
GROUP_BY => [qr{group by}, 'DEFAULT'],
],
);
sub parse {
my $string = shift;
my %params = @_;
my $debug = $params{'tokdebug'};
my $yydebug = $params{'yydebug'} || 0;
print "\nStarting parse for string $string\n" if $debug;
my $parser = UR::BoolExpr::BxParser->new();
$parser->YYData->{STRING} = $string;
my $parser_state = 'DEFAULT';
my $get_next_token = sub {
if (length($string) == 0) {
print "String is empty, we're done!\n" if $debug;
return (undef, '');
}
GET_NEXT_TOKEN:
foreach (1) {
my $longest = 0;
my $longest_token = '';
my $longest_match = '';
for my $token_list ( $parser_state, 'DEFAULT' ) {
print "\nTrying tokens for state $token_list...\n" if $debug;
my $tokens = $token_states{$token_list};
for(my $i = 0; $i < @$tokens; $i += 2) {
my($tok, $re) = @$tokens[$i, $i+1];
print "Trying token $tok... " if $debug;
my($regex,$next_parser_state);
if (ref($re) eq 'ARRAY') {
($regex,$next_parser_state) = @$re;
} else {
$regex = $re;
}
if ($string =~ m/^($regex)/) {
print "Matched >>$1<<" if $debug;
my $match_len = length($1);
if ($match_len > $longest) {
print "\n ** It's now the longest" if $debug;
$longest = $match_len;
$longest_token = $tok;
$longest_match = $1;
if ($next_parser_state) {
$parser_state = $next_parser_state;
}
}
}
print "\n" if $debug;
}
$string = substr($string, $longest);
print "Consuming up to char pos $longest chars, string is now >>$string<<\n" if $debug;
if ($longest_token eq 'WHITESPACE' and $parser_state ne 'dont_gobble_spaces') {
print "Redoing token extraction after whitespace\n" if $debug;
redo GET_NEXT_TOKEN;
}
$parser->YYData->{REMAINING} = $string;
if ($longest) {
print "Returning token $longest_token, match $longest_match\n next state is named $parser_state\n" if $debug;
$parser->YYData->{INPUT} = $longest_token;
$parser->YYData->{MATCH} = $longest_match;
return ($longest_token, $longest_match);
}
last if $token_list eq 'DEFAULT'; # avoid going over it twice if $parser_state is DEFAULT
}
}
print "Didn't match anything, done!\n" if $debug;
return (undef, ''); # Didn't match anything
};
return ( $parser->YYParse(
yylex => $get_next_token,
yyerror => \&_error,
yydebug => $yydebug),
\$string,
);
}
# Used by the top-level expr production to turn an or-type parse tree with
# only a single AND condition into a simple AND-type tree (1-level arrayref).
# Or to add the '-or' to the front of a real OR-type tree so it can be passed
# directly to UR::BoolExpr::resolve()
sub _simplify {
my($class, $expr) = @_;
if (ref($expr->[0])) {
if (@$expr == 1) {
# An or-type parse tree, but with only one AND subrule - use as a simple and-type rule
$expr = $expr->[0];
} else {
$expr = ['-or', $expr]; # an or-type parse tree with multiple subrules
}
}
return $expr;
}
# Handles the case for "expr AND expr" where one or both exprs can be an
# OR-type expr. In that case, it distributes the AND exprs among all the
# OR conditions. For example:
# (a=1 or b=2) and (c=3 or d=4)
# is the same as
# (a=1 and c=3) or (a=1 and d=4) or (b=2 and c=3) or (b=2 and d=4)
# This is necessary because the BoolExpr resolver can only handle 1-level deep
# AND-type rules, or a 1-level deep OR-type rule composed of any number of
# 1-level deep AND-type rules
sub _and {
my($class,$left, $right) = @_;
# force them to be [[ "property operator" => value]] instead of just [ "property operator" => value ]
$left = [ $left ] unless (ref($left->[0]));
$right = [ $right ] unless (ref($right->[0]));
my @and;
foreach my $left_subexpr ( @$left ) {
foreach my $right_subexpr (@$right) {
push @and, [@$left_subexpr, @$right_subexpr];
}
}
\@and;
}
sub _or {
my($class,$left, $right) = @_;
# force them to be [[ "property operator" => value]] instead of just [ "property operator" => value ]
$left = [ $left ] unless (ref($left->[0]));
$right = [ $right ] unless (ref($right->[0]));
[ @$left, @$right ];
}
1;
1;
BxParser.yp 100664 023532 023421 33360 12544604516 16610 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/BoolExpr %right OR
%right AND
%left MINUS
# Generate the perl module with the command:
# yapp -sm UR::BoolExpr::BxParser -o - BxParser.yp | sed s/Parse::Yapp::Driver/UR::BoolExpr::BxParser::Yapp::Driver/ > BxParser.pm
%%
boolexpr: { [] }
| expr { UR::BoolExpr::BxParser->_simplify($_[1]) }
| boolexpr ORDER_BY order_by_list { [@{$_[1]}, '-order', $_[3]] }
| boolexpr GROUP_BY group_by_list { [@{$_[1]}, '-group', $_[3]] }
| boolexpr LIMIT INTEGER { [@{$_[1]}, '-limit', $_[3]] }
| boolexpr OFFSET INTEGER { [@{$_[1]}, '-offset', $_[3]] }
;
expr: condition { $_[1] }
| expr AND expr { UR::BoolExpr::BxParser->_and($_[1], $_[3]) }
| expr OR expr { UR::BoolExpr::BxParser->_or($_[1], $_[3]) }
| LEFT_PAREN expr RIGHT_PAREN { $_[2] }
;
condition: property operator optional_spaces value { [ "$_[1] $_[2]" => $_[4] ] }
| property like_operator like_value { [ "$_[1] $_[2]" => $_[3] ] }
| property in_operator set { [ "$_[1] $_[2]" => $_[3] ] }
| property COLON optional_spaces old_syntax_in_value { [ "$_[1] in" => $_[4] ] }
| property negation COLON optional_spaces old_syntax_in_value { [ "$_[1] $_[2] in" => $_[5] ] }
| property between_operator between_value { [ "$_[1] $_[2]" => $_[3] ] }
| property COLON optional_spaces between_value { [ "$_[1] between" => $_[4] ] }
| property negation COLON optional_spaces between_value { [ "$_[1] $_[2] between" => $_[5] ] }
| property boolean_op_word { [ "$_[1] $_[2]" => 1 ] }
| property null_op_word { [ "$_[1] $_[2]" => undef ] }
;
boolean_op_word: TRUE_WORD { $_[1] }
| FALSE_WORD { $_[1] }
;
null_op_word: IS_NULL { '=' }
| negation IS_NULL { "!=" }
| IS_NOT_NULL { '!=' }
;
spaces: WHITESPACE { $_[1] }
;
optional_spaces: { undef }
| spaces { undef }
;
property: IDENTIFIER { $_[1] }
| keyword_as_value { $_[1] }
;
order_by_property: property { $_[1 ] }
| MINUS property { '-'.$_[2] }
| property DESC_WORD { '-'.$_[1] }
| property ASC_WORD { $_[1] }
;
order_by_list: order_by_property { [ $_[1]] }
| order_by_property AND order_by_list { [$_[1], @{$_[3]}] }
;
group_by_list: property { [ $_[1] ] }
| property AND group_by_list { [$_[1], @{$_[3]}] }
;
operator: an_operator { $_[1] }
| negation an_operator { "$_[1] $_[2]" }
;
negation: NOT_WORD { 'not' }
| NOT_BANG { 'not' }
;
an_operator: OPERATORS { $_[1] }
| EQUAL_SIGN { '=' }
| DOUBLEEQUAL_SIGN { '=' }
;
like_operator: LIKE_WORD { 'like' }
| negation LIKE_WORD { "$_[1] like" }
| TILDE { 'like' }
| negation TILDE { "$_[1] like" }
;
like_value: value { $_[1] =~ m/\%/ ? $_[1] : '%' . $_[1] . '%' }
;
in_operator: IN_WORD { 'in' }
| negation IN_WORD { "$_[1] in" }
;
old_syntax_in_value: single_value IN_DIVIDER old_syntax_in_value { [ $_[1], @{$_[3]} ] }
| single_value IN_DIVIDER single_value { [ $_[1], $_[3] ] }
;
set: LEFT_BRACKET set_body RIGHT_BRACKET { $_[2] }
;
set_body: value SET_SEPARATOR set_body { [ $_[1], @{$_[3]} ] }
| value { [ $_[1] ] }
;
between_operator: BETWEEN_WORD { 'between' }
| negation BETWEEN_WORD { "$_[1] between" }
;
between_value: single_value MINUS single_value { [ $_[1], $_[3] ] }
;
keyword_as_value: IN_WORD { $_[1] }
| LIKE_WORD { $_[1] }
| BETWEEN_WORD { $_[1] }
| NOT_WORD { $_[1] }
| DESC_WORD { $_[1] }
| ASC_WORD { $_[1] }
| TRUE_WORD { $_[1] }
| FALSE_WORD { $_[1] }
;
value: single_value subsequent_values_list { $_[1].$_[2] }
| single_value { $_[1] }
;
subsequent_value_part: IDENTIFIER { $_[1] }
| number { $_[1] }
| WORD { $_[1] }
| DOUBLEQUOTE_STRING { ($_[1] =~ m/^"(.*?)"$/)[0]; }
| SINGLEQUOTE_STRING { ($_[1] =~ m/^'(.*?)'$/)[0]; }
| keyword_as_value { $_[1] }
;
subsequent_values_list: subsequent_value_part { $_[1] }
| subsequent_value_part subsequent_values_list { $_[1].$_[2] }
| spaces subsequent_values_list { $_[1].$_[2] }
| spaces { '' } # to gobble the final space in a value before the next expression part
;
single_value: subsequent_value_part { $_[1] }
| AND { $_[1] }
| OR { $_[1] }
;
number: INTEGER { $_[1] + 0 }
| REAL { $_[1] + 0 }
| MINUS INTEGER { 0 - $_[2] } # to reject --5
| MINUS REAL { 0 - $_[2] }
;
%%
package UR::BoolExpr::BxParser;
use strict;
use warnings;
sub _error {
my @expect = $_[0]->YYExpect;
my $tok = $_[0]->YYData->{INPUT};
my $match = $_[0]->YYData->{MATCH};
my $string = $_[0]->YYData->{STRING};
my $err = qq(Can't parse expression "$string"\n Syntax error near token $tok '$match');
my $rem = $_[0]->YYData->{REMAINING};
$err .= ", remaining text: '$rem'" if $rem;
$err .= "\nExpected one of: " . join(", ", @expect) . "\n";
Carp::croak($err);
}
my %token_states = (
'DEFAULT' => [
WHITESPACE => qr{\s+},
AND => [ qr{and}i, 'DEFAULT'],
OR => [ qr{or}i, 'DEFAULT' ],
BETWEEN_WORD => qr{between},
LIKE_WORD => qr{like},
IN_WORD => qr{in},
NOT_WORD => qr{not},
DESC_WORD => qr{desc},
ASC_WORD => qr{asc},
TRUE_WORD => qr{true},
FALSE_WORD => qr{false},
LIMIT => qr{limit},
OFFSET => qr{offset},
IDENTIFIER => qr{[a-zA-Z_][a-zA-Z0-9_.]*},
MINUS => qr{-},
INTEGER => qr{\d+},
REAL => qr{\d*\.\d+|\d+\.\d*},
WORD => [ qr{[%\+\.\/\w][\+\-\.%\w\/]*}, # also allow / for pathnames, - for hyphenated names, % for like wildcards
'dont_gobble_spaces' ],
DOUBLEQUOTE_STRING => qr{"(?:\\.|[^"])*"},
SINGLEQUOTE_STRING => qr{'(?:\\.|[^'])*'},
LEFT_PAREN => [ qr{\(}, 'DEFAULT' ],
RIGHT_PAREN => [ qr{\)}, 'DEFAULT' ],
LEFT_BRACKET => [ qr{\[}, 'set_contents'],
RIGHT_BRACKET => [qr{\]}, 'DEFAULT' ],
NOT_BANG => qr{!},
EQUAL_SIGN => [ qr{=}, 'dont_gobble_spaces' ],
DOUBLEEQUAL_SIGN => [ qr{=>}, 'dont_gobble_spaces' ],
OPERATORS => [ qr{<=|>=|<|>}, 'dont_gobble_spaces' ],
AND => [ qr{,}, 'DEFAULT' ],
COLON => [ qr{:}, 'after_colon_value' ],
TILDE => qr{~},
ORDER_BY => qr{order by},
GROUP_BY => qr{group by},
IS_NULL => qr{is null|is undef},
IS_NOT_NULL => qr{is not null|is not undef},
],
'set_contents' => [
SET_SEPARATOR => qr{,}, # Depending on state, can be either AND or SET_SEPARATOR
WORD => qr{[%\+\.\w\:][\+\.\:%\w]*}, # also allow / for pathnames, - for hyphenated names, % for like wildcards
RIGHT_BRACKET => [qr{\]}, 'DEFAULT' ],
],
'after_colon_value' => [
INTEGER => qr{\d+},
REAL => qr{\d*\.\d+|\d+\.\d*},
IN_DIVIDER => qr{\/},
#WORD => qr{\w+}, # Override WORD in DEFAULT to disallow /
WORD => qr{[%\+\.\w\:][\+\.\:%\w]*}, # Override WORD in DEFAULT to disallow /
DOUBLEQUOTE_STRING => qr{"(?:\\.|[^"])*"},
SINGLEQUOTE_STRING => qr{'(?:\\.|[^'])*'},
WHITESPACE => [qr{\s+}, 'DEFAULT'],
],
'dont_gobble_spaces' => [
AND => [ qr{and}, 'DEFAULT'],
OR => [ qr{or}, 'DEFAULT' ],
LIMIT => [qr{limit}, 'DEFAULT'],
OFFSET => [qr{offset}, 'DEFAULT'],
INTEGER => qr{\d+},
REAL => qr{\d*\.\d+|\d+\.\d*},
WORD => qr{[%\+\.\/\w][\+\-\.\:%\w\/]*}, # also allow / for pathnames, - for hyphenated names, % for like wildcards
ORDER_BY => [qr{order by}, 'DEFAULT'],
GROUP_BY => [qr{group by}, 'DEFAULT'],
],
);
sub parse {
my $string = shift;
my %params = @_;
my $debug = $params{'tokdebug'};
my $yydebug = $params{'yydebug'} || 0;
print "\nStarting parse for string $string\n" if $debug;
my $parser = UR::BoolExpr::BxParser->new();
$parser->YYData->{STRING} = $string;
my $parser_state = 'DEFAULT';
my $get_next_token = sub {
if (length($string) == 0) {
print "String is empty, we're done!\n" if $debug;
return (undef, '');
}
GET_NEXT_TOKEN:
foreach (1) {
my $longest = 0;
my $longest_token = '';
my $longest_match = '';
for my $token_list ( $parser_state, 'DEFAULT' ) {
print "\nTrying tokens for state $token_list...\n" if $debug;
my $tokens = $token_states{$token_list};
for(my $i = 0; $i < @$tokens; $i += 2) {
my($tok, $re) = @$tokens[$i, $i+1];
print "Trying token $tok... " if $debug;
my($regex,$next_parser_state);
if (ref($re) eq 'ARRAY') {
($regex,$next_parser_state) = @$re;
} else {
$regex = $re;
}
if ($string =~ m/^($regex)/) {
print "Matched >>$1<<" if $debug;
my $match_len = length($1);
if ($match_len > $longest) {
print "\n ** It's now the longest" if $debug;
$longest = $match_len;
$longest_token = $tok;
$longest_match = $1;
if ($next_parser_state) {
$parser_state = $next_parser_state;
}
}
}
print "\n" if $debug;
}
$string = substr($string, $longest);
print "Consuming up to char pos $longest chars, string is now >>$string<<\n" if $debug;
if ($longest_token eq 'WHITESPACE' and $parser_state ne 'dont_gobble_spaces') {
print "Redoing token extraction after whitespace\n" if $debug;
redo GET_NEXT_TOKEN;
}
$parser->YYData->{REMAINING} = $string;
if ($longest) {
print "Returning token $longest_token, match $longest_match\n next state is named $parser_state\n" if $debug;
$parser->YYData->{INPUT} = $longest_token;
$parser->YYData->{MATCH} = $longest_match;
return ($longest_token, $longest_match);
}
last if $token_list eq 'DEFAULT'; # avoid going over it twice if $parser_state is DEFAULT
}
}
print "Didn't match anything, done!\n" if $debug;
return (undef, ''); # Didn't match anything
};
return ( $parser->YYParse(
yylex => $get_next_token,
yyerror => \&_error,
yydebug => $yydebug),
\$string,
);
}
# Used by the top-level expr production to turn an or-type parse tree with
# only a single AND condition into a simple AND-type tree (1-level arrayref).
# Or to add the '-or' to the front of a real OR-type tree so it can be passed
# directly to UR::BoolExpr::resolve()
sub _simplify {
my($class, $expr) = @_;
if (ref($expr->[0])) {
if (@$expr == 1) {
# An or-type parse tree, but with only one AND subrule - use as a simple and-type rule
$expr = $expr->[0];
} else {
$expr = ['-or', $expr]; # an or-type parse tree with multiple subrules
}
}
return $expr;
}
# Handles the case for "expr AND expr" where one or both exprs can be an
# OR-type expr. In that case, it distributes the AND exprs among all the
# OR conditions. For example:
# (a=1 or b=2) and (c=3 or d=4)
# is the same as
# (a=1 and c=3) or (a=1 and d=4) or (b=2 and c=3) or (b=2 and d=4)
# This is necessary because the BoolExpr resolver can only handle 1-level deep
# AND-type rules, or a 1-level deep OR-type rule composed of any number of
# 1-level deep AND-type rules
sub _and {
my($class,$left, $right) = @_;
# force them to be [[ "property operator" => value]] instead of just [ "property operator" => value ]
$left = [ $left ] unless (ref($left->[0]));
$right = [ $right ] unless (ref($right->[0]));
my @and;
foreach my $left_subexpr ( @$left ) {
foreach my $right_subexpr (@$right) {
push @and, [@$left_subexpr, @$right_subexpr];
}
}
\@and;
}
sub _or {
my($class,$left, $right) = @_;
# force them to be [[ "property operator" => value]] instead of just [ "property operator" => value ]
$left = [ $left ] unless (ref($left->[0]));
$right = [ $right ] unless (ref($right->[0]));
[ @$left, @$right ];
}
1;
Template.pm 100664 023532 023421 55025 12544604516 16623 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/BoolExpr
=head1 NAME
UR::BoolExpr::Template - a UR::BoolExpr minus specific values
=head1 SYNOPSIS
=head1 DESCRIPTION
=cut
package UR::BoolExpr::Template;
use warnings;
use strict;
use Scalar::Util qw(blessed);
use Data::Dumper;
use UR;
our @CARP_NOT = qw(UR::BoolExpr);
# readable stringification
use overload ('""' => 'id');
use overload ('==' => sub { $_[0] . '' eq $_[1] . '' } );
use overload ('eq' => sub { $_[0] . '' eq $_[1] . '' } );
UR::Object::Type->define(
class_name => __PACKAGE__,
is_transactional => 0,
composite_id_separator => '/',
id_by => [
subject_class_name => { is => 'Text' },
logic_type => { is => 'Text' },
logic_detail => { is => 'Text' },
constant_value_id => { is => 'Text' }
],
has => [
is_normalized => { is => 'Boolean' },
is_id_only => { is => 'Boolean' },
is_partial_id => { is => 'Boolean' }, # True if at least 1, but not all the ID props are mentioned
is_unique => { is => 'Boolean' },
matches_all => { is => 'Boolean' },
key_op_hash => { is => 'HASH' },
id_position => { is => 'Integer' },
normalized_id => { is => 'Text' },
normalized_positions_arrayref => { is => 'ARRAY' },
normalization_extender_arrayref => { is => 'ARRAY' },
_property_meta_hash => { is => 'HASH' },
_property_names_arrayref => { is => 'ARRAY' },
num_values => { is => 'Integer' },
_ambiguous_keys => { is => 'ARRAY' },
_keys => { is => 'ARRAY' },
_constant_values => { is => 'ARRAY' },
],
has_optional => [
hints => { is => 'ARRAY' },
recursion_desc => { is => 'ARRAY' },
order_by => { is => 'ARRAY' },
group_by => { is => 'ARRAY' },
aggregate => { is => 'ARRAY' },
limit => { is => 'Integer' },
offset => { is => 'Integer' },
]
);
our $VERSION = "0.44"; # UR $VERSION;;
# Borrow from the util package.
# This will go away with refactoring.
our $id_sep = $UR::BoolExpr::Util::id_sep;
our $record_sep = $UR::BoolExpr::Util::record_sep;
our $unit_sep = $UR::BoolExpr::Util::unit_sep;
our $null_value = $UR::BoolExpr::Util::null_value;
our $empty_string = $UR::BoolExpr::Util::empty_string;
our $empty_list = $UR::BoolExpr::Util::empty_list;
# Names of the optional flags you can add to a rule
our @meta_param_names = qw(recursion_desc hints order_by group_by aggregate limit offset);
# Wrappers for regular properties
sub _property_names {
return @{ $_[0]->{_property_names_arrayref} };
}
# Indexability methods
sub _indexable_property_names {
$_[0]->_resolve_indexing_params unless $_[0]->{_resolve_indexing_params};
@{ $_[0]->{_indexable_property_names} }
}
sub _indexable_property_positions {
$_[0]->_resolve_indexing_params unless $_[0]->{_resolve_indexing_params};
@{ $_[0]->{_indexable_property_positions} }
}
sub _is_fully_indexable {
$_[0]->_resolve_indexing_params unless $_[0]->{_resolve_indexing_params};
$_[0]->{_is_fully_indexable};
}
sub _resolve_indexing_params {
my $self = $_[0];
my $class_meta = UR::Object::Type->get($self->subject_class_name);
my @all_names = $self->_property_names;
for my $name (@all_names) {
my $m = $class_meta->property($name);
unless ($m) {
#$DB::single = 1;
$class_meta->property($name);
#$DB::single = 1;
$class_meta->property($name);
}
}
my @indexable_names =
sort
map { $_->property_name }
grep { $_ } #and $_->is_indexable }
map { $class_meta->property_meta_for_name($_) }
@all_names;
my @indexable_positions
= UR::Util::positions_of_values(\@all_names,\@indexable_names);
$self->{_indexable_property_names} = \@indexable_names;
$self->{_indexable_property_positions} = \@indexable_positions;
$self->{_is_fully_indexable} = (@indexable_names == @all_names);
return 1;
}
# Return true if this rule template's parameters is a subset of the other's parameters
# Returns 0 if this rule specifies a parameter not in the other template
# Returns undef if all the properties match, but their operators do not, meaning that
# we do not know if an object evaluated as true under one rule's template would also be in the other
sub is_subset_of {
my($self,$other_template) = @_;
my $other_template_id = $other_template->id;
my $cached_subset_data = $self->{'__cache'}->{'is_subset_of'} ||= {};
if (exists $cached_subset_data->{$other_template_id}) {
return $cached_subset_data->{$other_template_id};
}
unless (ref($other_template) and $self->isa(ref $other_template)) {
$cached_subset_data->{$other_template_id} = 0;
return 0;
}
my $my_class = $self->subject_class_name;
my $other_class = $other_template->subject_class_name;
unless ($my_class eq $other_class or $my_class->isa($other_class)) {
$cached_subset_data->{$other_template_id} = undef;
return;
}
my %operators = map { $_ => $self->operator_for($_) } $self->_property_names;
my $operators_match = 1;
foreach my $prop ( $other_template->_property_names ) {
unless (exists $operators{$prop}) {
$operators_match = 0;
last;
}
$operators_match = undef if ($operators{$prop} ne $other_template->operator_for($prop));
}
$cached_subset_data->{$other_template_id} = $operators_match;
return $operators_match;
}
# This is set lazily currently
sub is_unique {
my $self = $_[0];
if (defined $self->{is_unique}) {
return $self->{is_unique}
}
# since this requires normalization, we don't set the value at construction time
my $normalized_self;
if ($self->is_normalized) {
$normalized_self = $self;
}
else {
$normalized_self = $self->get_normalized_template_equivalent($self);
}
my $op = $normalized_self->operator_for('id');
if (defined($op) and ($op eq '' or $op eq '=')) {
return $self->{is_unique} = 1;
}
else {
$self->{is_unique} = 0;
# if some combination of params can combine to
# satisfy at least one unique constraint,
# then we have uniqueness in the parameters.
if (my @ps = $self->subject_class_name->__meta__->unique_property_sets) {
my $property_meta_hash = $self->_property_meta_hash;
for my $property_set (@ps)
{
my $property_set = (ref($property_set) ? $property_set : [$property_set]);
my @properties_used_from_constraint =
grep { defined($_) }
@$property_meta_hash{@$property_set};
if (@properties_used_from_constraint == @$property_set) {
# filter imprecise operators
@properties_used_from_constraint =
grep {
$_->{operator} !~ /^(not |)like(-.|)$/i
and
$_->{operator} !~ /^(not |)in/i
}
@properties_used_from_constraint;
if (@properties_used_from_constraint == @$property_set) {
$self->{is_unique} = 1;
last;
}
else {
## print "some properties use bad operators: @properties_used_from_constraint\n";
}
}
else {
## print "too few properties in @properties_used_from_constraint\n";
}
}
}
return $self->{is_unique};
}
}
# Derivative of the ID.
sub rule_template_subclass_name {
return "UR::BoolExpr::Template::" . shift->logic_type;
}
sub get_normalized_template_equivalent {
UR::BoolExpr::Template->get($_[0]->{normalized_id});
}
sub get_rule_for_values {
my $self = shift;
my $value_id = UR::BoolExpr::Util::values_to_value_id(@_);
my $rule_id = UR::BoolExpr->__meta__->resolve_composite_id_from_ordered_values($self->id,$value_id);
my $r = UR::BoolExpr->get($rule_id);
#
# # FIXME - Don't do this part if the operator is 'in' or 'between'
# for (my $i = 0; $i < @_; $i++) {
# if (ref($_[$i]) and ! Scalar::Util::blessed($_[$i])) {
# $r->{'hard_refs'}->{$i} = $_[$i];
# }
# }
return $r;
}
sub get_rule_for_value_id {
my $self = shift;
my $value_id = shift;
my $rule_id = UR::BoolExpr->__meta__->resolve_composite_id_from_ordered_values($self->id,$value_id);
return UR::BoolExpr->get($rule_id);
}
sub extend_params_list_for_values {
my $self = shift;
#my @prev = @_;
my $extenders = $self->normalization_extender_arrayref;
if (@$extenders) {
my @result;
my $subject_class = $self->subject_class_name->__meta__;
for my $n (0 .. @$extenders-1) {
my $extender = $extenders->[$n];
my ($input_positions_arrayref,$subref,@more_keys) = @$extender;
my @more_values = @_[@$input_positions_arrayref];
if ($subref) {
## print "calling $subref on \n\t" . join("\n\t",@more_values) . "\n";
@more_values = $subject_class->$subref(@more_values);
## print "got: \n\t" . join("\n\t",@more_values) . "\n";
}
while (@more_keys) {
my $k = shift @more_keys;
my $v = shift @more_values;
push @result, $k => $v;
}
}
return @result;
}
return ();
}
sub get_normalized_rule_for_values {
my $self = shift;
my @unnormalized_values = @_;
if ($self->is_normalized) {
return $self->get_rule_for_values(@unnormalized_values);
}
my $normalized_rule_template = $self->get_normalized_template_equivalent;
# The normalized rule set may have more values than were actually
# passed-in. These 'extenders' will add to the @values array
# before re-ordering it.
my $extenders = $self->normalization_extender_arrayref;
if (@$extenders) {
my $subject_class = $self->subject_class_name->__meta__;
for my $extender (@$extenders) {
my ($input_positions_arrayref,$subref) = @$extender;
my @more_values = @unnormalized_values[@$input_positions_arrayref];
if ($subref) {
## print "calling $subref on \n\t" . join("\n\t",@more_values) . "\n";
@more_values = $subject_class->$subref(@more_values);
## print "got: \n\t" . join("\n\t",@more_values) . "\n";
}
push @unnormalized_values, @more_values;
}
}
# Normalize the values. Since the normalized template may have added properties,
# and a different order we may need to re-order and expand the values list.
my $normalized_positions_arrayref = $self->normalized_positions_arrayref;
my @normalized_values = @unnormalized_values[@$normalized_positions_arrayref];
my $rule = $normalized_rule_template->get_rule_for_values(@normalized_values);
return $rule;
}
sub _normalize_non_ur_values_hash {
my ($self,$unnormalized) = @_;
my %normalized;
if ($self->subject_class_name ne 'UR::Object::Property') {
my $normalized_positions_arrayref = $self->normalized_positions_arrayref;
my @reordered_values = @$unnormalized{@$normalized_positions_arrayref};
for (my $n = 0; $n < @reordered_values; $n++) {
my $value = $reordered_values[$n];
$normalized{$n} = $value if defined $value;
}
}
return \%normalized;
}
sub value_position_for_property_name {
if (exists $_[0]{_property_meta_hash}{$_[1]}) {
return $_[0]{_property_meta_hash}{$_[1]}{value_position};
} else {
return undef;
}
}
sub operator_for {
if (exists $_[0]{_property_meta_hash}{$_[1]}) {
return $_[0]{_property_meta_hash}{$_[1]}{operator} || '=';
} else {
return undef;
}
}
sub operators_for_properties {
my %properties = map { $_ => $_[0]->{'_property_meta_hash'}->{$_}->{'operator'} || '=' }
@{ $_[0]->{'_property_names_arrayref'} };
return \%properties;
}
sub add_filter {
my $self = shift;
my $property_name = shift;
my $op = shift;
my $new_key = $property_name;
$new_key .= ' ' . $op if defined $op;
my ($subject_class_name, $logic_type, $logic_detail) = split("/",$self->id);
unless ($logic_type eq 'And') {
die "Attempt to add a filter to a rule besides an 'And' rule!";
}
my @keys = split(',',$logic_detail);
my $new_id = join('/',$subject_class_name,$logic_type,join(',',@keys,$new_key));
return $self->class->get($new_id);
}
sub remove_filter {
my $self = shift;
my $filter = shift;
my ($subject_class_name, $logic_type, $logic_detail) = split("/",$self->id);
my @keys = grep { $_ !~ /^${filter}\b/ } split(',',$logic_detail);
my $new_id = join('/',$subject_class_name,$logic_type,join(',',@keys));
#print "$new_id\n";
return $self->class->get($new_id);
}
sub sub_classify {
my ($self,$subclass_name) = @_;
my $new_id = $self->id;
$new_id =~ s/^.*?\//$subclass_name\//;
return $self->class->get($new_id);
}
# flyweight constructor
# NOTE: this caches outside of the regular system since these are stateless objects
sub get_by_subject_class_name_logic_type_and_logic_detail {
my $class = shift;
my $subject_class_name = shift;
Carp::croak("Expected a subject class name as the first arg of UR::BoolExpr::Template constructor, got "
. ( defined($subject_class_name) ? "'$subject_class_name'" : "(undef)" ) ) unless ($subject_class_name);
my $logic_type = shift;
my $logic_detail = shift;
my $constant_value_id = shift || UR::BoolExpr::Util::values_to_value_id(); # default is an empty list of values
return $class->get(join('/',$subject_class_name,$logic_type,$logic_detail,$constant_value_id));
}
# The analogue of resolve in UR::BoolExpr. @params_list is a list if
# strings containing properties and operators separated by a space. For ex: "some_param ="
sub resolve {
my($class,$subject_class_name, @params_list) = @_;
my(@params, @constant_values);
for (my $i = 0; $i < @params_list; $i++) {
push @params, $params_list[$i];
if (UR::BoolExpr::Util::is_meta_param($params_list[$i])) {
push @constant_values, $params_list[++$i];
}
}
return $class->get_by_subject_class_name_logic_type_and_logic_detail(
$subject_class_name,
"And",
join(',',@params),
UR::BoolExpr::Util::values_to_value_id(@constant_values));
}
sub get {
my $class = shift;
my $id = shift;
Carp::croak("Non-id params not supported for " . __PACKAGE__ . " yet!") if @_;
my $self = $UR::Object::rule_templates->{$id};
return $self if $self;
my ($subject_class_name,$logic_type,$logic_detail,$constant_value_id,@extra) = split('/',$id);
if (@extra) {
# account for a possible slash in the constant value id
$constant_value_id = join('/',$constant_value_id,@extra);
}
# work on the base class or on subclasses
my $sub_class_name = (
$class eq __PACKAGE__
? __PACKAGE__ . "::" . $logic_type
: $class
);
unless ($logic_type) {
Carp::croak("Could not determine logic type from UR::BoolExpr::Template with id $id");
}
if ($logic_type eq "And") {
# TODO: move into subclass
my @keys = split(/,/,$logic_detail || '');
my @constant_values;
@constant_values = UR::BoolExpr::Util::value_id_to_values($constant_value_id) if defined $constant_value_id;
return $sub_class_name->_fast_construct(
$subject_class_name,
\@keys,
\@constant_values,
$logic_detail,
$constant_value_id,
);
}
else {
$self = bless {
id => $id,
subject_class_name => $subject_class_name,
logic_type => $logic_type,
logic_detail => $logic_detail,
constant_value_id => $constant_value_id,
normalized_id => $id,
}, $sub_class_name;
$UR::Object::rule_templates->{$id} = $self;
return $self;
}
}
# Return true if the template has recursion_desc, hints, order or page set
sub has_meta_options {
my $self = shift;
return 1 if @$self{@meta_param_names};
return 0;
}
# This is the basis for the hash used by the existing UR::Object system for each rule.
# this is created upon first request and cached in the object
sub legacy_params_hash {
my $self = shift;
my $legacy_params_hash = $self->{legacy_params_hash};
return $legacy_params_hash if $legacy_params_hash;
$legacy_params_hash = {};
my $template_id = $self->id;
my $key_op_hash = $self->key_op_hash;
my $id_only = $self->is_id_only;
my $subject_class_name = $self->subject_class_name;
my $logic_type = $self->logic_type;
my $logic_detail = $self->logic_detail;
my @keys_sorted = $self->_underlying_keys;
my $subject_class_meta = $subject_class_name->__meta__;
if (
(@keys_sorted and not $logic_detail)
or
($logic_detail and not @keys_sorted)
) {
Carp::confess();
}
if (!$logic_detail) {
%$legacy_params_hash = (_unique => 0, _none => 1);
}
else {
# _id_only
if ($id_only) {
$legacy_params_hash->{_id_only} = 1;
}
else {
$legacy_params_hash->{_id_only} = 0;
$legacy_params_hash->{_param_key} = undef;
}
# _unique
if (my $id_op = $key_op_hash->{id}) {
if ($id_op->{""} or $id_op->{"="}) {
$legacy_params_hash->{_unique} = 1;
unless ($self->is_unique) {
Carp::carp("The BoolExpr includes a filter on ID, but the is_unique flag is unexpectedly false for $self->{id}");
}
}
}
unless ($legacy_params_hash->{_unique}) {
if (defined $legacy_params_hash->{id} and not ref $legacy_params_hash->{id}) {
# if we have the id, then we have uniqueness
# NOT TRUE: we catch the truly unieq cses of having an id and an unambiguous operator above
#$legacy_params_hash->{_unique} = 1;
}
else {
# default to non-unique
$legacy_params_hash->{_unique} = 0;
# if some combination of params can combine to
# satisfy at least one unique constraint,
# then we have uniqueness in the parameters.
my @ps = $subject_class_meta->unique_property_sets;
for my $property_set (@ps)
{
my $property_set = (ref($property_set) ? $property_set : [$property_set]);
my @properties_used_from_constraint =
grep { defined($_) }
(ref($property_set) ? @$key_op_hash{@$property_set} : $key_op_hash->{$property_set});
if (@properties_used_from_constraint == @$property_set) {
# filter imprecise operators
@properties_used_from_constraint =
grep {
not (
grep { /^(not |)like(-.|)$/i or /^\[\]/}
keys %$_
)
}
@properties_used_from_constraint;
if (@properties_used_from_constraint == @$property_set) {
$legacy_params_hash->{_unique} = 1;
last;
}
else {
## print "some properties use bad operators: @properties_used_from_constraint\n";
}
}
else {
## print "too few properties in @properties_used_from_constraint\n";
}
}
}
# _param_key gets re-set as long as this has a true value
$legacy_params_hash->{_param_key} = undef unless $id_only;
}
}
if ($self->is_unique and not $legacy_params_hash->{_unique}) {
Carp::carp "is_unique IS set but legacy params hash is NO for $self->{id}";
#$DB::single = 1;
$self->is_unique;
}
if (!$self->is_unique and $legacy_params_hash->{_unique}) {
Carp::carp "is_unique NOT set but legacy params hash IS for $self->{id}";
#$DB::single = 1;
$self->is_unique;
}
$self->{legacy_params_hash} = $legacy_params_hash;
return $legacy_params_hash;
}
sub sorter {
my $self = shift;
# return a standard sorter for expressions using this template
# the template might contain a group_by or order_by clause which affects it...
die "this method takes no paramters!" if @_;
my $class = $self->subject_class_name;
my $sort_meta;
if ($self->group_by) {
my $set_class = $class . "::Set";
$sort_meta = $set_class->__meta__;
}
else {
$sort_meta = $class->__meta__;
}
my $sorter;
if (my $order_by = $self->order_by) {
$sorter = $sort_meta->sorter(@$order_by);
}
else {
$sorter = $sort_meta->sorter();
}
return $sorter;
}
1;
And.pm 100664 023532 023421 106120 12544604516 17336 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/BoolExpr/Template package UR::BoolExpr::Template::And;
use warnings;
use strict;
require UR;
our $VERSION = "0.44"; # UR $VERSION;;
UR::Object::Type->define(
class_name => __PACKAGE__,
is => ['UR::BoolExpr::Template::Composite'],
);
sub _flatten_bx {
my ($class, $bx) = @_;
my $template = $bx->template;
my ($flattened_template, @extra_values) = $template->_flatten(@_);
my $flattened_bx;
if (not @extra_values) {
# optimized
my $flattened_bx_id = $flattened_template->id . $UR::BoolExpr::Util::id_sep . $bx->value_id;
$flattened_bx = UR::BoolExpr->get($flattened_bx_id);
$flattened_bx->{'values'} = $bx->{'values'} unless $flattened_bx->{'values'};
}
else {
$flattened_bx = $flattened_template->get_rule_for_values($bx->values, @extra_values);
}
return $flattened_bx;
}
sub _reframe_bx {
my ($class, $bx, $in_terms_of_property_name) = @_;
my $template = $bx->template;
my ($reframed_template, @extra_values) = $template->_reframe($in_terms_of_property_name);
my $reframed_bx;
if (@extra_values == 0) {
my $reframed_bx_id = $reframed_template->id . $UR::BoolExpr::Util::id_sep . $bx->value_id;
$reframed_bx = UR::BoolExpr->get($reframed_bx_id);
$reframed_bx->{'values'} = $bx->{'values'} unless $reframed_bx->{'values'};
}
else {
my @values = ($bx->values, @extra_values);
$reframed_bx = $reframed_template->get_rule_for_values(@values);
}
return $reframed_bx;
}
sub _flatten {
my $self = $_[0];
if ($self->{flatten}) {
return @{ $self->{flatten} }
}
my @old_keys = @{ $self->_keys };
my $old_property_meta_hash = $self->_property_meta_hash;
my $class_meta = $self->subject_class_name->__meta__;
my @new_keys;
my @extra_keys;
my @extra_values;
my $old_constant_values;
my @new_constant_values;
my $found_unflattened_params = 0;
while (my $key = shift @old_keys) {
my $name = $key;
$name =~ s/ .*//;
if (! UR::BoolExpr::Util::is_meta_param($name)) {
my $mdata = $old_property_meta_hash->{$name};
my ($value_position, $operator) = @$mdata{'value_position','operator'};
my ($flat, $add_keys, $add_values) = $class_meta->_flatten_property_name($name);
$found_unflattened_params = 1 if $flat ne $name or @$add_keys or @$add_values;
$flat .= ' ' . $operator if $operator and $operator ne '=';
push @new_keys, $flat;
push @extra_keys, @$add_keys;
push @extra_values, @$add_values;
}
else {
push @new_keys, $key;
$old_constant_values ||= [ @{ $self->_constant_values } ];
my $old_value = shift @$old_constant_values;
my $new_value = [];
for my $part (@$old_value) {
my ($flat, $add_keys, $add_values) = $class_meta->_flatten_property_name($part);
$found_unflattened_params = 1 if $flat ne $name or @$add_keys or @$add_values;
push @$new_value, $flat;
push @extra_keys, @$add_keys;
push @extra_values, @$add_values;
}
push @new_constant_values, $new_value;
}
}
my $constant_values;
if ($old_constant_values) {
# some -* keys were found above, and we flattened the value internals
$constant_values = \@new_constant_values;
}
else {
# no -* keys, just re-use the empty arrayref
$constant_values = $self->_constant_values;
}
if ($found_unflattened_params or @extra_keys) {
if (@extra_keys) {
# there may be duplication between these and the primary joins
# or each other
my %keys_seen = map { $_ => 1 } @new_keys;
my @nodup_extra_keys;
my @nodup_extra_values;
while (my $extra_key = shift @extra_keys) {
my $extra_value = shift @extra_values;
unless ($keys_seen{$extra_key}) {
push @nodup_extra_keys, $extra_key;
push @nodup_extra_values, $extra_value;
$keys_seen{$extra_key} = 1;
}
}
push @new_keys, @nodup_extra_keys;
@extra_values = @nodup_extra_values
}
my $flat = UR::BoolExpr::Template::And->_fast_construct(
$self->subject_class_name,
\@new_keys,
$constant_values,
);
$self->{flatten} = [$flat,@extra_values];
return ($flat, @extra_values);
}
else {
# everything was already flat, just remember this so you DRY
$self->{flatten} = [$self];
Scalar::Util::weaken($self->{flatten}[0]);
return $self
}
}
sub _reframe {
my $self = shift;
my $in_terms_of_property_name = shift;
# determine the from_class, to_class, and path_back
my $from_class = $self->subject_class_name;
my $cmeta = $self->subject_class_name->__meta__;
my @pmeta = $cmeta->property_meta_for_name($in_terms_of_property_name);
unless (@pmeta) {
Carp::confess("Failed to find property $in_terms_of_property_name on $from_class. Cannot reframe $self!");
}
my @reframe_path_forward = map { $_->_resolve_join_chain($in_terms_of_property_name) } @pmeta;
my $to_class = $reframe_path_forward[-1]{foreign_class};
# translate all of the old properties to use the path back to the original class
my ($flat,@extra_values) = $self->_flatten;
my @old_keys = @{ $flat->_keys };
my $old_property_meta_hash = $flat->_property_meta_hash;
my %sub_group_label_used;
my $reframer = sub {
my $old_name = $_[0];
# uses: @reframe_path_forward from above in this closure
# get back to the original object
my @reframe_path_back = reverse @reframe_path_forward;
# then forward to the property related to it
my @filter_path_forward = split('\.',$old_name);
# if the end of the path back matches the beginning of the path
# to the property in the expression unneeded steps (beyond 1)
my $new_key;
while (1) {
unless (@reframe_path_back) {
last;
}
unless (@filter_path_forward) {
last;
}
my $last_name_back = $reframe_path_back[-1]{source_name_for_foreign};
my $first_name_forward = $filter_path_forward[0];
my $turnaround_match = 0;
if ($last_name_back eq $first_name_forward) {
# complete overlap
$turnaround_match = 1; # safe
}
else {
# see if stripping off any labels makes them match
my $last_name_back_base = $last_name_back;
$last_name_back_base =~ s/-.*//;
my $first_name_forward_base = $first_name_forward;
$first_name_forward_base =~ s/-.*//;
if ($last_name_back_base eq $first_name_forward_base) {
# removing the grouping label causes a match
# possible overlap
for my $pair (
[$first_name_forward_base, $last_name_back],
[$last_name_back_base, $first_name_forward],
) {
my ($partial, $full) = @$pair;
if (index($full, $partial) == 0) {
#print "$partial is part of $full\n";
if (my $prev_full = $sub_group_label_used{$partial}) {
# we've tracked back through this $partially specified relationship once
# see if we did it the same way
if ($prev_full eq $full) {
$turnaround_match = 1;
}
else {
#print "previously used $prev_full for $partial: cannot use $full\n";
next;
}
}
else {
# this relationship has not been seen
#print "using $full for $partial\n";
$sub_group_label_used{$partial} = $full;
$turnaround_match = 1;
}
}
}
}
}
if ($turnaround_match == 0) {
# found a difference: no shortcut
# we have to trek all the way back to the original subject before
# moving forward to this property
last;
}
else {
# the last step back matches the first step to the property
if (@reframe_path_back == 1 and @filter_path_forward == 1) {
# just keep one of the identical pair
shift @filter_path_forward;
}
else {
# remove both (if one is empty this is no problem)
pop @reframe_path_back;
shift @filter_path_forward;
}
}
}
$new_key = join('.', map { $_->{foreign_name_for_source} } @reframe_path_back);
$new_key = join('.', ($new_key ? $new_key : ()), @filter_path_forward);
return $new_key;
};
# this is only set below if we find any -* keys
my $old_constant_values;
my @new_keys;
my @new_constant_values;
while (@old_keys) {
my $old_key = shift @old_keys;
if (! UR::BoolExpr::Util::is_meta_param($old_key)) {
# a regular property
my $old_name = $old_key;
$old_name =~ s/ .*//;
my $mdata = $old_property_meta_hash->{$old_name};
my ($value_position, $operator) = @$mdata{'value_position','operator'};
my $new_key = $reframer->($old_name);
$new_key .= ' ' . $operator if $operator and $operator ne '=';
push @new_keys, $new_key;
}
else {
# this key is not a property, it's a special key like -order_by or -group_by
unless ($old_key eq '-order_by'
or $old_key eq '-group_by'
or $old_key eq '-hints'
or $old_key eq '-recurse'
) {
Carp::confess("no support yet for $old_key in bx reframe()!");
}
push @new_keys, $old_key;
unless ($old_constant_values) {
$old_constant_values = [ @{ $flat->_constant_values } ];
}
my $old_value = shift @$old_constant_values;
my $new_value = [];
for my $part (@$old_value) {
my $reframed_part = $reframer->($part);
push @$new_value, $reframed_part;
}
push @new_constant_values, $new_value;
}
}
my $constant_values;
if (@new_constant_values) {
$constant_values = \@new_constant_values;
}
else {
$constant_values = $flat->_constant_values; # re-use empty immutable arrayref
}
my $reframed = UR::BoolExpr::Template::And->_fast_construct(
$to_class,
\@new_keys,
$constant_values,
);
return $reframed, @extra_values;
}
sub _template_for_grouped_subsets {
my $self = shift;
my $group_by = $self->group_by;
die "rule template $self->{id} has no -group_by!?!?" unless $group_by;
my @base_property_names = $self->_property_names;
for (my $i = 0; $i < @base_property_names; $i++) {
my $operator = $self->operator_for($base_property_names[$i]);
if ($operator ne '=') {
$base_property_names[$i] .= " $operator";
}
}
my $template = UR::BoolExpr::Template->get_by_subject_class_name_logic_type_and_logic_detail(
$self->subject_class_name,
'And',
join(",", @base_property_names, @$group_by),
);
return $template;
}
sub _variable_value_count {
my $self = shift;
my $k = $self->_underlying_keys;
my $v = $self->_constant_values;
if ($v) {
$v = scalar(@$v);
}
else {
$v = 0;
}
return $k-$v;
}
sub _underlying_keys {
my $self = shift;
my $logic_detail = $self->logic_detail;
return unless $logic_detail;
my @underlying_keys = split(",",$logic_detail);
return @underlying_keys;
}
sub get_underlying_rule_templates {
my $self = shift;
my @underlying_keys = grep { UR::BoolExpr::Util::is_meta_param($_) ? () : ($_) } $self->_underlying_keys();
my $subject_class_name = $self->subject_class_name;
return map {
UR::BoolExpr::Template::PropertyComparison
->_get_for_subject_class_name_and_logic_detail(
$subject_class_name,
$_
);
} @underlying_keys;
}
sub specifies_value_for {
my ($self, $property_name) = @_;
Carp::confess('Missing required parameter property_name for specifies_value_for()') if not defined $property_name;
my @underlying_templates = $self->get_underlying_rule_templates();
foreach ( @underlying_templates ) {
return 1 if $property_name eq $_->property_name;
}
return;
}
sub _filter_breakdown {
my $self = $_[0];
my $filter_breakdown = $self->{_filter_breakdown} ||= do {
my @underlying = $self->get_underlying_rule_templates;
my @primary;
my %sub_group_filters;
my %sub_group_sub_filters;
for (my $n = 0; $n < @underlying; $n++) {
my $underlying = $underlying[$n];
my $sub_group = $underlying->sub_group;
if ($sub_group) {
if (substr($sub_group,-1) ne '?') {
# control restruct the subject based on the sub-group properties
my $list = $sub_group_filters{$sub_group} ||= [];
push @$list, $underlying, $n;
}
else {
# control what is IN a sub-group (effectively define it with these)
chop($sub_group);
my $list = $sub_group_sub_filters{$sub_group} ||= [];
push @$list, $underlying, $n;
}
}
else {
push @primary, $underlying, $n;
}
}
{
primary => \@primary,
sub_group_filters => \%sub_group_filters,
sub_group_sub_filters => \%sub_group_sub_filters,
};
};
return $filter_breakdown;
}
sub evaluate_subject_and_values {
my $self = shift;
my $subject = shift;
return unless (ref($subject) && $subject->isa($self->subject_class_name));
my $filter_breakdown = $self->_filter_breakdown;
my ($primary,$sub_group_filters,$sub_group_sub_filters)
= @$filter_breakdown{"primary","sub_group_filters","sub_group_sub_filters"};
# flattening expresions now requires that we re-group them :(
# these effectively are subqueries where they occur
# check the ungrouped comparisons first since they are simpler
for (my $n = 0; $n < @$primary; $n+=2) {
my $underlying = $primary->[$n];
my $pos = $primary->[$n+1];
my $value = $_[$pos];
unless ($underlying->evaluate_subject_and_values($subject, $value)) {
return;
}
}
# only check the complicated rules if none of the above failed
if (%$sub_group_filters) {
#$DB::single = 1;
for my $sub_group (keys %$sub_group_filters) {
my $filters = $sub_group_filters->{$sub_group};
my $sub_filters = $sub_group_sub_filters->{$sub_group};
print "FILTERING $sub_group: " . Data::Dumper::Dumper($filters, $sub_filters);
}
}
return 1;
}
sub params_list_for_values {
# This is the reverse of the bulk of resolve.
# It returns the params in list form, directly coercable into a hash if necessary.
# $r = UR::BoolExpr->resolve($c1,@p1);
# ($c2, @p2) = ($r->subject_class_name, $r->params_list);
my $rule_template = shift;
my @values_sorted = @_;
my @keys_sorted = $rule_template->_underlying_keys;
my $constant_values = $rule_template->_constant_values;
my @params;
my ($v,$c) = (0,0);
for (my $k=0; $k<@keys_sorted; $k++) {
my $key = $keys_sorted[$k];
#if (substr($key,0,1) eq "_") {
# next;
#}
if (UR::BoolExpr::Util::is_meta_param($key)) {
my $value = $constant_values->[$c];
push @params, $key, $value;
$c++;
}
else {
my ($property, $op) = ($key =~ /^(\-*[\w\.]+)\s*(.*)$/);
unless ($property) {
$DB::single = 1;
Carp::confess("bad key '$key' in ",join(', ', @keys_sorted));
}
my $value = $values_sorted[$v];
if ($op) {
if ($op ne "in") {
if ($op =~ /^(.+)-(.+)$/) {
$value = { operator => $1, value => $value, escape => $2 };
}
else {
$value = { operator => $op, value => $value };
}
}
}
push @params, $property, $value;
$v++;
}
}
return @params;
}
sub _fast_construct {
my ($class,
$subject_class_name, # produces subject class meta
$keys, # produces logic detail
$constant_values, # produces constant value id
$logic_detail, # optional, passed by get
$constant_value_id, # optional, passed by get
$subject_class_meta, # optional, passed by bx
) = @_;
my $logic_type = 'And';
$logic_detail ||= join(",",@$keys);
$constant_value_id ||= UR::BoolExpr::Util::values_to_value_id(@$constant_values);
my $id = join('/',$subject_class_name,$logic_type,$logic_detail,$constant_value_id);
my $self = $UR::Object::rule_templates->{$id};
return $self if $self;
$subject_class_meta ||= $subject_class_name->__meta__;
# See what properties are id-related for the class
my $cache = $subject_class_meta->{cache}{'UR::BoolExpr::Template::get'} ||= do {
my $id_related = {};
my $id_translations = [];
my $id_pos = {};
my $id_prop_is_real; # true if there's a property called 'id' that's a real property, not from UR::Object
for my $iclass ($subject_class_name, $subject_class_meta->ancestry_class_names) {
last if $iclass eq "UR::Object";
next unless $iclass->isa("UR::Object");
my $iclass_meta = $iclass->__meta__;
my @id_props = $iclass_meta->id_property_names;
next unless @id_props;
$id_prop_is_real = 1 if (grep { $_ eq 'id'} @id_props);
next if @id_props == 1 and $id_props[0] eq "id" and !$id_prop_is_real;
@$id_related{@id_props} = @id_props;
push @$id_translations, \@id_props;
@$id_pos{@id_props} = (0..$#id_props) unless @id_props == 1 and $id_props[0] eq 'id';
}
[$id_related,$id_translations,$id_pos];
};
my ($id_related,$id_translations,$id_pos) = @$cache;
my @keys = @$keys;
my @constant_values = @$constant_values;
# Make a hash to quick-validate the params for duplication
no warnings;
my %check_for_duplicate_rules;
for (my $n=0; $n < @keys; $n++) {
next if UR::BoolExpr::Util::is_meta_param($keys[$n]);
my $pos = index($keys[$n],' ');
if ($pos != -1) {
my $property = substr($keys[$n],0,$pos);
$check_for_duplicate_rules{$property}++;
}
else {
$check_for_duplicate_rules{$keys[$n]}++;
}
}
# each item in this list mutates the initial set of key-value pairs
my $extenders = [];
# add new @$extenders for class-specific characteristics
# add new @keys at the same time
# flag keys as removed also at the same time
# note the positions for each key in the "original" rule
# by original, we mean the original plus the extensions from above
#
my $id_position = undef;
my $var_pos = 0;
my $const_pos = 0;
my $property_meta_hash = {};
my $property_names = [];
for my $key (@keys) {
if (UR::BoolExpr::Util::is_meta_param($key)) {
$property_meta_hash->{$key} = {
name => $key,
value_position => $const_pos
};
$const_pos++;
}
else {
my ($name, $op) = ($key =~ /^(.+?)\s+(.*)$/);
$name ||= $key;
if ($name eq 'id') {
$id_position = $var_pos;
}
$property_meta_hash->{$name} = {
name => $name,
operator => $op,
value_position => $var_pos
};
$var_pos++;
push @$property_names, $name;
}
}
# Note whether there are properties not involved in the ID
# Add value extenders for any cases of id-related properties,
# or aliases.
my $original_key_count = @keys;
my $id_only = 1;
my $partial_id = 0;
my $key_op_hash = {};
if (@$id_translations and @{$id_translations->[0]} == 1) {
# single-property ID
## use Data::Dumper;
## print "single property id\n". Dumper($id_translations);
my ($property, $op);
# Presume we are only getting id properties until another is found.
# If a multi-property is partially specified, we'll zero this out too.
my $values_index = -1; # -1 so we can bump it at start of loop
for (my $key_pos = 0; $key_pos < $original_key_count; $key_pos++) {
my $key = $keys[$key_pos];
if (UR::BoolExpr::Util::is_meta_param($key)) {
# -* are constant value keys and do not need to be changed
next;
} else {
$values_index++;
}
my ($property, $op) = ($key =~ /^(.+?)\s+(.*)$/);
$property ||= $key;
$op ||= "";
$op =~ s/\s+//;
$key_op_hash->{$property} ||= {};
$key_op_hash->{$property}{$op}++;
if ($property eq "id" or $id_related->{$property}) {
# Put an id key into the key list.
for my $alias (["id"], @$id_translations) {
next if $alias->[0] eq $property;
next if $check_for_duplicate_rules{$alias->[0]};
$op ||= "";
push @keys, $alias->[0] . ($op ? " $op" : "");
push @$extenders, [ [$values_index], undef, $keys[-1] ];
$key_op_hash->{$alias->[0]} ||= {};
$key_op_hash->{$alias->[0]}{$op}++;
## print ">> extend for @$alias with op $op.\n";
}
unless ($op =~ m/^(=|eq|in|\[\]|)$/) {
$id_only = 0;
}
}
elsif (! UR::BoolExpr::Util::is_meta_param($key)) {
$id_only = 0;
## print "non id single property $property on $subject_class\n";
}
}
}
else {
# multi-property ID
## print "multi property id\n". Dumper($id_translations);
my ($property, $op);
my %id_parts;
my $values_index = -1; # -1 so we can bump it at start of loop
my $id_op;
for (my $key_pos = 0; $key_pos < $original_key_count; $key_pos++) {
my $key = $keys[$key_pos];
if (UR::BoolExpr::Util::is_meta_param($key)) {
# -* are constant value keys and do not need to be changed
next;
} else {
$values_index++;
}
next if UR::BoolExpr::Util::is_meta_param($key);
my ($property, $op) = ($key =~ /^(.+?)\s+(.*)$/);
$property ||= $key;
$op ||= '';
$op =~ s/^\s+// if $op;
$key_op_hash->{$property} ||= {};
$key_op_hash->{$property}{$op}++;
if ($property eq "id") {
$id_op = $op;
$key_op_hash->{id} ||= {};
$key_op_hash->{id}{$op}++;
# Put an id-breakdown key into the key list.
for my $alias (@$id_translations) {
my @new_keys = map { $_ . ($op ? " $op" : "") } @$alias;
if (grep { $check_for_duplicate_rules{$_} } @$alias) {
#print "up @new_keys with @$alias\n";
}
else {
push @keys, @new_keys;
push @$extenders, [ [$values_index], "resolve_ordered_values_from_composite_id", @new_keys ];
for (@$alias) {
$key_op_hash->{$_} ||= {};
$key_op_hash->{$_}{$op}++;
}
# print ">> extend for @$alias with op $op.\n";
}
}
}
elsif ($id_related->{$property}) {
$id_op ||= $op;
if ($op eq "" or $op eq "eq" or $op eq "=" or $op eq 'in') {
$id_parts{$id_pos->{$property}} = $values_index;
}
else {
# We're doing some sort of gray-area comparison on an ID
# field, and though we could possibly resolve an ID
# from things like an 'in' op, it's more than we've done
# before.
$id_only = 0;
}
}
else {
## print "non id multi property $property on class $subject_class\n";
$id_only = 0;
}
}
if (my $parts = (scalar(keys(%id_parts)))) {
# some parts are id-related
if ($parts == @{$id_translations->[0]}) {
# all parts are of the id are there
if (@$id_translations) {
if (grep { $_ eq 'id' } @keys) {
#print "found id already\n";
}
else {
#print "no id\n";
# we have translations of that ID into underlying properties
#print "ADDING ID for " . join(",",keys %id_parts) . "\n";
my @id_pos = sort { $a <=> $b } keys %id_parts;
push @$extenders, [ [@id_parts{@id_pos}], "resolve_composite_id_from_ordered_values", 'id' ]; #TODO was this correct?
$key_op_hash->{id} ||= {};
$key_op_hash->{id}{$id_op}++;
push @keys, "id";
}
}
}
else {
# not all parts of the id are there
## print "partial id property $property on class $subject_class\n";
$id_only = 0;
$partial_id = 1;
}
} else {
$id_only = 0;
$partial_id = 0;
}
}
# Determine the positions of each key in the parameter list.
# In actuality, the position of the key's value in the @values or @constant_values array,
# depending on whether it is a -* key or not.
my %key_positions;
my $vpos = 0;
my $cpos = 0;
for my $key (@keys) {
$key_positions{$key} ||= [];
if (UR::BoolExpr::Util::is_meta_param($key)) {
push @{ $key_positions{$key} }, $cpos++;
}
else {
push @{ $key_positions{$key} }, $vpos++;
}
}
# Sort the keys, and make an arrayref which will
# re-order the values to match.
my $last_key = '';
my @keys_sorted = map { $_ eq $last_key ? () : ($last_key = $_) } sort @keys;
my $normalized_positions_arrayref = [];
my $constant_value_normalized_positions = [];
my $recursion_desc = undef;
my $hints = undef;
my $order_by = undef;
my $group_by = undef;
my $page = undef;
my $limit = undef;
my $offset = undef;
my $aggregate = undef;
my @constant_values_sorted;
for my $key (@keys_sorted) {
my $pos_list = $key_positions{$key};
my $pos = pop @$pos_list;
if (UR::BoolExpr::Util::is_meta_param($key)) {
push @$constant_value_normalized_positions, $pos;
my $constant_value = $constant_values[$pos];
if ($key eq '-recurse') {
$constant_value = [$constant_value] if (!ref $constant_value);
$recursion_desc = $constant_value;
}
elsif ($key eq '-hints' or $key eq '-hint') {
$constant_value = [$constant_value] if (!ref $constant_value);
$hints = $constant_value;
}
elsif ($key eq '-order_by' or $key eq '-order') {
$constant_value = [$constant_value] if (!ref $constant_value);
$order_by = $constant_value;
}
elsif ($key eq '-group_by' or $key eq '-group') {
$constant_value = [$constant_value] if (!ref $constant_value);
$group_by = $constant_value;
}
elsif ($key eq '-page') {
$constant_value = [$constant_value] if (!ref $constant_value);
$page = $constant_value;
}
elsif ($key eq '-limit') {
$limit = $constant_value;
}
elsif ($key eq '-offset') {
$offset = $constant_value;
}
elsif ($key eq '-aggregate') {
$constant_value = [$constant_value] if (!ref $constant_value);
$aggregate = $constant_value;
}
else {
Carp::croak("Unknown special param '$key'. Expected one of: @UR::BoolExpr::Template::meta_param_names");
}
push @constant_values_sorted, $constant_value;
}
else {
push @$normalized_positions_arrayref, $pos;
}
}
if ($page) {
if (defined($limit) || defined($offset)) {
Carp::croak("-page and -limit/-offset are mutually exclusive when defining a BoolExpr");
}
if (ref($page) and ref($page) eq 'ARRAY') {
if (@$page == 2) {
$limit = $page->[1];
$offset = ($page->[0] - 1) * $limit;
} elsif (@$page) {
Carp::croak('-page must be an arrayref of two integers: -page => [$page_number, $page_size]');
}
} else {
Carp::croak('-page must be an arrayref of two integers: -page => [$page_number, $page_size]');
}
}
if (defined($hints) and ref($hints) ne 'ARRAY') {
if (! ref($hints)) {
$hints = [$hints]; # convert it to a list of one item
} else {
Carp::croak('-hints of a rule must be an arrayref of property names');
}
}
my $matches_all = scalar(@keys_sorted) == scalar(@constant_values);
$id_only = 0 if ($matches_all);
# these are used to rapidly turn a bx used for querying into one
# suitable for object construction
my @ambiguous_keys;
my @ambiguous_property_names;
for (my $n=0; $n < @keys; $n++) {
next if UR::BoolExpr::Util::is_meta_param($keys[$n]);
my ($property, $op) = ($keys[$n] =~ /^(.+?)\s+(.*)$/);
$property ||= $keys[$n];
$op ||= '';
$op =~ s/^\s+// if $op;
if ($op and $op ne 'eq' and $op ne '==' and $op ne '=') {
push @ambiguous_keys, $keys[$n];
push @ambiguous_property_names, $property;
}
}
# Determine the rule template's ID.
# The normalizer will store this. Below, we'll
# find or create the template for this ID.
my $normalized_constant_value_id = (scalar(@constant_values_sorted) ? UR::BoolExpr::Util::values_to_value_id(@constant_values_sorted) : $constant_value_id);
my @keys_unaliased = $UR::Object::Type::bootstrapping
? @keys_sorted
: map { $_->[0] = UR::BoolExpr::Util::is_meta_param($_->[0]) ? $_->[0] : $subject_class_meta->resolve_property_aliases($_->[0]);
join(' ',@$_); }
map { [ split(' ') ] }
@keys_sorted;
my $normalized_id = UR::BoolExpr::Template->__meta__->resolve_composite_id_from_ordered_values($subject_class_name, "And", join(",",@keys_unaliased), $normalized_constant_value_id);
$self = bless {
id => $id,
subject_class_name => $subject_class_name,
logic_type => $logic_type,
logic_detail => $logic_detail,
constant_value_id => $constant_value_id,
normalized_id => $normalized_id,
# subclass specific
id_position => $id_position,
is_id_only => $id_only,
is_partial_id => $partial_id,
is_unique => undef, # assigned on first use
matches_all => $matches_all,
key_op_hash => $key_op_hash,
_property_names_arrayref => $property_names,
_property_meta_hash => $property_meta_hash,
recursion_desc => $recursion_desc,
hints => $hints,
order_by => $order_by,
group_by => $group_by,
limit => $limit,
offset => $offset,
aggregate => $aggregate,
is_normalized => ($id eq $normalized_id ? 1 : 0),
normalized_positions_arrayref => $normalized_positions_arrayref,
constant_value_normalized_positions_arrayref => $constant_value_normalized_positions,
normalization_extender_arrayref => $extenders,
num_values => scalar(@$keys),
_keys => \@keys,
_constant_values => $constant_values,
_ambiguous_keys => (@ambiguous_keys ? \@ambiguous_keys : undef),
_ambiguous_property_names => (@ambiguous_property_names ? \@ambiguous_property_names : undef),
}, 'UR::BoolExpr::Template::And';
$UR::Object::rule_templates->{$id} = $self;
return $self;
}
1;
=pod
=head1 NAME
UR::BoolExpr::And - a rule which is true if ALL the underlying conditions are true
=head1 SEE ALSO
UR::BoolExpr;(3)
=cut
Composite.pm 100664 023532 023421 3037 12544604516 20541 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/BoolExpr/Template package UR::BoolExpr::Template::Composite;
use warnings;
use strict;
our $VERSION = "0.44"; # UR $VERSION;;
require UR;
UR::Object::Type->define(
class_name => __PACKAGE__,
is => ['UR::BoolExpr::Template'],
);
# sub _underlying_keys {
sub get_underlying_rules_for_values {
my $self = shift;
my @values = @_;
my @underlying_templates = $self->get_underlying_rule_templates();
my @underlying_rules;
for my $template (@underlying_templates) {
my $n = $template->_variable_value_count;
my $rule = $template->get_rule_for_values(splice(@values,0,$n));
push @underlying_rules, $rule;
}
return @underlying_rules;
}
sub _get_for_subject_class_name_and_logic_detail {
my $class = shift;
my $subject_class_name = shift;
my $logic_detail = shift;
my $constant_id = shift;
my ($logic_type) = ($class =~ /^UR::BoolExpr::Template::(.*)/);
my $id = $class->__meta__->resolve_composite_id_from_ordered_values($subject_class_name, $logic_type, $logic_detail, $constant_id);
return $class->get($id);
}
# sub get_underlying_rule_templates {
# sub specifies_value_for {
# evalutate_subject_and_values {
1;
=pod
=head1 NAME
UR::BoolExpr::Composite - an "and" or "or" rule
=head1 SYNOPSIS
@r = $r->get_underlying_rules();
for (@r) {
print $r->evaluate($c1);
}
=head1 DESCRIPTION
=head1 SEE ALSO
UR::Object(3), UR::BoolExpr, UR::BoolExpr::Template, UR::BoolExpr::Template::And, UR::BoolExpr::Template::Or, UR::BoolExpr::Template::PropertyComparison
=cut
Or.pm 100664 023532 023421 13132 12544604516 17174 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/BoolExpr/Template package UR::BoolExpr::Template::Or;
use warnings;
use strict;
our $VERSION = "0.44"; # UR $VERSION;;
require UR;
UR::Object::Type->define(
class_name => __PACKAGE__,
is => ['UR::BoolExpr::Template::Composite'],
);
sub _flatten_bx {
my ($class, $bx) = @_;
my @old = $bx->underlying_rules;
my @new;
for my $old (@old) {
my $new = $old->flatten;
push @new, [ $new->_params_list ];
}
my $flattened_bx = $class->_compose($bx->subject_class_name,\@new);
return $flattened_bx;
}
sub _reframe_bx {
my ($class, $bx, $in_terms_of) = @_;
my @old = $bx->underlying_rules;
my @new;
for my $old (@old) {
my $new = $old->reframe($in_terms_of);
push @new, [ $new->_params_list ];
}
my @meta = $bx->subject_class_name->__meta__->property_meta_for_name($in_terms_of);
my @joins = $meta[-1]->_resolve_join_chain($in_terms_of);
my $reframed_bx = $class->_compose($joins[-1]{foreign_class},\@new);
return $reframed_bx;
}
sub _compose {
my $self = shift;
my $subject_class = shift;
my $sub_queries = shift;
my $meta_params = shift;
my @underlying_rules;
my @expressions;
my @values;
while (@$sub_queries) {
my $underlying_query;
if (ref($sub_queries->[0]) eq 'ARRAY') {
$underlying_query = UR::BoolExpr->resolve($subject_class, @{$sub_queries->[0]}, @$meta_params);
shift @$sub_queries;
}
elsif (ref($sub_queries->[0]) eq 'UR::BoolExpr::And') {
$underlying_query = shift @$sub_queries;
}
else {
$underlying_query = UR::BoolExpr->resolve($subject_class, @$sub_queries[0,1], @$meta_params);
shift @$sub_queries;
shift @$sub_queries;
}
if ($underlying_query->{'_constant_values'}) {
Carp::confess("cannot use -* expressions in subordinate clauses of a logical ");
}
unless ($underlying_query->template->isa("UR::BoolExpr::Template::And")) {
Carp::confess("$underlying_query is not an AND template");
}
push @underlying_rules, $underlying_query;
push @expressions, $underlying_query->template->logic_detail;
push @values, $underlying_query->values;
}
my $bxt = UR::BoolExpr::Template::Or->get_by_subject_class_name_logic_type_and_logic_detail($subject_class,'Or',join('|',@expressions));
my $bx = $bxt->get_rule_for_values(@values);
# This (and accompanying "caching" in UR::BoolExpr::underlying_rules())
# is a giant hack to allow composite rules to have -order and -group
# The real fix is to coax the above combination of
# get_by_subject_class_name_logic_type_and_logic_detail() and get_rule_for_values() to
# properly encode these constant/template values into the rule and template IDs,
# and subsequently reconsitiute them when you call $template->order_by
$bx->{'_underlying_rules'} = \@underlying_rules;
for (my $i = 0; $i < @$meta_params; $i += 2) {
my $method = $meta_params->[$i];
substr($method, 0, 1, ''); # remove the -
if ($method eq 'recurse') {
$bx->template->recursion_desc($meta_params->[$i + 1]);
} elsif ($method eq 'order') {
$bx->template->order_by($meta_params->[$i + 1]);
} else {
$bx->template->$method($meta_params->[$i + 1]);
}
}
return $bx;
}
sub _underlying_keys {
my $self = shift;
my $logic_detail = $self->logic_detail;
return unless $logic_detail;
my @underlying_keys = split('\|',$logic_detail);
return @underlying_keys;
}
# sub get_underlying_rules_for_values
sub get_underlying_rule_templates {
my $self = shift;
my @underlying_keys = $self->_underlying_keys();
my $subject_class_name = $self->subject_class_name;
return map {
UR::BoolExpr::Template::And
->_get_for_subject_class_name_and_logic_detail(
$subject_class_name,
$_
);
} @underlying_keys;
}
sub specifies_value_for {
my ($self, $property_name) = @_;
Carp::confess() if not defined $property_name;
my @underlying_templates = $self->get_underlying_rule_templates();
my @all_specified;
for my $template (@underlying_templates) {
my @specified = $template->specifies_value_for($property_name);
if (@specified) {
push @all_specified, @specified;
}
else {
return;
}
}
return @all_specified;
}
sub evaluate_subject_and_values {
my $self = shift;
my $subject = shift;
return unless (ref($subject) && $subject->isa($self->subject_class_name));
my @underlying = $self->get_underlying_rule_templates;
while (my $underlying = shift (@underlying)) {
my $n = $underlying->_variable_value_count;
my @next_values = splice(@_,0,$n);
if ($underlying->evaluate_subject_and_values($subject,@_)) {
return 1;
}
}
return;
}
sub params_list_for_values {
my $self = shift;
my @values_sorted = @_;
my @list;
my @t = $self->get_underlying_rule_templates;
for my $t (@t) {
my $c = $t->_variable_value_count;
my @l = $t->params_list_for_values(splice(@values_sorted,0,$c));
push @list, \@l;
}
return -or => \@list;
}
sub get_normalized_rule_for_values {
my $self = shift;
return $self->get_rule_for_values(@_);
}
1;
=pod
=head1 NAME
UR::BoolExpr::Or - a rule which is true if ANY of the underlying conditions are true
=head1 SEE ALSO
UR::BoolExpr;(3)
=cut
PropertyComparison.pm 100664 023532 023421 7344 12544604516 22463 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/BoolExpr/Template
package UR::BoolExpr::Template::PropertyComparison;
use warnings;
use strict;
our $VERSION = "0.44"; # UR $VERSION;;
# Define the class metadata.
require UR;
UR::Object::Type->define(
class_name => __PACKAGE__,
is => ['UR::BoolExpr::Template'],
#has => [qw/
# rule_type
# subject_class_name
# property_name
# comparison_operator
# value
# resolution_code_perl
# resolution_code_sql
#/],
#id_by => ['subject_class_name','logic_string']
);
use UR::BoolExpr::Template::PropertyComparison::Equals;
use UR::BoolExpr::Template::PropertyComparison::LessThan;
use UR::BoolExpr::Template::PropertyComparison::In;
use UR::BoolExpr::Template::PropertyComparison::Like;
sub property_name {
(split(' ',$_[0]->logic_detail))[0]
}
sub comparison_operator {
(split(' ',$_[0]->logic_detail))[1]
}
sub sub_group {
my $self = shift;
my $spec = $self->property_name;
if ($spec =~ /-/) {
#$DB::single = 1;
}
if ($spec =~ /^(.*)+\-(\w+)(\?|)(\..+|)/) {
return $2 . $3;
}
else {
return '';
}
}
sub get_underlying_rules_for_values {
return;
}
sub num_values {
# Not strictly correct...
return 1;
}
sub evaluate_subject_and_values {
my ($self,$subject,$comparison_value) = @_;
my @property_values = $subject->__get_attr__($self->property_name);
return $self->_compare($comparison_value, @property_values);
}
sub resolve_subclass_for_comparison_operator {
my $class = shift;
my $comparison_operator = shift;
# Remove any escape sequence that may have been put in at UR::BoolExpr::resolve()
$comparison_operator =~ s/-.+$// if $comparison_operator;
my $suffix = UR::Util::class_suffix_for_operator($comparison_operator);
my $subclass_name = join('::', $class, $suffix);
my $subclass_meta = UR::Object::Type->get($subclass_name);
unless ($subclass_meta) {
Carp::confess("Unknown operator '$comparison_operator'");
}
return $subclass_name;
}
sub _get_for_subject_class_name_and_logic_detail {
my $class = shift;
my $subject_class_name = shift;
my $logic_detail = shift;
my ($property_name, $comparison_operator) = split(' ',$logic_detail, 2);
my $subclass_name = $class->resolve_subclass_for_comparison_operator($comparison_operator);
my $id = $subclass_name->__meta__->resolve_composite_id_from_ordered_values($subject_class_name, 'PropertyComparison', $logic_detail);
return $subclass_name->get($id);
}
sub comparison_value_and_escape_character_to_regex {
my ($class, $value, $escape) = @_;
return '' unless defined($value);
# anyone who uses the % as an escape character deserves to suffer
if ($value eq '%') {
return '^.+$';
}
my $regex = $value;
# Escape all special characters in the regex.
$regex =~ s/([\(\)\[\]\{\}\+\*\.\?\|\^\$\-])/\\$1/g;
# Handle the escape sequence
if (defined $escape)
{
$escape =~ s/\\/\\\\/g; # replace \ with \\
$regex =~ s/(?define(
class_name => __PACKAGE__,
is => ['UR::BoolExpr::Template::PropertyComparison'],
);
sub _compare {
my ($self, $value, @property_value) = @_;
my $lower_bound = $value->[0];
my $upper_bound = $value->[1];
my $cv_is_number = Scalar::Util::looks_like_number($lower_bound)
and
Scalar::Util::looks_like_number($upper_bound);
no warnings 'uninitialized';
foreach my $property_value ( @property_value ) {
my $pv_is_number = Scalar::Util::looks_like_number($property_value);
if ($cv_is_number and $pv_is_number) {
return 1 if ( $property_value >= $lower_bound and $property_value <= $upper_bound);
} else {
return 1 if ( $property_value ge $lower_bound and $property_value le $upper_bound);
}
}
return '';
}
1;
=pod
=head1 NAME
UR::BoolExpr::Template::PropertyComparison::Between - perform a 'between' test
=head1 DESCRIPTION
Evaluates to true of the property's value is between the lower and upper bounds, inclusive.
If the property returns multiple values, this comparison returns true if any of the values are
within the bounds.
=cut
Equals.pm 100664 023532 023421 2224 12544604516 23705 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/BoolExpr/Template/PropertyComparison package UR::BoolExpr::Template::PropertyComparison::Equals;
use strict;
use warnings;
use UR;
our $VERSION = "0.44"; # UR $VERSION;
UR::Object::Type->define(
class_name => __PACKAGE__,
is => ['UR::BoolExpr::Template::PropertyComparison'],
);
sub _compare {
my ($class,$comparison_value,@property_values) = @_;
no warnings 'uninitialized';
if (@property_values == 0) {
return ($comparison_value eq '' ? 1 : '');
}
no warnings 'numeric';
my $cv_is_number = Scalar::Util::looks_like_number($comparison_value);
foreach my $property_value ( @property_values ) {
my $pv_is_number = Scalar::Util::looks_like_number($property_value);
if ($pv_is_number and $cv_is_number) {
return 1 if $property_value == $comparison_value;
} else {
return 1 if $property_value eq $comparison_value;
}
}
return '';
}
1;
=pod
=head1 NAME
UR::BoolExpr::Template::PropertyComparison::Equals - perform a strictly equals test
=head1 DESCRIPTION
If the property returns multiple values, this comparison returns true if any of the values are equal to the comparison value
=cut
False.pm 100664 023532 023421 1432 12544604516 23505 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/BoolExpr/Template/PropertyComparison package UR::BoolExpr::Template::PropertyComparison::False;
use strict;
use warnings;
use UR;
our $VERSION = "0.44"; # UR $VERSION;
UR::Object::Type->define(
class_name => __PACKAGE__,
is => ['UR::BoolExpr::Template::PropertyComparison'],
);
sub _compare {
my ($class,$comparison_value,@property_value) = @_;
no warnings;
if (@property_value == 0) {
return 1;
} else {
for (@property_value) {
return 1 if (! $_); # Returns true if _any_ of the values are false
}
return '';
}
}
1;
=pod
=head1 NAME
UR::BoolExpr::Template::PropertyComparison::False - evaluates to true if the property's value is false
If the property returns multiple values, this comparison returns true if any of the values are false
=cut
GreaterOrEqual.pm 100664 023532 023421 2114 12544604516 25333 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/BoolExpr/Template/PropertyComparison
package UR::BoolExpr::Template::PropertyComparison::GreaterOrEqual;
use strict;
use warnings;
use UR;
our $VERSION = "0.44"; # UR $VERSION;
UR::Object::Type->define(
class_name => __PACKAGE__,
is => ['UR::BoolExpr::Template::PropertyComparison'],
);
sub _compare {
my ($class,$comparison_value,@property_value) = @_;
my $cv_is_number = Scalar::Util::looks_like_number($comparison_value);
no warnings qw(numeric uninitialized);
foreach my $property_value ( @property_value ) {
my $pv_is_number = Scalar::Util::looks_like_number($property_value);
if ($cv_is_number and $pv_is_number) {
return 1 if ( $property_value >= $comparison_value );
} else {
return 1 if ( $property_value ge $comparison_value );
}
}
return '';
}
1;
=pod
=head1 NAME
UR::BoolExpr::Template::PropertyComparison::GreaterOrEqual - perform a greater than or equal test
=head1 DESCRIPTION
If the property returns multiple values, this comparison returns true if any of the values are greater
or equal to the comparison value
=cut
GreaterThan.pm 100664 023532 023421 2066 12544604516 24663 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/BoolExpr/Template/PropertyComparison
package UR::BoolExpr::Template::PropertyComparison::GreaterThan;
use strict;
use warnings;
require UR;
our $VERSION = "0.44"; # UR $VERSION;
UR::Object::Type->define(
class_name => __PACKAGE__,
is => ['UR::BoolExpr::Template::PropertyComparison'],
);
sub _compare {
my ($class,$comparison_value,@property_value) = @_;
my $cv_is_number = Scalar::Util::looks_like_number($comparison_value);
no warnings 'uninitialized';
foreach my $property_value ( @property_value ) {
my $pv_is_number = Scalar::Util::looks_like_number($property_value);
if ($cv_is_number and $pv_is_number) {
return 1 if ( $property_value > $comparison_value );
} else {
return 1 if ( $property_value gt $comparison_value );
}
}
return '';
}
1;
=pod
=head1 NAME
UR::BoolExpr::Template::PropertyComparison::GreaterThan - perform a greater than test
=head1 DESCRIPTION
If the property returns multiple values, this comparison returns true if any of the values are
greater than the comparison value
=cut
In.pm 100664 023532 023421 3350 12544604516 23022 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/BoolExpr/Template/PropertyComparison
package UR::BoolExpr::Template::PropertyComparison::In;
use strict;
use warnings;
use UR;
our $VERSION = "0.44"; # UR $VERSION;
UR::Object::Type->define(
class_name => __PACKAGE__,
is => ['UR::BoolExpr::Template::PropertyComparison'],
doc => "Returns true if any of the property's values appears in the comparison value list",
);
sub _compare {
my ($class,$comparison_values,@property_values) = @_;
if (@property_values == 1 and ref($property_values[0]) eq 'ARRAY') {
@property_values = @{$property_values[0]};
}
# undef should match missing values, which will be sorted at the end - the sorter in
# UR::BoolExpr::resolve() takes care of the sorting for us
if (! @property_values and !defined($comparison_values->[-1])) {
return 1;
}
my($pv_idx, $cv_idx);
no warnings;
my $sorter = sub { return $property_values[$pv_idx] cmp $comparison_values->[$cv_idx] };
use warnings;
# Binary search within @$comparison_values
for ( $pv_idx = 0; $pv_idx < @property_values; $pv_idx++ ) {
my $cv_min = 0;
my $cv_max = $#$comparison_values;
do {
$cv_idx = ($cv_min + $cv_max) >> 1;
my $result = &$sorter;
if (!$result) {
return 1;
} elsif ($result > 0) {
$cv_min = $cv_idx + 1;
} else {
$cv_max = $cv_idx - 1;
}
} until ($cv_min > $cv_max);
}
return '';
}
1;
=pod
=head1 NAME
UR::BoolExpr::Template::PropertyComparison::In - perform an In test
=head1 DESCRIPTION
Returns true if any of the property's values appears in the comparison value list.
Think of 'in' as short for 'intersect', and not just SQL's 'IN' operator.
=cut
Isa.pm 100664 023532 023421 2240 12544604516 23165 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/BoolExpr/Template/PropertyComparison package UR::BoolExpr::Template::PropertyComparison::Isa;
use strict;
use warnings;
use UR;
our $VERSION = "0.44"; # UR $VERSION;
UR::Object::Type->define(
class_name => __PACKAGE__,
is => ['UR::BoolExpr::Template::PropertyComparison'],
);
sub _compare {
my ($class,$comparison_value,@property_values) = @_;
if (ref $comparison_value) {
# Reference... maybe an Object?
if (eval { $comparison_value->isa('UR::Object::Type')} ) {
# It's a class object. Compare to the Class's class_name
$comparison_value = $comparison_value->class_name;
} else {
# It's an object... test on that object's type
$comparison_value = ref($comparison_value);
}
}
foreach my $property_value ( @property_values ) {
return 1 if (eval { $property_value->isa($comparison_value) });
}
return '';
}
1;
=pod
=head1 NAME
UR::BoolExpr::Template::PropertyComparison::Isa - Test whether a value is-a subclass of another class
=head1 DESCRIPTION
If the property returns multiple values, this comparison returns true if any
of the values are a subclass of the comparison value
=cut
LessOrEqual.pm 100664 023532 023421 2075 12544604516 24656 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/BoolExpr/Template/PropertyComparison
package UR::BoolExpr::Template::PropertyComparison::LessOrEqual;
use strict;
use warnings;
require UR;
our $VERSION = "0.44"; # UR $VERSION;
UR::Object::Type->define(
class_name => __PACKAGE__,
is => ['UR::BoolExpr::Template::PropertyComparison'],
);
sub _compare {
my ($class,$comparison_value,@property_value) = @_;
my $cv_is_number = Scalar::Util::looks_like_number($comparison_value);
no warnings 'uninitialized';
foreach my $property_value ( @property_value ) {
my $pv_is_number = Scalar::Util::looks_like_number($property_value);
if ($cv_is_number and $pv_is_number) {
return 1 if ( $property_value <= $comparison_value );
} else {
return 1 if ( $property_value le $comparison_value );
}
}
return '';
}
1;
=pod
=head1 NAME
UR::BoolExpr::Template::PropertyComparison::LessOrEqual - perform a less than or equal test
=head1 DESCRIPTION
If the property returns multiple values, this comparison returns true if any of the values are
less or equal to the comparison value
=cut
LessThan.pm 100664 023532 023421 2046 12544604516 24176 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/BoolExpr/Template/PropertyComparison
package UR::BoolExpr::Template::PropertyComparison::LessThan;
use strict;
use warnings;
require UR;
our $VERSION = "0.44"; # UR $VERSION;
UR::Object::Type->define(
class_name => __PACKAGE__,
is => ['UR::BoolExpr::Template::PropertyComparison'],
);
sub _compare {
my ($class,$comparison_value,@property_value) = @_;
my $cv_is_number = Scalar::Util::looks_like_number($comparison_value);
no warnings 'uninitialized';
foreach my $property_value ( @property_value ) {
my $pv_is_number = Scalar::Util::looks_like_number($property_value);
if ($cv_is_number and $pv_is_number) {
return 1 if ( $property_value < $comparison_value );
} else {
return 1 if ( $property_value lt $comparison_value );
}
}
return '';
}
1;
=pod
=head1 NAME
UR::BoolExpr::Template::PropertyComparison::LessThan - perform a less than test
=head1 DESCRIPTION
If the property returns multiple values, this comparison returns true if any of the values are
less than the comparison value
=cut
Like.pm 100664 023532 023421 2275 12544604516 23345 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/BoolExpr/Template/PropertyComparison
package UR::BoolExpr::Template::PropertyComparison::Like;
use strict;
use warnings;
use UR;
our $VERSION = "0.44"; # UR $VERSION;
UR::Object::Type->define(
class_name => __PACKAGE__,
is => ['UR::BoolExpr::Template::PropertyComparison'],
);
sub _compare {
my ($class,$comparison_value,@property_value) = @_;
return '' unless defined ($comparison_value); # property like NULL should always be false
my $escape = '\\';
my $regex = $class->
comparison_value_and_escape_character_to_regex(
$comparison_value,
$escape
);
no warnings 'uninitialized';
foreach my $value ( @property_value ) {
return 1 if $value =~ $regex;
}
return '';
}
1;
=pod
=head1 NAME
UR::BoolExpr::Template::PropertyComparison::Like - perform an SQL-ish like test
=head1 DESCRIPTION
The input test value is assummed to be an SQL 'like' value, where '_'
represents a one character wildcard, and '%' means a 0 or more character
wildcard. It gets converted to a perl regular expression and used to match
against an object's properties.
If the property returns multiple values, this comparison returns true if any of the values
match.
=cut
Matches.pm 100664 023532 023421 1352 12544604516 24040 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/BoolExpr/Template/PropertyComparison
package UR::BoolExpr::Template::PropertyComparison::Matches;
use strict;
use warnings;
use UR;
our $VERSION = "0.44"; # UR $VERSION;
UR::Object::Type->define(
class_name => __PACKAGE__,
is => ['UR::BoolExpr::Template::PropertyComparison'],
);
sub _compare {
my ($class,$comparison_value,@property_value) = @_;
no warnings 'uninitialized';
foreach my $property_value ( @property_value ) {
return 1 if ( $property_value =~ m/$comparison_value/ );
}
return '';
}
1;
=pod
=head1 NAME
UR::BoolExpr::Template::PropertyComparison::Matches - perform a Perl regular expression match
=head1 DESCRIPTION
If the property returns multiple values, this comparison returns true if any of the values match
=cut
NotBetween.pm 100664 023532 023421 2514 12544604516 24527 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/BoolExpr/Template/PropertyComparison package UR::BoolExpr::Template::PropertyComparison::NotBetween;
use strict;
use warnings;
use UR;
our $VERSION = "0.44"; # UR $VERSION;
UR::Object::Type->define(
class_name => __PACKAGE__,
is => ['UR::BoolExpr::Template::PropertyComparison'],
);
sub _compare {
my ($self, $value, @property_value) = @_;
my $lower_bound = $value->[0];
my $upper_bound = $value->[1];
my $cv_is_number = Scalar::Util::looks_like_number($lower_bound)
and
Scalar::Util::looks_like_number($upper_bound);
no warnings 'uninitialized';
foreach my $property_value ( @property_value ) {
my $pv_is_number = Scalar::Util::looks_like_number($property_value);
if ($cv_is_number and $pv_is_number) {
return 1 if ( $property_value < $lower_bound or $property_value > $upper_bound);
} else {
return 1 if ( $property_value lt $lower_bound or $property_value gt $upper_bound);
}
}
return '';
}
1;
=pod
=head1 NAME
UR::BoolExpr::Template::PropertyComparison::NotBetween - perform a 'not between' test
=head1 DESCRIPTION
Evaluates to true of the property's value is not between the lower and upper bounds, inclusive.
If the property returns multiple values, this comparison returns true if any of the values are
outside the bounds.
=cut
NotEquals.pm 100664 023532 023421 2177 12544604516 24375 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/BoolExpr/Template/PropertyComparison
package UR::BoolExpr::Template::PropertyComparison::NotEquals;
use strict;
use warnings;
use UR;
our $VERSION = "0.44"; # UR $VERSION;
UR::Object::Type->define(
class_name => __PACKAGE__,
is => ['UR::BoolExpr::Template::PropertyComparison'],
);
sub _compare {
my ($class,$comparison_value,@property_value) = @_;
no warnings 'uninitialized';
if (@property_value == 0) {
return ($comparison_value eq '' ? '' : 1);
}
my $cv_is_number = Scalar::Util::looks_like_number($comparison_value);
foreach my $property_value ( @property_value ) {
my $pv_is_number = Scalar::Util::looks_like_number($property_value);
if ($cv_is_number and $pv_is_number) {
return '' if ( $property_value == $comparison_value );
} else {
return '' if ( $property_value eq $comparison_value );
}
}
return 1;
}
1;
=pod
=head1 NAME
UR::BoolExpr::Template::PropertyComparison::NotEqual - perform a not-equal test
=head1 DESCRIPTION
If the property returns multiple values, this comparison returns false if any if the values
are equal to the comparison value
=cut
NotIn.pm 100664 023532 023421 3254 12544604516 23506 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/BoolExpr/Template/PropertyComparison
package UR::BoolExpr::Template::PropertyComparison::NotIn;
use strict;
use warnings;
use UR;
our $VERSION = "0.44"; # UR $VERSION;
UR::Object::Type->define(
class_name => __PACKAGE__,
is => ['UR::BoolExpr::Template::PropertyComparison'],
doc => "Returns false if any of the property's values appears in the comparison value list",
);
sub _compare {
my ($class,$comparison_values,@property_values) = @_;
if (@property_values == 1 and ref($property_values[0]) eq 'ARRAY') {
@property_values = @{$property_values[0]};
}
# undef should match missing values, which will be sorted at the end - the sorter in
# UR::BoolExpr::resolve() takes care of the sorting for us
if (! @property_values and !defined($comparison_values->[-1])) {
return '';
}
my($pv_idx, $cv_idx);
no warnings;
my $sorter = sub { return $property_values[$pv_idx] cmp $comparison_values->[$cv_idx] };
use warnings;
# Binary search within @$comparison_values
my $cv_min = 0;
my $cv_max = $#$comparison_values;
for ( $pv_idx = 0; $pv_idx < @property_values; $pv_idx++ ) {
do {
$cv_idx = ($cv_min + $cv_max) >> 1;
my $result = &$sorter;
if (!$result) {
return '';
} elsif ($result > 0) {
$cv_min = $cv_idx + 1;
} else {
$cv_max = $cv_idx - 1;
}
} until ($cv_min > $cv_max);
}
return 1;
}
1;
=pod
=head1 NAME
UR::BoolExpr::Template::PropertyComparison::NotIn - perform a negated In comparison
=head1 DESCRIPTION
Returns false if any of the property's values appears in the comparison value list
=cut
NotLike.pm 100664 023532 023421 2223 12544604516 24017 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/BoolExpr/Template/PropertyComparison
package UR::BoolExpr::Template::PropertyComparison::NotLike;
use strict;
use warnings;
use UR;
our $VERSION = "0.44"; # UR $VERSION;
UR::Object::Type->define(
class_name => __PACKAGE__,
is => ['UR::BoolExpr::Template::PropertyComparison'],
);
sub _compare {
my ($class,$comparison_value,@property_value) = @_;
my $escape = '\\';
my $regex = $class->
comparison_value_and_escape_character_to_regex(
$comparison_value,
$escape
);
no warnings 'uninitialized';
foreach my $property_value ( @property_value ) {
return '' if ($property_value =~ $regex);
}
return 1;
}
1;
=pod
=head1 NAME
UR::BoolExpr::Template::PropertyComparison::NotLike - perform a negated SQL-ish like test
=head1 DESCRIPTION
The input test value is assummed to be an SQL 'like' value, where '_'
represents a one character wildcard, and '%' means a 0 or more character
wildcard. It gets converted to a perl regular expression and used in a
negated match against an object's properties
If the property returns multiple values, this comparison returns false if
any of the values matches the pattern
=cut
True.pm 100664 023532 023421 1426 12544604516 23375 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/BoolExpr/Template/PropertyComparison
package UR::BoolExpr::Template::PropertyComparison::True;
use strict;
use warnings;
use UR;
our $VERSION = "0.44"; # UR $VERSION;
UR::Object::Type->define(
class_name => __PACKAGE__,
is => ['UR::BoolExpr::Template::PropertyComparison'],
);
sub _compare {
my ($class,$comparison_value,@property_value) = @_;
no warnings;
if (@property_value == 0) {
return '';
} else {
for (@property_value) {
return 1 if ($_); # Returns true if _any_ of the values are true
}
return '';
}
}
1;
=pod
=head1 NAME
UR::BoolExpr::Template::PropertyComparison::True - Evaluates to true if the property's value is true
If the property returns multiple values, this comparison returns true if any of the values are true
=cut
Util.pm 100664 023532 023421 14555 12544604516 15770 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/BoolExpr
package UR::BoolExpr::Util;
# Non-OO Utility methods for the rule modules.
use strict;
use warnings;
require UR;
our $VERSION = "0.44"; # UR $VERSION;
use Scalar::Util qw(blessed reftype refaddr);
use Data::Dumper;
use FreezeThaw;
# Because the id is actually a full data structure we need some separators.
# Note that these are used for the common case, where FreezeThaw is for arbitrarily complicated rule identifiers.
our $id_sep = chr(29); # spearetes id property values instead of the old \t
our $record_sep = chr(30); # within a value_id, delimits a distinct values
our $unit_sep = chr(31); # seperates items within a single value
our $null_value = chr(21); # used for undef/null
our $empty_string = chr(28); # used for ""
our $empty_list = chr(20); # used for []
# These are used when there is any sort of complicated data in the rule.
sub values_to_value_id_frozen {
my $frozen = FreezeThaw::safeFreeze(@_);
return "F:" . $frozen;
}
sub value_id_to_values_frozen {
my $value_id = shift;
return _fixup_ur_objects_from_thawed_data(FreezeThaw::thaw($value_id));
}
sub _fixup_ur_objects_from_thawed_data {
my @values = @_;
our $seen;
local $seen = $seen;
$seen ||= {};
# For things that are UR::Objects (or used to be UR objects), swap the
# thawed/cloned one with one from the object cache
#
# This sub is localized inside _fixup_ur_objects_from_thawed_data so it's not called
# externally, and uses $_ as the thing to process, which is set in the foreach loop
# below - both as a performance speedup of# not having to prepare an argument list while
# processing a possibly deep data structure, and clarity of avoiding double dereferencing
# as this sub needs to mutate the item it's processing
my $process_it = sub {
if (blessed($_)
and (
$_->isa('UR::Object')
or
$_->isa('UR::BoolExpr::Util::clonedThing')
)
) {
my($class, $id) = ($_->class, $_->id);
if (refaddr($_) != refaddr($UR::Context::all_objects_loaded->{$class}->{$id})) {
# bless the original thing to a non-UR::Object class so UR::Object::DESTROY
# doesn't run on it
my $cloned_thing = UR::BoolExpr::Util::clonedThing->bless($_);
# Swap in the object from the object cache
$_ = $UR::Context::all_objects_loaded->{$class}->{$id};
}
}
_fixup_ur_objects_from_thawed_data($_);
};
foreach my $data ( @values ) {
next unless ref $data; # Don't need to recursively inspect normal scalar data
next if $seen->{$data}++;
if (ref $data) {
my $reftype = reftype($data);
my $iter;
if ($reftype eq 'ARRAY') {
foreach (@$data) {
&$process_it;
}
} elsif ($reftype eq 'HASH') {
foreach (values %$data) {
&$process_it;
}
} elsif ($reftype eq 'SCALAR' or $reftype eq 'REF') {
local $_ = $$data;
&$process_it;
}
}
}
return @values;
}
# These are used for the simple common-case rules.
sub values_to_value_id {
my $value_id = "O:";
for my $value (@_) {
no warnings;# 'uninitialized';
if (length($value)) {
if (ref($value) eq "ARRAY") {
if (@$value == 0) {
$value_id .= $empty_list;
}
else {
for my $value2 (@$value) {
if (not defined $value2 ) {
$value_id .= $null_value . $unit_sep;
}
elsif ($value2 eq "") {
$value_id .= $empty_string . $unit_sep;
}
else {
if (ref($value2) or index($value2, $unit_sep) >= 0 or index($value2, $record_sep) >= 0) {
return values_to_value_id_frozen(@_);
}
$value_id .= $value2 . $unit_sep;
}
}
}
$value_id .= $record_sep;
}
else {
if (ref($value) or index($value,$unit_sep) >= 0 or index($value,$record_sep) >= 0) {
return values_to_value_id_frozen(@_);
}
$value_id .= $value . $record_sep;
}
} elsif (not defined $value ) {
$value_id .= $null_value . $record_sep;
}
else {# ($value eq "") {
$value_id .= $empty_string . $record_sep;
}
}
return $value_id;
}
sub value_id_to_values {
my $value_id = shift;
unless (defined $value_id) {
Carp::confess('No value_id passed in to value_id_to_values()!?');
}
my $method_identifier = substr($value_id,0,2);
$value_id = substr($value_id, 2, length($value_id)-2);
if ($method_identifier eq "F:") {
return value_id_to_values_frozen($value_id);
}
my @values = ($value_id =~ /(.*?)$record_sep/gs);
for (@values) {
if (substr($_,-1) eq $unit_sep) {
#$_ = [split($unit_sep,$_)]
my @values2 = /(.*?)$unit_sep/gs;
$_ = \@values2;
for (@values2) {
if ($_ eq $null_value) {
$_ = undef;
}
elsif ($_ eq $empty_string) {
$_ = "";
}
}
}
elsif ($_ eq $null_value) {
$_ = undef;
}
elsif ($_ eq $empty_string) {
$_ = "";
}
elsif ($_ eq $empty_list) {
$_ = [];
}
}
return @values;
}
sub is_meta_param {
my $param_name = shift;
return substr($param_name, 0, 1) eq '-';
}
package UR::BoolExpr::Util::clonedThing;
sub bless {
my($class, $thing) = @_;
# return $thing if ($thing->isa(__PACKAGE__));
$thing->{__original_class} = $thing->class;
bless $thing, $class;
}
sub id {
return shift->{id};
}
sub class {
return shift->{__original_class};
}
1;
=pod
=head1 NAME
UR::BoolExpr::Util - non-OO module to collect utility functions used by the BoolExpr modules
=cut
Change.pm 100664 023532 023421 12146 12544604516 14500 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR
package UR::Change;
use strict;
use warnings;
use IO::File;
require UR;
our $VERSION = "0.44"; # UR $VERSION;
UR::Object::Type->define(
class_name => __PACKAGE__,
has => [ changed_class_name => { is => 'String' },
changed_id => { },
changed_aspect => { is => 'String' },
undo_data => { is_optional => 1 }, # Some changes (like create) have no undo data
],
is_transactional => 1,
);
sub changed_object {
my $self = shift;
my $changed_obj;
my $changed_aspect = $self->changed_aspect;
if ($changed_aspect eq "delete" or $changed_aspect eq "unload") {
my $undo_data = $self->undo_data;
unless (defined $undo_data) {
$undo_data = '';
}
$changed_obj = eval "no strict; no warnings; " . $undo_data;
my $error = $@;
bless($changed_obj, 'UR::DeletedRef') if (ref $changed_obj); # changed class so that UR::Object::DESTROY is not called on a "fake" UR::Object
if ($error) {
Carp::confess("Error reconstructing $changed_aspect data for @_: $error");
}
}
else {
$changed_obj = $self->changed_class_name->get($self->changed_id);
}
if (defined $changed_obj) {
return $changed_obj;
}
else {
return;
}
}
sub undo {
my $self = shift;
my $changed_class_name = $self->changed_class_name;
my $changed_id = $self->changed_id;
my $changed_aspect = $self->changed_aspect;
my $undo_data = $self->undo_data;
if (0) {
no warnings;
my @k = qw/changed_class_name changed_id changed_aspect undo_data/;
my @v = @$self{@k};
print "\tundoing @v\n";
};
# Ghosts are managed internally by create/delete.
# Allow reversal of those methods to indirectly reverse ghost changes.
if ($changed_class_name =~ /::Ghost/) {
if ($changed_aspect !~ /^(create|delete)(_object|)$/) {
Carp::confess("Unlogged change on ghost? @_");
}
return 1;
}
# For tracking "external" changes allow the undo to execute a closure
if ($changed_aspect eq 'external_change') {
if (ref($undo_data) eq 'CODE') {
return eval { &$undo_data };
}
else {
die $self->error_message("'external_change' expects a code ref for undo data!");
}
}
my $changed_obj = $self->changed_object();
return unless $changed_obj;
# TODO: if no changed object, die?
if ($changed_aspect eq "__define__") {
$changed_obj->unload();
}
elsif ($changed_aspect eq "create") {
if ($changed_obj->isa('UR::Observer')) {
UR::Observer::delete($changed_obj); # Observers have state that needs to be cleaned up
} else {
UR::Object::delete($changed_obj);
}
}
elsif ($changed_aspect eq "delete") {
my %stored;
for my $key (keys %$changed_obj) {
if ($key =~ /^(status|warning|error|debug)_message$/
or ref($changed_obj->{$key})
) {
$stored{$key} = delete $changed_obj->{$key};
}
}
$changed_obj = UR::Object::create($changed_class_name,%$changed_obj);
for my $key (keys %stored) {
$changed_obj->{$key} = $stored{$key};
}
$changed_obj->{'_change_count'}--; # it was incremented when delete() was called on the object
}
elsif ($changed_aspect eq "load") {
UR::Object::unload($changed_obj);
}
elsif ($changed_aspect eq "load_external") {
}
elsif ($changed_aspect eq "unload") {
$changed_obj = $UR::Context::current->_construct_object($changed_class_name,%$changed_obj);
UR::Object::__signal_change__($changed_obj,"load") if $changed_obj;
} elsif ($changed_aspect eq "commit") {
if ($changed_obj->isa('UR::Context::Transaction')) {
UR::Object::unload($changed_obj);
} else {
Carp::confess();
}
} elsif ($changed_aspect eq "rollback") {
Carp::confess();
} elsif ($changed_aspect eq 'rewrite_module_header') {
my $VAR1;
eval $undo_data;
my $filename = $VAR1->{'path'};
my $data = $VAR1->{'data'};
if (defined $data) {
# The file previously existed, restore the old contents
my $f = IO::File->new(">$filename");
unless ($f) {
Carp::confess("Can't open $filename for writing while undo on rewrite_module_header for class $changed_class_name: $!");
}
$f->print($data);
$f->close();
} else {
# The file did not previously exist, remove the file
unlink($filename);
}
}
else {
# regular property
if ($changed_obj->can($changed_aspect)) {
$changed_obj->$changed_aspect($undo_data);
$changed_obj->{'_change_count'} -= 2; # 2 because the line above will actually increment the counter, too
}
}
$changed_obj->{'_change_count'} = 0 if ($changed_obj->{'_change_count'} and $changed_obj->{'_change_count'} < 0);
return 1;
}
1;
Context.pm 100664 023532 023421 456376 12544604516 15000 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR package UR::Context;
use strict;
use warnings;
use Sub::Name;
use Scalar::Util;
require UR;
our $VERSION = "0.44"; # UR $VERSION;
use UR::Context::ImportIterator;
use UR::Context::ObjectFabricator;
use UR::Context::LoadingIterator;
UR::Object::Type->define(
class_name => 'UR::Context',
is_abstract => 1,
has => [
parent => { is => 'UR::Context', id_by => 'parent_id', is_optional => 1 },
query_underlying_context => { is => 'Boolean',
is_optional => 1,
default_value => undef,
doc => 'Flag indicating whether the context must (1), must not (0) or may (undef) query underlying contexts when handling a query' },
],
valid_signals => [qw(precommit sync_databases commit prerollback rollback)],
doc => <get($root_id);
unless ($UR::Context::root) {
die "Failed to find root context object '$root_id':!? Odd value in environment variable UR_CONTEXT_ROOT?";
}
if (my $base_id = $ENV{UR_CONTEXT_BASE}) {
$UR::Context::base = UR::Context::Process->get($base_id);
unless ($UR::Context::base) {
die "Failed to find base context object '$base_id':!? Odd value in environment variable UR_CONTEXT_BASE?";
}
}
else {
$UR::Context::base = $UR::Context::root;
}
$UR::Context::process = UR::Context::Process->_create_for_current_process(parent_id => $UR::Context::base->id);
if (exists $ENV{'UR_CONTEXT_CACHE_SIZE_LOWWATER'} || exists $ENV{'UR_CONTEXT_CACHE_SIZE_HIGHWATER'}) {
$UR::Context::destroy_should_clean_up_all_objects_loaded = 1;
$cache_size_highwater = $ENV{'UR_CONTEXT_CACHE_SIZE_HIGHWATER'} || 0;
$cache_size_lowwater = $ENV{'UR_CONTEXT_CACHE_SIZE_LOWWATER'} || 0;
}
# This changes when we initiate in-memory transactions on-top of the basic, heavier weight one for the process.
$UR::Context::current = $UR::Context::process;
if (exists $ENV{'UR_CONTEXT_MONITOR_QUERY'}) {
$UR::Context::current->monitor_query($ENV{'UR_CONTEXT_MONITOR_QUERY'});
}
$initialized = 1;
return $UR::Context::current;
}
# the current context is either the process context, or the current transaction on-top of it
*get_current = \¤t;
sub current {
return $UR::Context::current;
}
sub process {
return $UR::Context::process;
}
sub date_template {
return q|%Y-%m-%d %H:%M:%S|;
}
sub now {
return Date::Format::time2str(date_template(), time());
}
my $master_monitor_query = 0;
sub monitor_query {
return if $UR::Object::Type::bootstrapping;
my $self = shift;
$self = $UR::Context::current unless (ref $self);
if (@_) {
if (ref $self) {
$self->{'monitor_query'} = shift;
} else {
$master_monitor_query = shift;
}
}
return ref($self) ? $self->{'monitor_query'} : $master_monitor_query;
}
my %_query_log_times;
my $query_logging_fh = IO::Handle->new();
$query_logging_fh->fdopen(fileno(STDERR), 'w');
$query_logging_fh->autoflush(1);
sub query_logging_fh {
$query_logging_fh = $_[1] if @_ > 1;
return $query_logging_fh;
}
sub _log_query_for_rule {
return if $UR::Object::Type::bootstrapping;
my $self = shift;
my($subject_class,$rule,$message) = @_;
my $monitor_level;
return unless ($monitor_level = $self->monitor_query);
return if (substr($subject_class, 0,4) eq 'UR::' and $monitor_level < 2); # Don't log queries for internal classes
my $elapsed_time = 0;
if (defined($rule)) {
my $time_now = Time::HiRes::time();
if (! exists $_query_log_times{$rule->id}) {
$_query_log_times{$rule->id} = $time_now;
} else {
$elapsed_time = $time_now - $_query_log_times{$rule->id};
}
}
if ($elapsed_time) {
$message .= sprintf(" Elapsed %.4f s", $elapsed_time);
}
$query_logging_fh->print($message."\n");
}
sub _log_done_elapsed_time_for_rule {
my($self, $rule) = @_;
delete $_query_log_times{$rule->id};
}
sub resolve_data_sources_for_class_meta_and_rule {
my $self = shift;
my $class_meta = shift;
my $boolexpr = shift; ## ignored in the default case
my $class_name = $class_meta->class_name;
# These are some hard-coded cases for splitting up class-classes
# and data dictionary entities into namespace-specific meta DBs.
# Maybe there's some more generic way to move this somewhere else
# FIXME This part is commented out for the moment. When class info is in the
# Meta DBs, then try getting this to work
#if ($class_name eq 'UR::Object::Type') {
# my %params = $boolexpr->legacy_params_hash;
# my($namespace) = ($params->{'class_name'} =~ m/^(\w+?)::/);
# $namespace ||= $params->{'class_name'}; # In case the class name is just the namespace
#
# return $namespace . '::DataSource::Meta';
#}
my $data_source;
# For data dictionary items
# When the FileMux datasource is more generalized and works for
# any kind of underlying datasource, this code can move from here
# and into the base class for Meta datasources
if ($class_name->isa('UR::DataSource::RDBMS::Entity')) {
my $params = $boolexpr->legacy_params_hash;
my $namespace;
if ($params->{'namespace'}) {
$namespace = $params->{'namespace'};
$data_source = $params->{'namespace'} . '::DataSource::Meta';
} elsif ($params->{'data_source'} &&
! ref($params->{'data_source'}) &&
$params->{'data_source'}->can('get_namespace')) {
$namespace = $params->{'data_source'}->get_namespace;
$data_source = $namespace . '::DataSource::Meta';
} elsif ($params->{'data_source'} &&
ref($params->{'data_source'}) eq 'ARRAY') {
my %namespaces = map { $_->get_namespace => 1 } @{$params->{'data_source'}};
unless (scalar(keys %namespaces) == 1) {
Carp::confess("get() across multiple namespaces is not supported");
}
$namespace = $params->{'data_source'}->[0]->get_namespace;
$data_source = $namespace . '::DataSource::Meta';
} else {
Carp::confess("Required parameter (namespace or data_source_id) missing");
#$data_source = 'UR::DataSource::Meta';
}
if (my $exists = UR::Object::Type->get($data_source)) {
# switch the terminology above to stop using $data_source for the class name
# now it's the object..
$data_source = $data_source->get();
}
else {
$self->warning_message("no data source $data_source: generating for $namespace...");
UR::DataSource::Meta->generate_for_namespace($namespace);
$data_source = $data_source->get();
}
unless ($data_source) {
Carp::confess "Failed to find or generate a data source for meta data for namespace $namespace!";
}
} else {
$data_source = $class_meta->data_source;
}
if ($data_source) {
$data_source = $data_source->resolve_data_sources_for_rule($boolexpr);
}
return $data_source;
}
# this is used to determine which data source an object should be saved-to
sub resolve_data_source_for_object {
my $self = shift;
my $object = shift;
my $class_meta = $object->__meta__;
my $class_name = $class_meta->class_name;
if ($class_name->isa('UR::DataSource::RDBMS::Entity') || $class_name->isa('UR::DataSource::RDBMS::Entity::Ghost')) {
my $data_source = $object->data_source;
my($namespace) = ($data_source =~ m/(^\w+?)::DataSource/);
unless ($namespace) {
Carp::croak("Can't resolve data source for object of type $class_name: The object's namespace could not be inferred from its data_source $data_source");
}
my $ds_name = $namespace . '::DataSource::Meta';
return $ds_name->get();
}
# Default behavior
my $ds = $class_meta->data_source;
return $ds;
}
# this turns on and off light caching (weak refs)
sub _light_cache {
if (@_ > 1) {
$UR::Context::light_cache = $_[1];
$UR::Context::destroy_should_clean_up_all_objects_loaded = $UR::Context::light_cache;
}
return $UR::Context::light_cache;
}
# Given a rule, and a property name not mentioned in the rule,
# can we infer the value of that property from what actually is in the rule?
sub infer_property_value_from_rule {
my($self,$wanted_property_name,$rule) = @_;
# First, the easy case... The property is directly mentioned in the rule
if ($rule->specifies_value_for($wanted_property_name)) {
return $rule->value_for($wanted_property_name);
}
my $subject_class_name = $rule->subject_class_name;
my $subject_class_meta = UR::Object::Type->get($subject_class_name);
my $wanted_property_meta = $subject_class_meta->property_meta_for_name($wanted_property_name);
unless ($wanted_property_meta) {
$self->error_message("Class $subject_class_name has no property named $wanted_property_name");
return;
}
if ($wanted_property_meta->is_delegated) {
$self->context_return($self->_infer_delegated_property_from_rule($wanted_property_name,$rule));
} else {
$self->context_return($self->_infer_direct_property_from_rule($wanted_property_name,$rule));
}
}
# These are things that are changes to the program state, but not changes to the object instance
# so they shouldn't be counted in the object's change_count
my %changes_not_counted = map { $_ => 1 } qw(load define unload query connect);
sub add_change_to_transaction_log {
my ($self,$subject, $property, @data) = @_;
my ($class,$id);
if (ref($subject)) {
$class = ref($subject);
$id = $subject->id;
unless ($changes_not_counted{$property} ) {
$subject->{_change_count}++;
#print "changing $subject $property @data\n";
}
}
else {
$class = $subject;
$subject = undef;
$id = undef;
}
if ($UR::Context::Transaction::log_all_changes) {
# eventually all calls to __signal_change__ will go directly here
UR::Context::Transaction->log_change($subject, $class, $id, $property, @data);
}
if (my $index_list = $UR::Object::Index::all_by_class_name_and_property_name{$class}{$property}) {
unless ($property eq 'create' or $property eq 'load' or $property eq 'define') {
for my $index (@$index_list) {
$index->_remove_object(
$subject,
{ $property => $data[0] }
)
}
}
unless ($property eq 'delete' or $property eq 'unload') {
for my $index (@$index_list) {
$index->_add_object($subject)
}
}
}
}
our $sig_depth = 0;
my %subscription_classes;
sub send_notification_to_observers {
my ($self,$subject, $property, @data) = @_;
my ($class,$id);
if (ref($subject)) {
$class = ref($subject);
$id = $subject->id;
} else {
$class = $subject;
}
my $check_classes = $subscription_classes{$class};
unless ($check_classes) {
$subscription_classes{$class} = $check_classes = [
$class
? (
$class,
(grep { $_->isa("UR::Object") } $class->inheritance),
''
)
: ('')
];
}
my @check_properties = ($property ? ($property, '') : ('') );
my @check_ids = (defined($id) ? ($id, '') : ('') );
my @matches =
map { @$_ }
grep { defined $_ } map { defined($id) ? @$_{@check_ids} : values(%$_) }
grep { defined $_ } map { @$_{@check_properties} }
grep { defined $_ } @$UR::Context::all_change_subscriptions{@$check_classes};
return unless @matches;
$sig_depth++;
if (@matches > 1) {
no warnings;
# sort by priority
@matches = sort { $a->[2] <=> $b->[2] } @matches;
};
foreach my $callback_info (@matches) {
my ($callback, $note, undef, $id, $once) = @$callback_info;
UR::Observer->get($id)->delete() if $once;
$callback->($subject, $property, @data);
}
$sig_depth--;
return scalar(@matches);
}
sub query {
my $self = shift;
# Fast optimization for the default case.
if ( ( !ref($self) or ! $self->query_underlying_context)
and ! Scalar::Util::blessed($_[1]) # This happens when query() is called with a class name and boolexpr
) {
no warnings;
if (exists $UR::Context::all_objects_loaded->{$_[0]}) {
my $is_monitor_query = $self->monitor_query;
if (defined(my $obj = $UR::Context::all_objects_loaded->{$_[0]}->{$_[1]})) {
# Matched the class and ID directly - pull it right out of the cache
if ($is_monitor_query) {
$self->_log_query_for_rule($_[0], undef, Carp::shortmess("QUERY: class $_[0] by ID $_[1]"));
$self->_log_query_for_rule($_[0], undef, "QUERY: matched 1 cached object\nQUERY: returning 1 object\n\n");
}
$obj->{'__get_serial'} = $UR::Context::GET_COUNTER++;
return $obj;
} elsif (my $subclasses = $UR::Object::Type::_init_subclasses_loaded{$_[0]}) {
# Check subclasses of the requested class, along with the ID
# yes, it only goes one level deep. This should catch enough cases to be worth it.
# Deeper searches will be covered by get_objects_for_class_and_rule()
foreach my $subclass (@$subclasses) {
if (exists $UR::Context::all_objects_loaded->{$subclass} and
my $obj = $UR::Context::all_objects_loaded->{$subclass}->{$_[1]}
) {
if ($is_monitor_query) {
$self->_log_query_for_rule($_[0], undef, Carp::shortmess("QUERY: class $_[0] by ID $_[1]"));
$self->_log_query_for_rule($_[0], undef, "QUERY: matched 1 cached object in subclass $subclass\nQUERY: returning 1 object\n\n");
}
$obj->{'__get_serial'} = $UR::Context::GET_COUNTER++;
return $obj;
}
}
}
}
};
# Normal logic for finding objects smartly is below.
my $class = shift;
# Handle the case in which this is called as an object method.
# Functionality is completely different.
if(ref($class)) {
my @rvals;
foreach my $prop (@_) {
push(@rvals, $class->$prop());
}
if(wantarray) {
return @rvals;
}
else {
return \@rvals;
}
}
my ($rule, @extra) = UR::BoolExpr->resolve($class,@_);
if (@extra) {
# remove this and have the developer go to the datasource
if (scalar @extra == 2 and ($extra[0] eq "sql" or $extra[0] eq 'sql in')) {
return $UR::Context::current->_get_objects_for_class_and_sql($class,$extra[1]);
}
# keep this part: let the sub-class handle special params if it can
return $class->get_with_special_parameters($rule, @extra);
}
# This is here for bootstrapping reasons: we must be able to load class singletons
# in order to have metadata for regular loading....
# UR::DataSource::QueryPlan isa UR::Value (which has custom loading logic), but we need to be able to generate
# a QueryPlan independant of the normal loading process, otherwise there'd be endless recursion (Can't generate a QueryPlan
# for a QueryPlan without generating a QueryPlan first....)
if (!$rule->has_meta_options and ($class->isa("UR::Object::Type") or $class->isa("UR::Singleton") or $class->isa("UR::DataSource::QueryPlan"))) {
my $normalized_rule = $rule->normalize;
my @objects = $class->_load($normalized_rule);
return unless defined wantarray;
return @objects if wantarray;
if ( @objects > 1 and defined(wantarray)) {
Carp::croak("Multiple matches for $class query called in scalar context. $rule matches " . scalar(@objects). " objects");
}
return $objects[0];
}
return $UR::Context::current->get_objects_for_class_and_rule($class, $rule);
}
sub _resolve_id_for_class_and_rule {
my ($self,$class_meta,$rule) = @_;
my $class = $class_meta->class_name;
my $id;
my @id_property_names = $class_meta->id_property_names
or Carp::confess( # Bad should be at least one
"No id property names for class ($class). This should not have happened."
);
if ( @id_property_names == 1 ) { # only 1 - try to auto generate
$id = $class_meta->autogenerate_new_object_id($rule);
unless ( defined $id ) {
$class->error_message("Failed to auto-generate an ID for single ID property class ($class)");
return;
}
}
else { # multiple
# Try to give a useful message by getting id prop names that are not deinfed
my @missed_names;
for my $name ( @id_property_names ) {
push @missed_names, $name unless $rule->specifies_value_for($name);
}
if ( @missed_names ) { # Ok - prob w/ class def, list the ones we missed
$class->error_message("Attempt to create $class with multiple ids without these properties: ".join(', ', @missed_names));
return;
}
else { # Bad - something is really wrong...
Carp::confess("Attempt to create $class failed to resolve id from underlying id properties.");
}
}
return $id;
}
our $construction_method = 'create';
# Pulled out the complicated code of create_entity() below that deals with
# abstract classes and subclassify_by
sub _create_entity_from_abstract_class {
my $self = shift;
my $class = shift;
my $class_meta = $class->__meta__;
my($rule, %extra) = UR::BoolExpr->resolve_normalized($class, @_);
# If we can easily determine the correct subclass, delegate to that subclass' create()
my $subclassify_by = $class_meta->subclassify_by();
unless (defined $subclassify_by) {
Carp::croak("Can't call $construction_method on abstract class $class without a subclassify_by property");
}
my $sub_class_name = $rule->value_for($subclassify_by);
unless (defined $sub_class_name) {
# The subclassification wasn't included in the rule
my $property_meta = $class_meta->property($subclassify_by);
unless ($property_meta) {
Carp::croak("Abstract class $class has subclassify_by $subclassify_by, but no property exists by that name");
}
# There are a few different ways the property can supply a value for subclassify_by...
# The sure-fire way to get a value is to go ahead an instantiate the object into the
# base/abstract class, and then we can just call the property as a method. There's
# a lot of overhead in that, so first we'll try some of the easier, common-case ways
if ($property_meta->default_value) {
# The property has a default value
$sub_class_name = $property_meta->default_value();
} elsif ($property_meta->is_calculated and ref($property_meta->calculate) eq 'CODE') {
# It's calculated via a coderef
my $calculate_from = $property_meta->calculate_from;
my @calculate_params;
foreach my $prop_name ( @$calculate_from ) {
# The things in calculate_from must appear in the rule
unless ($rule->specifies_value_for($prop_name)) {
Carp::croak("Class $class subclassify_by calculation property '$subclassify_by' "
. "requires '$prop_name' in the $construction_method() params\n"
. "Params were: " . UR::Util->display_string_for_params_list($rule->params_list));
}
push @calculate_params, $rule->value_for($prop_name);
}
my $sub = $property_meta->calculate;
unless ($sub) {
Carp::croak("Can't use undefined value as subroutine reference while resolving "
. "value for class $class calculated property '$subclassify_by'");
}
$sub_class_name = $sub->(@calculate_params);
} elsif ($property_meta->is_calculated and !ref($property_meta->calculate)) {
# It's calculated via a string that's eval-ed
Carp::croak("Can't use a non-coderef as a calculation for class $class subclassify_by");
} elsif ($property_meta->is_delegated) {
#Carp::croak("Delegated properties are not supported for subclassifying $class with property '$subclassify_by'");
my @values = $self->infer_property_value_from_rule($subclassify_by, $rule);
if (! @values ) {
Carp::croak("Invalid parameters for $class->$construction_method(): "
. "Couldn't infer a value for indirect property '$subclassify_by' via rule $rule");
} elsif (@values > 1) {
Carp::croak("Invalid parameters for $class->$construction_method(): "
. "Infering a value for property '$subclassify_by' via rule $rule returned multiple values: "
. join(', ', @values));
} else {
$sub_class_name = $values[0];
}
} else {
Carp::croak("Can't use undefined value as a subclass name for $class property '$subclassify_by'");
}
}
unless (defined $sub_class_name) {
Carp::croak("Invalid parameters for $class->$construction_method(): "
. "Can't use undefined value as a subclass name for param '$subclassify_by'");
}
if ($sub_class_name eq $class) {
Carp::croak("Invalid parameters for $class->$construction_method(): "
. "Value for $subclassify_by cannot be the same as the original class");
}
unless ($sub_class_name->isa($class)) {
Carp::croak("Invalid parameters for $class->$construction_method(): "
. "Class $sub_class_name is not a subclass of $class");
}
return $sub_class_name->$construction_method(@_);
}
my %memos;
my %memos2;
sub create_entity {
my $self = shift;
my $class = shift;
my $memo = $memos{$class};
unless ($memo) {
# we only want to grab the data necessary for object construction once
# this occurs the first time a new object is created for a given class
my $class_meta = $class->__meta__;
my @inheritance = reverse ($class_meta, $class_meta->ancestry_class_metas);
# %property_objects maps property names to UR::Object::Property objects
# by going through the reversed list of UR::Object::Type objects below
# We set up this hash to have the correct property objects for each property
# name. This is important in the case of property name overlap via
# inheritance. The property object used should be the one "closest"
# to the class. In other words, a property directly on the class gets
# used instead of an inherited one.
my %property_objects;
my %direct_properties;
my %indirect_properties;
my %set_properties;
my %default_values;
my %default_value_requires_query;
my %default_value_requires_call;
my %immutable_properties;
my @deep_copy_default_values;
for my $co ( @inheritance ) {
# Reverse map the ID into property values.
# This has to occur for all subclasses which represent table rows.
# deal with %property_objects
my @property_objects = $co->direct_property_metas;
my @property_names = map { $_->property_name } @property_objects;
@property_objects{@property_names} = @property_objects;
foreach my $prop ( @property_objects ) {
my $name = $prop->property_name;
unless (defined $name) {
Carp::confess("no name on property for class " . $co->class_name . "?\n" . Data::Dumper::Dumper($prop));
}
my $default_value = $prop->default_value;
if (defined $default_value) {
if ($prop->data_type and $prop->_data_type_as_class_name eq $prop->data_type and $prop->_data_type_as_class_name->can("get")) {
# an ID or other query params in hash/array form return an object or objects
$default_value_requires_query{$name} = $default_value;
}
elsif (ref($default_value)) {
#warn (
# "a reference value $default_value is used as a default on "
# . $co->class_name
# . " forcing a copy during construction "
# . " of $class $name..."
#);
push @deep_copy_default_values, $name;
}
$default_values{$name} = $default_value;
}
if ($prop->calculated_default) {
$default_value_requires_call{$name} = $prop->calculated_default;
}
if ($prop->is_many) {
$set_properties{$name} = $prop;
}
elsif ($prop->is_delegated) {
$indirect_properties{$name} = $prop;
}
else {
$direct_properties{$name} = $prop;
}
unless ($prop->is_mutable) {
$immutable_properties{$name} = 1;
}
}
}
my @indirect_property_names = keys %indirect_properties;
my @direct_property_names = keys %direct_properties;
my @subclassify_by_methods;
foreach my $co ( @inheritance ) {
# If this class inherits from something with subclassify_by, make sure the param
# actually matches. If it's not supplied, then set it to the same as the class create()
# is being called on
if ( $class ne $co->class_name
and $co->is_abstract
and my $method = $co->subclassify_by
) {
push @subclassify_by_methods, $method;
}
}
$memos{$class} = $memo = [
$class_meta,
$class_meta->first_sub_classification_method_name,
$class_meta->is_abstract,
\@inheritance,
\%property_objects,
\%direct_properties,
\%indirect_properties,
\%set_properties,
\%immutable_properties,
\@subclassify_by_methods,
\%default_values,
(@deep_copy_default_values ? \@deep_copy_default_values : undef),
\%default_value_requires_query,
\%default_value_requires_call,
];
}
my (
$class_meta,
$first_sub_classification_method_name,
$is_abstract,
$inheritance,
$property_objects,
$direct_properties,
$indirect_properties,
$set_properties,
$immutable_properties,
$subclassify_by_methods,
$initial_default_values,
$deep_copy_default_values,
$default_value_requires_query,
$initial_default_value_requires_call,
) = @$memo;
# The old way of automagic subclassing...
# The class specifies that we should call a class method (sub_classification_method_name)
# to determine the correct subclass
if ($first_sub_classification_method_name) {
my $sub_class_name = $class->$first_sub_classification_method_name(@_);
if (defined($sub_class_name) and ($sub_class_name ne $class)) {
# delegate to the sub-class to create the object
unless ($sub_class_name->can($construction_method)) {
Carp::croak("Can't locate object method '$construction_method' via package '$sub_class_name' "
. "while resolving proper subclass for $class during $construction_method");
}
return $sub_class_name->$construction_method(@_);
}
# fall through if the class names match
}
if ($is_abstract) {
# The new way of automagic subclassing. The class specifies a property (subclassify_by)
# that holds/returns the correct subclass name
return $self->_create_entity_from_abstract_class($class, @_);
}
# normal case: make a rule out of the passed-in params
# rather than normalizing the rule, we just do the extension part which is fast
my $rule = UR::BoolExpr->resolve($class, @_);
my $template = $rule->template;
my $params = { $rule->_params_list, $template->extend_params_list_for_values(@{$rule->{values}}) };
if (my $a = $template->{_ambiguous_keys}) {
my $p = $template->{_ambiguous_property_names};
@$params{@$p} = delete @$params{@$a};
}
my $id = $params->{id};
unless (defined $id) {
$id = $self->_resolve_id_for_class_and_rule($class_meta,$rule);
unless ($id) {
return;
}
$rule = UR::BoolExpr->resolve_normalized($class, %$params, id => $id);
$params = { $rule->params_list }; ;
}
my %default_value_requires_call = %$initial_default_value_requires_call;
delete @default_value_requires_call{ keys %$params };
# handle postprocessing default values
my %default_values = %$initial_default_values;
#for my $name (qw//) {
for my $name (keys %$default_value_requires_query) {
my @id_by;
if (my $id_by = $property_objects->{$name}->id_by) {
@id_by = (ref($id_by) ? @$id_by : ($id_by));
}
if ($params->{$name}) {
delete $default_values{$name};
}
elsif (@$params{@id_by}) {
# some or all of the id is present
# don't fall back to the default
for my $id_by (@id_by) {
delete $default_values{$id_by} if exists $params->{$id_by};
}
delete $default_values{$name};
}
else {
$DB::single = 1;
my $query = $default_value_requires_query->{$name};
my @query;
if (ref($query) eq 'HASH') {
# queries come in as a hash
@query = %$query;
}
else {
# an ID or a boolean expression
@query = ($query);
}
my $prop = $property_objects->{$name};
my $class = $prop->_data_type_as_class_name;
eval {
if ($prop->is_many) {
$default_values{$name} = [ $class->get(@query) ];
}
else {
$default_values{$name} = $class->get(@query);
}
};
if ($@) {
warn "error setting " . $prop->class_name . " " . $prop->property_name . " to default_value from query $query for type $class!";
};
}
}
if ($deep_copy_default_values) {
for my $name (@$deep_copy_default_values) {
if ($params->{$name}) {
delete $default_values{$name};
}
else {
$default_values{$name} = UR::Util::deep_copy($default_values{$name});
}
}
}
# @extra is extra values gotten by inheritance
my @extra;
my $indirect_values = {};
for my $property_name (keys %$indirect_properties) {
# pull indirect values out of the constructor hash
# so we can apply them separately after making the object
if ( exists $params->{ $property_name } ) {
$indirect_values->{ $property_name } = delete $params->{ $property_name };
delete $default_values{$property_name};
}
elsif (exists $default_values{$property_name}) {
$indirect_values->{ $property_name } = delete $default_values{$property_name};
}
}
# if the indirect property is immutable, but it is via something which is
# mutable, we use those values to get or create the bridge.
my %indirect_immutable_properties_via;
for my $property_name (keys %$indirect_values) {
if ($immutable_properties->{$property_name}) {
my $meta = $indirect_properties->{$property_name};
next unless $meta; # not indirect
my $via = $meta->via;
next unless $via; # not a via/to (id_by or reverse_id_by)
$indirect_immutable_properties_via{$via}{$property_name} = delete $indirect_values->{$property_name};
}
}
for my $via (keys %indirect_immutable_properties_via) {
my $via_property_meta = $class_meta->property_meta_for_name($via);
my ($source_indirect_property, $source_value) = each %{$indirect_immutable_properties_via{$via}}; # There'll only ever be one key/value
unless ($via_property_meta) {
Carp::croak("No metadata for class $class property $via while resolving indirect value for property $source_indirect_property");
}
my $indirect_property_meta = $class_meta->property_meta_for_name($source_indirect_property);
unless ($indirect_property_meta) {
Carp::croak("No metadata for class $class property $source_indirect_property while resolving indirect value for property $source_indirect_property");
}
unless ($indirect_property_meta->to) {
# We're probably dealing with a subclassify_by property where the subclass has
# implicitly overridden the indirect property in the parent class with a constant-value
# property in the subclass. Try asking the parent class about a property of the same name
($indirect_property_meta) = grep { $_->property_name eq $indirect_property_meta->property_name } $class_meta->ancestry_property_metas();
unless ($indirect_property_meta and $indirect_property_meta->to) {
Carp::croak("Can't resolve indirect relationship for possibly overridden property '$source_indirect_property'"
. " in class $class. Parent classes have no property named '$source_indirect_property'");
}
}
my $foreign_class = $via_property_meta->data_type;
my $foreign_property = $indirect_property_meta->to;
my $foreign_object = $foreign_class->get($foreign_property => $source_value);
unless ($foreign_object) {
# This will trigger recursion back here (into create_entity() ) if this property is multiply
# indirect, such as through a bridge object
$foreign_object = $foreign_class->create($foreign_property => $source_value);
unless ($foreign_object) {
Carp::croak("Can't create object of class $foreign_class with params ($foreign_property => '$source_value')"
. " while resolving indirect value for class $class property $source_indirect_property");
}
}
my @joins = $indirect_property_meta->_resolve_join_chain();
my %local_properties_to_set;
foreach my $join ( @joins ) {
if ($join->{foreign_class}->isa("UR::Value")) {
# this final "join" is to the set of values available to the raw primitive type
# ...not what we really mean by delegation
next;
}
for (my $i = 0; $i < @{$join->{'source_property_names'}}; $i++) {
my $source_property_name = $join->{'source_property_names'}->[$i];
next unless (exists $direct_properties->{$source_property_name});
my $foreign_property_name = $join->{'foreign_property_names'}->[$i];
my $value = $foreign_object->$foreign_property_name;
if ($rule->specifies_value_for($source_property_name)
and
$rule->value_for($source_property_name) ne $value)
{
Carp::croak("Invalid parameters for $class->$construction_method(): "
. "Conflicting values for property '$source_property_name'. $construction_method rule "
. "specifies value '" . $rule->value_for($source_property_name) . "' but "
. "indirect immutable property '$source_indirect_property' with value "
. "$source_value requires it to be '$value'");
}
$local_properties_to_set{$source_property_name} = $value;
}
}
# transfer the values we resolved back into %$params
my @param_keys = keys %local_properties_to_set;
@$params{@param_keys} = @local_properties_to_set{@param_keys};
}
my $set_values = {};
for my $property_name (keys %$set_properties) {
if (exists $params->{ $property_name }) {
delete $default_values{ $property_name };
$set_values->{ $property_name } = delete $params->{ $property_name };
}
}
my $entity = $self->_construct_object($class, %default_values, %$params, @extra);
return unless $entity;
$self->add_change_to_transaction_log($entity, $construction_method);
$self->add_change_to_transaction_log($entity, 'load') if $construction_method eq '__define__';
for my $property_name ( keys %default_value_requires_call ) {
my $method = $default_value_requires_call{$property_name};
my $value = $method->($entity);
$entity->$property_name($value);
}
# If a property is calculated + immutable, and it wasn't supplied in the params,
# that means we need to run the calculation once and store the value in the
# object as a read-only attribute
foreach my $property_name ( keys %$immutable_properties ) {
my $property_meta = $property_objects->{$property_name};
if (!exists($params->{$property_name}) and $property_meta and $property_meta->is_calculated) {
my $value = $entity->$property_name;
$params->{$property_name} = $value;
}
}
for my $subclassify_by (@$subclassify_by_methods) {
my $param_value = $rule->value_for($subclassify_by);
$param_value = eval { $entity->$subclassify_by } unless (defined $param_value);
$param_value = $default_values{$subclassify_by} unless (defined $param_value);
if (! defined $param_value) {
# This should have been taken care of by the time we got here...
Carp::croak("Invalid parameters for $class->$construction_method(): " .
"Can't use an undefined value as a subclass name for param '$subclassify_by'");
} elsif ($param_value ne $class) {
Carp::croak("Invalid parameters for $class->$construction_method(): " .
"Value for subclassifying param '$subclassify_by' " .
"($param_value) does not match the class it was called on ($class)");
}
}
# add items for any multi properties
if (%$set_values) {
for my $property_name (keys %$set_values) {
my $meta = $set_properties->{$property_name};
my $singular_name = $meta->singular_name;
my $adder = 'add_' . $singular_name;
my $value = $set_values->{$property_name};
unless (ref($value) eq 'ARRAY') {
$value = [$value];
}
for my $item (@$value) {
if (ref($item) eq 'ARRAY') {
$entity->$adder(@$item);
}
elsif (ref($item) eq 'HASH') {
$entity->$adder(%$item);
}
else {
$entity->$adder($item);
}
}
}
}
# set any indirect mutable properties
if (%$indirect_values) {
for my $property_name (keys %$indirect_values) {
$entity->$property_name($indirect_values->{$property_name});
}
}
if (%$immutable_properties) {
my @problems = $entity->__errors__();
if (@problems) {
my @errors_fatal_to_construction;
my %problems_by_property_name;
for my $problem (@problems) {
my @problem_properties;
for my $name ($problem->properties) {
if ($immutable_properties->{$name}) {
push @problem_properties, $name;
}
}
if (@problem_properties) {
push @errors_fatal_to_construction, join(" and ", @problem_properties) . ': ' . $problem->desc;
}
}
if (@errors_fatal_to_construction) {
my $msg = 'Failed to $construction_method ' . $class . ' with invalid immutable properties:'
. join("\n", @errors_fatal_to_construction);
}
}
}
$entity->__signal_observers__($construction_method);
$entity->__signal_observers__('load') if $construction_method eq '__define__';
$entity->{'__get_serial'} = $UR::Context::GET_COUNTER++;
$UR::Context::all_objects_cache_size++;
return $entity;
}
sub _construct_object {
my $self = shift;
my $class = shift;
my $params = { @_ };
my $id = $params->{id};
unless (defined($id)) {
Carp::confess(
"No ID specified (or incomplete id params) for $class _construct_object. Params were:\n"
. Data::Dumper::Dumper($params)
);
}
if ($UR::Context::all_objects_loaded->{$class}->{$id}) {
# The object exists. This is not an exception for some reason?
# We just return false to indicate that the object is not creatable.
$class->error_message("An object of class $class already exists with id value '$id'");
return;
}
my $object;
if ($object = $UR::DeletedRef::all_objects_deleted->{$class}->{$id}) {
UR::DeletedRef->resurrect($object);
%$object = %$params;
} else {
$object = bless $params, $class;
}
if (my $ghost = $UR::Context::all_objects_loaded->{$class . "::Ghost"}->{$id}) {
# we're making something which was previously deleted and is pending save.
# we must capture the old db_committed data to ensure eventual saving is done correctly.
# note this object's database state in the new object so saves occurr correctly,
# as an update instead of an insert.
if (my $committed_data = $ghost->{db_committed}) {
$object->{db_committed} = { %$committed_data };
}
if (my $unsaved_data = $ghost->{'db_saved_uncommitted'}) {
$object->{'db_saved_uncommitted'} = { %$unsaved_data };
}
$ghost->__signal_change__("delete");
$self->_abandon_object($ghost);
}
# put the object in the master repository of objects for the application.
$UR::Context::all_objects_loaded->{$class}{$id} = $object;
# If we're using a light cache, weaken the reference.
if ($UR::Context::light_cache) { # and substr($class,0,5) ne 'App::') {
Scalar::Util::weaken($UR::Context::all_objects_loaded->{$class}->{$id});
}
return $object;
}
sub delete_entity {
my ($self,$entity) = @_;
if (ref($entity)) {
# Delete the specified object.
if ($entity->{db_committed} || $entity->{db_saved_uncommitted}) {
# gather params for the ghost object
my $do_data_source;
my %ghost_params;
#my @pn;
#{ no warnings 'syntax';
# @pn = grep { $_ ne 'data_source_id' || ($do_data_source=1 and 0) } # yes this really is '=' and not '=='
# grep { exists $entity->{$_} }
# $entity->__meta__->all_property_names;
#}
my(@prop_names, @many_prop_names);
foreach my $prop_name ( $entity->__meta__->all_property_names) {
next unless exists $entity->{$prop_name}; # skip non-directly-stored properties
if ($prop_name eq 'data_source_id') {
$do_data_source = 1;
next;
}
if (ref($entity->{$prop_name}) eq 'ARRAY') {
push @many_prop_names, $prop_name;
} else {
push @prop_names, $prop_name;
}
}
# we're not really allowed to interrogate the data_source property directly
@ghost_params{@prop_names} = $entity->get(@prop_names); # hrm doesn't work for is_many properties :(
foreach my $prop_name ( @many_prop_names ) {
my @values = $entity->get($prop_name);
$ghost_params{$prop_name} = \@values;
}
if ($do_data_source) {
$ghost_params{'data_source_id'} = $entity->{'data_source_id'};
}
# create ghost object
my $ghost = $self->_construct_object($entity->ghost_class, id => $entity->id, %ghost_params);
unless ($ghost) {
Carp::confess("Failed to constructe a deletion record for an unsync'd delete.");
}
$ghost->__signal_change__("create");
for my $com (qw(db_committed db_saved_uncommitted)) {
$ghost->{$com} = $entity->{$com}
if $entity->{$com};
}
}
$entity->__signal_change__('delete');
$self->_abandon_object($entity);
return $entity;
}
else {
Carp::confess("Can't call delete as a class method.");
}
}
sub _abandon_object {
my $self = shift;
my $object = $_[0];
my $class = $object->class;
my $id = $object->id;
if ($object->{'__get_serial'}) {
# Keep a correct accounting of objects. This one is getting deleted by a method
# other than UR::Context::prune_object_cache
$UR::Context::all_objects_cache_size--;
}
# Remove the object from the main hash.
delete $UR::Context::all_objects_loaded->{$class}->{$id};
delete $UR::Context::all_objects_are_loaded->{$class};
# Remove all of the load info it is using so it'll get re-loaded if asked for later
if ($object->{'__load'}) {
while (my ($template_id, $rules) = each %{ $object->{'__load'}} ) {
foreach my $rule_id ( keys %$rules ) {
delete $UR::Context::all_params_loaded->{$template_id}->{$rule_id};
foreach my $fabricator ( UR::Context::ObjectFabricator->all_object_fabricators ) {
$fabricator->delete_from_all_params_loaded($template_id, $rule_id);
}
}
}
}
# Turn our $object reference into a UR::DeletedRef.
# Further attempts to use it will result in readable errors.
# The object can be resurrected.
if ($ENV{'UR_DEBUG_OBJECT_RELEASE'}) {
print STDERR "MEM DELETE object $object class ",$object->class," id ",$object->id,"\n";
}
UR::DeletedRef->bury($object);
return $object;
}
# This one works when the rule specifies the value of an indirect property, and we want
# the value of a direct property of the class
sub _infer_direct_property_from_rule {
my($self,$wanted_property_name,$rule) = @_;
my $rule_template = $rule->template;
my @properties_in_rule = $rule_template->_property_names; # FIXME - why is this method private?
my $subject_class_name = $rule->subject_class_name;
my $subject_class_meta = $subject_class_name->__meta__;
my($alternate_class,$alternate_get_property, $alternate_wanted_property);
my @r_values; # There may be multiple properties in the rule that will get to the wanted property
PROPERTY_IN_RULE:
foreach my $property_name ( @properties_in_rule) {
my $property_meta = $subject_class_meta->property_meta_for_name($property_name);
my $final_property_meta = $property_meta->final_property_meta || $property_meta;
$alternate_get_property = $final_property_meta->property_name;
$alternate_class = $final_property_meta->class_name;
unless ($alternate_wanted_property) {
# Either this was also a direct property of the rule, or there's no
# obvious link between the indirect property and the wanted property.
# the caller probably just should have done a get()
$alternate_wanted_property = $wanted_property_name;
$alternate_get_property = $property_name;
$alternate_class = $subject_class_name;
}
my $value_from_rule = $rule->value_for($property_name);
my @alternate_values;
eval {
# Inside an eval in case the get() throws an exception, the next
# property in the rule may succeed
my @alternate_objects = $self->query($alternate_class, $alternate_get_property => $value_from_rule );
@alternate_values = map { $_->$alternate_wanted_property } @alternate_objects;
};
next unless (@alternate_values);
push @r_values, \@alternate_values;
}
if (@r_values == 0) {
# no solutions found
return;
} elsif (@r_values == 1) {
# there was only one solution
return @{$r_values[0]};
} else {
# multiple solutions. Only return the intersection of them all
# FIXME - this totally won't work for properties that return objects, listrefs or hashrefs
# FIXME - this only works for AND rules - for now, that's all that exist
my %intersection = map { $_ => 1 } @{ shift @r_values };
foreach my $list ( @r_values ) {
%intersection = map { $_ => 1 } grep { $intersection{$_} } @$list;
}
return keys %intersection;
}
}
# we want the value of a delegated property, and the rule specifies
# a direct value
sub _infer_delegated_property_from_rule {
my($self, $wanted_property_name, $rule) = @_;
my $rule_template = $rule->template;
my $subject_class_name = $rule->subject_class_name;
my $subject_class_meta = $subject_class_name->__meta__;
my $wanted_property_meta = $subject_class_meta->property_meta_for_name($wanted_property_name);
unless ($wanted_property_meta->via) {
Carp::croak("There is no linking meta-property (via) on property $wanted_property_name on $subject_class_name");
}
my $linking_property_meta = $subject_class_meta->property_meta_for_name($wanted_property_meta->via);
my $final_property_meta = $wanted_property_meta->final_property_meta;
if ($linking_property_meta->reverse_as) {
eval{ $linking_property_meta->data_type->class() }; # Load the class if it isn't already loaded
if ($linking_property_meta->data_type ne $final_property_meta->class_name) {
Carp::croak("UR::Context::_infer_delegated_property_from_rule() doesn't handle multiple levels of indiretion yet");
}
}
my @rule_translation = $linking_property_meta->get_property_name_pairs_for_join();
my %alternate_get_params;
foreach my $pair ( @rule_translation ) {
my $rule_param = $pair->[0];
next unless ($rule_template->specifies_value_for($rule_param));
my $alternate_param = $pair->[1];
my $value = $rule->value_for($rule_param);
$alternate_get_params{$alternate_param} = $value;
}
my $alternate_class = $final_property_meta->class_name;
my $alternate_wanted_property = $wanted_property_meta->to;
my @alternate_values;
eval {
my @alternate_objects = $self->query($alternate_class, %alternate_get_params);
@alternate_values = map { $_->$alternate_wanted_property } @alternate_objects;
};
return @alternate_values;
}
sub object_cache_size_highwater {
my $self = shift;
if (@_) {
my $value = shift;
$cache_size_highwater = $value;
if (defined $value) {
if ($cache_size_lowwater and $value <= $cache_size_lowwater) {
Carp::confess("Can't set the highwater mark less than or equal to the lowwater mark");
return;
}
$UR::Context::destroy_should_clean_up_all_objects_loaded = 1;
$self->prune_object_cache();
} else {
# turn it off
$UR::Context::destroy_should_clean_up_all_objects_loaded = 0;
}
}
return $cache_size_highwater;
}
sub object_cache_size_lowwater {
my $self = shift;
if (@_) {
my $value = shift;
$cache_size_lowwater = $value;
if (defined($value) and $cache_size_highwater and $value >= $cache_size_highwater) {
Carp::confess("Can't set the lowwater mark greater than or equal to the highwater mark");
return;
}
}
return $cache_size_lowwater;
}
sub get_data_sources_for_loaded_classes {
my $class = shift;
my %data_source_for_class;
foreach my $class ( keys %$UR::Context::all_objects_loaded ) {
next if (substr($class,0,-6) eq '::Type'); # skip class objects
next unless exists $UR::Context::all_objects_loaded->{$class . '::Type'};
my $class_meta = $UR::Context::all_objects_loaded->{$class . '::Type'}->{$class};
next unless $class_meta;
next unless ($class_meta->is_uncachable());
$data_source_for_class{$class} = $class_meta->data_source_id;
}
return %data_source_for_class;
}
our $is_pruning = 0;
sub prune_object_cache {
my $self = shift;
return if ($is_pruning); # Don't recurse into here
return if (!defined($cache_size_highwater) or !defined($cache_size_lowwater));
return unless ($all_objects_cache_size > $cache_size_highwater);
$is_pruning = 1;
my $t1;
if ($ENV{'UR_DEBUG_OBJECT_RELEASE'} || $ENV{'UR_DEBUG_OBJECT_PRUNING'}) {
$t1 = Time::HiRes::time();
print STDERR Carp::longmess("MEM PRUNE begin at $t1 ",scalar(localtime($t1)),"\n");
}
my $index_id_sep = UR::Object::Index->__meta__->composite_id_separator() || "\t";
my %data_source_for_class = $self->get_data_sources_for_loaded_classes;
# NOTE: This pokes right into the object cache and futzes with Index IDs directly.
# We can't get the Index objects though get() because we'd recurse right back into here
my %indexes_by_class;
foreach my $idx_id ( keys %{$UR::Context::all_objects_loaded->{'UR::Object::Index'}} ) {
my $class = substr($idx_id, 0, index($idx_id, $index_id_sep));
next unless exists $data_source_for_class{$class};
push @{$indexes_by_class{$class}}, $UR::Context::all_objects_loaded->{'UR::Object::Index'}->{$idx_id};
}
my $deleted_count = 0;
my $pass = 0;
$cache_size_highwater = 1 if ($cache_size_highwater < 1);
$cache_size_lowwater = 1 if ($cache_size_lowwater < 1);
# Instead of sorting object cache by __get_serial, since we are trying to
# conserve memory, we pass through the object cache reviewing chunks of older objects
# first while working our way through the whole cache.
my $target_serial = $cache_last_prune_serial;
my $serial_range = ($GET_COUNTER - $target_serial);
my $max_passes = 10;
my $target_serial_increment = int($serial_range / $max_passes) + 1;
while ($all_objects_cache_size > $cache_size_lowwater && $target_serial < $GET_COUNTER) {
$pass++;
$target_serial += $target_serial_increment;
foreach my $class (keys %data_source_for_class) {
my $objects_for_class = $UR::Context::all_objects_loaded->{$class};
$indexes_by_class{$class} ||= [];
foreach my $id ( keys ( %$objects_for_class ) ) {
my $obj = $objects_for_class->{$id};
next unless defined $obj; # object with this ID does not exist
if (
$obj->is_weakened
|| $obj->is_prunable && $obj->{__get_serial} && $obj->{__get_serial} <= $target_serial
) {
foreach my $index ( @{$indexes_by_class{$class}} ) {
$index->weaken_reference_for_object($obj);
}
if ($ENV{'UR_DEBUG_OBJECT_RELEASE'}) {
print STDERR "MEM PRUNE object $obj class $class id $id\n";
}
delete $obj->{'__get_serial'};
Scalar::Util::weaken($objects_for_class->{$id});
$all_objects_cache_size--;
$deleted_count++;
}
}
}
}
$is_pruning = 0;
$cache_last_prune_serial = $target_serial;
if ($ENV{'UR_DEBUG_OBJECT_RELEASE'} || $ENV{'UR_DEBUG_OBJECT_PRUNING'}) {
my $t2 = Time::HiRes::time();
printf("MEM PRUNE complete, $deleted_count objects marked after $pass passes in %.4f sec\n\n\n",$t2-$t1);
}
if ($all_objects_cache_size > $cache_size_lowwater) {
Carp::carp "After several passes of pruning the object cache, there are still $all_objects_cache_size objects";
if ($ENV{'UR_DEBUG_OBJECT_PRUNING'}) {
warn "Top 10 classes by object count:\n" . $self->_object_cache_pruning_report;
}
}
return 1;
}
sub _object_cache_pruning_report {
my $self = shift;
my $max_show = shift;
$max_show = 10 unless defined ($max_show);
my @sorted_counts = sort { $b->[1] <=> $a->[1] }
map { [ $_ => scalar(keys %{$UR::Context::all_objects_loaded->{$_}}) ] }
grep { !$_->__meta__->is_meta_meta }
keys %$UR::Context::all_objects_loaded;
my $message = '';
for (my $i = 0; $i < 10 and $i < @sorted_counts; $i++) {
my $class_name = $sorted_counts[$i]->[0];
my $count = $sorted_counts[$i]->[1];
$message .= "$class_name: $count\n";
if ($ENV{'UR_DEBUG_OBJECT_PRUNING'} > 1) {
# more detailed info
my $no_data_source = 0;
my $other_references = 0;
my $strengthened = 0;
my $has_changes = 0;
my $prunable = 0;
my $class_data_source = eval { $class_name->__meta__->data_source_id; };
foreach my $obj ( values %{$UR::Context::all_objects_loaded->{$class_name}} ) {
next unless $obj;
my $is_prunable = 1;
if (! $class_data_source ) {
$no_data_source++;
$is_prunable = 0;
}
if (! exists $obj->{'__get_serial'}) {
$other_references++;
$is_prunable = 0;
}
if (exists $obj->{'__strengthened'}) {
$strengthened++;
$is_prunable = 0;
}
if ($obj->__changes__) {
$has_changes++;
$is_prunable = 0;
}
if ($is_prunable) {
$prunable++;
}
}
$message .= sprintf("\tNo data source: %d other refs: %d strengthend: %d has changes: %d prunable: %d\n",
$no_data_source, $other_references, $strengthened, $has_changes, $prunable);
}
}
return $message;
}
sub value_for_object_property_in_underlying_context {
my ($self, $obj, $property_name) = @_;
my $saved = $obj->{db_saved_uncommitted} || $obj->{db_committed};
unless ($saved) {
Carp::croak(qq(No object found in underlying context));
}
return $saved->{$property_name};
}
# True if the object was loaded from an underlying context and/or datasource, or if the
# object has been committed to the underlying context
sub object_exists_in_underlying_context {
my($self, $obj) = @_;
return if ($obj->{'__defined'});
return (exists($obj->{'db_committed'}) || exists($obj->{'db_saved_uncommitted'}));
}
# Holds the logic for handling OR-type rules passed to get_objects_for_class_and_rule()
sub _get_objects_for_class_and_or_rule {
my ($self, $class, $rule, $load, $return_closure) = @_;
$rule = $rule->normalize;
my @u = $rule->underlying_rules;
my @results;
for my $u (@u) {
if (wantarray or not defined wantarray) {
push @results, $self->get_objects_for_class_and_rule($class,$u,$load,$return_closure);
}
else {
my $result = $self->get_objects_for_class_and_rule($class,$u,$load,$return_closure);
push @results, $result;
}
}
if ($return_closure) {
my $object_sorter = $rule->template->sorter();
my @next;
return sub {
# fill in missing slots in @next
for(my $i = 0; $i < @results; $i++) {
unless (defined $next[$i]) {
# This slot got used last time through
$next[$i] = $results[$i]->();
unless (defined $next[$i]) {
# That iterator is exhausted, splice it out
splice(@results, $i, 1);
splice(@next, $i, 1);
redo if $i < @results; #the next iterator is now at $i, not $i++
}
}
}
my $lowest_slot = 0;
for(my $i = 1; $i < @results; $i++) {
my $cmp = $object_sorter->($next[$lowest_slot], $next[$i]);
if ($cmp > 0) {
$lowest_slot = $i;
} elsif ($cmp == 0) {
# duplicate object, mark this slot to fill in next time around
$next[$i] = undef;
}
}
my $retval = $next[$lowest_slot];
$next[$lowest_slot] = undef;
return $retval;
};
}
# remove duplicates
my $last = 0;
my $plast = 0;
my $next = 0;
@results = grep { $plast = $last; $last = $_; $plast == $_ ? () : ($_) } sort @results;
return unless defined wantarray;
return @results if wantarray;
if (@results > 1) {
$self->_exception_for_multi_objects_in_scalar_context($rule,\@results);
}
return $results[0];
}
# this is the underlying method for get/load/is_loaded in ::Object
sub get_objects_for_class_and_rule {
my ($self, $class, $rule, $load, $return_closure) = @_;
my $initial_load = $load;
#my @params = $rule->params_list;
#print "GET: $class @params\n";
my $rule_template = $rule->template;
my $group_by = $rule_template->group_by;
if (ref($self) and !defined($load)) {
$load = $self->query_underlying_context; # could still be undef...
}
if ($group_by and $rule_template->order_by) {
my %group_by = map { $_ => 1 } @{ $rule->template->group_by };
foreach my $order_by_property ( @{ $rule->template->order_by } ) {
unless ($group_by{$order_by_property}) {
Carp::croak("Property '$order_by_property' in the -order_by list must appear in the -group_by list for BoolExpr $rule");
}
}
}
if (
$cache_size_highwater
and
$all_objects_cache_size > $cache_size_highwater
) {
$self->prune_object_cache();
}
if ($rule_template->isa("UR::BoolExpr::Template::Or")) {
return $self->_get_objects_for_class_and_or_rule($class,$rule,$load,$return_closure);
}
# an identifier for all objects gotten in this request will be set/updated on each of them for pruning later
my $this_get_serial = $GET_COUNTER++;
my $meta = $class->__meta__();
# A query on a subclass where the parent class is_abstract and has a subclassify_by property
# (meaning that the parent class has a property which directly stores the proper subclass for
# each row - subclasses inherit the property from the parent, and the subclass isn't is_abstract)
# should have a filter added to the rule to keep only rows of the subclass we're interested in.
# This will improve the SQL performance when it's later constructed.
my $subclassify_by = $meta->subclassify_by;
if ($subclassify_by
and ! $meta->is_abstract
and ! $rule->template->group_by
and ! $rule->specifies_value_for($subclassify_by)
) {
$rule = $rule->add_filter($subclassify_by => $class);
}
# If $load is undefined, and there is no underlying context, we define it to FALSE explicitly
# TODO: instead of checking for a data source, skip this
# We'll always go to the underlying context, even if it has nothing.
# This optimization only works by coincidence since we don't stack contexts currently beyond 1.
my $ds;
if (!defined($load) or $load) {
($ds) = $self->resolve_data_sources_for_class_meta_and_rule($meta,$rule);
if (! $ds or $class =~ m/::Ghost$/) {
# Classes without data sources and Ghosts can only ever come from the cache
$load = 0;
}
}
# this is an arrayref of all of the cached data
# it is set in one of two places below
my $cached;
# this will turn foo=>$foo into foo.id=>$foo->id where possible
my $no_hard_refs_rule = $rule->flatten_hard_refs;
# we do not currently fully "flatten" b/c the bx constant_values do not flatten/reframe
#my $flat_rule = ( (1 or $no_hard_refs_rule->subject_class_name eq 'UR::Object::Property') ? $no_hard_refs_rule : $no_hard_refs_rule->flatten);
# this is a no-op if the rule is already normalized
my $normalized_rule = $no_hard_refs_rule->normalize;
my $is_monitor_query = $self->monitor_query;
$self->_log_query_for_rule($class,$normalized_rule,Carp::shortmess("QUERY: Query start for rule $normalized_rule")) if ($is_monitor_query);
# see if we need to load if load was not defined
unless (defined $load) {
# check to see if the cache is complete
# also returns a list of the complete cached objects where that list is found as a side-effect
my ($cache_is_complete, $cached) = $self->_cache_is_complete_for_class_and_normalized_rule($class, $normalized_rule);
$load = ($cache_is_complete ? 0 : 1);
}
if ($ds and $load and $rule_template->order_by) {
# if any of the order_by is calculated, then we need to do an unordered query against the
# data source, then we can do it as a non-load query and do the sorting on all the in-memory
# objects
my $qp = $ds->_resolve_query_plan($rule_template);
if ($qp->order_by_non_column_data) {
$self->_log_query_for_rule($class,$normalized_rule,"QUERY: Doing an unordered query on the datasource because one of the order_by properties of the rule is not expressable by the data source") if ($is_monitor_query);
$self->get_objects_for_class_and_rule($class, $rule->remove_filter('-order')->remove_filter('-order_by'), 1);
$load = 0;
}
}
my $normalized_rule_template = $normalized_rule->template;
# optimization for the common case
if (!$load and !$return_closure) {
my @c = $self->_get_objects_for_class_and_rule_from_cache($class,$normalized_rule);
my $obj_count = scalar(@c);
foreach ( @c ) {
unless (exists $_->{'__get_serial'}) {
# This is a weakened reference. Convert it back to a regular ref
my $class = ref $_;
my $id = $_->id;
my $ref = $UR::Context::all_objects_loaded->{$class}->{$id};
$UR::Context::all_objects_loaded->{$class}->{$id} = $ref;
}
$_->{'__get_serial'} = $this_get_serial;
}
if ($is_monitor_query) {
$self->_log_query_for_rule($class,$normalized_rule,"QUERY: matched $obj_count cached objects (no loading)");
$self->_log_query_for_rule($class,$normalized_rule,"QUERY: Query complete after returning $obj_count object(s) for rule $rule");
$self->_log_done_elapsed_time_for_rule($normalized_rule);
}
if (defined($normalized_rule_template->limit) || defined($normalized_rule_template->offset)) {
$self->_prune_obj_list_for_limit_and_offset(\@c,$normalized_rule_template);
}
return @c if wantarray; # array context
return unless defined wantarray; # null context
Carp::confess("multiple objects found for a call in scalar context!" . Data::Dumper::Dumper(\@c)) if @c > 1;
return $c[0]; # scalar context
}
my $object_sorter = $normalized_rule_template->sorter();
# the above process might have found all of the cached data required as a side-effect in which case
# we have a value for this early
# either way: ensure the cached data is known and sorted
if ($cached) {
@$cached = sort $object_sorter @$cached;
}
else {
$cached = [ sort $object_sorter $self->_get_objects_for_class_and_rule_from_cache($class,$normalized_rule) ];
}
$self->_log_query_for_rule($class, $normalized_rule, "QUERY: matched ".scalar(@$cached)." cached objects") if ($is_monitor_query);
foreach ( @$cached ) {
unless (exists $_->{'__get_serial'}) {
# This is a weakened reference. Convert it back to a regular ref
my $class = ref $_;
my $id = $_->id;
my $ref = $UR::Context::all_objects_loaded->{$class}->{$id};
$UR::Context::all_objects_loaded->{$class}->{$id} = $ref;
}
$_->{'__get_serial'} = $this_get_serial;
}
# make a loading iterator if loading must be done for this rule
my $loading_iterator;
if ($load) {
# this returns objects from the underlying context after importing them into the current context,
# but only if they did not exist in the current context already
$self->_log_query_for_rule($class, $normalized_rule, "QUERY: importing from underlying context with rule $normalized_rule") if ($is_monitor_query);
$loading_iterator = UR::Context::LoadingIterator->_create($cached, $self,$normalized_rule, $ds,$this_get_serial);
}
if ($return_closure) {
if ($load) {
# return the iterator made above
return $loading_iterator;
}
else {
# make a quick iterator for the cached data
if(defined($normalized_rule_template->limit) || defined($normalized_rule_template->offset)) {
$self->_prune_obj_list_for_limit_and_offset($cached,$normalized_rule_template);
}
return sub { return shift @$cached };
}
}
else {
my @results;
if ($loading_iterator) {
# use the iterator made above
my $found;
while (defined($found = $loading_iterator->(1))) {
push @results, $found;
}
}
else {
# just get the cached data
if(defined($normalized_rule_template->limit) || defined($normalized_rule_template->offset)) {
$self->_prune_obj_list_for_limit_and_offset($cached,$normalized_rule_template);
}
@results = @$cached;
}
return unless defined wantarray;
return @results if wantarray;
if (@results > 1) {
$self->_exception_for_multi_objects_in_scalar_context($rule,\@results);
}
return $results[0];
}
}
sub _exception_for_multi_objects_in_scalar_context {
my($self,$rule,$resultsref) = @_;
my $message = sprintf("Multiple results unexpected for query.\n\tClass %s\n\trule params: %s\n\tGot %d results",
$rule->subject_class_name,
join(',', $rule->params_list),
scalar(@$resultsref));
my $lastidx = $#$resultsref;
if (@$resultsref > 10) {
$message .= "; the first 10 are";
$lastidx = 9;
}
Carp::confess($message . ":\n" . Data::Dumper::Dumper([@$resultsref[0..$lastidx]]));
}
sub _prune_obj_list_for_limit_and_offset {
my($self, $obj_list, $tmpl) = @_;
my $limit = defined($tmpl->limit) ? $tmpl->limit : $#$obj_list;
my $offset = $tmpl->offset || 0;
if ($offset > @$obj_list) {
Carp::carp('-offset is larger than the result list');
@$obj_list = ();
} else {
@$obj_list = splice(@$obj_list, $offset, $limit);
}
}
sub __merge_db_data_with_existing_object {
my($self, $class_name, $existing_object, $pending_db_object_data, $property_names) = @_;
unless (defined $pending_db_object_data) {
# This means a row in the database is missing for an object we loaded before
if (defined($existing_object)
and $self->object_exists_in_underlying_context($existing_object)
and $existing_object->__changes__
) {
my $id = $existing_object->id;
Carp::croak("$class_name ID '$id' previously existed in an underlying context, has since been deleted from that context, and the cached object now has unsavable changes.\nDump: ".Data::Dumper::Dumper($existing_object)."\n");
} else {
#print "Removing object id ".$existing_object->id." because it has been removed from the database\n";
UR::Context::LoadingIterator->_remove_object_from_other_loading_iterators($existing_object);
$existing_object->__signal_change__('delete');
$self->_abandon_object($existing_object);
return $existing_object;
}
}
my $expected_db_data;
if (exists $existing_object->{'db_saved_uncommitted'}) {
$expected_db_data = $existing_object->{'db_saved_uncommitted'};
} elsif (exists $existing_object->{'db_committed'}) {
$expected_db_data = $existing_object->{'db_committed'};
} else {
my $id = $existing_object->id;
Carp::croak("$class_name ID '$id' has just been loaded, but it exists in the application as a new unsaved object!\nDump: " . Data::Dumper::Dumper($existing_object) . "\n");
}
my $different = 0;
my $conflict = undef;
foreach my $property ( @$property_names ) {
no warnings 'uninitialized';
# All direct properties are stored in the same-named hash key, right?
next unless (exists $existing_object->{$property});
my $object_value = $existing_object->{$property};
my $db_value = $pending_db_object_data->{$property};
my $expected_db_value = $expected_db_data->{$property};
if ($object_value ne $expected_db_value) {
$different++;
}
if ( $object_value eq $db_value # current value matches DB value
or
($object_value eq $expected_db_value) # current value hasn't changed since it was loaded from the DB
or
($db_value eq $expected_db_value) # DB value matches what it was when we loaded it from the DB
) {
# no conflict. Check the next one
next;
} else {
$conflict = $property;
last;
}
}
if (defined $conflict) {
# conflicting change!
# Since the user could be catching this exception, go ahead and update the
# object's notion of what is in the database
my %old_dbc = %$expected_db_data;
@$expected_db_data{@$property_names} = @$pending_db_object_data{@$property_names};
my $old_value = defined($old_dbc{$conflict})
? "'" . $old_dbc{$conflict} . "'"
: '(undef)';
my $new_db_value = defined($pending_db_object_data->{$conflict})
? "'" . $pending_db_object_data->{$conflict} . "'"
: '(undef)';
my $new_obj_value = defined($existing_object->{$conflict})
? "'" . $existing_object->{$conflict} . "'"
: '(undef)';
my $obj_id = $existing_object->id;
Carp::croak("\nA change has occurred in the database for $class_name property '$conflict' on object ID $obj_id from $old_value to $new_db_value.\n"
. "At the same time, this application has made a change to that value to $new_obj_value.\n\n"
. "The application should lock data which it will update and might be updated by other applications.");
}
# No conflicts. Update db_committed and db_saved_uncommitted based on the DB data
%$expected_db_data = (%$expected_db_data, %$pending_db_object_data);
if (! $different) {
# FIXME HACK! This is to handle the case when you get an object, start a software transaction,
# change something in the database for that object, reload the object (so __merge updates the value
# found in the DB), then rollback the transaction. The act of updating the value here in __merge makes
# a change record that gets undone when the transaction is rolled back. After the rollback, the current
# value goes back to the originally loaded value, db_committed has the newly clhanged DB value, but
# _change_count is 0 turning off change tracking makes it so this internal change isn't undone by rollback
local $UR::Context::Transaction::log_all_changes = 0; # HACK!
# The object has no local changes. Go ahead and update the current value, too
foreach my $property ( @$property_names ) {
no warnings 'uninitialized';
next if ($existing_object->{$property} eq $pending_db_object_data->{$property});
$existing_object->$property($pending_db_object_data->{$property});
}
}
# re-figure how many changes are really there
my @change_count = $existing_object->__changes__;
$existing_object->{'_change_count'} = scalar(@change_count);
return $different;
}
sub _get_objects_for_class_and_sql {
# this is a depracated back-door to get objects with raw sql
# only use it if you know what you're doing
my ($self, $class, $sql) = @_;
my $meta = $class->__meta__;
#my $ds = $self->resolve_data_sources_for_class_meta_and_rule($meta,$class->define_boolexpr());
my $ds = $self->resolve_data_sources_for_class_meta_and_rule($meta,UR::BoolExpr->resolve($class));
my $id_list = $ds->_resolve_ids_from_class_name_and_sql($class,$sql);
return unless (defined($id_list) and @$id_list);
my $rule = UR::BoolExpr->resolve_normalized($class, id => $id_list);
return $self->get_objects_for_class_and_rule($class,$rule);
}
sub _cache_is_complete_for_class_and_normalized_rule {
my ($self,$class,$normalized_rule) = @_;
# TODO: convert this to use the rule object instead of going back to the legacy hash format
my ($id,$params,@objects,$cache_is_complete);
$params = $normalized_rule->legacy_params_hash;
$id = $params->{id};
# Determine ahead of time whether we believe the object MUST be loaded if it exists.
# If this is true, we will shortcut out of any action which loads or prepares for loading.
# Try to resolve without loading in cases where we are sure
# that doing so will return the complete results.
my $id_only = $params->{_id_only};
$id_only = undef if ref($id) and ref($id) eq 'HASH';
if ($id_only) {
# _id_only means that only id parameters were passed in.
# Either a single id or an arrayref of ids.
# Try to pull objects from the cache in either case
if (ref $id) {
# arrayref id
# we check the immediate class and all derived
# classes for any of the ids in the set.
@objects =
grep { $_ }
map { @$_{@$id} }
map { $all_objects_loaded->{$_} }
($class, $class->__meta__->subclasses_loaded);
# see if we found all of the requested objects
if (@objects == @$id) {
# we found them all
# return them all
$cache_is_complete = 1;
}
else {
# Ideally we'd filter out the ones we found,
# but that gets complicated.
# For now, we do it the slow way for partial matches
@objects = ();
}
}
else {
# scalar id
# Check for objects already loaded.
no warnings;
if (exists $all_objects_loaded->{$class}->{$id}) {
$cache_is_complete = 1;
@objects =
grep { $_ }
$all_objects_loaded->{$class}->{$id};
}
elsif (not $class->isa("UR::Value")) {
# we already checked the immediate class,
# so just check derived classes
# this is not done for values because an identity can exist
# with independent objects with values, unlike entities
@objects =
grep { $_ }
map { $all_objects_loaded->{$_}->{$id} }
$class->__meta__->subclasses_loaded;
if (@objects) {
$cache_is_complete = 1;
}
}
}
}
elsif ($params->{_unique}) {
# _unique means that this set of params could never
# result in more than 1 object.
# See if the 1 is in the cache
# If not we have to load
@objects = $self->_get_objects_for_class_and_rule_from_cache($class,$normalized_rule);
if (@objects) {
$cache_is_complete = 1;
}
}
if ($cache_is_complete) {
# if the $cache_is_comlete, the $cached list DEFINITELY represents all objects we need to return
# we know that loading is NOT necessary because what we've found cached must be the entire set
# Because we happen to have that set, we return it in addition to the boolean flag
return wantarray ? (1, \@objects) : ();
}
# We need to do more checking to see if loading is necessary
# Either the parameters were non-unique, or they were unique
# and we didn't find the object checking the cache.
# See if we need to do a load():
my $template_id = $normalized_rule->template_id;
my $rule_id = $normalized_rule->id;
my $loading_is_in_progress_on_another_iterator =
grep { $_->is_loading_in_progress_for_boolexpr($normalized_rule) }
UR::Context::ObjectFabricator->all_object_fabricators;
return 0 if $loading_is_in_progress_on_another_iterator;
# complex (non-single-id) params
my $loading_was_done_before_with_these_params = (
# exact match to previous attempt
( exists ($UR::Context::all_params_loaded->{$template_id})
and
exists ($UR::Context::all_params_loaded->{$template_id}->{$rule_id})
)
||
# this is a subset of a previous attempt
($self->_loading_was_done_before_with_a_superset_of_this_rule($normalized_rule))
);
my $object_is_loaded_or_non_existent =
$loading_was_done_before_with_these_params
|| $class->all_objects_are_loaded;
if ($object_is_loaded_or_non_existent) {
# These same non-unique parameters were used to load previously,
# or we loaded everything at some point.
# No load necessary.
return 1;
}
else {
# Load according to params
return;
}
} # done setting $load, and possibly filling $cached/$cache_is_complete as a side-effect
sub all_objects_loaded {
my $self = shift;
my $class = $_[0];
return(
grep {$_}
map { values %{ $UR::Context::all_objects_loaded->{$_} } }
$class, $class->__meta__->subclasses_loaded
);
}
sub all_objects_loaded_unsubclassed {
my $self = shift;
my $class = $_[0];
return (grep {$_} values %{ $UR::Context::all_objects_loaded->{$class} } );
}
sub _get_objects_for_class_and_rule_from_cache {
# Get all objects which are loaded in the application which match
# the specified parameters.
my ($self, $class, $rule) = @_;
my ($template,@values) = $rule->template_and_values;
#my @param_list = $rule->params_list;
#print "CACHE-GET: $class @param_list\n";
my $strategy = $rule->{_context_query_strategy};
unless ($strategy) {
if ($rule->template->group_by) {
$strategy = $rule->{_context_query_strategy} = "set intersection";
}
elsif ($rule->num_values == 0) {
$strategy = $rule->{_context_query_strategy} = "all";
}
elsif ($rule->is_id_only) {
$strategy = $rule->{_context_query_strategy} = "id";
}
else {
$strategy = $rule->{_context_query_strategy} = "index";
}
}
my @results = eval {
if ($strategy eq "all") {
return $self->all_objects_loaded($class);
}
elsif ($strategy eq "id") {
my $id = $rule->value_for_id();
unless (defined $id) {
$id = $rule->value_for_id();
}
# Try to get the object(s) from this class directly with the ID.
# Note that the code below is longer than it needs to be, but
# is written to run quickly by resolving the most common cases
# first, and gathering data only if and when it must.
my @matches;
if (ref($id) eq 'ARRAY') {
# The $id is an arrayref. Get all of the set.
@matches = grep { $_ } map { @$_{@$id} } map { $all_objects_loaded->{$_} } ($class);
# We're done if the number found matches the number of ID values.
return @matches if @matches == @$id;
}
else {
# The $id is a normal scalar.
if (not defined $id) {
#Carp::carp("Undefined id passed as params for query on $class");
Carp::cluck("\n\n**** Undefined id passed as params for query on $class");
$id ||= '';
}
my $match;
# FIXME This is a performance optimization for class metadata to avoid the search through
# @subclasses_loaded a few lines further down. When 100s of classes are loaded it gets
# a bit slow. Maybe UR::Object::Type should override get() instad and put it there?
if (! $UR::Object::Type::bootstrapping and $class eq 'UR::Object::Type') {
my $meta_class_name = $id . '::Type';
$match = $all_objects_loaded->{$meta_class_name}->{$id}
||
$all_objects_loaded->{'UR::Object::Type'}->{$id};
if ($match) {
return $match;
} else {
return;
}
}
$match = $all_objects_loaded->{$class}->{$id};
# We're done if we found anything. If not we keep checking.
return $match if $match;
}
# Try to get the object(s) from this class's subclasses.
# We may be adding to matches made above is we used an arrayref
# and the results are incomplete.
my @subclasses_loaded = $class->__meta__->subclasses_loaded;
return @matches unless @subclasses_loaded;
if (ref($id) eq 'ARRAY') {
# The $id is an arrayref. Get all of the set and add it to anything found above.
push @matches,
grep { $_ }
map { @$_{@$id} }
map { $all_objects_loaded->{$_} }
@subclasses_loaded;
}
else {
# The $id is a normal scalar, but we didn't find it above.
# Try each subclass, exiting if we find anything.
for (@subclasses_loaded) {
my $match = $all_objects_loaded->{$_}->{$id};
return $match if $match;
}
}
# Since an ID was specified, and we've scanned the core hash every way possible,
# we're done. Return nothing if necessary.
return @matches;
}
elsif ($strategy eq "index") {
# FIXME - optimize by using the rule (template?)'s param names directly to get the
# index id instead of re-figuring it out each time
my $class_meta = $rule->subject_class_name->__meta__;
my %params = $rule->params_list;
my $should_evaluate_later;
for my $key (keys %params) {
if (substr($key,0,1) eq '-' or substr($key,0,1) eq '_') {
delete $params{$key};
}
elsif ($key =~ /^\w*\./) {
# a chain of properties
$should_evaluate_later = 1;
delete $params{$key};
}
else {
my $prop_meta = $class_meta->property_meta_for_name($key);
# NOTE: We _could_ remove the is_delegated check if we knew we were operating on
# a read-only context.
if ($prop_meta && ($prop_meta->is_many or $prop_meta->is_delegated)) {
# These indexes perform poorly in the general case if we try to index
# the is_many properties. Instead, strip them out from the basic param
# list, and evaluate the superset of indexed objects through the rule
$should_evaluate_later = 1;
delete $params{$key};
}
}
}
my @properties = sort keys %params;
unless (@properties) {
# All the supplied filters were is_many properties
return grep { $rule->evaluate($_) } $self->all_objects_loaded($class);
}
my @values = map { $params{$_} } @properties;
unless (@properties == @values) {
Carp::confess();
}
# find or create the index
my $pstring = join(",",@properties);
my $index_id = UR::Object::Index->__meta__->resolve_composite_id_from_ordered_values($class,$pstring);
my $index = $all_objects_loaded->{'UR::Object::Index'}{$index_id};
$index ||= UR::Object::Index->create(
id => $index_id,
indexed_class_name => $class,
indexed_property_string => $pstring
);
# add the indexed objects to the results list
if ($UR::Debug::verify_indexes) {
my @matches = $index->get_objects_matching(@values);
@matches = sort @matches;
my @matches2 = sort grep { $rule->evaluate($_) } $self->all_objects_loaded($class);
unless ("@matches" eq "@matches2") {
print "@matches\n";
print "@matches2\n";
#Carp::cluck("Mismatch!");
my @matches3 = $index->get_objects_matching(@values);
my @matches4 = $index->get_objects_matching(@values);
return @matches2;
}
return @matches;
}
if ($should_evaluate_later) {
return grep { $rule->evaluate($_) } $index->get_objects_matching(@values);
} else {
return $index->get_objects_matching(@values);
}
}
elsif ($strategy eq 'set intersection') {
#print $rule->num_values, " ", $rule->is_id_only, "\n";
my $template = $rule->template;
my $group_by = $template->group_by;
# get the objects in memory, and make sets for them if they do not exist
my $rule_no_group = $rule->remove_filter('-group_by');
$rule_no_group = $rule_no_group->remove_filter('-order_by');
my @objects_in_set = $self->_get_objects_for_class_and_rule_from_cache($class, $rule_no_group);
my @sets_from_grouped_objects = _group_objects($rule_no_group->template,\@values,$group_by,\@objects_in_set);
# determine the template that the grouped subsets will use
# find templates which are subsets of that template
# find sets with a
my $set_class = $class . '::Set';
my $expected_template_id = $rule->template->_template_for_grouped_subsets->id;
my @matches =
grep {
# TODO: make the template something indexable so we can pull from index
my $bx = UR::BoolExpr->get($_->id);
my $bxt = $bx->template;
if ($bxt->id ne $expected_template_id) {
#print "TEMPLATE MISMATCH $expected_template_id does not match $bxt->{id}! set: $_ with bxid $bx->{id} cannot be under rule $rule_no_group" . Data::Dumper::Dumper($_);
();
}
elsif (not $bx->is_subset_of($rule_no_group) ) {
#print "SUBSET MISMATCH: $rule_no_group is not a superset of $_ with bxid $bx->{id}" . Data::Dumper::Dumper($_);
();
}
else {
#print "MATCH: $rule_no_group with $expected_template_id matches $bx $bx->{id}" . Data::Dumper::Dumper($_);
($_);
}
}
$self->all_objects_loaded($set_class);
# Code to check that newly fabricated set definitions are in the set we query back out:
# my @all = $self->all_objects_loaded($set_class);
# my %expected;
# @expected{@sets_from_grouped_objects} = @sets_from_grouped_objects;
# for my $match (@matches) {
# delete $expected{$match};
# }
# if (keys %expected) {
# #$DB::single = 1;
# print Data::Dumper::Dumper(\%expected);
# }
return @matches;
}
else {
die "unknown strategy $strategy";
}
};
# Handle passing-through any exceptions.
die $@ if $@;
if (my $recurse = $template->recursion_desc) {
my ($this,$prior) = @$recurse;
# remove undef items. undef/NULL in the recursion linkage means it doesn't link to anything
my @values = grep { defined }
map { $_->$prior }
@results;
if (@values) {
# We do get here, so that adjustments to intermediate foreign keys
# in the cache will result in a new query at the correct point,
# and not result in missing data.
#push @results, $class->get($this => \@values, -recurse => $recurse);
push @results, map { $class->get($this => $_, -recurse => $recurse) } @values;
}
}
my $group_by = $template->group_by;
#if ($group_by) {
# # return sets instead of the actual objects
# @results = _group_objects($template,\@values,$group_by,\@results);
#}
if (@results > 1) {
my $sorter;
if ($group_by) {
# We need to rewrite the original rule on the member class to be a rule
# on the Set class to do proper ordering
my $set_class = $template->subject_class_name . '::Set';
my $set_template = UR::BoolExpr::Template->resolve($set_class, -group_by => $group_by);
$sorter = $set_template->sorter;
} else {
$sorter = $template->sorter;
}
@results = sort $sorter @results;
}
# Return in the standard way.
return @results if (wantarray);
Carp::confess("Multiple matches for $class @_!") if (@results > 1);
return $results[0];
}
sub _group_objects {
my ($template,$values,$group_by,$objects) = @_;
my $sub_template = $template->remove_filter('-group_by');
for my $property (@$group_by) {
$sub_template = $sub_template->add_filter($property);
}
my $set_class = $template->subject_class_name . '::Set';
my @groups;
my %seen;
for my $result (@$objects) {
my %values_for_group_property;
foreach my $group_property ( @$group_by ) {
my @values = $result->$group_property;
if (@values) {
$values_for_group_property{$group_property} = \@values;
} else {
$values_for_group_property{$group_property} = [ undef ];
}
}
my @combinations = UR::Util::combinations_of_values(map { $values_for_group_property{$_} } @$group_by);
foreach my $extra_values ( @combinations ) {
my $bx = $sub_template->get_rule_for_values(@$values,@$extra_values);
next if $seen{$bx->id}++;
my $group = $set_class->get($bx->id);
push @groups, $group;
}
}
return @groups;
}
sub _loading_was_done_before_with_a_superset_of_this_rule {
my($self,$rule) = @_;
my $template = $rule->template;
if (exists $UR::Context::all_params_loaded->{$template->id}
and exists $UR::Context::all_params_loaded->{$template->id}->{$rule->id}
) {
return 1;
}
if ($template->subject_class_name->isa("UR::Value")) {
return;
}
my @rule_values = $rule->values;
my @rule_param_names = $template->_property_names;
my %rule_values;
for (my $i = 0; $i < @rule_param_names; $i++) {
$rule_values{ $rule_param_names[$i] } = $rule_values[$i];
}
foreach my $loaded_template_id ( keys %$UR::Context::all_params_loaded ) {
my $loaded_template = UR::BoolExpr::Template->get($loaded_template_id);
if($template->is_subset_of($loaded_template)) {
# Try limiting the possibilities by matching the previously-loaded rule value_id's
# on this rule's values
my @param_names = $loaded_template->_property_names;
my @values = @rule_values{ @param_names };
my $value_id;
{ no warnings 'uninitialized';
$value_id = join($UR::BoolExpr::Util::record_sep, @values);
}
my @candidates = grep { index($_, $value_id) > 0 } keys(%{ $UR::Context::all_params_loaded->{$loaded_template_id} });
foreach my $loaded_rule_id ( @candidates ) {
my $loaded_rule = UR::BoolExpr->get($loaded_rule_id);
return 1 if ($rule->is_subset_of($loaded_rule));
}
}
}
return;
}
sub _forget_loading_was_done_with_template_and_rule {
my($self,$template_id, $rule_id) = @_;
delete $all_params_loaded->{$template_id}->{$rule_id};
}
# Given a list of values, returns a list of lists containing all subsets of
# the input list, including the original list and the empty list
sub _get_all_subsets_of_params {
my $self = shift;
return [] unless @_;
my $first = shift;
my @rest = $self->_get_all_subsets_of_params(@_);
return @rest, map { [$first, @$_ ] } @rest;
}
sub query_underlying_context {
my $self = shift;
unless (ref $self) {
$self = $self->current;
}
if (@_) {
$self->{'query_underlying_context'} = shift;
}
return $self->{'query_underlying_context'};
}
# all of these delegate to the current context...
sub has_changes {
return shift->get_current->has_changes(@_);
}
sub commit {
Carp::carp 'UR::Context::commit() called as a function, not a method. Assumming commit on current context' unless @_;
my $self = shift;
$self = UR::Context->current() unless ref $self;
$self->__signal_change__('precommit');
unless ($self->_sync_databases) {
$self->__signal_observers__('sync_databases', 0);
$self->__signal_change__('commit',0);
return;
}
$self->__signal_observers__('sync_databases', 1);
unless ($self->_commit_databases) {
$self->__signal_change__('commit',0);
die "Application failure during commit!";
}
$self->__signal_change__('commit',1);
foreach ( $self->all_objects_loaded('UR::Object') ) {
delete $_->{'_change_count'};
}
return 1;
}
sub rollback {
my $self = shift;
unless ($self) {
warn 'UR::Context::rollback() called as a function, not a method. Assumming rollback on current context';
$self = UR::Context->current();
}
$self->__signal_change__('prerollback');
unless ($self->_reverse_all_changes) {
$self->__signal_change__('rollback', 0);
die "Application failure during reverse_all_changes?!";
}
unless ($self->_rollback_databases) {
$self->__signal_change__('rollback', 0);
die "Application failure during rollback!";
}
$self->__signal_change__('rollback', 1);
return 1;
}
sub _tmp_self {
my $self = shift;
if (ref($self)) {
return ($self,ref($self));
}
else {
return ($UR::Context::current, $self);
}
}
sub clear_cache {
my ($self,$class) = _tmp_self(shift @_);
my %args = @_;
# dont unload any of the infrastructional classes, or any classes
# the user requested to be saved
my %local_dont_unload;
if ($args{'dont_unload'}) {
for my $class_name (@{$args{'dont_unload'}}) {
$local_dont_unload{$class_name} = 1;
for my $subclass_name ($class_name->__meta__->subclasses_loaded) {
$local_dont_unload{$subclass_name} = 1;
}
}
}
for my $class_name (UR::Object->__meta__->subclasses_loaded) {
# Once transactions are fully implemented, the command params will sit
# beneath the regular transaction, so we won't need this. For now,
# we need a work-around.
next if $class_name eq "UR::Command::Param";
next if $class_name->isa('UR::Singleton');
my $class_obj = $class_name->__meta__;
#if ($class_obj->data_source and $class_obj->is_transactional) {
# # normal
#}
#elsif (!$class_obj->data_source and !$class_obj->is_transactional) {
# # expected
#}
#elsif ($class_obj->data_source and !$class_obj->is_transactional) {
# Carp::confess("!!!!!data source on non-transactional class $class_name?");
#}
#elsif (!$class_obj->data_source and $class_obj->is_transactional) {
# # okay
#}
next unless $class_obj->is_uncachable;
next if $class_obj->is_meta_meta;
next unless $class_obj->is_transactional;
next if ($local_dont_unload{$class_name} ||
grep { $class_name->isa($_) } @{$args{'dont_unload'}});
next if $class_obj->is_meta;
next if not defined $class_obj->data_source;
for my $obj ($self->all_objects_loaded_unsubclassed($class_name)) {
# Check the type against %local_dont_unload again, because all_objects_loaded()
# will return child class objects, as well as the class you asked for. For example,
# GSC::DNA->a_o_l() will also return GSC::ReadExp objects, and the user may have wanted
# to save those. We also check whether the $obj type isa one of the requested classes
# because, for example, GSC::Sequence->a_o_l returns GSC::ReadExp types, and the user
# may have wanted to save all GSC::DNAs
my $obj_type = ref $obj;
next if ($local_dont_unload{$obj_type} ||
grep {$obj_type->isa($_) } @{$args{'dont_unload'}});
$obj->unload;
}
my @obj = grep { defined($_) } values %{ $UR::Context::all_objects_loaded->{$class_name} };
if (@obj) {
$class->warning_message("Skipped unload of $class_name objects during clear_cache: "
. join(",",map { $_->id } @obj )
. "\n"
);
if (my @changed = grep { $_->__changes__ } @obj) {
require YAML;
$class->error_message(
"The following objects have changes:\n"
. Data::Dumper::Dumper(\@changed)
. "The clear_cache method cannot be called with unsaved changes on objects.\n"
. "Use reverse_all_changes() first to really undo everything, then clear_cache(),"
. " or call sync_database() and clear_cache() if you want to just lighten memory but keep your changes.\n"
. "Clearing the cache with active changes will be supported after we're sure all code like this is gone. :)\n"
);
exit 1;
}
}
delete $UR::Context::all_objects_loaded->{$class_name};
delete $UR::Context::all_objects_are_loaded->{$class_name};
delete $UR::Context::all_params_loaded->{$class_name};
}
1;
}
sub _order_data_sources_for_saving {
my @data_sources = @_;
my %can_savepoint = map { $_->id => $_->can_savepoint } @data_sources;
my %classes = map { $_->id => $_->class } @data_sources;
my %is_default = map { $_->id => $_->isa('UR::DataSource::Default') ? -1 : 0 } @data_sources; # Default data sources go last
return
sort {
$is_default{$a->id} <=> $is_default{$b->id}
||
$can_savepoint{$a->id} <=> $can_savepoint{$b->id}
||
$classes{$a->id} cmp $classes{$b->id}
}
@data_sources;
}
our $IS_SYNCING_DATABASE = 0;
sub _sync_databases {
my $self = shift;
my %params = @_;
# Glue App::DB->sync_database with UR::Context->_sync_databases()
# and avoid endless recursion.
# FIXME Remove this when we're totally off of the old API
# You'll also want to remove all the gotos from this function and uncomment
# the returns
return 1 if $IS_SYNCING_DATABASE;
$IS_SYNCING_DATABASE = 1;
if ($App::DB::{'sync_database'}) {
unless (App::DB->sync_database() ) {
$IS_SYNCING_DATABASE = 0;
$self->error_message(App::DB->error_message());
return;
}
}
$IS_SYNCING_DATABASE = 0; # This should be far down enough to avoid recursion, right?
my @o = grep { ref($_) eq 'UR::DeletedRef' } $self->all_objects_loaded('UR::Object');
if (@o) {
print Data::Dumper::Dumper(\@o);
Carp::confess();
}
# Determine what has changed.
my @changed_objects = (
$self->all_objects_loaded('UR::Object::Ghost'),
grep { $_->__changes__ } $self->all_objects_loaded('UR::Object')
#UR::Util->mapreduce_grep(sub { $_[0]->__changes__ },$self->all_objects_loaded('UR::Object'))
);
return 1 unless (@changed_objects);
# Ensure validity.
# This is primarily to catch custom validity logic in class overrides.
my @invalid = grep { $_->__errors__ } @changed_objects;
#my @invalid = UR::Util->mapreduce_grep(sub { $_[0]->__errors__}, @changed_objects);
if (@invalid) {
$self->display_invalid_data_for_save(\@invalid);
goto PROBLEM_SAVING;
#return;
}
# group changed objects by data source
my %ds_objects;
for my $obj (@changed_objects) {
my $data_source = $self->resolve_data_source_for_object($obj);
next unless $data_source;
my $data_source_id = $data_source->id;
$ds_objects{$data_source_id} ||= { 'ds_obj' => $data_source, 'changed_objects' => []};
push @{ $ds_objects{$data_source_id}->{'changed_objects'} }, $obj;
}
my @ds_in_order =
map { $_->id }
_order_data_sources_for_saving(map { $_->{ds_obj} } values(%ds_objects));
# save on each in succession
my @done;
my $rollback_on_non_savepoint_handle;
for my $data_source_id (@ds_in_order) {
my $obj_list = $ds_objects{$data_source_id}->{'changed_objects'};
my $data_source = $ds_objects{$data_source_id}->{'ds_obj'};
my $result = $data_source->_sync_database(
%params,
changed_objects => $obj_list,
);
if ($result) {
push @done, $data_source;
next;
}
else {
$self->error_message(
"Failed to sync data source: $data_source_id: "
. $data_source->error_message
);
for my $prev_data_source (@done) {
$prev_data_source->_reverse_sync_database;
}
goto PROBLEM_SAVING;
#return;
}
}
return 1;
PROBLEM_SAVING:
if ($App::DB::{'rollback'}) {
App::DB->rollback();
}
return;
}
sub display_invalid_data_for_save {
my $self = shift;
my @objects_with_errors = @{shift @_};
$self->error_message('Invalid data for save!');
for my $obj (@objects_with_errors) {
no warnings;
my $identifier = eval { $obj->__display_name__ } || $obj->id;
my $msg = $obj->class . " identified by " . $identifier . " has problems on\n";
my @problems = $obj->__errors__;
foreach my $error ( @problems ) {
$msg .= $error->__display_name__ . "\n";
}
$msg .= " Current state:\n";
my $datadumper = Data::Dumper::Dumper($obj);
my $nr_of_lines = $datadumper =~ tr/\n//;
if ($nr_of_lines > 40) {
# trim it down to the first 15 and last 3 lines
$datadumper =~ m/^((?:.*\n){15})/;
$msg .= $1;
$datadumper =~ m/((?:.*(?:\n|$)){3})$/;
$msg .= "[...]\n$1\n";
} else {
$msg .= $datadumper;
}
$self->error_message($msg);
}
return 1;
}
sub _reverse_all_changes {
my $self = shift;
my $class;
if (ref($self)) {
$class = ref($self);
}
else {
$class = $self;
$self = $UR::Context::current;
}
@UR::Context::Transaction::open_transaction_stack = ();
@UR::Context::Transaction::change_log = ();
$UR::Context::Transaction::log_all_changes = 0;
$UR::Context::current = $UR::Context::process;
my @objects =
map { $self->all_objects_loaded_unsubclassed($_) }
grep { $_->__meta__->is_transactional }
grep { ! $_->isa('UR::Value') }
sort UR::Object->__meta__->subclasses_loaded();
for my $object (@objects) {
$object->__rollback__();
}
return 1;
}
our $IS_COMMITTING_DATABASE = 0;
sub _commit_databases {
my $class = shift;
# Glue App::DB->commit() with UR::Context->_commit_databases()
# and avoid endless recursion.
# FIXME Remove this when we're totally off of the old API
return 1 if $IS_COMMITTING_DATABASE;
$IS_COMMITTING_DATABASE = 1;
if ($App::DB::{'commit'}) {
unless (App::DB->commit() ) {
$IS_COMMITTING_DATABASE = 0;
$class->error_message(App::DB->error_message());
return;
}
}
$IS_COMMITTING_DATABASE = 0;
my @ds_in_order = _order_data_sources_for_saving($UR::Context::current->all_objects_loaded('UR::DataSource'));
my @committed;
foreach my $ds ( @ds_in_order ) {
if ($ds->commit) {
push @committed, $ds;
} else {
my $message = 'Data source ' . $ds->get_name . ' failed to commit: ' . join("\n\t", $ds->error_messages);
if (@committed) {
$message .= "\nThese data sources were successfully committed, resulting in a FRAGMENTED DISTRIBUTED TRANSACTION: "
. join(', ', map { $_->get_name } @committed);
}
Carp::croak($message);
}
}
return 1;
}
our $IS_ROLLINGBACK_DATABASE = 0;
sub _rollback_databases {
my $class = shift;
# Glue App::DB->rollback() with UR::Context->_rollback_databases()
# and avoid endless recursion.
# FIXME Remove this when we're totally off of the old API
return 1 if $IS_ROLLINGBACK_DATABASE;
$IS_ROLLINGBACK_DATABASE = 1;
if ($App::DB::{'rollback'}) {
unless (App::DB->rollback()) {
$IS_ROLLINGBACK_DATABASE = 0;
$class->error_message(App::DB->error_message());
return;
}
}
$IS_ROLLINGBACK_DATABASE = 0;
$class->_for_each_data_source("rollback")
or die "FAILED TO ROLLBACK!: " . $class->error_message;
return 1;
}
sub _disconnect_databases {
my $class = shift;
$class->_for_each_data_source("disconnect");
return 1;
}
sub _for_each_data_source {
my($class,$method) = @_;
my @ds = $UR::Context::current->all_objects_loaded('UR::DataSource');
foreach my $ds ( @ds ) {
unless ($ds->$method) {
$class->error_message("$method failed on DataSource ",$ds->get_name);
return;
}
}
return 1;
}
sub _get_committed_property_value {
my $class = shift;
my $object = shift;
my $property_name = shift;
if ($object->{'db_committed'}) {
return $object->{'db_committed'}->{$property_name};
} elsif ($object->{'db_saved_uncommitted'}) {
return $object->{'db_saved_uncommitted'}->{$property_name};
} else {
return;
}
}
sub _dump_change_snapshot {
my $class = shift;
my %params = @_;
my @c = grep { $_->__changes__ } $UR::Context::current->all_objects_loaded('UR::Object');
my $fh;
if (my $filename = $params{filename})
{
$fh = IO::File->new(">$filename");
unless ($fh)
{
$class->error_message("Failed to open file $filename: $!");
return;
}
}
else
{
$fh = "STDOUT";
}
require YAML;
$fh->print(YAML::Dump(\@c));
$fh->close;
}
sub reload {
my $self = shift;
# this is here for backward external compatability
# get() now goes directly to the context
my $class = shift;
if (ref $class) {
# Trying to reload a specific object?
if (@_) {
Carp::confess("load() on an instance with parameters is not supported");
return;
}
@_ = ('id' ,$class->id());
$class = ref $class;
}
my ($rule, @extra) = UR::BoolExpr->resolve_normalized($class,@_);
if (@extra) {
if (scalar @extra == 2 and ($extra[0] eq "sql" or $extra[0] eq 'sql in')) {
return $UR::Context::current->_get_objects_for_class_and_sql($class,$extra[1]);
}
else {
die "Odd parameters passed directly to $class load(): @extra.\n"
. "Processable params were: "
. Data::Dumper::Dumper({ $rule->params_list });
}
}
return $UR::Context::current->get_objects_for_class_and_rule($class,$rule,1);
}
## This is old, untested code that we may wany to resurrect at some point
#
#our $CORE_DUMP_VERSION = 1;
## Use Data::Dumper to save a representation of the object cache to a file. Args are:
## filename => the name of the file to save to
## dumpall => boolean flagging whether to dump _everything_, or just the things
## that would actually be loaded later in core_restore()
#
#sub _core_dump {
# my $class = shift;
# my %args = @_;
#
# my $filename = $args{'filename'} || "/tmp/core." . UR::Context::Process->prog_name . ".$ENV{HOST}.$$";
# my $dumpall = $args{'dumpall'};
#
# my $fh = IO::File->new(">$filename");
# if (!$fh) {
# $class->error_message("Can't open dump file $filename for writing: $!");
# return undef;
# }
#
# my $dumper;
# if ($dumpall) { # Go ahead and dump everything
# $dumper = Data::Dumper->new([$CORE_DUMP_VERSION,
# $UR::Context::all_objects_loaded,
# $UR::Context::all_objects_are_loaded,
# $UR::Context::all_params_loaded,
# $UR::Context::all_change_subscriptions],
# ['dump_version','all_objects_loaded','all_objects_are_loaded',
# 'all_params_loaded','all_change_subscriptions']);
# } else {
# my %DONT_UNLOAD =
# map {
# my $co = $_->__meta__;
# if ($co and not $co->is_transactional) {
# ($_ => 1)
# }
# else {
# ()
# }
# }
# $UR::Context::current->all_objects_loaded('UR::Object');
#
# my %aol = map { ($_ => $UR::Context::all_objects_loaded->{$_}) }
# grep { ! $DONT_UNLOAD{$_} } keys %$UR::Context::all_objects_loaded;
# my %aoal = map { ($_ => $UR::Context::all_objects_are_loaded->{$_}) }
# grep { ! $DONT_UNLOAD{$_} } keys %$UR::Context::all_objects_are_loaded;
# my %apl = map { ($_ => $UR::Context::all_params_loaded->{$_}) }
# grep { ! $DONT_UNLOAD{$_} } keys %$UR::Context::all_params_loaded;
# # don't dump $UR::Context::all_change_subscriptions
# $dumper = Data::Dumper->new([$CORE_DUMP_VERSION,\%aol, \%aoal, \%apl],
# ['dump_version','all_objects_loaded','all_objects_are_loaded',
# 'all_params_loaded']);
#
# }
#
# $dumper->Purity(1); # For dumping self-referential data structures
# $dumper->Sortkeys(1); # Makes quick and dirty file comparisons with sum/diff work correctly-ish
#
# $fh->print($dumper->Dump() . "\n");
#
# $fh->close;
#
# return $filename;
#}
#
## Read a file previously generated with core_dump() and repopulate the object cache. Args are:
## filename => name of the coredump file
## force => boolean flag whether to go ahead and attempt to load the file even if it thinks
## there is a formatting problem
#sub _core_restore {
# my $class = shift;
# my %args = @_;
# my $filename = $args{'filename'};
# my $forcerestore = $args{'force'};
#
# my $fh = IO::File->new("$filename");
# if (!$fh) {
# $class->error_message("Can't open dump file $filename for restoring: $!");
# return undef;
# }
#
# my $code;
# while (<$fh>) { $code .= $_ }
#
# my($dump_version,$all_objects_loaded,$all_objects_are_loaded,$all_params_loaded,$all_change_subscriptions);
# eval $code;
#
# if ($@)
# {
# $class->error_message("Failed to restore core file state: $@");
# return undef;
# }
# if ($dump_version != $CORE_DUMP_VERSION) {
# $class->error_message("core file's version $dump_version differs from expected $CORE_DUMP_VERSION");
# return 0 unless $forcerestore;
# }
#
# my %DONT_UNLOAD =
# map {
# my $co = $_->__meta__;
# if ($co and not $co->is_transactional) {
# ($_ => 1)
# }
# else {
# ()
# }
# }
# $UR::Context::current->all_objects_loaded('UR::Object');
#
# # Go through the loaded all_objects_loaded, prune out the things that
# # are in %DONT_UNLOAD
# my %loaded_classes;
# foreach ( keys %$all_objects_loaded ) {
# next if ($DONT_UNLOAD{$_});
# $UR::Context::all_objects_loaded->{$_} = $all_objects_loaded->{$_};
# $loaded_classes{$_} = 1;
#
# }
# foreach ( keys %$all_objects_are_loaded ) {
# next if ($DONT_UNLOAD{$_});
# $UR::Context::all_objects_are_loaded->{$_} = $all_objects_are_loaded->{$_};
# $loaded_classes{$_} = 1;
# }
# foreach ( keys %$all_params_loaded ) {
# next if ($DONT_UNLOAD{$_});
# $UR::Context::all_params_loaded->{$_} = $all_params_loaded->{$_};
# $loaded_classes{$_} = 1;
# }
# # $UR::Context::all_change_subscriptions is basically a bunch of coderef
# # callbacks that can't reliably be dumped anyway, so we skip it
#
# # Now, get the classes to instantiate themselves
# foreach ( keys %loaded_classes ) {
# $_->class() unless m/::Ghost$/;
# }
#
# return 1;
#}
1;
=pod
=head1 NAME
UR::Context - Manage the current state of the application
=head1 SYNOPSIS
use AppNamespace;
my $obj = AppNamespace::SomeClass->get(id => 1234);
$obj->some_property('I am changed');
UR::Context->get_current->rollback; # some_property reverts to its original value
$obj->other_property('Now, I am changed');
UR::Context->commit; # other_property now permanently has that value
=head1 DESCRIPTION
The main application code will rarely interact with UR::Context objects
directly, except for the C and C methods. It manages
the mappings between an application's classes, object cache, and external
data sources.
=head1 SUBCLASSES
UR::Context is an abstract class. When an application starts up, the system
creates a handful of Contexts that logically exist within one another:
=over 2
=item 1.
L - A context to represent all the data reachable in the
application's namespace. It connects the application to external data
sources.
=item 2.
L - A context to represent the state of data within
the currently running application. It handles the transfer of data to and
from the Root context, through the object cache, on behalf of the application
code.
=item 3.
L - A context to represent an in-memory transaction
as a diff of the object cache. The Transaction keeps a list of changes to
objects and is able to revert those changes with C, or apply them
to the underlying context with C.
=back
=head1 CONSTRUCTOR
=over 4
=item begin
my $trans = UR::Context::Transaction->begin();
L instances are created through C.
=back
A L and L context will be created
for you when the application initializes. Additional instances of these
classes are not usually instantiated.
=head1 METHODS
Most of the methods below can be called as either a class or object method
of UR::Context. If called as a class method, they will operate on the current
context.
=over 4
=item get_current
my $context = UR::Context::get_current();
Returns the UR::Context instance of whatever is the most currently created
Context. Can be called as a class or object method.
=item query_underlying_context
my $should_load = $context->query_underlying_context();
$context->query_underlying_context(1);
A property of the Context that sets the default value of the C<$should_load>
flag inside C as described below. Initially,
its value is undef, meaning that during a get(), the Context will query the
underlying data sources only if this query has not been done before. Setting
this property to 0 will make the Context never query data sources, meaning
that the only objects retrievable are those already in memory. Setting the
property to 1 means that every query will hit the data sources, even if the
query has been done before.
=item get_objects_for_class_and_rule
@objs = $context->get_objects_for_class_and_rule(
$class_name,
$boolexpr,
$should_load,
$should_return_iterator
);
This is the method that serves as the main entry point to the Context behind
the C, and C methods of L, and C method
of UR::Context.
C<$class_name> and C<$boolexpr> are required arguments, and specify the
target class by name and the rule used to filter the objects the caller
is interested in.
C<$should_load> is a flag indicating whether the Context should load objects
satisfying the rule from external data sources. A true value means it should
always ask the relevent data sources, even if the Context believes the
requested data is in the object cache, A false but defined value means the
Context should not ask the data sources for new data, but only return what
is currently in the cache matching the rule. The value C means the
Context should use the value of its query_underlying_context property. If
that is also undef, then it will use its own judgement about asking the
data sources for new data, and will merge cached and external data as
necessary to fulfill the request.
C<$should_return_iterator> is a flag indicating whether this method should
return the objects directly as a list, or iterator function instead. If
true, it returns a subref that returns one object each time it is called,
and undef after the last matching object:
my $iter = $context->get_objects_for_class_and_rule(
'MyClass',
$rule,
undef,
1
);
my @objs;
while (my $obj = $iter->());
push @objs, $obj;
}
=item has_changes
my $bool = $context->has_changes();
Returns true if any objects in the given Context's object cache (or the
current Context if called as a class method) have any changes that haven't
been saved to the underlying context.
=item commit
UR::Context->commit();
Causes all objects with changes to save their changes back to the underlying
context. If the current context is a L, then the
changes will be applied to whatever Context the transaction is a part of.
if the current context is a L context, then C
pushes the changes to the underlying L context, meaning
that those changes will be applied to the relevent data sources.
In the usual case, where no transactions are in play and all data sources
are RDBMS databases, calling C will cause the program to begin
issuing SQL against the databases to update changed objects, insert rows
for newly created objects, and delete rows from deleted objects as part of
an SQL transaction. If all the changes apply cleanly, it will do and SQL
C, or C if not.
commit() returns true if all the changes have been safely transferred to the
underlying context, false if there were problems.
=item rollback
UR::Context->rollback();
Causes all objects' changes for the current transaction to be reversed.
If the current context is a L, then the
transactional properties of those objects will be reverted to the values
they had when the transaction started. Outside of a transaction, object
properties will be reverted to their values when they were loaded from the
underlying data source. rollback() will also ask all the underlying
databases to rollback.
=item clear_cache
UR::Context->clear_cache();
Asks the current context to remove all non-infrastructional data from its
object cache. This method will fail and return false if any object has
changes.
=item resolve_data_source_for_object
my $ds = $obj->resolve_data_source_for_object();
For the given C<$obj> object, return the L instance that
object was loaded from or would be saved to. If objects of that class do
not have a data source, then it will return C.
=item resolve_data_sources_for_class_meta_and_rule
my @ds = $context->resolve_data_sources_for_class_meta_and_rule($class_obj, $boolexpr);
For the given class metaobject and boolean expression (rule), return the list of
data sources that will need to be queried in order to return the objects
matching the rule. In most cases, only one data source will be returned.
=item infer_property_value_from_rule
my $value = $context->infer_property_value_from_rule($property_name, $boolexpr);
For the given boolean expression (rule), and a property name not mentioned in
the rule, but is a property of the class the rule is against, return the value
that property must logically have.
For example, if this object is the only TestClass object where C is
the value 'bar', it can infer that the TestClass property C must
have the value 'blah' in the current context.
my $obj = TestClass->create(id => 1, foo => 'bar', baz=> 'blah');
my $rule = UR::BoolExpr->resolve('TestClass', foo => 'bar);
my $val = $context->infer_property_value_from_rule('baz', $rule);
# val now is 'blah'
=item object_cache_size_highwater
UR::Context->object_cache_size_highwater(5000);
my $highwater = UR::Context->object_cache_size_highwater();
Set or get the value for the Context's object cache pruning high water
mark. The object cache pruner will be run during the next C if the
cache contains more than this number of prunable objects. See the
L section below for more information.
=item object_cache_size_lowwater
UR::Context->object_cache_size_lowwater(5000);
my $lowwater = UR::Context->object_cache_size_lowwater();
Set or get the value for the Context's object cache pruning high water
mark. The object cache pruner will stop when the number of prunable objects
falls below this number.
=item prune_object_cache
UR::Context->prune_object_cache();
Manually run the object cache pruner.
=item reload
UR::Context->reload($object);
UR::Context->reload('Some::Class', 'property_name', value);
Ask the context to load an object's data from an underlying Context, even if
the object is already cached. With a single parameter, it will use that
object's ID parameters as the basis for querying the data source. C
will also accept a class name and list of key/value parameters the same as
C.
=item _light_cache
UR::Context->_light_cache(1);
Turn on or off the light caching flag. Light caching alters the behavior
of the object cache in that all object references in the cache are made weak
by Scalar::Util::weaken(). This means that the application code must keep
hold of any object references it wants to keep alive. Light caching defaults
to being off, and must be explicitly turned on with this method.
=back
=head1 Custom observer aspects
UR::Context sends signals for observers watching for some non-standard aspects.
=over 2
=item precommit
After C has been called, but before any changes are saved to the
data sources. The only parameters to the Observer's callback are the Context
object and the aspect ("precommit").
=item commit
After C has been called, and after an attempt has been made to save
the changes to the data sources. The parameters to the callback are the
Context object, the aspect ("commit"), and a boolean value indicating whether
the commit succeeded or not.
=item prerollback
After C has been called, but before and object state is reverted.
=item rollback
After C has been called, and after an attempt has been made to
revert the state of all the loaded objects. The parameters to the callback
are the Context object, the aspect ("rollback"), and a boolean value
indicating whether the rollback succeeded or not.
=back
=head1 Data Concurrency
Currently, the Context is optimistic about data concurrency, meaning that
it does very little to prevent clobbering data in underlying Contexts during
a commit() if other processes have changed an object's data after the Context
has cached and object. For example, a database has an object with ID 1 and
a property with value 'bob'. A program loads this object and changes the
property to 'fred', but does not yet commit(). Meanwhile, another program
loads the same object, changes the value to 'joe' and does commit(). Finally
the first program calls commit(). The final value in the database will be
'fred', and no exceptions will be raised.
As part of the caching behavior, the Context keeps a record of what the
object's state is as it's loaded from the underlying Context. This is how
the Context knows what object have been changed during C.
If an already cached object's data is reloaded as part of some other query,
data consistency of each property will be checked. If there are no
conflicting changes, then any differences between the object's initial state
and the current state in the underlying Context will be applied to the
object's notion of what it thinks its initial state is.
In some future release, UR may support additional data concurrency methods
such as pessimistic concurrency: check that the current state of all
changed (or even all cached) objects in the underlying Context matches the
initial state before committing changes downstream. Or allowing the object
cache to operate in write-through mode for some or all classes.
=head1 Internal Methods
There are many methods in UR::Context meant to be used internally, but are
worth documenting for anyone interested in the inner workings of the Context
code.
=over 4
=item _create_import_iterator_for_underlying_context
$subref = $context->_create_import_iterator_for_underlying_context(
$boolexpr, $data_source, $serial_number
);
$next_obj = $subref->();
This method is part of the object loading process, and is called by
L when it is determined that the requested
data does not exist in the object cache, and data should be brought in from
another, underlying Context. Usually this means the data will be loaded
from an external data source.
C<$boolexpr> is the L rule, usually from the application code.
C<$data_source> is the L that will be used to load data from.
C<$serial_number> is used by the object cache pruner. Each object loaded
through this iterator will have $serial_number in its C<__get_serial> hashref
key.
It works by first getting an iterator for the data source (the
C<$db_iterator>). It calls L to find out
how data is to be loaded and whether this request spans multiple data
sources. It calls L to get
a list of closures to transform the primary data source's data into UR
objects, and L (if necessary) to get
more closures that can load and join data from the primary to the secondary
data source(s).
It returns a subref that works as an iterator, loading and returning objects
one at a time from the underlying context into the current context. It
returns undef when there are no more objects to return.
The returned iterator works by first asking the C<$db_iterator> for the next
row of data as a listref. Asks the secondary data source joiners whether
there is any matching data. Calls the object fabricator closures to convert
the data source data into UR objects. If any of the object requires
subclassing, then additional importing iterators are created to handle that.
Finally, the objects matching the rule are returned to the caller one at a
time.
=item _resolve_query_plan_for_ds_and_bxt
my $query_plan = $context->_resolve_query_plan_for_ds_and_bxt(
$data_source,
$boolexpr_tmpl
);
my($query_plan, @addl_info) = $context->_resolve_query_plan_for_ds_and_bxt(
$data_source,
$boolexpr_tmpl
);
When a request is made that will hit one or more data sources,
C<_resolve_query_plan_for_ds_and_bxt> is used to call a method of the same name
on the data source. It retuns a hashref used by many other parts of the
object loading system, and describes what data source to use, how to query
that data source to get the objects, how to use the raw data returned by
the data source to construct objects and how to resolve any delegated
properties that are a part of the rule.
C<$data_source> is a L object ID. C<$coolexpr_tmpl> is a
L object.
In the common case, the query will only use one data source, and this method
returns that data directly. But if the primary data source sets the
C key on the data structure as may be the case
when a rule involves a delegated property to a class that uses a different
data source, then this methods returns an additional list of data. For
each additional data source needed to resolve the query, this list will have
three items:
=over 2
=item 1.
The secondary data source ID
=item 2.
A listref of delegated L objects joining the primary
data source to this secondary data source.
=item 3.
A L rule template applicable against the secondary
data source
=back
=item _create_secondary_rule_from_primary
my $new_rule = $context->_create_secondary_rule_from_primary(
$primary_rule,
$delegated_properties,
$secondary_rule_tmpl
);
When resolving a request that requires multiple data sources,
this method is used to construct a rule against applicable against the
secondary data source. C<$primary_rule> is the L rule used
in the original query. C<$delegated_properties> is a listref of
L objects as returned by
L linking the primary to the secondary data
source. C<$secondary_rule_tmpl> is the rule template, also as returned by
L.
=item _create_secondary_loading_closures
my($obj_importers, $joiners) = $context->_create_secondary_loading_closures(
$primary_rule_tmpl,
@addl_info);
When reolving a request that spans multiple data sources,
this method is used to construct two lists of subrefs to aid in the request.
C<$primary_rule_tmpl> is the L rule template made
from the original rule. C<@addl_info> is the same list returned by
L. For each secondary data source, there
will be one item in the two listrefs that are returned, and in the same
order.
C<$obj_importers> is a listref of subrefs used as object importers. They
transform the raw data returned by the data sources into UR objects.
C<$joiners> is also a listref of subrefs. These closures know how the
properties link the primary data source data to the secondary data source.
They take the raw data from the primary data source, load the next row of
data from the secondary data source, and returns the secondary data that
successfully joins to the primary data. You can think of these closures as
performing the same work as an SQL C between data in different data
sources.
=item _cache_is_complete_for_class_and_normalized_rule
($is_cache_complete, $objects_listref) =
$context->_cache_is_complete_for_class_and_normalized_rule(
$class_name, $boolexpr
);
This method is part of the object loading process, and is called by
L to determine if the objects requested
by the L C<$boolexpr> will be found entirely in the object
cache. If the answer is yes then C<$is_cache_complete> will be true.
C<$objects_listef> may or may not contain objects matching the rule from
the cache. If that list is not returned, then
L does additional work to locate the
matching objects itself via L
It does its magic by looking at the C<$boolexpr> and loosely matching it
against the query cache C<$UR::Context::all_params_loaded>
=item _get_objects_for_class_and_rule_from_cache
@objects = $context->_get_objects_for_class_and_rule_from_cache(
$class_name, $boolexpr
);
This method is called by L when
L<_cache_is_complete_for_class_and_normalized_rule> says the requested
objects do exist in the cache, but did not return those items directly.
The L C<$boolexpr> contains hints about how the matching data
is likely to be found. Its C<_context_query_strategy> key will contain
one of three values
=over 2
=item 1. all
This rule is against a class with no filters, meaning it should return every
member of that class. It calls C<$class-Eall_objects_loaded> to extract
all objects of that class in the object cache.
=item 2. id
This rule is against a class and filters by only a single ID, or a list of
IDs. The request is fulfilled by plucking the matching objects right out
of the object cache.
=item 3. index
This rule is against one more more non-id properties. An index is built
mapping the filtered properties and their values, and the cached objects
which have those values. The request is fulfilled by using the index to
find objects matching the filter.
=item 4. set intersection
This is a group-by rule and will return a ::Set object.
=back
=item _loading_was_done_before_with_a_superset_of_this_params_hashref
$bool = $context->_loading_was_done_before_with_a_superset_of_this_params_hashref(
$class_name,
$params_hashref
);
This method is used by L
to determine if the requested data was asked for previously, either from a
get() asking for a superset of the current request, or from a request on
a parent class of the current request.
For example, if a get() is done on a class with one param:
@objs = ParentClass->get(param_1 => 'foo');
And then later, another request is done with an additional param:
@objs2 = ParentClass->get(param_1 => 'foo', param_2 => 'bar');
Then the first request must have returned all the data that could have
possibly satisfied the second request, and so the system will not issue
a query against the data source.
As another example, given those two previously done queries, if another
get() is done on a class that inherits from ParentClass
@objs3 = ChildClass->get(param_1 => 'foo');
again, the first request has already loaded all the relevent data, and
therefore won't query the data source.
=item _sync_databases
$bool = $context->_sync_databases();
Starts the process of committing all the Context's changes to the external
data sources. _sync_databases() is the workhorse behind L.
First, it finds all objects with changes. Checks those changed objects
for validity with C<$obj-Einvalid>. If any objects are found invalid,
then _sync_databases() will fail. Finally, it bins all the changed objects
by data source, and asks each data source to save those objects' changes.
It returns true if all the data sources were able to save the changes,
false otherwise.
=item _reverse_all_changes
$bool = $context->_reverse_all_changes();
_reverse_all_changes() is the workhorse behind L.
For each class, it goes through each object of that class. If the object
is a L, representing a deleted object, it converts the
ghost back to the live version of the object. For other classes, it makes
a list of properties that have changed since they were loaded (represented
by the C hash key in the object), and reverts those changes
by using each property's accessor method.
=back
=head1 The Object Cache
The object cache is integral to the way the Context works, and also the main
difference between UR and other ORMs. Other systems do no caching and
require the calling application to hold references to any objects it
is interested in. Say one part of the app loads data from the database and
gives up its references, then if another part of the app does the same or
similar query, it will have to ask the database again.
UR handles caching of classes, objects and queries to avoid asking the data
sources for data it has loaded previously. The object cache is essentially
a software transaction that sits above whatever database transaction is
active. After objects are loaded, any changes, creations or deletions exist
only in the object cache, and are not saved to the underlying data sources
until the application explicitly requests a commit or rollback.
Objects are returned to the application only after they are inserted into
the object cache. This means that if disconnected parts of the application
are returned objects with the same class and ID, they will have references
to the same exact object reference, and changes made in one part will be
visible to all other parts of the app. An unchanged object can be removed
from the object cache by calling its C method.
Since changes to the underlying data sources are effectively delayed, it is
possible that the application's notion of the object's current state does
not match the data stored in the data source. You can mitigate this by using
the C class or object method to fetch the latest data if it's a
problem. Another issue to be aware of is if multiple programs are likely
to commit conflicting changes to the same data, then whichever applies its
changes last will win; some kind of external locking needs to be applied.
Finally, if two programs attempt to insert data with the same ID columns
into an RDBMS table, the second application's commit will fail, since that
will likely violate a constraint.
=head2 Object Change Tracking
As objects are loaded from their data sources, their properties are
initialized with the data from the query, and a copy of the same data is
stored in the object in its C hash key. Anyone can ask the
object for a list of its changes by calling C<$obj-Echanged>.
Internally, changed() goes through all the object's properties, comparing
the current values in the object's hash with the same keys under
'db_committed'.
Objects created through the C class method have no 'db_committed',
and so the object knows it it a newly created object in this context.
Every time an object is retrieved with get() or through an iterator, it is
assigned a serial number in its C<__get_serial> hash key from the
C<$UR::Context::GET_SERIAL> counter. This number is unique and increases
with each get(), and is used by the L to expire the
least recently requested data.
Objects also track what parameters have been used to get() them in the hash
C<$obj-E{__load}>. This is a copy of the data in
C<$UR::Context::all_params_loaded-E{$template_id}>. For each rule
ID, it will have a count of the number of times that rule was used in a get().
=head2 Deleted Objects and Ghosts
Calling delete() on an object is tracked in a different way. First, a new
object is created, called a ghost. Ghost classes exist for every
class in the application and are subclasses of L. For
example, the ghost class for MyClass is MyClass::Ghost. This ghost object
is initialized with the data from the original object. The original object
is removed from the object cache, and is reblessed into the UR::DeletedRef
class. Any attempt to interact with the object further will raise an
exception.
Ghost objects are not included in a get() request on the regular class,
though the app can ask for them specificly using
Cget(%params)>.
Ghost classes do not have ghost classes themselves. Calling create() or
delete() on a Ghost class or object will raise an exception. Calling other
methods on the Ghost object that exist on the original, live class will
delegate over to the live class's method.
=head2 all_objects_are_loaded
C<$UR::Context::all_objects_are_loaded> is a hashref keyed by class names.
If the value is true, then L
knows that all the instances of that class exist in the object cache, and
it can avoid asking the underlying context/datasource for that class' data.
=head2 all_params_loaded
C<$UR::Context::all_params_loaded> is a two-level hashref. The first level
is class names. The second level is rule (L) IDs. The values
are how many times that class and rule have been involved in a get(). This
data is used by L
to determine if the requested data will be found in the object cache for
non-id queries.
=head2 all_objects_loaded
C<$UR::Context::all_objects_loaded> is a two-level hashref. The first level
is class names. The second level is object IDs. Every time an object is
created, defined or loaded from an underlying context, it is inserted into
the C hash. For queries involving only ID properties,
the Context can retrieve them directly out of the cache if they appear there.
The entire cache can be purged of non-infrastructional objects by calling
L.
=head2 Object Cache Pruner
The default Context behavior is to cache all objects it knows about for the
entire life of the process. For programs that churn through large amounts
of data, or live for a long time, this is probably not what you want.
The Context has two settings to loosely control the size of the object
cache. L and L.
As objects are created and loaded, a count of uncachable objects is kept
in C<$UR::Context::all_objects_cache_size>. The first part of
L checks to see of the current size is
greater than the highwater setting, and call L if so.
prune_object_cache() works by looking at what C<$UR::Context::GET_SERIAL>
was the last time it ran, and what it is now, and making a guess about
what object serial number to use as a guide for removing objects by starting
at 10% of the difference between the last serial and the current value,
called the target serial.
It then starts executing a loop as long as C<$UR::Context::all_objects_cache_size>
is greater than the lowwater setting. For each uncachable object, if its
C<__get_serial> is less than the target serial, it is weakened from any
Les it may be a member of, and then weakened from the
main object cache, C<$UR::Context::all_objects_loaded>.
The application may lock an object in the cache by calling C<__strengthen__> on
it, Likewise, the app may hint to the pruner to throw away an object as
soon as possible by calling C<__weaken__>.
=head1 SEE ALSO
L, L, L,
L, L, L
=cut
AutoUnloadPool.pm 100664 023532 023421 7271 12544604516 17627 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/Context package UR::Context::AutoUnloadPool;
use strict;
use warnings;
require UR;
our $VERSION = "0.44"; # UR $VERSION
use Scalar::Util qw();
# These are plain Perl objects that get garbage collected in the normal way,
# not UR::Objects
our @CARP_NOT = qw( UR::Context );
sub create {
my $class = shift;
my $self = bless { pool => {} }, $class;
$self->_attach_observer();
return $self;
}
sub delete {
my $self = shift;
delete $self->{pool};
$self->_detach_observer();
}
sub _attach_observer {
my $self = shift;
Scalar::Util::weaken($self);
my $o = UR::Object->add_observer(
aspect => 'load',
callback => sub {
my $loaded = shift;
return if ! $loaded->is_prunable();
$self->_object_was_loaded($loaded);
}
);
$self->{observer} = $o;
}
sub _detach_observer {
my $self = shift;
delete($self->{observer})->delete();
}
sub _is_printing_debug {
$ENV{UR_DEBUG_OBJECT_PRUNING} || $ENV{'UR_DEBUG_OBJECT_RELEASE'};
}
sub _object_was_loaded {
my($self, $o) = @_;
if (_is_printing_debug()) {
my($class, $id) = ($o->class, $o->id);
print STDERR Carp::shortmess("MEM AUTORELEASE $class id $id loaded in pool $self\n");
}
$self->{pool}->{$o->class}->{$o->id} = undef;
}
sub _unload_objects {
my $self = shift;
return unless $self->{pool};
print STDERR Carp::shortmess("MEM AUTORELEASE pool $self draining\n") if _is_printing_debug();
my @unload_exceptions;
foreach my $class_name ( keys %{$self->{pool}} ) {
print STDERR "MEM AUTORELEASE class $class_name: " if _is_printing_debug();
my $is_subsequent_obj;
my $objs_for_class = $UR::Context::all_objects_loaded->{$class_name};
next unless $objs_for_class;
foreach ( @$objs_for_class{ keys %{$self->{pool}->{$class_name}}} ) {
next unless $_;
print STDERR ($is_subsequent_obj++ ? ", " : ''), $_->id,"\n" if _is_printing_debug();
unless (eval { $_->unload(); 1; } ) {
push @unload_exceptions, $@;
}
}
print STDERR "\n" if _is_printing_debug();
}
delete $self->{pool};
die join("\n", 'The following exceptions happened while unloading:', @unload_exceptions) if @unload_exceptions;
}
sub DESTROY {
local $@;
my $self = shift;
return unless ($self->{pool});
$self->_detach_observer();
$self->_unload_objects();
}
1;
=pod
=head1 NAME
UR::Context::AutoUnloadPool - Automaticaly unload objects when scope ends
=head1 SYNOPSIS
my $not_unloaded = Some::Class->get(...);
do {
my $guard = UR::Context::AutoUnloadPool->create();
my $object = Some::Class->get(...); # load an object from the database
... # load more things
}; # $guard goes out of scope - unloads objects
=head1 DESCRIPTION
UR Objects retrieved from the database normally live in the object cache for
the life of the program. When a UR::Context::AutoUnloadPool is instantiated,
it tracks every object loaded during its life. The Pool's destructor calls
unload() on those objects.
Changed objects and objects loaded before before the Pool is created will not
get unloaded.
=head1 METHODS
=over 4
=item create
my $guard = UR::Context::AutoUnloadPool->create();
Creates a Pool object. All UR Objects loaded from the database during this
object's lifetime will get unloaded when the Pool goes out of scope.
=item delete
$guard->delete();
Invalidates the Pool object. No objects are unloaded. When the Pool later
goes out of scope, no objects will be unloaded.
=back
=head1 SEE ALSO
UR::Object, UR::Context
=cut
DefaultRoot.pm 100664 023532 023421 644 12544604516 17127 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/Context package UR::Context::DefaultRoot;
use strict;
use warnings;
require UR;
our $VERSION = "0.44"; # UR $VERSION;
UR::Object::Type->define(
class_name => 'UR::Context::DefaultRoot',
is => ['UR::Context::Root'],
doc => 'The base context used when no special base context is specified.',
);
1;
=pod
=head1 NAME
UR::Context::DefaultRoot - The base context used when no special base context is specified
=cut
ImportIterator.pm 100664 023532 023421 122656 12544604516 17753 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/Context package UR::Context;
# Methods related to the import iterator (part of the loading process).
#
# They are broken out here for readability purposes. The methods still live
# in the UR::Context namespace.
use strict;
use warnings;
our $VERSION = "0.44"; # UR $VERSION;
# A wrapper around the method of the same name in UR::DataSource::* to iterate over the
# possible data sources involved in a query. The easy case (a query against a single data source)
# will return the $primary_template data structure. If the query involves more than one data source,
# then this method also returns a list containing triples (@addl_loading_info) where each member is:
# 1) The secondary data source name
# 2) a listref of delegated properties joining the primary class to the secondary class
# 3) a rule template applicable against the secondary data source
sub _resolve_query_plan_for_ds_and_bxt {
my($self,$primary_data_source,$rule_template) = @_;
my $primary_query_plan = $primary_data_source->_resolve_query_plan($rule_template);
unless ($primary_query_plan->{'joins_across_data_sources'}) {
# Common, easy case
return $primary_query_plan;
}
my @addl_loading_info;
foreach my $secondary_data_source_id ( keys %{$primary_query_plan->{'joins_across_data_sources'}} ) {
my $this_ds_delegations = $primary_query_plan->{'joins_across_data_sources'}->{$secondary_data_source_id};
my %seen_properties;
foreach my $delegated_property ( @$this_ds_delegations ) {
my $delegated_property_name = $delegated_property->property_name;
next if ($seen_properties{$delegated_property_name}++);
my $operator = $rule_template->operator_for($delegated_property_name);
$operator ||= '='; # FIXME - shouldn't the template return this for us?
my @secondary_params = ($delegated_property->to . ' ' . $operator);
my $class_meta = UR::Object::Type->get($delegated_property->class_name);
my $relation_property = $class_meta->property_meta_for_name($delegated_property->via);
my $secondary_class = $relation_property->data_type;
# we can also add in any properties in the property's joins that also appear in the rule
my @property_pairs = $relation_property->get_property_name_pairs_for_join();
foreach my $pair ( @property_pairs ) {
my($primary_property, $secondary_property) = @$pair;
next if ($seen_properties{$primary_property}++);
next unless ($rule_template->specifies_value_for($primary_property));
my $operator = $rule_template->operator_for($primary_property);
$operator ||= '=';
push @secondary_params, "$secondary_property $operator";
}
my $secondary_rule_template = UR::BoolExpr::Template->resolve($secondary_class, @secondary_params);
# FIXME there should be a way to collect all the requests for the same datasource together...
# FIXME - currently in the process of switching to object-based instead of class-based data sources
# For now, data sources are still singleton objects, so this get() will work. When we're fully on
# regular-object-based data sources, then it'll probably change to UR::DataSource->get($secondary_data_source_id);
my $secondary_data_source = UR::DataSource->get($secondary_data_source_id) || $secondary_data_source_id->get();
push @addl_loading_info,
$secondary_data_source,
[$delegated_property],
$secondary_rule_template;
}
}
return ($primary_query_plan, @addl_loading_info);
}
# Used by _create_secondary_loading_comparators to convert a rule against the primary data source
# to a rule that can be used against a secondary data source
# FIXME this might be made simpler be leaning on infer_property_value_from_rule()?
sub _create_secondary_rule_from_primary {
my($self,$primary_rule, $delegated_properties, $secondary_rule_template) = @_;
my @secondary_values;
my %seen_properties; # FIXME - we've already been over this list in _resolve_query_plan_for_ds_and_bxt()...
# FIXME - is there ever a case where @$delegated_properties will be more than one item?
foreach my $property ( @$delegated_properties ) {
my $value = $primary_rule->value_for($property->property_name);
my $secondary_property_name = $property->to;
my $pos = $secondary_rule_template->value_position_for_property_name($secondary_property_name);
$secondary_values[$pos] = $value;
$seen_properties{$property->property_name}++;
my $class_meta = $property->class_meta;
my $via_property = $class_meta->property_meta_for_name($property->via);
my @pairs = $via_property->get_property_name_pairs_for_join();
foreach my $pair ( @pairs ) {
my($primary_property_name, $secondary_property_name) = @$pair;
next if ($seen_properties{$primary_property_name}++);
$value = $primary_rule->value_for($primary_property_name);
next unless $value;
$pos = $secondary_rule_template->value_position_for_property_name($secondary_property_name);
$secondary_values[$pos] = $value;
}
}
my $secondary_rule = $secondary_rule_template->get_rule_for_values(@secondary_values);
return $secondary_rule;
}
# Since we'll be appending more "columns" of data to the listrefs returned by
# the primary datasource's query, we need to apply fixups to the column positions
# to all the secondary loading templates
# The column_position and object_num offsets needed for the next call of this method
# are returned
sub _fixup_secondary_loading_template_column_positions {
my($self,$primary_loading_templates, $secondary_loading_templates, $column_position_offset, $object_num_offset) = @_;
if (! defined($column_position_offset) or ! defined($object_num_offset)) {
$column_position_offset = 0;
foreach my $tmpl ( @{$primary_loading_templates} ) {
$column_position_offset += scalar(@{$tmpl->{'column_positions'}});
}
$object_num_offset = scalar(@{$primary_loading_templates});
}
my $this_template_column_count;
foreach my $tmpl ( @$secondary_loading_templates ) {
foreach ( @{$tmpl->{'column_positions'}} ) {
$_ += $column_position_offset;
}
foreach ( @{$tmpl->{'id_column_positions'}} ) {
$_ += $column_position_offset;
}
$tmpl->{'object_num'} += $object_num_offset;
$this_template_column_count += scalar(@{$tmpl->{'column_positions'}});
}
return ($column_position_offset + $this_template_column_count,
$object_num_offset + scalar(@$secondary_loading_templates) );
}
# For queries that have to hit multiple data sources, this method creates two lists of
# closures. The first is a list of object fabricators, where the loading templates
# have been given fixups to the column positions (see _fixup_secondary_loading_template_column_positions())
# The second is a list of closures for each data source (the @addl_loading_info stuff
# from _resolve_query_plan_for_ds_and_bxt) that's able to compare the row loaded from the
# primary data source and see if it joins to a row from this secondary datasource's database
sub _create_secondary_loading_closures {
my($self, $primary_template, $rule, @addl_loading_info) = @_;
my $loading_templates = $primary_template->{'loading_templates'};
# Make a mapping of property name to column positions returned by the primary query
my %primary_query_column_positions;
foreach my $tmpl ( @$loading_templates ) {
my $property_name_count = scalar(@{$tmpl->{'property_names'}});
for (my $i = 0; $i < $property_name_count; $i++) {
my $property_name = $tmpl->{'property_names'}->[$i];
my $pos = $tmpl->{'column_positions'}->[$i];
$primary_query_column_positions{$property_name} = $pos;
}
}
my @secondary_object_importers;
my @addl_join_comparators;
# used to shift the apparent column position of the secondary loading template info
my ($column_position_offset,$object_num_offset);
while (@addl_loading_info) {
my $secondary_data_source = shift @addl_loading_info;
my $this_ds_delegations = shift @addl_loading_info;
my $secondary_rule_template = shift @addl_loading_info;
my $secondary_rule = $self->_create_secondary_rule_from_primary (
$rule,
$this_ds_delegations,
$secondary_rule_template,
);
$secondary_data_source = $secondary_data_source->resolve_data_sources_for_rule($secondary_rule);
my $secondary_template = $self->_resolve_query_plan_for_ds_and_bxt($secondary_data_source,$secondary_rule_template);
# sets of triples where the first in the triple is the column index in the
# $secondary_db_row (in the join_comparator closure below), the second is the
# index in the $next_db_row. And the last is a flag indicating if we should
# perform a numeric comparison. This way we can preserve the order the comparisons
# should be done in
my @join_comparison_info;
foreach my $property ( @$this_ds_delegations ) {
# first, map column names in the joined class to column names in the primary class
my %foreign_property_name_map;
my @this_property_joins = $property->_resolve_join_chain();
foreach my $join ( @this_property_joins ) {
my @source_names = @{$join->{'source_property_names'}};
my @foreign_names = @{$join->{'foreign_property_names'}};
@foreign_property_name_map{@foreign_names} = @source_names;
}
# Now, find out which numbered column in the result query maps to those names
my $secondary_loading_templates = $secondary_template->{'loading_templates'};
foreach my $tmpl ( @$secondary_loading_templates ) {
my $property_name_count = scalar(@{$tmpl->{'property_names'}});
for (my $i = 0; $i < $property_name_count; $i++) {
my $property_name = $tmpl->{'property_names'}->[$i];
if ($foreign_property_name_map{$property_name}) {
# This is the one we're interested in... Where does it come from in the primary query?
my $column_position = $tmpl->{'column_positions'}->[$i];
# What are the types involved?
my $primary_query_column_name = $foreign_property_name_map{$property_name};
my $primary_property_meta = UR::Object::Property->get(class_name => $primary_template->{'class_name'},
property_name => $primary_query_column_name);
my $secondary_property_meta = UR::Object::Property->get(class_name => $secondary_template->{'class_name'},
property_name => $property_name);
my $comparison_type;
if ($primary_property_meta->is_numeric && $secondary_property_meta->is_numeric) {
$comparison_type = 1;
}
my $comparison_position;
if (exists $primary_query_column_positions{$primary_query_column_name} ) {
$comparison_position = $primary_query_column_positions{$primary_query_column_name};
} else {
# This isn't a real column we can get from the data source. Maybe it's
# in the constant_property_names of the primary_loading_template?
unless (grep { $_ eq $primary_query_column_name}
@{$loading_templates->[0]->{'constant_property_names'}}) {
die sprintf("Can't resolve datasource comparison to join %s::%s to %s:%s",
$primary_template->{'class_name'}, $primary_query_column_name,
$secondary_template->{'class_name'}, $property_name);
}
my $comparison_value = $rule->value_for($primary_query_column_name);
unless (defined $comparison_value) {
$comparison_value = $self->infer_property_value_from_rule($primary_query_column_name, $rule);
}
$comparison_position = \$comparison_value;
}
push @join_comparison_info, $column_position,
$comparison_position,
$comparison_type;
}
}
}
}
my $secondary_db_iterator = $secondary_data_source->create_iterator_closure_for_rule($secondary_rule);
my $secondary_db_row;
# For this closure, pass in the row we just loaded from the primary DB query.
# This one will return the data from this secondary DB's row if the passed-in
# row successfully joins to this secondary db iterator. It returns an empty list
# if there were no matches, and returns false if there is no more data from the query
my $join_comparator = sub {
my $next_db_row = shift; # From the primary DB
READ_DB_ROW:
while(1) {
return unless ($secondary_db_iterator);
unless ($secondary_db_row) {
($secondary_db_row) = $secondary_db_iterator->();
unless($secondary_db_row) {
# No more data to load
$secondary_db_iterator = undef;
return;
}
}
for (my $i = 0; $i < @join_comparison_info; $i += 3) {
my $secondary_column = $join_comparison_info[$i];
my $primary_column = $join_comparison_info[$i+1];
my $is_numeric = $join_comparison_info[$i+2];
my $comparison;
if (ref $primary_column) {
# This was one of those constant value items
if ($is_numeric) {
$comparison = $secondary_db_row->[$secondary_column] <=> $$primary_column;
} else {
$comparison = $secondary_db_row->[$secondary_column] cmp $$primary_column;
}
} else {
if ($join_comparison_info[$i+2]) {
$comparison = $secondary_db_row->[$secondary_column] <=> $next_db_row->[$primary_column];
} else {
$comparison = $secondary_db_row->[$secondary_column] cmp $next_db_row->[$primary_column];
}
}
if ($comparison < 0) {
# less than, get the next row from the secondary DB
$secondary_db_row = undef;
redo READ_DB_ROW;
} elsif ($comparison == 0) {
# This one was the same, keep looking at the others
} else {
# greater-than, there's no match for this primary DB row
return 0;
}
}
# All the joined columns compared equal, return the data
return $secondary_db_row;
}
};
Sub::Name::subname('UR::Context::__join_comparator(closure)__', $join_comparator);
push @addl_join_comparators, $join_comparator;
# And for the object importer/fabricator, here's where we need to shift the column order numbers
# over, because these closures will be called after all the db iterators' rows are concatenated
# together. We also need to make a copy of the loading_templates list so as to not mess up the
# class' notion of where the columns are
# FIXME - it seems wasteful that we need to re-created this each time. Look into some way of using
# the original copy that lives in $primary_template->{'loading_templates'}? Somewhere else?
my @secondary_loading_templates;
foreach my $tmpl ( @{$secondary_template->{'loading_templates'}} ) {
my %copy;
foreach my $key ( keys %$tmpl ) {
my $value_to_copy = $tmpl->{$key};
if (ref($value_to_copy) eq 'ARRAY') {
$copy{$key} = [ @$value_to_copy ];
} elsif (ref($value_to_copy) eq 'HASH') {
$copy{$key} = { %$value_to_copy };
} else {
$copy{$key} = $value_to_copy;
}
}
push @secondary_loading_templates, \%copy;
}
($column_position_offset,$object_num_offset) =
$self->_fixup_secondary_loading_template_column_positions($primary_template->{'loading_templates'},
\@secondary_loading_templates,
$column_position_offset,$object_num_offset);
#my($secondary_rule_template,@secondary_values) = $secondary_rule->get_template_and_values();
my @secondary_values = $secondary_rule->values();
foreach my $secondary_loading_template ( @secondary_loading_templates ) {
my $secondary_object_importer = UR::Context::ObjectFabricator->create_for_loading_template(
$self,
$secondary_loading_template,
$secondary_template,
$secondary_rule,
$secondary_rule_template,
\@secondary_values,
$secondary_data_source
);
next unless $secondary_object_importer;
push @secondary_object_importers, $secondary_object_importer;
}
}
return (\@secondary_object_importers, \@addl_join_comparators);
}
# This returns an iterator that is used to bring objects in from an underlying
# context into this context.
sub _create_import_iterator_for_underlying_context {
my ($self, $rule, $dsx, $this_get_serial) = @_;
# TODO: instead of taking a data source, resolve this internally.
# The underlying context itself should be responsible for its data sources.
# Make an iterator for the primary data source.
# Primary here meaning the one for the class we're explicitly requesting.
# We may need to join to other data sources to complete the query.
my ($db_iterator)
= $dsx->create_iterator_closure_for_rule($rule);
my ($rule_template, @values) = $rule->template_and_values();
my ($query_plan,@addl_loading_info) = $self->_resolve_query_plan_for_ds_and_bxt($dsx,$rule_template);
my $class_name = $query_plan->{class_name};
my $group_by = $rule_template->group_by;
my $order_by = $rule_template->order_by;
my $aggregate = $rule_template->aggregate;
my $limit = $rule_template->limit;
if (my $sub_typing_property) {
# When the rule has a property specified which indicates a specific sub-type, catch this and re-call
# this method recursively with the specific subclass name.
my ($rule_template, @values) = $rule->template_and_values();
my $rule_template_specifies_value_for_subtype = $query_plan->{rule_template_specifies_value_for_subtype};
my $class_table_name = $query_plan->{class_table_name};
warn "Implement me carefully";
if ($rule_template_specifies_value_for_subtype) {
my $sub_classification_meta_class_name = $query_plan->{sub_classification_meta_class_name};
my $value = $rule->value_for($sub_typing_property);
my $type_obj = $sub_classification_meta_class_name->get($value);
if ($type_obj) {
my $subclass_name = $type_obj->subclass_name($class_name);
if ($subclass_name and $subclass_name ne $class_name) {
#$rule = $subclass_name->define_boolexpr($rule->params_list, $sub_typing_property => $value);
$rule = UR::BoolExpr->resolve_normalized($subclass_name, $rule->params_list, $sub_typing_property => $value);
return $self->_create_import_iterator_for_underlying_context($rule,$dsx,$this_get_serial);
}
}
else {
die "No $value for $class_name?\n";
}
}
elsif (not $class_table_name) {
die "No longer supported!";
my $rule = UR::BoolExpr->resolve(
$class_name,
$rule_template->get_rule_for_values(@values)->params_list,
);
return $self->_create_import_iterator_for_underlying_context($rule,$dsx,$this_get_serial)
}
else {
# continue normally
# the logic below will handle sub-classifying each returned entity
}
}
my $loading_templates = $query_plan->{loading_templates};
my $sub_typing_property = $query_plan->{sub_typing_property};
my $next_db_row;
my $rows = 0; # number of rows the query returned
my $recursion_desc = $query_plan->{recursion_desc};
my($rule_template_without_recursion_desc, $rule_template_id_without_recursion);
my($rule_without_recursion_desc, $rule_id_without_recursion);
# These get set if you're doing a -recurse query, and the underlying data source doesn't support recursion
my($by_hand_recursive_rule_template,$by_hand_recursive_source_property,@by_hand_recursive_source_values,$by_hand_recursing_iterator);
if ($recursion_desc) {
$rule_template_without_recursion_desc = $query_plan->{rule_template_without_recursion_desc};
$rule_template_id_without_recursion = $rule_template_without_recursion_desc->id;
$rule_without_recursion_desc = $rule_template_without_recursion_desc->get_rule_for_values(@values);
$rule_id_without_recursion = $rule_without_recursion_desc->id;
if ($query_plan->{'recurse_resolution_by_iteration'}) {
# The data source does not support a recursive query. Accomplish the same thing by
# recursing back into _create_import_iterator_for_underlying_context for each level
my $this;
($this,$by_hand_recursive_source_property) = @$recursion_desc;
my @extra;
$by_hand_recursive_rule_template = UR::BoolExpr::Template->resolve($class_name, "$this in");
$by_hand_recursive_rule_template->recursion_desc($recursion_desc);
if (!$by_hand_recursive_rule_template or @extra) {
Carp::croak("Can't resolve recursive query: Class $class_name cannot filter by one or more properties: "
. join(', ', @extra));
}
}
}
my $rule_id = $rule->id;
my $rule_template_id = $rule_template->id;
my $needs_further_boolexpr_evaluation_after_loading = $query_plan->{'needs_further_boolexpr_evaluation_after_loading'};
my %subordinate_iterator_for_class;
# TODO: move the creation of the fabricators into the query plan object initializer.
# instead of making just one import iterator, we make one per loading template
# we then have our primary iterator use these to fabricate objects for each db row
my @object_fabricators;
if ($group_by) {
# returning sets for each sub-group instead of instance objects...
my $division_point = scalar(@$group_by)-1;
my $subset_template = $rule_template->_template_for_grouped_subsets();
my $set_class = $class_name . '::Set';
my @aggregate_properties = ($aggregate ? @$aggregate : ());
unshift(@aggregate_properties, 'count') unless (grep { $_ eq 'count' } @aggregate_properties);
my $fab_subref = sub {
my $row = $_[0];
my @group_values = @$row[0..$division_point];
my $ss_rule = $subset_template->get_rule_for_values(@values, @group_values);
my $set = $set_class->get($ss_rule->id);
unless ($set) {
Carp::croak("Failed to fabricate $set_class for rule $ss_rule");
}
my $aggregates = $set->{__aggregates} ||= {};
@$aggregates{@aggregate_properties} = @$row[$division_point+1..$#$row];
return $set;
};
my $object_fabricator = UR::Context::ObjectFabricator->_create(
fabricator => $fab_subref,
context => $self,
);
unshift @object_fabricators, $object_fabricator;
}
else {
# regular instances
for my $loading_template (@$loading_templates) {
my $object_fabricator =
UR::Context::ObjectFabricator->create_for_loading_template(
$self,
$loading_template,
$query_plan,
$rule,
$rule_template,
\@values,
$dsx,
);
next unless $object_fabricator;
unshift @object_fabricators, $object_fabricator;
}
}
# For joins across data sources, we need to create importers/fabricators for those
# classes, as well as callbacks used to perform the equivalent of an SQL join in
# UR-space
my @addl_join_comparators;
if (@addl_loading_info) {
if ($group_by) {
Carp::croak("cross-datasource group-by is not supported yet");
}
my($addl_object_fabricators, $addl_join_comparators) =
$self->_create_secondary_loading_closures( $query_plan,
$rule,
@addl_loading_info
);
unshift @object_fabricators, @$addl_object_fabricators;
push @addl_join_comparators, @$addl_join_comparators;
}
# To avoid calling the useless method 'fabricate' on a fabricator object for each object of each resultset row
my @object_fabricator_closures = map { $_->fabricator } @object_fabricators;
# Insert the key into all_objects_are_loaded to indicate that when we're done loading, we'll
# have everything
if ($query_plan->{'rule_matches_all'} and not $group_by) {
$class_name->all_objects_are_loaded(undef);
}
#my $is_monitor_query = $self->monitor_query();
# Make the iterator we'll return.
my $next_object_to_return;
my @object_ids_from_fabricators;
my $underlying_context_iterator = sub {
return undef unless $db_iterator;
my $primary_object_for_next_db_row;
LOAD_AN_OBJECT:
until (defined $primary_object_for_next_db_row) { # note that we return directly when the db is out of data
my ($next_db_row);
($next_db_row) = $db_iterator->() if ($db_iterator);
if (! $next_db_row and $by_hand_recursive_rule_template and @by_hand_recursive_source_values) {
# DB is out of results for this query, we need to handle recursion here in the context
# and there are values to recurse on
unless ($by_hand_recursing_iterator) {
# Do a new get() on the data source to recursively get more data
my $recurse_rule = $by_hand_recursive_rule_template->get_rule_for_values(\@by_hand_recursive_source_values);
$by_hand_recursing_iterator = $self->_create_import_iterator_for_underlying_context($recurse_rule,$dsx,$this_get_serial);
}
my $retval = $next_object_to_return;
$next_object_to_return = $by_hand_recursing_iterator->();
unless ($next_object_to_return) {
$by_hand_recursing_iterator = undef;
$by_hand_recursive_rule_template = undef;
}
return $retval;
}
unless ($next_db_row) {
$db_iterator = undef;
if ($rows == 0) {
# if we got no data at all from the sql then we give a status
# message about it and we update all_params_loaded to indicate
# that this set of parameters yielded 0 objects
my $rule_template_is_id_only = $query_plan->{rule_template_is_id_only};
if ($rule_template_is_id_only) {
my $id = $rule->value_for_id;
$UR::Context::all_objects_loaded->{$class_name}->{$id} = undef;
}
else {
$UR::Context::all_params_loaded->{$rule_template_id}->{$rule_id} = 0;
}
}
if ( $query_plan->{rule_matches_all} ) {
# No parameters. We loaded the whole class.
# Doing a load w/o a specific ID w/o custom SQL loads the whole class.
# Set a flag so that certain optimizations can be made, such as
# short-circuiting future loads of this class.
#
# If the key still exists in the all_objects_are_loaded hash, then
# we can set it to true. This is needed in the case where the user
# gets an iterator for all the objects of some class, but unloads
# one or more of the instances (be calling unload or through the
# cache pruner) before the iterator completes. If so, _abandon_object()
# will have removed the key from the hash
if (exists($UR::Context::all_objects_are_loaded->{$class_name})) {
$class_name->all_objects_are_loaded(1);
}
}
if ($recursion_desc) {
my @results = $class_name->is_loaded($rule_without_recursion_desc);
$UR::Context::all_params_loaded->{$rule_template_id_without_recursion}{$rule_id_without_recursion} = scalar(@results);
for my $object (@results) {
$object->{__load}->{$rule_template_id_without_recursion}->{$rule_id_without_recursion}++;
}
}
# Apply changes to all_params_loaded that each importer has collected
foreach (@object_fabricators) {
$_->finalize if $_;
}
# If the SQL for the subclassed items was constructed properly, then each
# of these iterators should be at the end, too. Call them one more time
# so they'll finalize their object fabricators.
foreach my $class ( keys %subordinate_iterator_for_class ) {
my $obj = $subordinate_iterator_for_class{$class}->();
if ($obj) {
# The last time this happened, it was because a get() was done on an abstract
# base class with only 'id' as a param. When the subclassified rule was
# turned into SQL in UR::DataSource::QueryPlan()
# it removed that one 'id' filter, since it assummed any class with more than
# one ID property (usually classes have a named whatever_id property, and an alias 'id'
# property) will have a rule that covered both ID properties
Carp::carp("Leftover objects in subordinate iterator for $class. This shouldn't happen, but it's not fatal...");
while ($obj = $subordinate_iterator_for_class{$class}->()) {1;}
}
}
my $retval = $next_object_to_return;
$next_object_to_return = undef;
return $retval;
}
# we count rows processed mainly for more concise sanity checking
$rows++;
# For multi-datasource queries, does this row successfully join with all the other datasources?
#
# Normally, the policy is for the data source query to return (possibly) more than what you
# asked for, and then we'd cache everything that may have been loaded. In this case, we're
# making the choice not to. Reason being that a join across databases is likely to involve
# a lot of objects, and we don't want to be stuffing our object cache with a lot of things
# we're not interested in. FIXME - in order for this to be true, then we could never query
# these secondary data sources against, say, a calculated property because we're never turning
# them into objects. FIXME - fix this by setting the $needs_further_boolexpr_evaluation_after_loading
# flag maybe?
my @secondary_data;
foreach my $callback (@addl_join_comparators) {
# FIXME - (no, not another one...) There's no mechanism for duplicating SQL join's
# behavior where if a row from a table joins to 2 rows in the secondary table, the
# first table's data will be in the result set twice.
my $secondary_db_row = $callback->($next_db_row);
unless (defined $secondary_db_row) {
# That data source has no more data, so there can be no more joins even if the
# primary data source has more data left to read
$db_iterator = undef;
$primary_object_for_next_db_row = undef;
last LOAD_AN_OBJECT;
}
unless ($secondary_db_row) {
# It returned 0
# didn't join (but there is still more data we can read later)... throw this row out.
$primary_object_for_next_db_row = undef;
redo LOAD_AN_OBJECT;
}
# $next_db_row is a read-only value from DBI, so we need to track our additional
# data seperately and smash them together before the object importer is called
push(@secondary_data, @$secondary_db_row);
}
# get one or more objects from this row of results
my $re_iterate = 0;
my @imported;
for (my $i = 0; $i < @object_fabricator_closures; $i++) {
my $object_fabricator = $object_fabricator_closures[$i];
# The usual case is that the query is just against one data source, and so the importer
# callback is just given the row returned from the DB query. For multiple data sources,
# we need to smash together the primary and all the secondary lists
my $imported_object;
#my $object_creation_time;
#if ($is_monitor_query) {
# $object_creation_time = Time::HiRes::time();
#}
if (@secondary_data) {
$imported_object = $object_fabricator->([@$next_db_row, @secondary_data]);
} else {
$imported_object = $object_fabricator->($next_db_row);
}
#if ($is_monitor_query) {
# $self->_log_query_for_rule($class_name, $rule, sprintf("QUERY: object fabricator took %.4f s",Time::HiRes::time() - $object_creation_time));
#}
if ($imported_object and not ref($imported_object)) {
# object requires sub-classsification in a way which involves different db data.
$re_iterate = 1;
}
push @imported, $imported_object;
# If the object ID for fabricator slot $i changes, then we can apply the
# all_params_loaded changes from iterators 0 .. $i-1 because we know we've
# loaded all the hangoff data related to the previous object
# remember that the last fabricator in the list is for the primary object
if (defined $imported_object and ref($imported_object)) {
if (!defined $object_ids_from_fabricators[$i]) {
$object_ids_from_fabricators[$i] = $imported_object->id;
} elsif ($object_ids_from_fabricators[$i] ne $imported_object->id) {
for (my $j = 0; $j < $i; $j++) {
$object_fabricators[$j]->apply_all_params_loaded;
}
$object_ids_from_fabricators[$i] = $imported_object->id;
}
}
}
$primary_object_for_next_db_row = $imported[-1];
# The object importer will return undef for an object if no object
# got created for that $next_db_row, and will return a string if the object
# needs to be subclassed before being returned. Don't put serial numbers on
# these
map { $_->{'__get_serial'} = $this_get_serial }
grep { defined && ref }
@imported;
if ($re_iterate and defined($primary_object_for_next_db_row) and ! ref($primary_object_for_next_db_row)) {
# It is possible that one or more objects go into subclasses which require more
# data than is on the results row. For each subclass (or set of subclasses),
# we make a more specific, subordinate iterator to delegate-to.
my $subclass_name = $primary_object_for_next_db_row;
my $subclass_meta = UR::Object::Type->get(class_name => $subclass_name);
my $table_subclass = $subclass_meta->most_specific_subclass_with_table();
my $sub_iterator = $subordinate_iterator_for_class{$table_subclass};
unless ($sub_iterator) {
#print "parallel iteration for loading $subclass_name under $class_name!\n";
my $sub_classified_rule_template = $rule_template->sub_classify($subclass_name);
my $sub_classified_rule = $sub_classified_rule_template->get_normalized_rule_for_values(@values);
$sub_iterator
= $subordinate_iterator_for_class{$table_subclass}
= $self->_create_import_iterator_for_underlying_context($sub_classified_rule,$dsx,$this_get_serial);
}
($primary_object_for_next_db_row) = $sub_iterator->();
if (! defined $primary_object_for_next_db_row) {
# the newly subclassed object
redo LOAD_AN_OBJECT;
}
} # end of handling a possible subordinate iterator delegate
unless (defined $primary_object_for_next_db_row) {
#if (!$primary_object_for_next_db_row or $rule->evaluate($primary_object_for_next_db_row)) {
redo LOAD_AN_OBJECT;
}
if ( !$group_by and (ref($primary_object_for_next_db_row) ne $class_name) and (not $primary_object_for_next_db_row->isa($class_name)) ) {
$primary_object_for_next_db_row = undef;
redo LOAD_AN_OBJECT;
}
if ($by_hand_recursive_source_property) {
my @values = grep { defined } $primary_object_for_next_db_row->$by_hand_recursive_source_property;
push @by_hand_recursive_source_values, @values;
}
if (! defined($next_object_to_return)
or (Scalar::Util::refaddr($next_object_to_return) == Scalar::Util::refaddr($primary_object_for_next_db_row))
) {
# The first time through the iterator, we need to buffer the object until
# $primary_object_for_next_db_row is something different.
$next_object_to_return = $primary_object_for_next_db_row;
$primary_object_for_next_db_row = undef;
redo LOAD_AN_OBJECT;
}
} # end of loop until we have a defined object to return
#foreach my $object_fabricator ( @object_fabricators ) {
# # Don't apply all_params_loaded for primary fab until it's all done
# next if ($object_fabricator eq $object_fabricators[-1]);
# $object_fabricator->apply_all_params_loaded;
#}
my $retval = $next_object_to_return;
$next_object_to_return = $primary_object_for_next_db_row;
return $retval;
};
Sub::Name::subname('UR::Context::__underlying_context_iterator(closure)__', $underlying_context_iterator);
return $underlying_context_iterator;
}
1;
LoadingIterator.pm 100664 023532 023421 72015 12544604516 20027 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/Context package UR::Context::LoadingIterator;
use strict;
use warnings;
use UR::Context;
our $VERSION = "0.44"; # UR $VERSION;
# A helper package for UR::Context to handling queries which require loading
# data from outside the current context. It is responsible for collating
# cached objects and incoming objects. When create_iterator() is used in
# application code, this is the iterator that gets returned
#
# These are normal Perl objects, not UR objects, so they get regular
# refcounting and scoping
our @CARP_NOT = qw( UR::Context );
# A boolean flag used in the loading iterator to control whether we need to
# inject loaded objects into other loading iterators' cached lists
my $is_multiple_loading_iterators = 0;
my %all_loading_iterators;
# The set of objects returned by an iterator is initially determined when the
# iterator is created, but the final determination of membership happens when
# the object is about to be returned from the iterator's next() method.
# In practice, this means that an object matches the BoolExpr at iterator
# creation, and no longer matches when that object is about to be returned,
# it will not be returned.
#
# If an object does not match the bx when the iterator is created, it will
# not be returned even if it later changes to match before the iterator is
# exhausted.
#
# If an object changes so that it's sort order changes after the iterator is
# created but before it is returned by the iterator, the object will be
# returned in the order it had at iterator creation time.
# Finally, the LoadingIterator will throw an exception if an object matches
# the BoolExpr at iterator creation time, but is deleted when next() is about
# to return it (ie. isa UR::DeletedRef). Since DeletedRef's die any time you
# try to use them, the object sorters can't sort them. Instead, we'll just
# punt and throw an exception ourselves if we come across one.
#
# This seems like the least suprising thing to do, but there are other solutions:
# 1) just plain don't return the deleted object
# 2) use signal_change to register a callback which will remove objects being deleted
# from all the in-process iterator @$cached lists (accomplishes the same as #1).
# For completeness, this may imply that other signal_change callbacks would remove
# objects that no longer match rules for in-process iterators, and that means that
# next() returns things true at the time next() is called, not when the iterator
# is created.
# 3) Put in some additional infrastructure so we can pull out the ID of a deleted
# object. That lets us call $next_object->id at the end of the closure, and return these
# deleted objects back to the user. Problem being that the user then can't really
# do anything with them. But it would be consistent about returning _all_ objects
# that matched the rule at iterator creation time
# 4) Like #3, but just always return the deleted object before any underlying_context
# object, and then don't try to get its ID at the end if the iterator if it's deleted
sub _create {
my($class, $cached, $context, $normalized_rule, $data_source, $this_get_serial ) = @_;
my $underlying_context_iterator = $context->_create_import_iterator_for_underlying_context(
$normalized_rule, $data_source, $this_get_serial);
my $is_monitor_query = $context->monitor_query;
# These are captured by the closure...
my($last_loaded_id, $next_obj_current_context, $next_obj_underlying_context);
my $object_sorter = $normalized_rule->template->sorter();
my $bx_subject_class = $normalized_rule->subject_class_name;
# Collection of object IDs that were read from the DB query. These objects are for-sure
# not deleted, even though a cached object for it might have been turned into a ghost or
# had its properties changed
my %db_seen_ids_that_are_not_deleted;
# Collection of object IDs that were read from the cached object list and haven't been
# seen in the lsit of results from the database (yet). It could be missing from the DB
# results because that row has been deleted, because the DB row still exists but has been
# changed since we loaded it and now doesn't match the BoolExp, or because we're sorting
# results by something other than just ID, that sorted property has been changed in the DB
# and we haven't come across this row yet but will before.
#
# The short story is that if there is anything in this hash when the underlying context iterator
# is exhausted, then the ID-ed object is really deleted, and should be an exception
my %changed_objects_that_might_be_db_deleted;
my $underlying_context_objects_count = 0;
my $cached_objects_count = 0;
# knowing if an object's changed properties are one of the rule's order-by
# properties helps later on in the loading process of detecting deleted DB rows
my %order_by_properties;
if ($normalized_rule->template->order_by) {
%order_by_properties = map { $_ => 1 } @{ $normalized_rule->template->order_by };
}
my $change_is_order_by_property = sub {
foreach my $prop_name ( shift->_changed_property_names ) {
return 1 if exists($order_by_properties{$prop_name});
}
return;
};
my %bx_filter_properties = map { $_ => 1 } $normalized_rule->template->_property_names;
my $change_is_bx_filter_property = sub {
foreach my $prop_name ( shift->_changed_property_names ) {
return 1 if exists($bx_filter_properties{$prop_name});
}
return;
};
my $limit = $normalized_rule->template->limit;
my $offset = $normalized_rule->template->offset;
my $me_loading_iterator_as_string; # See note below the closure definition
my $loading_iterator = sub {
return if (defined($limit) and !$limit);
my $next_object;
PICK_NEXT_OBJECT_FOR_LOADING:
while (! defined($next_object)) {
if ($underlying_context_iterator && ! defined($next_obj_underlying_context)) {
($next_obj_underlying_context) = $underlying_context_iterator->(1);
$underlying_context_objects_count++ if ($is_monitor_query and defined($next_obj_underlying_context));
if (defined($next_obj_underlying_context)) {
if ($next_obj_underlying_context->isa('UR::DeletedRef')) {
# This object is deleted in the current context and not yet committed
# skip it and pick again
$next_obj_underlying_context = undef;
redo PICK_NEXT_OBJECT_FOR_LOADING;
} elsif ($next_obj_underlying_context->__changes__
and
$change_is_order_by_property->($next_obj_underlying_context)
) {
unless (delete $changed_objects_that_might_be_db_deleted{$next_obj_underlying_context->id}) {
$db_seen_ids_that_are_not_deleted{$next_obj_underlying_context->id} = 1;
}
$next_obj_underlying_context = undef;
redo PICK_NEXT_OBJECT_FOR_LOADING;
}
}
}
unless (defined $next_obj_current_context) {
($next_obj_current_context) = shift @$cached;
$cached_objects_count++ if ($is_monitor_query and $next_obj_current_context);
}
if (defined($next_obj_current_context) and $next_obj_current_context->isa('UR::DeletedRef')) {
my $obj_to_complain_about = $next_obj_current_context;
# undef it in case the user traps the exception, next time we'll pull another off the list
$next_obj_current_context = undef;
Carp::croak("Attempt to fetch an object which matched $normalized_rule when the iterator was created, "
. "but was deleted in the meantime:\n"
. Data::Dumper::Dumper($obj_to_complain_about) );
}
if (!defined($next_obj_underlying_context)) {
if ($is_monitor_query) {
$context->_log_query_for_rule($bx_subject_class,
$normalized_rule,
"QUERY: loaded $underlying_context_objects_count object(s) total from underlying context.");
}
$underlying_context_iterator = undef;
# Anything left in this hash when the DB iterator is exhausted are object we expected to
# see by now and must be deleted. If any of these object have changes then
# the __merge below will throw an exception
foreach my $problem_obj (values(%changed_objects_that_might_be_db_deleted)) {
$context->__merge_db_data_with_existing_object($bx_subject_class, $problem_obj, undef, []);
}
}
elsif (defined($last_loaded_id)
and
$last_loaded_id eq $next_obj_underlying_context->id)
{
# during a get() with -hints or is_many+is_optional (ie. something with an
# outer join), it's possible that the join can produce the same main object
# as it's chewing through the (possibly) multiple objects joined to it.
# Since the objects will be returned sorted by their IDs, we only have to
# remember the last one we saw
# FIXME - is this still true now that the underlying context iterator and/or
# object fabricator hold off on returning any objects until all the related
# joined data bas been loaded?
$next_obj_underlying_context = undef;
redo PICK_NEXT_OBJECT_FOR_LOADING;
}
# decide which pending object to return next
# both the cached list and the list from the database are sorted separately but with
# equivalent algorithms (we hope).
#
# we're collating these into one return stream here
my $comparison_result = undef;
if (defined($next_obj_underlying_context) && defined($next_obj_current_context)) {
$comparison_result = $object_sorter->($next_obj_underlying_context, $next_obj_current_context);
}
my $next_obj_underlying_context_id;
$next_obj_underlying_context_id = $next_obj_underlying_context->id if (defined $next_obj_underlying_context);
my $next_obj_current_context_id;
$next_obj_current_context_id = $next_obj_current_context->id if (defined $next_obj_current_context);
# This if() section is for when the in-memory and DB iterators return the same
# object at the same time.
if (
defined($next_obj_underlying_context)
and defined($next_obj_current_context)
and $comparison_result == 0 # $next_obj_underlying_context->id eq $next_obj_current_context->id
) {
# Both objects sort the same. Since the ID properties are always last in the sort order list,
# this means both objects must be the same object.
$context->_log_query_for_rule($bx_subject_class, $normalized_rule, "QUERY: loaded object was already cached") if ($is_monitor_query);
$next_object = $next_obj_current_context;
$next_obj_current_context = undef;
$next_obj_underlying_context = undef;
}
# This if() section is for when the DB iterator's object sorts first
elsif (
defined($next_obj_underlying_context)
and (
(!defined($next_obj_current_context))
or
($comparison_result < 0) # ($next_obj_underlying_context->id le $next_obj_current_context->id)
)
) {
# db object sorts first
# If we deleted it from memorym the DB would not have given it back.
# So it either failed to match the BX now, or one of the order-by parameters changed
if ($next_obj_underlying_context->__changes__) {
# See if one of the changes is an order-by property
if ($change_is_order_by_property->($next_obj_underlying_context)) {
# If the object has changes, and one of the changes is one of the
# order-by properties, then the object will:
# 1) Already have appeared as $next_obj_current_context.
# it will be in $changed_objects_that_might_be_db_deleted - remove it from that list
# 2) Will appear later as $next_obj_current_context.
# Mark here that it's not deleted
unless (delete $changed_objects_that_might_be_db_deleted{$next_obj_underlying_context_id}) {
$db_seen_ids_that_are_not_deleted{$next_obj_underlying_context_id} = 1;
}
} elsif ($change_is_bx_filter_property->($next_obj_underlying_context)) {
# If the object has any changes, then it will appear in the cached object list in
# $next_object_current_context at the appropriate time. For the case where the
# object no longer matches the BoolExpr, then the appropriate time is never.
# Discard this object from the DB and pick again
$next_obj_underlying_context = undef;
redo PICK_NEXT_OBJECT_FOR_LOADING;
} else {
# some other kind of change?
$next_object = $next_obj_underlying_context;
$next_obj_underlying_context = undef;
next PICK_NEXT_OBJECT_FOR_LOADING;
}
} else {
# If the object has no changes, it must be something newly brought into the system.
$next_object = $next_obj_underlying_context;
$next_obj_underlying_context = undef;
next PICK_NEXT_OBJECT_FOR_LOADING;
}
}
# This if() section is for when the in-memory iterator's object sorts first
elsif (
defined($next_obj_current_context)
and (
(!defined($next_obj_underlying_context))
or
($comparison_result > 0) # ($next_obj_underlying_context->id ge $next_obj_current_context->id)
)
) {
# The cached object sorts first
# Either it was changed in memory, in the DB or both
# In addition, the change could have been to an order-by property, one of the
# properties in the BoolExpr, or both
if (! $next_obj_current_context->isa('UR::Object::Set') # Sets aren't really from the underlying context
and
$context->object_exists_in_underlying_context($next_obj_current_context)
) {
if ($next_obj_current_context->__changes__) {
if ($change_is_order_by_property->($next_obj_current_context)) {
# This object is expected to exist in the underlying context, has changes, and at
# least one of those changes is to an order-by property
#
# if it's in %db_seen_ids_that_are_not_deleted, then it was seen earlier
# from the DB, and can now be removed from that hash.
unless (delete $db_seen_ids_that_are_not_deleted{$next_obj_current_context_id}) {
# If not in that list, then add it to the list of things we might see later
# in the DB iterator. If we don't see it by the end if the iterator, it
# must have been deleted from the DB. At that time, we'll throw an exception.
# It's later than we'd like, since the caller has already gotten ahold of the
# object, but better late than never. The alternative is to do an id-only
# query right now, but that would be inefficient.
#
# We could avoid storing this if we could verify that the db_committed/db_saved_uncommitted
# values did NOT match the BoolExpr, but this will suffice for now.
$changed_objects_that_might_be_db_deleted{$next_obj_current_context_id} = $next_obj_current_context;
}
# In any case, return the cached object.
$next_object = $next_obj_current_context;
$next_obj_current_context = undef;
next PICK_NEXT_OBJECT_FOR_LOADING;
}
elsif ($change_is_bx_filter_property->($next_obj_current_context)) {
# The change was that the object originally did not the filter, but since being
# loaded it's been changed so it now matches the filter. The DB iterator isn't
# returning the object since the DB's copy doesn't match the filter.
delete $db_seen_ids_that_are_not_deleted{$next_obj_current_context_id};
$next_object = $next_obj_current_context;
$next_obj_current_context = undef;
next PICK_NEXT_OBJECT_FOR_LOADING;
}
else {
# The change is not an order-by property. This object must have been deleted
# from the DB. The call to __merge below will throw an exception
$context->__merge_db_data_with_existing_object($bx_subject_class, $next_obj_current_context, undef, []);
$next_obj_current_context = undef;
redo PICK_NEXT_OBJECT_FOR_LOADING;
}
} else {
# This cached object has no changes, so the database must have changed.
# It could be deleted, no longer match the BoolExpr, or have changes in an order-by property
if (delete $db_seen_ids_that_are_not_deleted{$next_obj_current_context_id}) {
# We saw this already on the DB iterator. It's not deleted. Go ahead and return it
$next_object = $next_obj_current_context;
$next_obj_current_context = undef;
next PICK_NEXT_OBJECT_FOR_LOADING;
}
elsif ($normalized_rule->is_id_only) {
# If the query is id-only, and we didn't see the DB object at the same time, then
# the DB row must have been deleted. Changing the PK columns in the DB are logically
# the same as deleting the old object and creating/defineing a new one in UR.
#
# The __merge will delete the cached object, then pick again
$context->__merge_db_data_with_existing_object($bx_subject_class, $next_obj_current_context, undef, []);
$next_obj_current_context = undef;
redo PICK_NEXT_OBJECT_FOR_LOADING;
} else {
# Force an ID-only query to the underying context
my $requery_obj = $context->reload($bx_subject_class, id => $next_obj_current_context_id);
if ($requery_obj) {
# In any case, the DB iterator will pull it up at the appropriate time,
# and since the object has no changes, it will be returned to the caller then.
# Discard this in-memory object and pick again
$next_obj_current_context = undef;
redo PICK_NEXT_OBJECT_FOR_LOADING;
} else {
# We've now confirmed that the object in the DB is really gone
# NOTE: the reload() has already performed the __merge (implying deletion)
# in the above branch "elsif ($normalized_rule->is_id_only)" so we don't need
# to __merge/delete it here
$next_obj_current_context = undef;
redo PICK_NEXT_OBJECT_FOR_LOADING;
}
}
}
} else {
# The object does not exist in the underlying context. It must be
# a newly created object.
$next_object = $next_obj_current_context;
$next_obj_current_context = undef;
next PICK_NEXT_OBJECT_FOR_LOADING;
}
} elsif (!defined($next_obj_current_context)
and
!defined($next_obj_underlying_context)
) {
# Both iterators are exhausted. Bail out
$next_object = undef;
$last_loaded_id = undef;
last PICK_NEXT_OBJECT_FOR_LOADING;
} else {
# Couldn't decide which to pick next? Something has gone horribly wrong.
# We're using other vars to hold the objects and setting
# $next_obj_current_context/$next_obj_underlying_context to undef so if
# the caller is trapping exceptions, this iterator will pick new objects next time
my $current_problem_obj = $next_obj_current_context;
my $underlying_problem_obj = $next_obj_underlying_context;
$next_obj_current_context = undef;
$next_obj_underlying_context = undef;
$next_object = undef;
Carp::croak("Loading iterator internal error. Could not pick a next object for loading.\n"
. "Next object underlying context: " . Data::Dumper::Dumper($underlying_problem_obj)
. "\nNext object current context: ". Data::Dumper::Dumper($current_problem_obj));
}
return unless defined $next_object;
# end while ! $next_object
} continue {
if (defined($next_object) and defined($offset) and $offset) {
$offset--;
$next_object = undef;
}
}
$last_loaded_id = $next_object->id if (defined $next_object);
$limit-- if defined $limit;
return $next_object;
}; # end of the closure
bless $loading_iterator, $class;
Sub::Name::subname($class . '__loading_iterator_closure__', $loading_iterator);
# Inside the closure, it needs to know its own address, but without holding a real reference
# to itself - otherwise the closure would never go out of scope, the destructor would never
# get called, and the list of outstanding loaders would never get pruned. This way, the closure
# holds a reference to the string version of its address, which is the only thing it really
# needed anyway
$me_loading_iterator_as_string = $loading_iterator . '';
$all_loading_iterators{$me_loading_iterator_as_string} =
[ $me_loading_iterator_as_string,
$normalized_rule,
$object_sorter,
$cached,
\$underlying_context_objects_count,
\$cached_objects_count,
$context,
];
$is_multiple_loading_iterators = 1 if (keys(%all_loading_iterators) > 1);
return $loading_iterator;
} # end _create()
sub DESTROY {
my $self = shift;
my $iter_data = $all_loading_iterators{$self};
if ($iter_data->[0] eq $self) {
# that's me!
# Items in the listref are: $loading_iterator_string, $rule, $object_sorter, $cached,
# \$underlying_context_objects_count, \$cached_objects_count, $context
my $context = $iter_data->[6];
if ($context and $context->monitor_query) {
my $rule = $iter_data->[1];
my $count = ${$iter_data->[4]} + ${$iter_data->[5]};
$context->_log_query_for_rule($rule->subject_class_name, $rule, "QUERY: Query complete after returning $count object(s) for rule $rule.");
$context->_log_done_elapsed_time_for_rule($rule);
}
delete $all_loading_iterators{$self};
$is_multiple_loading_iterators = 0 if (keys(%all_loading_iterators) < 2);
} else {
Carp::carp('A loading iterator went out of scope, but could not be found in the registered list of iterators');
}
}
# Used by the loading itertor to inject a newly loaded object into another
# loading iterator's @$cached list. This is to handle the case where the user creates
# an iterator which will load objects from the DB. Before all the data from that
# iterator is read, another get() or iterator is created that covers (some of) the same
# objects which get pulled into the object cache, and the second request is run to
# completion. Since the underlying context iterator has been changed to never return
# objects currently cached, the first iterator would have incorrectly skipped ome objects that
# were not loaded when the first iterator was created, but later got loaded by the second.
sub _inject_object_into_other_loading_iterators {
my($self, $new_object, $iterator_to_skip) = @_;
ITERATOR:
foreach my $iter_name ( keys %all_loading_iterators ) {
next if $iter_name eq $iterator_to_skip; # That's me! Don't insert into our own @$cached this way
my($loading_iterator, $rule, $object_sorter, $cached)
= @{$all_loading_iterators{$iter_name}};
if ($rule->evaluate($new_object)) {
my $cached_list_len = @$cached;
for(my $i = 0; $i < $cached_list_len; $i++) {
my $cached_object = $cached->[$i];
next if $cached_object->isa('UR::DeletedRef');
my $comparison = $object_sorter->($new_object, $cached_object);
if ($comparison < 0) {
# The new object sorts sooner than this one. Insert it into the list
splice(@$cached, $i, 0, $new_object);
next ITERATOR;
} elsif ($comparison == 0) {
# This object is already in the list
next ITERATOR;
}
}
# It must go at the end...
push @$cached, $new_object;
}
} # end foreach
}
# Reverse of _inject_object_into_other_loading_iterators(). Used when one iterator detects that
# a previously loaded object no longer exists in the underlying context/datasource
sub _remove_object_from_other_loading_iterators {
my($self, $disappearing_object, $iterator_to_skip) = @_;
ITERATOR:
foreach my $iter_name ( keys %all_loading_iterators ) {
next if(! defined $iterator_to_skip or ($iter_name eq $iterator_to_skip)); # That's me! Don't remove into our own @$cached this way
my($loading_iterator, $rule, $object_sorter, $cached)
= @{$all_loading_iterators{$iter_name}};
next if (defined($iterator_to_skip)
and $loading_iterator eq $iterator_to_skip); # That's me! Don't insert into our own @$cached this way
if ($rule->evaluate($disappearing_object)) {
my $cached_list_len = @$cached;
for(my $i = 0; $i < $cached_list_len; $i++) {
my $cached_object = $cached->[$i];
next if $cached_object->isa('UR::DeletedRef');
my $comparison = $object_sorter->($disappearing_object, $cached_object);
if ($comparison == 0) {
# That's the one, remove it from the list
splice(@$cached, $i, 1);
next ITERATOR;
} elsif ($comparison < 0) {
# past the point where we expect to find this object
next ITERATOR;
}
}
}
} # end foreach
}
# Returns true if any of the object's changed properites are keys
# in the passed-in hashref. Used by the Loading Iterator to find out if
# a change is one of the order-by properties of a bx
sub _changed_property_in_hash {
my($self,$object,$hash) = @_;
foreach my $prop_name ( $object->_changed_property_names ) {
return 1 if (exists $hash->{$prop_name});
}
return;
}
1;
ObjectFabricator.pm 100664 023532 023421 154757 12544604516 20201 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/Context package UR::Context::ObjectFabricator;
use strict;
use warnings;
use Scalar::Util;
use UR::Context;
our $VERSION = "0.44"; # UR $VERSION;
# A helper package for UR::Context to keep track of the subrefs used
# to create objects from database data
# These are normal Perl objects, not UR objects, so they get
# regular refcounting and scoping
our @CARP_NOT = qw( UR::Context );
my %all_object_fabricators;
sub _create {
my $class = shift;
my %params = @_;
unless ($params{'fabricator'} and ref($params{'fabricator'}) eq 'CODE') {
Carp::croak("UR::Context::ObjectFabricator::create requires a subroutine ref for the 'fabricator' parameter");
}
unless ($params{'context'} and ref($params{'context'}) and $params{'context'}->isa('UR::Context')) {
Carp::croak("UR::Context::ObjectFabricator::create requires a UR::Context object for the 'context' parameter");
}
my $self = bless {}, $class;
$self->{'fabricator'} = $params{'fabricator'};
$self->{'context'} = $params{'context'};
$self->{'all_params_loaded'} = $params{'all_params_loaded'} || {};
$self->{'in_clause_values'} = $params{'in_clause_values'} || {};
$all_object_fabricators{$self} = $self;
Scalar::Util::weaken($all_object_fabricators{$self});
return $self;
}
sub create_for_loading_template {
my($fab_class, $context, $loading_template, $query_plan, $rule, $rule_template, $values, $dsx) = @_;
my @values = @$values;
my $class_name = $loading_template->{final_class_name};
#$class_name or Carp::croak("No final_class_name in loading template?");
unless ($class_name) {
#Carp::carp("No final_class_name in loading template for rule $rule");
return; # This join doesn't result in an object? - i think this happens when you do a get() with -hints
}
my $class_meta = $class_name->__meta__;
my $class_data = $dsx->_get_class_data_for_loading($class_meta);
my $class = $class_name;
my $ghost_class = $class_data->{ghost_class};
my $sub_classification_meta_class_name = $class_data->{sub_classification_meta_class_name};
my $subclassify_by = $class_data->{subclassify_by};
my $sub_classification_method_name = $class_data->{sub_classification_method_name};
# FIXME, right now, we don't have a rule template for joined entities...
my $rule_template_id = $query_plan->{rule_template_id};
my $rule_template_without_recursion_desc = $query_plan->{rule_template_without_recursion_desc};
my $rule_template_id_without_recursion_desc = $query_plan->{rule_template_id_without_recursion_desc};
my $rule_matches_all = $query_plan->{rule_matches_all};
my $rule_template_is_id_only = $query_plan->{rule_template_is_id_only};
my $rule_specifies_id = $query_plan->{rule_specifies_id};
my $rule_template_specifies_value_for_subtype = $query_plan->{rule_template_specifies_value_for_subtype};
my $recursion_desc = $query_plan->{recursion_desc};
my $recurse_property_on_this_row = $query_plan->{recurse_property_on_this_row};
my $recurse_property_referencing_other_rows = $query_plan->{recurse_property_referencing_other_rows};
my $needs_further_boolexpr_evaluation_after_loading = $query_plan->{'needs_further_boolexpr_evaluation_after_loading'};
my $rule_id = $rule->id;
my $rule_without_recursion_desc = $rule_template_without_recursion_desc->get_rule_for_values(@values);
my $loading_base_object;
if ($loading_template == $query_plan->{loading_templates}[0]) {
$loading_base_object = 1;
}
else {
$loading_base_object = 0;
$needs_further_boolexpr_evaluation_after_loading = 0;
}
my %subclass_is_safe_for_re_bless;
my %subclass_for_subtype_name;
my %recurse_property_value_found;
my @property_names = @{ $loading_template->{property_names} };
my @id_property_names = @{ $loading_template->{id_property_names} };
my @column_positions = @{ $loading_template->{column_positions} };
my @id_positions = @{ $loading_template->{id_column_positions} };
my $multi_column_id = (@id_positions > 1 ? 1 : 0);
my $composite_id_resolver = $class_meta->get_composite_id_resolver;
# The old way of specifying that some values were constant for all objects returned
# by a get(). The data source would wrap the method that builds the loading template
# and wedge in some constant_property_names. The new way is to add columns to the
# loading template, and then add the values onto the list returned by the data source
# iterator.
my %initial_object_data;
if ($loading_template->{constant_property_names}) {
my @constant_property_names = @{ $loading_template->{constant_property_names} };
my @constant_property_values = map { $rule->value_for($_) } @constant_property_names;
@initial_object_data{@constant_property_names} = @constant_property_values;
}
my $rule_class_name = $rule_template->subject_class_name;
my $template_id = $rule_template->id;
my $load_class_name = $class;
# $rule can contain params that may not apply to the subclass that's currently loading.
# define_boolexpr() in array context will return the portion of the rule that actually applies
#my($load_rule, undef) = $load_class_name->define_boolexpr($rule->params_list);
my($load_rule, @extra_params) = UR::BoolExpr->resolve($load_class_name, $rule->params_list);
my $load_rule_id = $load_rule->id;
my $load_template_id = $load_rule->template_id;
my @rule_properties_with_in_clauses =
grep { $rule_template_without_recursion_desc->operator_for($_) eq 'in' }
$rule_template_without_recursion_desc->_property_names;
my($rule_template_without_in_clause,$rule_template_id_without_in_clause,%in_clause_values,@all_rule_property_names);
my $do_record_in_all_params_loaded = 1;
if (@rule_properties_with_in_clauses) {
$rule_template_id_without_in_clause = $rule_template_without_recursion_desc->id;
foreach my $property_name ( @rule_properties_with_in_clauses ) {
# FIXME - removing and re-adding the filter should have the same effect as the substitute below,
# but the two result in different rules in the end.
#$rule_template_without_in_clause = $rule_template_without_in_clause->remove_filter($property_name);
#$rule_template_without_in_clause = $rule_template_without_in_clause->add_filter($property_name);
$rule_template_id_without_in_clause =~ s/($property_name) in/$1/;
}
$rule_template_without_in_clause = UR::BoolExpr::Template->get($rule_template_id_without_in_clause);
# Make a note of all the values in the in-clauses. As the objects get returned from the
# data source, we'll remove these notes. Anything that's left by the time the iterator is
# finalized must be values that matched nothing. Then, finalize can put data in
# all_params_loaded showing it matches nothing
my %rule_properties_with_in_clauses = map { $_ => 1 } @rule_properties_with_in_clauses;
@all_rule_property_names = $rule_template_without_in_clause->_property_names;
foreach my $property ( @rule_properties_with_in_clauses ) {
my $values_for_in_clause = $rule_without_recursion_desc->value_for($property);
unless ($values_for_in_clause) {
Carp::confess("rule has no value for property $property: $rule_without_recursion_desc");
}
if (@$values_for_in_clause > 100) {
$do_record_in_all_params_loaded = 0;
next;
}
my @other_values = map { exists $rule_properties_with_in_clauses{$_}
? undef # placeholder filled in below
: $rule_without_recursion_desc->value_for($_) }
$rule_template_without_in_clause->_property_names;
my $position_for_this_property = $rule_template_without_in_clause->value_position_for_property_name($property);
# If the number of items in the in-clause is over this number, then don't bother recording
# the template-id/rule-id, since searching the list to see if this query has been done before
# is going to take longer than just re-doing the query
foreach my $value ( @$values_for_in_clause ) {
$value = '' if (!defined $value);
$other_values[$position_for_this_property] = $value;
my $rule_with_this_in_property = $rule_template_without_in_clause->get_rule_for_values(@other_values);
$in_clause_values{$property}->{$value}
= [$rule_template_id_without_in_clause, $rule_with_this_in_property->id];
}
}
}
# This is a local copy of what we want to put in all_params_loaded, when the object fabricator is
# finalized
my $local_all_params_loaded = {};
my($hints_or_delegation,$delegations_with_no_objects);
if (!$loading_base_object) {
($hints_or_delegation,$delegations_with_no_objects)
= $fab_class->_resolve_delegation_data($rule,$loading_template,$query_plan,$local_all_params_loaded);
}
my $update_apl_for_loaded_object = sub {
my $pending_db_object = shift;
# Make a note in all_params_loaded (essentially, the query cache) that we've made a
# match on this rule, and some equivalent rules
if ($loading_base_object and not $rule_specifies_id) {
if ($do_record_in_all_params_loaded) {
if ($rule_class_name ne $load_class_name and scalar(@extra_params) == 0) {
$pending_db_object->{__load}->{$load_template_id}{$load_rule_id}++;
$UR::Context::all_params_loaded->{$load_template_id}{$load_rule_id} = undef;
$local_all_params_loaded->{$load_template_id}{$load_rule_id}++;
}
$pending_db_object->{__load}->{$template_id}{$rule_id}++;
$UR::Context::all_params_loaded->{$template_id}{$rule_id} = undef;
$local_all_params_loaded->{$template_id}{$rule_id}++;
}
if (@rule_properties_with_in_clauses) {
# FIXME - confirm that all the object properties are filled in at this point, right?
#my @values = @$pending_db_object{@rule_properties_with_in_clauses};
my @values = @$pending_db_object{@all_rule_property_names};
my $r = $rule_template_without_in_clause->get_normalized_rule_for_values(@values);
my $r_id = $r->id;
$UR::Context::all_params_loaded->{$rule_template_id_without_in_clause}{$r_id} = undef;
$local_all_params_loaded->{$rule_template_id_without_in_clause}{$r_id}++;
# remove the notes about these in-clause values since they matched something
no warnings; # undef treated as an empty string below
foreach my $property (@rule_properties_with_in_clauses) {
my $value = $pending_db_object->{$property};
delete $in_clause_values{$property}->{$value};
}
}
}
};
my $fabricator_obj; # filled in after the closure definition
my $object_fabricator = sub {
my $next_db_row = $_[0];
# If all the columns for this object are undef, then this doesn't encode an actual
# object, it's a result of a left join that matched nothing
my $values_exist;
foreach my $column ( @column_positions ) {
if (defined($next_db_row->[$column])) {
$values_exist = 1;
last;
}
}
if (!$loading_base_object and !$values_exist and $delegations_with_no_objects) {
my $templates_and_rules = $fab_class->_lapl_data_for_delegation_data($delegations_with_no_objects, $next_db_row);
while ( my($template_id, $rule_id) = each %$templates_and_rules) {
$local_all_params_loaded->{$template_id}->{$rule_id} = 0;
$UR::Context::all_params_loaded->{$template_id}->{$rule_id} = 0;
}
return;
}
my $pending_db_object_data = { %initial_object_data };
@$pending_db_object_data{@property_names} = @$next_db_row[@column_positions];
# resolve id
my $pending_db_object_id;
if ($multi_column_id) {
$pending_db_object_id = $composite_id_resolver->(@$pending_db_object_data{@id_property_names})
}
else {
$pending_db_object_id = $pending_db_object_data->{$id_property_names[0]};
}
unless (defined $pending_db_object_id) {
return undef;
Carp::confess(
"no id found in object data for $class_name?\n"
. Data::Dumper::Dumper($pending_db_object_data)
);
}
my $pending_db_object;
# skip if this object has been deleted but not committed
do {
no warnings;
if ($UR::Context::all_objects_loaded->{$ghost_class}{$pending_db_object_id}) {
return;
#$pending_db_object = undef;
#redo;
}
};
# Handle the object based-on whether it is already loaded in the current context.
if ($pending_db_object = $UR::Context::all_objects_loaded->{$class}{$pending_db_object_id}) {
$context->__merge_db_data_with_existing_object($class, $pending_db_object, $pending_db_object_data, \@property_names);
if ($loading_base_object
and
$needs_further_boolexpr_evaluation_after_loading
and
not $rule->evaluate($pending_db_object)
) {
return;
}
$update_apl_for_loaded_object->($pending_db_object);
}
else {
# Handle the case in which the object is completely new in the current context.
# Create a new object for the resultset row
$pending_db_object = bless { %$pending_db_object_data, id => $pending_db_object_id }, $class;
$pending_db_object->{db_committed} = $pending_db_object_data;
# determine the subclass name for classes which automatically sub-classify
my $subclass_name;
if (
(
$sub_classification_method_name
or $subclassify_by
or $sub_classification_meta_class_name
)
and
(ref($pending_db_object) eq $class) # not already subclased
) {
if ($sub_classification_method_name) {
$subclass_name = $class->$sub_classification_method_name($pending_db_object);
unless ($subclass_name) {
my $pending_obj_id = eval { $pending_db_object->id };
Carp::confess(
"Object with id '$pending_obj_id' loaded as abstract class $class failed to subclassify itself using method "
. $sub_classification_method_name
);
}
}
elsif ($sub_classification_meta_class_name) {
# Group objects requiring reclassification by type,
# and catch anything which doesn't need reclassification.
my $subtype_name = $pending_db_object->$subclassify_by;
$subclass_name = $subclass_for_subtype_name{$subtype_name};
unless ($subclass_name) {
my $type_obj = $sub_classification_meta_class_name->get($subtype_name);
unless ($type_obj) {
# The base type may give the final subclass, or an intermediate
# either choice has trade-offs, but we support both.
# If an intermediate subclass is specified, that subclass
# will join to a table with another field to indicate additional
# subclassing. This means we have to do this part the hard way.
# TODO: handle more than one level.
my @all_type_objects = $sub_classification_meta_class_name->get();
for my $some_type_obj (@all_type_objects) {
my $some_subclass_name = $some_type_obj->subclass_name($class);
unless (UR::Object::Type->get($some_subclass_name)->is_abstract) {
next;
}
my $some_subclass_meta = $some_subclass_name->__meta__;
my $some_subclass_type_class =
$some_subclass_meta->sub_classification_meta_class_name;
if ($type_obj = $some_subclass_type_class->get($subtype_name)) {
# this second-tier subclass works
last;
}
else {
# try another subclass, and check the subclasses under it
#print "skipping $some_subclass_name: no $subtype_name for $some_subclass_type_class\n";
}
}
}
if ($type_obj) {
$subclass_name = $type_obj->subclass_name($class);
}
else {
warn "Failed to find $class_name sub-class for type '$subtype_name'!";
$subclass_name = $class_name;
}
unless ($subclass_name) {
Carp::confess(
"Failed to sub-classify $class using "
. $type_obj->class
. " '" . $type_obj->id . "'"
);
}
$subclass_name->class;
}
$subclass_for_subtype_name{$subtype_name} = $subclass_name;
}
else {
$subclass_name = $pending_db_object->$subclassify_by;
unless ($subclass_name) {
Carp::croak("Failed to sub-classify $class while loading; calling method "
. "'$subclassify_by' returned false. Relevant object data: "
. Data::Dumper::Dumper($pending_db_object));
}
}
# note: we check this again with the real base class, but this keeps junk objects out of the core hash
unless ($subclass_name->isa($class)) {
# We may have done a load on the base class, and not been able to use properties to narrow down to the correct subtype.
# The resultset returned more data than we needed, and we're filtering out the other subclasses here.
return;
}
}
else {
# regular, non-subclassifier
$subclass_name = $class;
}
# store the object
# note that we do this on the base class even if we know it's going to be put into a subclass below
$UR::Context::all_objects_loaded->{$class}{$pending_db_object_id} = $pending_db_object;
$UR::Context::all_objects_cache_size++;
# If we're using a light cache, weaken the reference.
if ($UR::Context::light_cache and substr($class,0,5) ne 'App::') {
Scalar::Util::weaken($UR::Context::all_objects_loaded->{$class_name}->{$pending_db_object_id});
}
$update_apl_for_loaded_object->($pending_db_object);
my $boolexpr_evaluated_ok;
if ($subclass_name eq $class) {
# This object doesn't need additional subclassing
# Signal that the object has been loaded
# NOTE: until this is done indexes cannot be used to look-up an object
$pending_db_object->__signal_change__('load');
}
else {
# we did this above, but only checked the base class
my $subclass_ghost_class = $subclass_name->ghost_class;
if ($UR::Context::all_objects_loaded->{$subclass_ghost_class}{$pending_db_object_id}) {
# We put it in the object cache a few lines above.
# FIXME - why not wait until we know we're keeping it before putting it in there?
delete $UR::Context::all_objects_loaded->{$class}{$pending_db_object_id};
$UR::Context::all_objects_cache_size--;
return;
#$pending_db_object = undef;
#redo;
}
my $re_bless = $subclass_is_safe_for_re_bless{$subclass_name};
if (not defined $re_bless) {
$re_bless = $dsx->_class_is_safe_to_rebless_from_parent_class($subclass_name, $class);
$re_bless ||= 0;
$subclass_is_safe_for_re_bless{$subclass_name} = $re_bless;
}
my $loading_info;
if (!$re_bless) {
# This object cannot just be re-classified into a subclass because the subclass joins to additional tables.
# We'll make a parallel iterator for each subclass we encounter.
# Note that we let the calling db-based iterator do that, so that if multiple objects on the row need
# sub-classing, we do them all at once.
# Decrement all of the param_keys it is using.
if ($loading_base_object) {
$loading_info = $dsx->_get_object_loading_info($pending_db_object);
$loading_info = $dsx->_reclassify_object_loading_info_for_new_class($loading_info,$subclass_name);
}
#$pending_db_object->unload;
delete $UR::Context::all_objects_loaded->{$class}->{$pending_db_object_id};
if ($loading_base_object) {
$dsx->_record_that_loading_has_occurred($loading_info);
}
# NOTE: we're returning a class name instead of an object
# this tells the caller to re-do the entire row using a subclass to get the real data.
# Hack? Probably so...
return $subclass_name;
}
# Performance shortcut.
# These need to be subclassed, but there is no additional data to load.
# Just remove from the object cache, rebless to the proper subclass, and
# re-add to the object cache
my $already_loaded = $subclass_name->is_loaded($pending_db_object_id);
my $different;
my $merge_exception;
if ($already_loaded) {
eval { $different = $context->__merge_db_data_with_existing_object($class, $already_loaded, $pending_db_object_data, \@property_names) };
$merge_exception = $@;
}
if ($already_loaded and !$different and !$merge_exception) {
if ($pending_db_object == $already_loaded) {
Carp::croak("An object of type ".$already_loaded->class." with ID '".$already_loaded->id
."' was just loaded, but already exists in the object cache in the proper subclass");
}
if ($loading_base_object) {
# Get our records about loading this object
$loading_info = $dsx->_get_object_loading_info($pending_db_object);
# Transfer the load info for the load we _just_ did to the subclass too.
my $subclassified_template = $rule_template->sub_classify($subclass_name);
$loading_info->{$subclassified_template->id} = $loading_info->{$template_id};
$loading_info = $dsx->_reclassify_object_loading_info_for_new_class($loading_info,$subclass_name);
}
# This will wipe the above data from the object and the contex...
delete $UR::Context::all_objects_loaded->{$class}->{$pending_db_object_id};
if ($loading_base_object) {
# ...now we put it back for both.
$dsx->_add_object_loading_info($already_loaded, $loading_info);
$dsx->_record_that_loading_has_occurred($loading_info);
}
bless($pending_db_object,'UR::DeletedRef');
$pending_db_object = $already_loaded;
}
else {
if ($loading_base_object) {
my $subclassified_template = $rule_template->sub_classify($subclass_name);
$loading_info = $dsx->_get_object_loading_info($pending_db_object);
$dsx->_record_that_loading_has_occurred($loading_info);
$loading_info->{$subclassified_template->id} = delete $loading_info->{$template_id};
$loading_info = $dsx->_reclassify_object_loading_info_for_new_class($loading_info,$subclass_name);
}
my $prev_class_name = $pending_db_object->class;
#my $id = $pending_db_object->id;
#$pending_db_object->__signal_change__("unload");
delete $UR::Context::all_objects_loaded->{$prev_class_name}->{$pending_db_object_id};
delete $UR::Context::all_objects_are_loaded->{$prev_class_name};
if ($merge_exception) {
# Now that we've removed traces of the incorrectly-subclassed $pending_db_object,
# we can pass up any exception generated in __merge_db_data_with_existing_object
Carp::croak($merge_exception);
}
if ($already_loaded) {
# The new object should replace the old object. Since other parts of the user's program
# may have references to this object, we need to copy the values from the new object into
# the existing cached object
bless($pending_db_object,'UR::DeletedRef');
$pending_db_object = $already_loaded;
} else {
# This is a completely new object
$UR::Context::all_objects_loaded->{$subclass_name}->{$pending_db_object_id} = $pending_db_object;
}
bless $pending_db_object, $subclass_name;
$pending_db_object->__signal_change__("load");
$dsx->_add_object_loading_info($pending_db_object, $loading_info);
$dsx->_record_that_loading_has_occurred($loading_info);
}
# the object may no longer match the rule after subclassifying...
if ($needs_further_boolexpr_evaluation_after_loading
and
$loading_base_object
and
not $rule->evaluate($pending_db_object)
) {
#print "Object does not match rule!" . Dumper($pending_db_object,[$rule->params_list]) . "\n";
#$rule->evaluate($pending_db_object);
return;
} else {
$boolexpr_evaluated_ok = 1;
}
} # end of sub-classification code
if (
$loading_base_object
and
$needs_further_boolexpr_evaluation_after_loading
and
( ! $boolexpr_evaluated_ok )
and
( ! $rule->evaluate($pending_db_object) )
) {
return;
}
} # end handling newly loaded objects
# If the rule had hints, mark that we loaded those things too, in all_params_loaded
if ($hints_or_delegation) {
my $templates_and_rules = $fab_class->_lapl_data_for_delegation_data($hints_or_delegation,
$next_db_row,
$pending_db_object);
while ( my($template_id, $rule_id) = each %$templates_and_rules) {
$local_all_params_loaded->{$template_id}->{$rule_id}++;
$UR::Context::all_params_loaded->{$template_id}->{$rule_id} = undef;
}
}
# note all of the joins which follow this object as having been "done"
if (my $next_joins = $loading_template->{next_joins}) {
if (0) {
# disabled until a fully reframed query is the basis for these joins
for my $next_join (@$next_joins) {
my ($bxt_id, $values, $value_position_property_name) = @$next_join;
for (my $n = 0; $n < @$value_position_property_name; $n+=2) {
my $pos = $value_position_property_name->[$n];
my $name = $value_position_property_name->[$n+1];
$values->[$pos] = $pending_db_object->$name;
}
my $bxt = UR::BoolExpr::Template::And->get($bxt_id);
my $bx = $bxt->get_rule_for_values(@$values);
$UR::Context::all_params_loaded->{$bxt->{id}}->{$bx->{id}} = undef;
$local_all_params_loaded->{$bxt->{id}}->{$bx->{id}}++;
print "remembering $bx\n";
}
}
}
# When there is recursion in the query, we record data from each
# recursive "level" as though the query was done individually.
if ($recursion_desc and $loading_base_object) {
# if we got a row from a query, the object must have
# a db_committed or db_saved_committed
my $dbc = $pending_db_object->{db_committed} || $pending_db_object->{db_saved_uncommitted};
Carp::croak("Loaded database data has no save data for $class id ".$pending_db_object->id
.". Something bad happened.".Data::Dumper::Dumper($pending_db_object)) unless $dbc;
my $value_by_which_this_object_is_loaded_via_recursion = $dbc->{$recurse_property_on_this_row};
my $value_referencing_other_object = $dbc->{$recurse_property_referencing_other_rows};
$value_referencing_other_object = '' unless (defined $value_referencing_other_object);
unless ($recurse_property_value_found{$value_referencing_other_object}) {
# This row points to another row which will be grabbed because the query is hierarchical.
# Log the smaller query which would get the hierarchically linked data directly as though it happened directly.
$recurse_property_value_found{$value_referencing_other_object} = 1;
# note that the direct query need not be done again
my $equiv_rule = UR::BoolExpr->resolve_normalized(
$class,
$recurse_property_on_this_row => $value_referencing_other_object,
);
my $equiv_rule_id = $equiv_rule->id;
my $equiv_template_id = $equiv_rule->template_id;
# note that the recursive query need not be done again
my $equiv_rule_2 = UR::BoolExpr->resolve_normalized(
$class,
$recurse_property_on_this_row => $value_referencing_other_object,
-recurse => $recursion_desc,
);
my $equiv_rule_id_2 = $equiv_rule_2->id;
my $equiv_template_id_2 = $equiv_rule_2->template_id;
# For any of the hierarchically related data which is already loaded,
# note on those objects that they are part of that query. These may have loaded earlier in this
# query, or in a previous query. Anything NOT already loaded will be hit later by the if-block below.
my @subset_loaded = $class->is_loaded($recurse_property_on_this_row => $value_referencing_other_object);
$UR::Context::all_params_loaded->{$equiv_template_id}->{$equiv_rule_id} = undef;
$UR::Context::all_params_loaded->{$equiv_template_id_2}->{$equiv_rule_id_2} = undef;
$local_all_params_loaded->{$equiv_template_id}->{$equiv_rule_id} = scalar(@subset_loaded);
$local_all_params_loaded->{$equiv_template_id_2}->{$equiv_rule_id_2} = scalar(@subset_loaded);
for my $pending_db_object (@subset_loaded) {
$pending_db_object->{__load}->{$equiv_template_id}->{$equiv_rule_id}++;
$pending_db_object->{__load}->{$equiv_template_id_2}->{$equiv_rule_id_2}++;
}
}
# NOTE: if it were possible to use undef values in a connect-by, this could be a problem
# however, connect by in UR is always COL = COL, which would always fail on NULLs.
if (defined($value_by_which_this_object_is_loaded_via_recursion) and $recurse_property_value_found{$value_by_which_this_object_is_loaded_via_recursion}) {
# This row was expected because some other row in the hierarchical query referenced it.
# Up the object count, and note on the object that it is a result of this query.
my $equiv_rule = UR::BoolExpr->resolve_normalized(
$class,
$recurse_property_on_this_row => $value_by_which_this_object_is_loaded_via_recursion,
);
my $equiv_rule_id = $equiv_rule->id;
my $equiv_template_id = $equiv_rule->template_id;
# note that the recursive query need not be done again
my $equiv_rule_2 = UR::BoolExpr->resolve_normalized(
$class,
$recurse_property_on_this_row => $value_by_which_this_object_is_loaded_via_recursion,
-recurse => $recursion_desc
);
my $equiv_rule_id_2 = $equiv_rule_2->id;
my $equiv_template_id_2 = $equiv_rule_2->template_id;
$UR::Context::all_params_loaded->{$equiv_template_id}->{$equiv_rule_id} = undef;
$UR::Context::all_params_loaded->{$equiv_template_id_2}->{$equiv_rule_id_2} = undef;
$local_all_params_loaded->{$equiv_template_id}->{$equiv_rule_id}++;
$local_all_params_loaded->{$equiv_template_id_2}->{$equiv_rule_id_2}++;
$pending_db_object->{__load}->{$equiv_template_id}->{$equiv_rule_id}++;
$pending_db_object->{__load}->{$equiv_template_id_2}->{$equiv_rule_id_2}++;
}
} # end of handling recursion
return $pending_db_object;
}; # end of per-class object fabricator
Sub::Name::subname("UR::Context::__object_fabricator(closure)__ ($class_name)", $object_fabricator);
# remember all the changes to $UR::Context::all_params_loaded that should be made.
# This fixes the problem where you create an iterator for a query, read back some of
# the items, but not all, then later make the same query. The old behavior made
# entries in all_params_loaded as objects got loaded from the DB, so that at the time
# the second query is made, UR::Context::_cache_is_complete_for_class_and_normalized_rule()
# sees there are entries in all_params_loaded, and so reports yes, the cache is complete,
# and the second query only returns the objects that were loaded during the first query.
#
# The new behavior builds up changes to be made to all_params_loaded, and someone
# needs to call $object_fabricator->finalize() to apply these changes
$fabricator_obj = $fab_class->_create(fabricator => $object_fabricator,
context => $context,
all_params_loaded => $local_all_params_loaded,
in_clause_values => \%in_clause_values);
return $fabricator_obj;
}
# Given the data created in _resolve_delegation_data (rule templates and values/valuerefs)
# return a hash of template IDs => rule IDs that need to be manipulated in local_all_params_loaded
sub _lapl_data_for_delegation_data {
my($fab_class, $delegation_data_list, $next_db_row, $pending_db_object) = @_;
my %tmpl_and_rules;
#$DB::single=1;
foreach my $delegation_data ( @$delegation_data_list ) {
my $value_sources = $delegation_data->[0];
my $rule_tmpl = $delegation_data->[1];
my @values;
foreach my $value_source ( @$value_sources ) {
if (! ref($value_source)) {
push @values, $value_source;
} elsif (Scalar::Util::looks_like_number($$value_source)) {
push @values, $next_db_row->[$$value_source];
} elsif ($pending_db_object) {
my $method_name = $$value_source;
my $result = eval { $pending_db_object->$method_name };
push @values, $result;
} else {
Carp::croak("Can't resolve value for '".$$value_source."' in delegation data when there is no object involved");
}
}
my $rule = $rule_tmpl->get_normalized_rule_for_values(@values);
$tmpl_and_rules{$rule_tmpl->id} = $rule->id;
}
return \%tmpl_and_rules;
}
# This is used by fabricators created as a result of filters or hints on delegated properties
# of the primary object to pre-calculate rule templates and value sources that can be combined
# with these templates to make rules. The resulting template and rule IDs are then plugged into
# all_params_loaded to indicate these related objects are loaded so that subsequent queries
# will not hit the data sources.
sub _resolve_delegation_data {
my($fab_class,$rule,$loading_template,$query_plan,$local_all_params_loaded) = @_;
my $rule_template = $rule->template;
my $query_class_meta = $rule_template->subject_class_name->__meta__;
my %hints;
if ($rule_template->hints) {
$hints{$_} = 1 foreach(@{ $rule_template->hints });
}
my %delegations;
if (@{ $query_plan->{'joins'}} ) {
foreach my $delegated_property_name ( $rule_template->_property_names ) {
my $delegated_property_meta = $query_class_meta->property_meta_for_name($delegated_property_name);
next unless ($delegated_property_meta and $delegated_property_meta->is_delegated);
$delegations{$delegated_property_name} = 1;
}
}
my $this_object_num = $loading_template->{'object_num'};
my $join = $query_plan->_get_alias_join($loading_template->{'table_alias'});
return unless $join; # would this ever be false?
return unless ($join->{'foreign_class'} eq $loading_template->{'data_class_name'}); # sanity check
my $delegated_property_meta;
# Find out which delegation property was responsible for this object being loaded
DELEGATIONS:
foreach my $delegation ((keys %hints), (keys %delegations)) {
my $query_property_meta = $query_class_meta->property_meta_for_name($delegation);
next DELEGATIONS unless $query_property_meta;
my @joins_from_delegation = $query_property_meta->_resolve_join_chain();
foreach my $join_from_delegation ( @joins_from_delegation ) {
if ($join_from_delegation->id eq $join->id) {
$delegated_property_meta = $query_property_meta;
last DELEGATIONS;
}
}
}
return unless $delegated_property_meta;
my $delegated_property_name = $delegated_property_meta->property_name;
return if $join->destination_is_all_id_properties();
my @template_filter_names = @{$join->{'foreign_property_names'}};
my %template_filter_values;
foreach my $name ( @template_filter_names ) {
my $column_num = $query_plan->column_index_for_class_property_and_object_num(
$join->{'foreign_class'},
$name,
$this_object_num);
if (defined $column_num) {
$template_filter_values{$name} = \$column_num;
} else {
my $prop_name = $name;
$template_filter_values{$name} = \$prop_name;
}
}
if ($delegations{$delegated_property_name}) {
my $delegation_final_property_meta = $delegated_property_meta->final_property_meta;
if ($delegation_final_property_meta
and
$delegation_final_property_meta->class_name eq $join->{'foreign_class'}
) {
# This delegation points to (or at least through) this join's foreign class
# We'll note that these related objects were loaded as a result of being
# connected to the primary object by this value, and filtered by the
# delegation property's value
my $delegation_final_property_name = $delegation_final_property_meta->property_name;
my $column_num = $query_plan->column_index_for_class_property_and_object_num(
$join->{'foreign_class'},
$delegation_final_property_name,
$this_object_num);
push @template_filter_names, $delegation_final_property_name;
if ($delegation_final_property_meta->column_name and ! defined ($column_num)) {
# sanity check
Carp::carp("Could not determine column offset in result set for property "
. "$delegation_final_property_name of class " . $join->{'foreign_class'}
. " even though it has column_name " . $delegation_final_property_meta->column_name);
$column_num = undef;
}
if (defined $column_num) {
$template_filter_values{$delegation_final_property_name} = \$column_num;
} else {
$template_filter_values{$delegation_final_property_name} = \$delegation_final_property_name;
}
}
}
# For missing objects, ie. a left join was done and it matched nothing
my @missing_prop_names;
my %missing_values;
for (my $i = 0; $i < @{ $join->{'foreign_property_names'}}; $i++) {
# we're using the source class/property here because we're going to denote that a value
# of the source class of the join matched nothing
my $prop_name = $join->{'foreign_property_names'}->[$i];
push @missing_prop_names, $prop_name;
my $source_class = $join->{'source_class'};
my $source_prop_name = $join->{'source_property_names'}->[$i];
my $column_num;
if( my($actual_prop_meta) = $source_class->__meta__->_concrete_property_meta_for_class_and_name($source_prop_name) ) {
$column_num = $query_plan->column_index_for_class_and_property_before_object_num($actual_prop_meta->class_name,
$actual_prop_meta->property_name,
$this_object_num);
}
if (defined $column_num) {
$missing_values{$prop_name} = \$column_num;
} else {
Carp::croak("Can't determine resultset column for $source_class property $source_prop_name for rule $rule");
}
}
if ($join->{'where'}) {
for (my $i = 0; $i < @{$join->{'where'}}; $i += 2) {
my $where_prop = $join->{'where'}->[$i];
push @template_filter_names, $where_prop;
push @missing_prop_names, $where_prop;
my $pos = index($where_prop, ' ');
if ($pos != -1) {
# the key is "propname op"
$where_prop = substr($where_prop,0,$pos);
}
my $where_value = $join->{'where'}->[$i+1];
$template_filter_values{$where_prop} = $where_value;
$missing_values{$where_prop} = $where_value;
}
}
my $missing_rule_tmpl = UR::BoolExpr::Template->resolve($join->{'foreign_class'}, @missing_prop_names)->get_normalized_template_equivalent;
my $related_rule_tmpl = UR::BoolExpr::Template->resolve($join->{'foreign_class'},
@template_filter_names)->get_normalized_template_equivalent;
my(@hints_or_delegation, @delegations_with_no_objects);
# Items in the first listref can be one of three things:
# 1) a reference to an integer - meaning retrieve the value from this column in the result set
# 2) a reference to a string - meaning retrieve the value from the object usign this as a property name
# 3) a string - meaning this is a literal value to fill in directly
# The second item is a rule template we'll be feeding these values in to
my @template_filter_values = @template_filter_values{$related_rule_tmpl->_property_names};
push @hints_or_delegation, [ \@template_filter_values, $related_rule_tmpl];
my @missing_values = @missing_values{$missing_rule_tmpl->_property_names};
push @delegations_with_no_objects, [\@missing_values, $missing_rule_tmpl];
return (\@hints_or_delegation, \@delegations_with_no_objects);
}
sub all_object_fabricators {
return values %all_object_fabricators;
}
# simple accessors
sub fabricator {
my $self = shift;
return $self->{'fabricator'};
}
sub context {
my $self = shift;
return $self->{'context'};
}
sub all_params_loaded {
my $self = shift;
return $self->{'all_params_loaded'};
}
sub in_clause_values {
my $self = shift;
return $self->{'in_clause_values'};
}
# call the object fabricator closure
sub fabricate {
my $self = shift;
&{$self->{'fabricator'}};
}
# Returns true if this fabricator has loaded an object matching this boolexpr
sub is_loading_in_progress_for_boolexpr {
my $self = shift;
my $boolexpr = shift;
my $template_id = $boolexpr->template_id;
# FIXME should it use is_subsest_of here?
return unless exists $self->{'all_params_loaded'}->{$template_id};
return unless exists $self->{'all_params_loaded'}->{$template_id}->{$boolexpr->id};
return 1;
}
# UR::Contect::_abandon_object calls this to forget about loading an object
sub delete_from_all_params_loaded {
my($self,$template_id,$boolexpr_id) = @_;
return unless ($template_id and $boolexpr_id);
my $all_params_loaded = $self->all_params_loaded;
return unless $all_params_loaded;
return unless exists($all_params_loaded->{$template_id});
delete $all_params_loaded->{$template_id}->{$boolexpr_id};
}
sub finalize {
my $self = shift;
$self->apply_all_params_loaded();
delete $all_object_fabricators{$self};
$self->{'all_params_loaded'} = undef;
}
sub apply_all_params_loaded {
my $self = shift;
my $local_all_params_loaded = $self->{'all_params_loaded'};
my @template_ids = keys %$local_all_params_loaded;
foreach my $template_id ( @template_ids ) {
my @rule_ids = keys %{$local_all_params_loaded->{$template_id}};
foreach my $rule_id ( @rule_ids ) {
my $val = $local_all_params_loaded->{$template_id}->{$rule_id};
next unless exists $UR::Context::all_params_loaded->{$template_id}->{$rule_id}; # Has unload() removed this one earlier?
$UR::Context::all_params_loaded->{$template_id}->{$rule_id} += $val;
}
}
# Anything left in here is in-clause values that matched nothing. Make a note in
# all_params_loaded showing that so later queries for those values won't hit the
# data source
my $in_clause_values = $self->{'in_clause_values'};
my @properties = keys %$in_clause_values;
foreach my $property ( @properties ) {
my @values = keys %{$in_clause_values->{$property}};
foreach my $value ( @values ) {
my $data = $in_clause_values->{$property}->{$value};
$UR::Context::all_params_loaded->{$data->[0]}->{$data->[1]} = 0;
}
}
$self->{'all_params_loaded'} = {};
}
sub DESTROY {
my $self = shift;
# Don't apply the changes. Maybe the importer closure just went out of scope before
# it read all the data
my $local_all_params_loaded = $self->{'all_params_loaded'};
if ($local_all_params_loaded) {
# finalize wasn't called on this iterator; maybe the importer closure went out
# of scope before it read all the data.
# Conditionally apply the changes from the local all_params_loaded. If the Context's
# all_params_loaded is defined, then another query has successfully run to
# completion, and we should add our data to it. Otherwise, we're the only query like
# this and all_params_loaded should be cleaned out
foreach my $template_id ( keys %$local_all_params_loaded ) {
while(1) {
my($rule_id, $val) = each %{$local_all_params_loaded->{$template_id}};
last unless $rule_id;
if (defined $UR::Context::all_params_loaded->{$template_id}->{$rule_id}) {
$UR::Context::all_params_loaded->{$template_id}->{$rule_id} += $val;
} else {
delete $UR::Context::all_params_loaded->{$template_id}->{$rule_id};
}
}
}
}
delete $all_object_fabricators{$self};
}
1;
=pod
=head1 NAME
UR::Context::ObjectFabricator - Track closures used to fabricate objects from data sources
=head1 DESCRIPTION
Object Fabricators are closures that accept listrefs of data returned by
data source iterators, take slices out of them, and construct UR objects
out of the results. They also handle updating the query cache and merging
changed DB data with previously cached objects.
UR::Context::ObjectFabricator objects are used internally by UR::Context,
and not intended to be used directly.
=head1 METHODS
=over 4
=item create_for_loading_template
my $fab = UR::Context::ObjectFabricator->create_for_loading_template(
$context, $loading_tmpl_hashref, $template_data,
$rule, $rule_template, $values, $dsx);
Returns an object fabricator instance that is able to construct objects
of the rule's target class from rows of data returned by data source
iterators. Object fabricators are used a part of the object loading
process, and are called by UR::Context::get_objects_for_class_and_rule()
to transform a row of data returned by a data source iterator into a UR
object.
For each class involved in a get request, the system prepares a loading
template that describes which columns of the data source data are to be
used to construct an instance of that class. For example, in the case where
a get() is done on a child class, and the parent and child classes store data
in separate tables linked by a relation-property/foreign-key, then the query
against the data source will involve and SQL join (for RDBMS data sources).
That join will produce a result set that includes data from both tables.
The C<$loading_tmpl_hashref> will have information about which columns of
that result set map to which properties of each involved class. The heart
of the fabricator closure is a list slice extracting the data for that class
and assigning it to a hash slice of properties to fill in the initial object
data for its class. The remainder of the closure is bookkeeping to keep the
object cache ($UR::Context::all_objects_loaded) and query cache
($UR::Context::all_params_loaded) consistent.
The interaction of the object fabricator, the query cache, object cache
pruner and object loading iterators that may or may not have loaded all
their data requires that the object fabricators keep a list of changes they
plan to make to the query cache instead of applying them directly. When
the Underlying Context Loading iterator has loaded the last row from the
Data Source Iterator, it calls C on the object fabricator to
tell it to go ahead and apply its changes; essentially treating that
data as a transaction.
=item all_object_fabricators
my @fabs = UR::Context::ObjectFabricator->all_object_fabricators();
Returns a list of all object fabricators that have not yet been finalized
=item fabricate
my $ur_object = $fab->fabricate([columns,from,data,source]);
Given a listref of data pulled from a data source iterator, it slices out
the appropriate columns from the list and constructs a single object to
return.
=item is_loading_in_progress_for_boolexpr
my $bool = $fab->is_loading_in_progress_for_boolexpr($boolexpr);
Given a UR::BoolExpr instance, it returns true if the given fabricator is
prepared to construct objects matching this boolexpr. This is used by
UR::Context to know if other iterators are still pulling in objects that
could match another iterator's boolexpr, and it should therefore not trust
that the object cache is conplete.
=item finalize
$fab->finalize();
Indicates to the iterator that the caller is done using it for constructing
objects, probably because the data source has no more data or the iterator
that was using this fabricator has gone out of scope.
=item apply_all_params_loaded
$fab->apply_all_params_loaded();
As the fabricator constructs objects, it buffers changes to all_params_loaded
(the Context's query cache) to maintain consistency if multiple iterators are
working concurrently. At the appripriate time, call apply_all_params_loaded()
to take those changes and apply them to the current Context's all_params_loaded.
=back
=cut
Process.pm 100664 023532 023421 30245 12544604516 16355 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/Context package UR::Context::Process;
=pod
=head1 NAME
UR::Context::Process - Impliments a generic interface to the current application.
=head1 SYNOPSIS
$name = UR::Context::Process->base_name;
$name = UR::Context::Process->prog_name;
UR::Context::Process->prog_name($name);
$name = UR::Context::Process->pkg_name;
UR::Context::Process->pkg_name($name);
$name = UR::Context::Process->title;
UR::Context::Process->title($name);
$version = UR::Context::Process->version;
UR::Context::Process->version($version);
$author = UR::Context::Process->author;
UR::Context::Process->author($author);
$author_email = UR::Context::Process->author_email;
UR::Context::Process->author_email($author_email);
$support_email = UR::Context::Process->support_email;
UR::Context::Process->support_email($support_email);
$login = UR::Context::Process->real_user_name;
=head1 DESCRIPTION
This module provides methods to set and retrieve various names
associated with the program and the program version number.
=cut
package UR::Context::Process;
our $VERSION = "0.44"; # UR $VERSION;;
require 5.006_000;
use strict;
use warnings;
use Sys::Hostname;
use File::Basename;
require UR;
UR::Object::Type->define(
class_name => 'UR::Context::Process',
is => ['UR::Context'],
is_transactional => 0,
has => [
host_name => { is => 'Text' },
process_id => { is => 'Integer' },
access_level => { is => 'Text', default_value => '??' },
debug_level => { is => 'Integer', default_value => 0 },
],
doc => 'A context for a given process.',
);
=pod
=head1 METHODS
These methods provide the accessor and set methods for various names
associated with an application.
=over
=item get_current
$ctx = UR::Context::Process->get_current();
This is the context which represents the current process.
Also available as UR::Context->get_process();
=back
=cut
sub get_current {
return $UR::Context::process;
}
=pod
=over
=item has_changes()
$bool = UR::Context::Process->has_changes();
Returns true if the current process has changes which might be committed back to
the underlying context.
=back
=cut
sub has_changes {
my $self = shift;
my @ns = $self->all_objects_loaded('UR::Namespace');
for my $ns (@ns) {
my @ds = $ns->get_data_sources();
for my $ds (@ds) {
return 1 if $ds->has_changes_in_base_context();
}
}
return;
}
=pod
=over
=item _create_for_current_process
$ctx = UR::Context::Process->_create_for_current_process(@PARAMS)
This is only used internally by UR.
It materializes a new object to represent a real process somewhere.
TODO: Remove the exception from create(), and allow other processes to be
created explicitly w/ the appropriate characteristics.
=back
=cut
sub _create_for_current_process {
my $class = shift;
die "Process object for the current process already exists!" if $UR::Context::process;
#my $rule = $class->define_boolexpr(@_);
my $rule = UR::BoolExpr->resolve($class, @_);
my $host_name = Sys::Hostname::hostname();
my $id = $host_name . "\t" . $$;
my $self = $class->SUPER::create(id => $id, process_id => $$, host_name => $host_name, $rule->params_list);
return $self;
}
sub create {
# Note that the above method does creation by going straight to SUPER::create()
# for the current process only.
die "Creation of parallel/child processes not yet supported!"
}
# TODO: the remaining methods are from the old App::Name module.
# They currently only work for the current process, and operate as class methods.
# They should be re-written to work as class methods on $this_process, or
# instance methods on any process. For now, only the class methods are needed.
=pod
=over
=item base_name
$name = UR::Context::Process->base_name;
This is C.
=back
=cut
our $base_name = basename($0, '.pl');
sub base_name { return $base_name }
=pod
=over
=item prog_name
$name = UR::Context::Process->prog_name;
UR::Context::Process->prog_name($name);
This method is used to access and set the name of the program name.
This name is used in the output of the C and C
subroutines (see L<"version"> and L<"usage">). If given an argument,
this method sets the program name and returns the new name or C
if unsuccessful.
It defaults to C if unspecified.
=back
=cut
our $prog_name;
sub prog_name
{
my $class = shift;
my ($name) = @_;
if (@_)
{
$prog_name = $name;
}
return $prog_name || $class->base_name;
}
=pod
=over
=item pkg_name
$name = UR::Context::Process->pkg_name;
UR::Context::Process->pkg_name($name);
This method is used to access and set the GNU-standard package name
for the package to which this program belongs. This is does B
refer-to a Perl package. It allows a set of spefic programs to be
grouped together under a common name, which is used in standard
message output, and is used in the output of the C subroutine
(see L<"version"> output.
If given an argument, this method sets the package name and returns
the the new name or C if unsuccessful. Without an argument,
the current package name is returned.
It defaults to C when unspecified, which in turn
defaults to C, which in turn defaults to
C.
=back
=cut
# NOTE: this should not use App::Debug because App::Debug::level calls it
our $pkg_name;
sub pkg_name
{
my $class = shift;
my ($name) = @_;
if (@_)
{
$pkg_name = $name;
}
return $pkg_name || $class->prog_name;
}
=pod
=over
=item title
$name = UR::Context::Process->title;
UR::Context::Process->title($name);
This gets and sets the "friendly name" for an application. It is
often mixed-case, with spaces, and is used in autogenerated
documentation, and sometimes as a header in generic GUI components.
Without an argument, it returns the current title. If an argument is
specified, this method sets the application title and returns the new
title or C if unsuccessful.
It defaults to C when otherwise unspecified, which
in turn defaults to C when unspecified, which in
turn defaults to C when unspecified, which
defaults to C when unspecified.
=back
=cut
our $title;
sub title
{
my $class = shift;
my ($name) = @_;
if (@_)
{
$title = $name;
}
return $title || $class->pkg_name;
}
=pod
=over
=item version
$version = UR::Context::Process->version;
UR::Context::Process->version($version);
This method is used to access and set the package version. This
version is used in the output of the C method (see
L). If given an argument, this method
sets the package version and returns the version or C if
unsuccessful. Without an argument, the current package version is
returned.
This message defaults to C<$main::VERSION> if not set. Note that
C<$main::VERSION> may be C.
=back
=cut
# set/get version
# use $main::VERSION for compatibility with non-App animals.
sub version
{
my $class = shift;
my ($version) = @_;
if (@_)
{
$main::VERSION = $version;
}
return $main::VERSION;
}
=pod
=over
=item author
$author = UR::Context::Process->author;
UR::Context::Process->author($author);
This method is used to access and set the package author. If given an
argument, this method sets the package author and returns the author
or C if unsuccessful. Without an argument, the current author
is returned.
=back
=cut
# set/get author
our $author;
sub author
{
my $class = shift;
my ($name) = @_;
if (@_)
{
$author = $name;
}
return $author;
}
=pod
=over
=item author_email
$author_email = UR::Context::Process->author_email;
UR::Context::Process->author_email($author_email);
This method is used to access and set the package author's email
address. This information is used in the output of the C
method (see L). If given an argument, this
method sets the package author's email address and returns email
address or C if unsuccessful. Without an argument, the current
email address is returned.
=back
=cut
# set/return author email address
our $author_email;
sub author_email
{
my $class = shift;
my ($email) = @_;
if (@_)
{
$author_email = $email;
}
return $author_email;
}
=pod
=over
=item support_email
$support_email = UR::Context::Process->support_email;
UR::Context::Process->support_email($support_email);
This method is used to access and set the email address to which the
user should go for support. This information is used in the output of
the C method (see L). If given an
argument, this method sets the support email address and returns that
email address or C if unsuccessful. Without an argument, the
current email address is returned.
=back
=cut
# set/return author email address
our $support_email;
sub support_email
{
my $class = shift;
my ($email) = @_;
if (@_)
{
$support_email = $email;
}
return $support_email;
}
=pod
=over
=item real_user_name
$login = UR::Context::Process->real_user_name;
This method is used to get the login name of the effective user id of
the running script.
=back
=cut
# return the name of the user running the program
our $real_user_name;
sub real_user_name
{
my $class = shift;
if (!$real_user_name)
{
if ($^O eq 'MSWin32' || $^O eq 'cygwin')
{
$real_user_name = 'WindowsUser';
}
else
{
$real_user_name = getpwuid($<) || getlogin || 'unknown';
}
}
return $real_user_name;
}
=pod
=over
=item fork
$pid = UR::Context::Process->fork;
Safe fork() wrapper.
Handles properly disconnecting database handles if necessary so that data sources in children
are still valid. Also ensures that the active UR::Context::process has the child's PID
recorded within.
=back
=cut
sub fork
{
my $class = shift;
my @ds = UR::DataSource->is_loaded();
for (grep {defined $_} @ds) {
$_->prepare_for_fork;
}
my $pid = fork();
unless(defined $pid) {
Carp::confess('Failed to fork process. ' . $!);
}
if (!$pid) {
$UR::Context::process = undef;
$UR::Context::process = $class->_create_for_current_process;
for (grep {defined $_} @ds) {
$_->do_after_fork_in_child;
}
}
for (grep {defined $_} @ds) {
$_->finish_up_after_fork;
}
return $pid;
}
=pod
=over
=item effective_user_name
$login = UR::Context::Process->effective_user_name;
This method is used to get the login name of the effective user id of
the running script.
=back
=cut
# return the name of the user running the program
our $effective_user_name;
sub effective_user_name
{
my $class = shift;
if (!$effective_user_name)
{
$effective_user_name = getpwuid($>) || 'unknown';
}
return $effective_user_name;
}
=pod
=over
=item original_program_path
$path = UR::Context::Process->original_program_path;
This method is used to (try to) get the original program path of the running script.
This will not change even if the current working directory is changed.
(In truth it will find the path at the time UR::Context::Process was used. So, a chdir
before that happens will cause incorrect results; in that case, undef will be returned.
=back
=cut
our ($original_program_name, $original_program_dir);
eval '
use FindBin;
$original_program_dir=$FindBin::Bin;
$original_program_name=__PACKAGE__->base_name;
';
sub original_program_path {
my $class=shift;
my $original_program_dir=$class->original_program_dir;
return unless($original_program_dir);
my $original_program_name=$class->original_program_name;
return unless($original_program_name);
return $original_program_dir.q(/).$original_program_name;
}
sub original_program_dir {
return unless($original_program_dir);
return $original_program_dir;
}
sub original_program_name {
return unless($original_program_name);
return $original_program_name;
}
1;
__END__
=pod
=head1 SEE ALSO
L
=cut
1;
Root.pm 100664 023532 023421 4723 12544604516 15644 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/Context package UR::Context::Root;
use strict;
use warnings;
require UR;
our $VERSION = "0.44"; # UR $VERSION;
UR::Object::Type->define(
class_name => 'UR::Context::Root',
is => ['UR::Singleton', 'UR::Context'],
is_abstract => 1,
is_transactional => 1,
doc => 'A base level context, representing the committed state of datasources external to the application.',
);
# this is called automatically by UR.pm at the end of the module
my $initialized = 0;
sub _initialize_for_current_process {
my $class = shift;
if ($initialized) {
die "Attempt to re-initialize the current process?";
}
my $context_singleton_class = $ENV{UR_CONTEXT_ROOT} ||= 'UR::Context::DefaultRoot';
$class->set_current($context_singleton_class);
}
sub name {
my $class = shift->_singleton_class_name;
my ($name) = ($class =~ /^\w+?\:\:\w+?\:\:(\w+)$/);
die "failed to parse name from $class!" unless $name;
return lc($name);
}
sub get_current {
#shift->_initialize_for_current_process() unless $initialized;
#eval "sub get_current { \$ENV{UR_CONTEXT_ROOT} }";
return $ENV{UR_CONTEXT_ROOT};
}
sub set_current {
my $class = shift;
my $value = shift;
return $value if $value eq $ENV{UR_CONTEXT_ROOT};
$ENV{UR_CONTEXT_ROOT} = $value;
#print "base context set to $value\n";
#print Carp::longmess();
eval {
local $SIG{__DIE__};
local $SIG{__WARN__};
$ENV{UR_CONTEXT_ROOT}->class;
};
if ($@) {
die "The context at application initialization is set to "
. $ENV{UR_CONTEXT_ROOT} . ".\n"
. "This failed to compile:\n$@"
}
unless ($ENV{UR_CONTEXT_ROOT}->isa("UR::Context")) {
die "The context at application initialization is set to "
. $ENV{UR_CONTEXT_ROOT} . ".\n"
. "This does not inherit from UR::Context."
}
unless ($ENV{UR_CONTEXT_ROOT}->__meta__) {
die "The context at application initialization is set to "
. $ENV{UR_CONTEXT_ROOT} . ".\n"
. "This is not defined with UR::Object::Type metadata!"
}
# Initialize the bottom of the transaction stack
if (@UR::Context::Transaction::open_transaction_stack > 1) {
die "Cannot change the base context once transactions are in progress!"
}
return $value;
}
sub access_level {
my $self = shift->_singleton_object;
return "???";
}
# sub has_changes { return }
1;
Transaction.pm 100664 023532 023421 31524 12544604516 17225 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/Context package UR::Context::Transaction;
use strict;
use warnings;
require UR;
our $VERSION = "0.44"; # UR $VERSION;
use Carp qw(croak confess shortmess);
UR::Object::Type->define(
class_name => __PACKAGE__,
is => ['UR::Context'],
has => [
begin_point => { is => 'Integer' },
end_point => { is => 'Integer', is_optional => 1}, # FIXME is this ever used anywhere?
state => { is => 'Text' }, # open, committed, rolled-back
],
is_transactional => 1,
);
our $log_all_changes = 0;
our @change_log;
our @open_transaction_stack;
our $last_transaction_id = 0;
sub delete {
my $self = shift;
$self->rollback;
}
sub begin {
my $class = shift;
my $id = $last_transaction_id++;
my $begin_point = @change_log;
$log_all_changes = 1;
my $last_trans = $open_transaction_stack[-1];
if ($last_trans and $last_trans != $UR::Context::current) {
die "Current transaction does not match the top of the transaction stack!?"
}
$last_trans ||= $UR::Context::current;
my $self = $class->create(
id => $id,
begin_point => $begin_point,
state => "open",
parent => $last_trans,
@_
);
unless ($self) {
Carp::confess("Failed to being transaction!");
}
push @open_transaction_stack, $self;
$UR::Context::current = $self;
return $self;
}
sub log_change {
my $this_class = shift;
my ($object, $class, $id, $aspect, $undo_data) = @_;
return if $class eq "UR::Change";
# wrappers (create/delete/load/unload/define) signal change also
# and we undo the wrapper, thereby undoing these
# -> ignore any signal from a method which is wrapped by another signalling method which gets undone
return if ( $aspect eq "load" or
$aspect eq "load_external"
);
if (!ref($object) or $class eq "UR::Object::Index") {
#print "skipping @_\n";
return;
}
if ($aspect eq "delete") {
$undo_data = Data::Dumper::Dumper($object);
}
Carp::confess() if ref($class);
my $change = UR::Change->create(
id => scalar(@change_log)+1,
changed_class_name => $class,
changed_id => $id,
changed_aspect => $aspect,
undo_data => $undo_data,
);
unless (ref($change)) {
#$DB::single = 1;
}
push @change_log, $change;
return $change;
}
sub has_changes {
my $self = shift;
my @changes = $self->get_changes();
return (@changes > 1 ? 1 : ());
}
sub get_changes {
my $self = shift;
my $begin_point = $self->begin_point;
my $end_point = $self->end_point || $#change_log;
my @changes = @change_log[$begin_point..$end_point];
if (@_) {
@changes = UR::Change->get(id => \@changes, @_)
}
else {
return @changes;
}
}
sub get_change_summary {
# TODO: This should compress multiple changes to the same object as much as possible
# Right now, it just omits the creation event for the transaction object itself.
# -> should the creation of the transaction be part of it?
# A: It should really be part of the prior transaction, and after commit/rollback
# the nesting collapses. The @change_log should be _inside the transaction object,
# or the change should contain a transaction id. The list can be destroyed on
# rollback, or summarized on commit.
my $self = shift;
my @changes =
grep { $_->changed_aspect !~ /^(load|define)$/ }
$self->get_changes;
shift @changes; # $self creation event
return @changes;
}
sub rollback {
my $self = shift;
# Support calling as a class method: UR::Context::Transaction->rollback rolls back the current trans
unless (ref($self)) {
$self = $open_transaction_stack[-1];
unless ($self) {
Carp::confess("No open transaction!? Cannot rollback.");
}
}
if ($self->state ne "open") {
Carp::confess("Cannot rollback a transaction that is " . $self->state . ".")
}
$self->__signal_change__('prerollback');
my $begin_point = $self->begin_point;
unless ($self eq $open_transaction_stack[-1]) {
# This is not the top transaction on the stack.
# Rollback internally nested transactions in order from the end.
my @transactions_with_begin_point =
map { [ $_->begin_point, $_ ] }
$self->class->get(
begin_point => { operator => ">", value => $begin_point }
);
my @later_transactions =
map { $_->[1] }
sort { $b->[0] <=> $a->[0] }
@transactions_with_begin_point;
for my $later_transaction (@later_transactions) {
if ($later_transaction->isa("UR::DeletedRef")) {
#$DB::single = 1;
}
$later_transaction->rollback;
}
}
my $parent = $self->parent;
if ($open_transaction_stack[-2] and $open_transaction_stack[-2] != $parent) {
die "Parent transaction $parent is not below this one on the stack $open_transaction_stack[-2]?";
}
{
# Reverse each change, starting from the most recent, and
# ending with the creation of the transaction object itself.
local $log_all_changes = 0;
$self->__signal_change__('rollback', 1);
my @changes_to_undo = reverse $self->get_changes();
my $transaction_change = pop @changes_to_undo;
my $transaction = $transaction_change->changed_class_name->get($transaction_change->changed_id);
unless ($self == $transaction && $transaction_change->changed_aspect eq 'create') {
die "First change was not the creation of this transaction!";
}
for my $change (@changes_to_undo) {
if ($change == $changes_to_undo[0]) {
# the transaction reverses itself in its own context,
# but the removal of the transaction itself happens in the parent context
$UR::Context::current = $parent;
}
$change->undo;
$change->delete;
}
for my $change (@changes_to_undo) {
unless($change->isa('UR::DeletedRef')) {
Carp::confess("Failed to undo a change during transaction rollback.");
}
}
$transaction_change->undo;
$transaction_change->delete;
}
$#change_log = $begin_point-1;
unless($self->isa("UR::DeletedRef")) {
#$DB::single = 1;
Carp::confess("Failed to remove transaction during rollback.");
}
pop @open_transaction_stack;
unless (@open_transaction_stack) {
$log_all_changes = 0;
}
$UR::Context::current = $parent;
return 1;
}
sub commit {
my $self = shift;
# Support calling as a class method: UR::Context::Transaction->commit commits the current transaction.
unless (ref($self)) {
$self = $open_transaction_stack[-1];
unless ($self) {
Carp::confess("No open transaction!? Cannot commit.");
}
}
if ($self->state ne "open") {
Carp::confess("Cannot commit a transaction that is " . $self->state . ".")
}
unless ($open_transaction_stack[-1] == $self) {
# TODO: decide if this should work like rollback, and commit nested transactions automatically
Carp::confess("Cannot commit a transaction with open sub-transactions!");
}
$self->__signal_change__('precommit');
unless ($self->changes_can_be_saved) {
return;
}
$self->state("committed");
if ($self->state eq 'committed') {
$self->__signal_change__('commit',1);
}
else {
$self->__signal_change__('commit',0);
}
pop @open_transaction_stack;
unless (@open_transaction_stack) {
$log_all_changes = 0;
}
$UR::Context::current = $self->parent;
return 1;
}
sub changes_can_be_saved {
my $self = shift;
# This is very similar to behavior in UR::Context::_sync_databases. The only
# reason it isn't re-used from UR::Context is the desire to limit changed
# objects to those changed within the transaction.
# TODO: limit to objects that changed within transaction as to not duplicate
# error checking unnecessarily.
my @changed_objects =
grep { ! $_->isa('UR::DeletedRef') }
map { $_->changed_object() } $self->get_changes();
# This is primarily to catch custom validity logic in class overrides.
my @invalid = grep { $_->__errors__ } @changed_objects;
if (@invalid) {
$self->display_invalid_data_for_save(\@invalid);
return;
}
return 1;
}
sub eval_or_do {
my $is_failure = shift;
my $block = shift;
my $class = __PACKAGE__;
if (@_) {
confess('%s::eval takes one argument', $class);
}
my $tx = $class->begin();
my $result = CORE::eval { $block->() };
my $eval_error = $@;
if ($is_failure->($result, $eval_error)) {
$class->debug_message(shortmess('Rolling back transaction'));
$class->debug_message($eval_error) if ($eval_error);
unless($tx->rollback()) {
die 'failed to rollback transaction';
}
} else {
unless($tx->commit()) {
die 'failed to commit transaction';
}
}
if (wantarray) {
return ($result, $eval_error);
} else {
return $result;
}
}
# eval function takes a block (&) sort of like CORE::eval
# eval will rollback on a caught die
sub eval(&) {
my $is_failure = sub {
my ($result, $eval_error) = @_;
return $eval_error;
};
return eval_or_do($is_failure, @_);
}
# do function takes a block (&) sort of like CORE::do
# do will rollback on a false result as well as before re-throwing a caught die
sub do(&) {
my $is_failure = sub {
my ($result, $eval_error) = @_;
return !$result || $eval_error;
};
my ($result, $eval_error) = eval_or_do($is_failure, @_);
if ($eval_error) {
croak $eval_error, "\t...propogated";
}
return $result;
}
1;
=pod
=head1 NAME
UR::Context::Transaction - API for software transactions
=head1 SYNOPSIS
my $o = Some::Obj->create(foo => 1);
print "o's foo is ",$o->foo,"\n"; # prints 1
my $t = UR::Context::Transaction->begin();
$o->foo(4);
print "In transaction, o's foo is ",$o->foo,"\n"; # prints 4
if (&should_we_commit()) {
$t->commit();
print "Transaction committed, o's foo is ",$o->foo,"\n"; # prints 4
} else {
$t->rollback();
print "Transaction rollback, o's foo is ",$o->foo,"\n"; # prints 1
}
=head1 DESCRIPTION
UR::Context::Transaction instances represent in-memory transactions as a diff
of the contents of the object cache in the Process context. Transactions are
nestable. Their instances exist in the object cache and are subject to the
same scoping rules as other UR-based objects, meaning that they do not
disappear mearly because the lexical variable they're assigned to goes out of
scope. They must be explicitly disposed of via the commit or rollback methods.
=head1 INHERITANCE
UR::Context::Transaction is a subclass of UR::Context
=head1 CONSTRUCTOR
=over 4
=item begin
$t = UR::Context::Transaction->begin();
Creates a new software transaction context to track changes to UR-based
objects. As all activity to objects occurs in some kind of transaction
context, the newly created transaction exists within whatever context was
current before the call to begin().
=back
=head1 METHODS
=over 4
=item commit
$t->commit();
Causes all objects with changes to save those changes back to the underlying
context.
=item rollback
$t->rollback();
Causes all objects with changes to have those changes reverted to their
state when the transaction began. Classes with properties whose meta-property
is_transactional => 0 are not tracked within a transaction and will not be
reverted.
=item delete
$t->delete();
delete() is a synomym for rollback
=item has_changes
$bool = $t->has_changes();
Returns true if any UR-based objects have changes within the transaction.
=item get_changes
@changes = $t->get_changes();
Return a list or L objects representing changes within the transaction.
=back
=head1 CLASS METHODS
=over 4
=item eval
UR::Context::Transaction::eval BLOCK
Executes the BLOCK (with no arguments) wrapped by a software transaction and a
CORE::eval. If the BLOCK dies then the exception is caught and the software
transaction is rolled back.
=item do
UR::Context::Transaction::do BLOCK
Executes the BLOCK (with no arguments) wrapped by a software transaction and a
CORE::eval. If the BLOCK returns a true value and does not die then the
software transaction is committed. If the BLOCK returns false or dies then the
software transaction is rolled back.
If the BLOCK throws an exception, it will be caught, the software transaction
rolled back, and the exception will be re-thrown with die().
=back
=head1 SEE ALSO
L
=cut
DBI.pm 100664 023532 023421 70624 12544604516 13716 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR # Additional methods for DBI.
package UR::DBI;
=pod
=head1 NAME
UR::DBI - methods for interacting with a database.
=head1 SYNOPSIS
##- use UR::DBI;
UR::DBI->monitor_sql(1);
my $dbh = UR::DBI->connect(...);
=head1 DESCRIPTION
This module subclasses DBI, and provides a few extra methods useful when using a database.
=head1 METHODS
=over 4
=cut
# set up package
require 5.006_000;
use warnings;
use strict;
our $VERSION = "0.44"; # UR $VERSION;;
# set up module
use base qw(Exporter DBI);
our (@EXPORT, @EXPORT_OK);
@EXPORT = qw();
@EXPORT_OK = qw();
use IO::Handle;
use IO::File;
use Time::HiRes;
# do not use UR::ModuleBase as base class because it does not play nice with DBI
#
# UR::DBI control flags
#
# Build a few class methods to manipulate the environment variables
# that control SQL monitoring
my %sub_env_map = ( monitor_sql => 'UR_DBI_MONITOR_SQL',
monitor_dml => 'UR_DBI_MONITOR_DML',
explain_sql_if => 'UR_DBI_EXPLAIN_SQL_IF',
explain_sql_slow => 'UR_DBI_EXPLAIN_SQL_SLOW',
explain_sql_match => 'UR_DBI_EXPLAIN_SQL_MATCH',
explain_sql_callstack => 'UR_DBI_EXPLAIN_SQL_CALLSTACK',
no_commit => 'UR_DBI_NO_COMMIT',
monitor_every_fetch => 'UR_DBI_MONITOR_EVERY_FETCH',
dump_stack_on_connect => 'UR_DBI_DUMP_STACK_ON_CONNECT',
);
our ($monitor_sql,$monitor_dml,$no_commit,$monitor_every_fetch,$dump_stack_on_connect,
$explain_sql_slow,$explain_sql_if,$explain_sql_match,$explain_sql_callstack);
while ( my($subname, $envname) = each ( %sub_env_map ) ) {
no strict 'refs';
# There's a scalar of the same name as the sub to hold the value, hook them together
*{$subname} = \$ENV{$envname};
my $subref = sub {
if (@_ > 1) {
$$subname = $_[1];
}
return $$subname;
};
if ($subname =~ /explain/) {
eval "\$$subname = '' if not defined \$$subname";
}
else {
eval "\$$subname = 0 if not defined \$$subname";
}
die $@ if $@;
*$subname = $subref;
}
# by default, monitored SQL goes to STDOUT
# FIXME change this 'our' back to a 'my' after we're transisitioned off of the old App API
our $sql_fh = IO::Handle->new;
$sql_fh->fdopen(fileno(STDERR), 'w');
$sql_fh->autoflush(1);
sub sql_fh
{
$sql_fh = $_[1] if @_ > 1;
return $sql_fh;
}
#
# Logging methods
#
our $log_file;
sub log_file {
$log_file = pop if @_ > 1;
return $log_file;
}
our $log_fh;
my $create_time=0;
sub start_logging {
return 1 if(defined($log_fh));
return 0 if(-e "$log_file");
$log_fh = new IO::File("> ${log_file}");
unless(defined($log_fh)) {
warn "Logging File $log_file Could not be created\n";
return 0;
}
$create_time=Time::HiRes::time();
return 1;
}
sub stop_logging {
return 1 unless(defined($log_fh));
$log_fh->close;
undef $log_fh;
}
sub log_sql {
return 1 unless(defined($log_fh));
my $sql=pop;
my $no_timestamp=pop;
print $log_fh '=' x 10, "\n" unless($no_timestamp);
print $log_fh Time::HiRes::time()-$create_time, "\n" unless($no_timestamp);
print $log_fh $sql;
}
#
# Standard DBI overrides
#
sub connect
{
my $self = shift;
my @params = @_;
if ($monitor_sql or $dump_stack_on_connect) {
my $time = time;
my $time_string = join(' ', $time, '[' . localtime($time) . ']');
$sql_fh->print("DB CONNECT AT: $time_string");
}
if ($dump_stack_on_connect) {
$sql_fh->print(Carp::longmess());
}
$params[2] = 'xxx';
# Param 3 is usually a hashref of connection modifiers
if (ref($params[3]) and ref($params[3]) =~ m/HASH/) {
my $string = join(', ',
map { $_ . ' => ' . $params[3]->{$_} }
keys(%{$params[3]})
);
$params[3] = "{ $string }";
}
my $params_stringified = join(",", map { defined($_) ? "'$_'" : 'undef' } @params);
UR::DBI::before_execute("connecting with params: ($params_stringified)");
my $rv = $self->SUPER::connect(@_);
UR::DBI::after_execute();
return $rv;
}
#
# UR::Object hooks
#
sub commit_all_app_db_objects {
my $this_class = shift;
my $handle = shift;
my $data_source;
if ($handle->isa("UR::DBI::db")) {
$data_source = UR::DataSource::RDBMS->get_for_dbh($handle);
}
elsif ($handle->isa("UR::DBI::st")) {
$data_source = UR::DataSource::RDBMS->get_for_dbh($handle->{Database});
}
else {
Carp::confess("No handle passed to method!?")
}
unless ($data_source) {
return;
}
return $data_source->_set_all_objects_saved_committed();
}
sub rollback_all_app_db_objects {
my $this_class = shift;
my $handle = shift;
my $data_source;
if ($handle->isa("UR::DBI::db")) {
$data_source = UR::DataSource::RDBMS->get_for_dbh($handle);
}
elsif ($handle->isa("UR::DBI::st")) {
$data_source = UR::DataSource::RDBMS->get_for_dbh($handle->{Database});
}
else {
Carp::confess("No handle passed to method!?")
}
unless ($data_source) {
Carp::confess("No data source found for database handle! $handle")
}
return $data_source->_set_all_objects_saved_rolled_back();
}
my @disable_dump_and_explain;
sub _disable_dump_explain
{
push @disable_dump_and_explain,
[$monitor_sql,$explain_sql_slow,$explain_sql_match];
$monitor_sql = 0;
$explain_sql_slow = '';
$explain_sql_match = '';
}
sub _restore_dump_explain
{
if (@disable_dump_and_explain) {
my $vars = pop @disable_dump_and_explain;
($monitor_sql,$explain_sql_slow,$explain_sql_match) = @$vars;
}
else {
Carp::confess("No state saved for disabled dump/explain");
}
}
# The before_execute/after_execute subroutine pair
# are callbacks called by execute() and by other
# methods which implicitly execute a statement.
# They use these three varaibles to track state,
# presuming that the callback pair cannot be nested. print("\nEXPLAIN QUERY MATCHING /$explain_sql_match/gi"
. ($val ne $sql ? " (on value '$val') " : "")
);
if ($monitor_sql) {
$sql_fh->print("\n");
}
else {
_print_sql_and_params($sql,@_);
}
if ($explain_sql_callstack) {
$sql_fh->print(Carp::longmess("callstack begins"),"\n");
}
if ($UR::DBI::explained_queries{$sql}) {
$sql_fh->print("(query explained above)\n");
}
else {
UR::DBI::_print_query_plan($sql,$dbh);
$UR::DBI::explained_queries{$sql} = 1;
}
last;
}
}
}
my $start_time = _set_start_time();
if ($monitor_sql){
_print_sql_and_params($sql,@_);
if ($monitor_sql > 1) {
$sql_fh->print(Carp::longmess("callstack begins"),"\n");
}
_print_monitor_label("EXECUTE");
}
elsif($monitor_dml && $sql !~ /^\s*select/i){
_print_sql_and_params($sql,@_);
_print_monitor_label("EXECUTE");
$monitor_dml=2;
}
no warnings;
UR::DBI::log_sql_for_summary($sql); # $ENV{UR_DBI_SUMMARIZE_SQL}
my $log_sql_str = _generate_sql_and_params_log_entry($sql, @_);
UR::DBI::log_sql($log_sql_str);
return $start_time;
}
sub after_execute
{
#my ($sql,@params) = @_;
my $elapsed_time = _set_elapsed_time();
if ($monitor_sql){
_print_elapsed_time();
}
elsif($monitor_dml == 2){
_print_elapsed_time();
$monitor_dml = 1;
}
UR::DBI::log_sql(1, ($elapsed_time)."\n");
return $elapsed_time;
}
# The before_fetch/after_fetch pair are callback
# called by fetch() and by other methods which implicitly
# fetch data w/o explicitly calling fetch().
our $_fetching = 0;
sub before_fetch {
my $sth = shift;
return if @disable_dump_and_explain;
if ($_fetching) {
Carp::cluck("before_fetch called after another before_fetch w/o intervening after_fetch!");
}
$_fetching = 1;
my $fetch_timing_arrayref = $sth->fetch_timing_arrayref;
if ($monitor_sql) {
if ($fetch_timing_arrayref and @$fetch_timing_arrayref == 0) {
UR::DBI::_print_monitor_label('FIRST FETCH');
}
elsif ($monitor_every_fetch) {
UR::DBI::_print_monitor_label('NTH FETCH');
}
}
return UR::DBI::_set_start_time();
}
sub after_fetch {
my $sth = shift;
return if @disable_dump_and_explain;
$_fetching = 0;
my $fetch_timing_arrayref = $sth->fetch_timing_arrayref;
my $time;
push @$fetch_timing_arrayref, UR::DBI::_set_elapsed_time();
if ($monitor_sql) {
if ($monitor_every_fetch || @$fetch_timing_arrayref == 1) {
$time = UR::DBI::_print_elapsed_time();
}
}
if (@$fetch_timing_arrayref == 1) {
my $time = $sth->execute_time + $fetch_timing_arrayref->[0];
UR::DBI::_check_query_timing($sth->{Statement},$time,$sth->{Database},$sth->last_params);
}
return $time;
}
sub after_all_fetches_with_sth {
my $sth = shift;
my $fetch_timing_arrayref = $sth->fetch_timing_arrayref;
# This arrayref is set when it goes through the subclass' execute(),
# and is removed when we finish all fetches().
# Since a variety of things attempt to call this from the various "final"
# positions of an $sth we delete this so the final callback operates only once.
# Also, internally generated $sths which do not get executed() normally
# will be skipped by this check.
if (!$fetch_timing_arrayref) {
# internal sth which did not go through prepare()
#print $sql_fh "SKIP STH\n";
return;
}
$sth->fetch_timing_arrayref(undef);
my $print_fetch_summary;
if ($monitor_sql and $sth->{Statement} =~ /select/i) {
$print_fetch_summary = 1;
UR::DBI::_print_monitor_label('TOTAL EXECUTE-FETCH');
}
my $time = $sth->execute_time;
if (@$fetch_timing_arrayref) {
for my $fetch_time (@$fetch_timing_arrayref ) {
$time += $fetch_time;
}
if ($print_fetch_summary) {
UR::DBI::_print_monitor_time($time);
}
# since there WERE fetches, we already checked query timing
}
else {
if ($print_fetch_summary) {
UR::DBI::_print_monitor_time($time);
}
# since there were NOT fetches, we check query timing now
UR::DBI::_check_query_timing($sth->{Statement},$time,$sth->{Database},$sth->last_params);
}
return $time;
}
sub after_all_fetches_no_sth {
my ($sql, $time, $dbh, @params) = @_;
$time = _set_elapsed_time() unless defined $time;
if ($monitor_sql and $sql =~ /select/i) {
UR::DBI::_print_monitor_label('TOTAL EXECUTE-FETCH');
UR::DBI::_print_monitor_time($time);
}
# no sth = no fetches = no query timing check done yet...
UR::DBI::_check_query_timing($sql,$time,$dbh,@params);
return $time;
}
my $__SQL_SUMMARY__ = {};
sub log_sql_for_summary {
my ($sql) = @_;
$__SQL_SUMMARY__->{$sql}++;
}
sub print_sql_summary {
for my $sql (sort {$__SQL_SUMMARY__->{$b} <=> $__SQL_SUMMARY__->{$a}} keys %$__SQL_SUMMARY__) {
print STDERR join('',"********************\n", $__SQL_SUMMARY__->{$sql}, " instances of query: $sql\n");
}
}
# These methods are called by the above.
sub _generate_sql_and_params_log_entry
{
my $sql = shift;
no warnings;
my $sql_log_str = "\nSQL: $sql\n";
if (@_) {
$sql_log_str .= "PARAMS: ";
$sql_log_str .= join(", ",
map { defined($_) ? "'$_'" : "NULL" }
map { scalar(grep { $_ } map { 128 & ord $_ } split(//, substr($_, 0, 64))) ? '' : $_ }
@_ )
. "\n";
}
return $sql_log_str;
}
sub _print_sql_and_params
{
my $sql = shift;
my $entry = _generate_sql_and_params_log_entry($sql, @_);
no warnings;
print $sql_fh $entry;
}
sub _set_start_time
{
$start_time=&Time::HiRes::time();
}
our $_print_monitor_label_or_time_is_ready_for = "label";
sub _print_monitor_label
{
#Carp::cluck() unless $_print_monitor_label_or_time_is_ready_for eq "label";
my $time_label = shift;
$sql_fh->print("$time_label TIME: ");
$_print_monitor_label_or_time_is_ready_for = "time";
}
sub _print_monitor_time
{
#Carp::cluck() unless $_print_monitor_label_or_time_is_ready_for eq "time";
$sql_fh->printf( "%.4f s\n", shift);
$_print_monitor_label_or_time_is_ready_for = "label";
}
sub _set_elapsed_time
{
$elapsed_time = &Time::HiRes::time()-$start_time;
}
sub _print_elapsed_time
{
_print_monitor_time($elapsed_time);
}
our $_print_check_for_slow_query = 0;
sub _check_query_timing
{
my ($sql,$time,$dbh,@params) = @_;
return if @disable_dump_and_explain;
return unless $sql =~ /select/i;
print $sql_fh "CHECK FOR SLOW QUERY:\n" if $_print_check_for_slow_query; # used only by a test case
if (length($explain_sql_slow) and $time >= $explain_sql_slow) {
$sql_fh->print("EXPLAIN QUERY SLOWER THAN $explain_sql_slow seconds ($time):");
if ($monitor_sql
|| ($monitor_dml && $sql !~ /^\s*select/i)) {
$sql_fh->print("\n");
}
else {
_print_sql_and_params($sql,@params);
}
if ($explain_sql_callstack) {
$sql_fh->print(Carp::longmess("callstack begins"),"\n");
}
if ($UR::DBI::explained_queries{$sql}) {
$sql_fh->print("(query explained above)\n");
}
else {
$UR::DBI::explained_queries{$sql} = 1;
UR::DBI::_print_query_plan($sql,$dbh);
}
}
}
sub _print_query_plan
{
my ($sql,$dbh,%params) = @_;
UR::DBI::_disable_dump_explain();
$dbh->do($UR::DBI::EXPLAIN_PLAN_CLEANUP_DML);
# placeholders in explain plan queries on windows
# results in Oracle throwing an ORA-00600 error,
# likely due to interaction with DBI. Replace with
# literals.
if ($^O eq "MSWin32" || $^O eq 'cygwin') {
$sql =~ s/\?/'1'/g;
}
$dbh->do($UR::DBI::EXPLAIN_PLAN_DML . "\n" . $sql)
or die "Failed to produce query plan! " . $dbh->errstr;
UR::DBI::Report->generate(
sql => [$UR::DBI::EXPLAIN_PLAN_SQL],
dbh => $dbh,
count => 0,
outfh => $sql_fh,
%params,
"explain-sql" => 0,
"echo" => 0,
);
$sql_fh->print("\n");
$dbh->do($UR::DBI::EXPLAIN_PLAN_CLEANUP_DML);
UR::DBI::_restore_dump_explain();
return 1;
}
############
#
# Database handle subclass
#
############
package UR::DBI::db;
use strict;
use warnings;
our @ISA = qw(DBI::db);
sub commit
{
my $self = shift;
# unless ($no_commit) {
# print "\n\n\n************* FORCIBLY SETTING NO-COMMIT FOR TESTING. This would have committeed!!!! **********\n\n\n";
# $no_commit = 1;
# }
if ($no_commit)
{
# Respect the ->no_commit(1) setting.
UR::DBI::before_execute("commit (ignored)");
UR::DBI::after_execute;
return 1;
}
else
{
if(UR::DataSource->use_dummy_autogenerated_ids) {
# Not cool...you shouldn't have dummy-ids on and no-commit off
# Don't commit, and notify the authorities
UR::DBI::before_execute("commit (ignored)");
$UR::Context::current->error_message('Tried to commit with dummy-ids on and no-commit off');
UR::DBI::after_execute;
#$UR::Context::current->send_email(
# To => 'example@example.edu',
# Subject => 'attempt to commit with dummy-ids on and no-commit off '.
# "by $ENV{USER} on $ENV{HOST} running ".
# UR::Context::Process->original_program_path." as pid $$",
# Message => "Call stack:\n" .Carp::longmess()
#);
} else {
# Commit and update the associated objects.
UR::DBI::before_execute("commit");
my $rv = $self->SUPER::commit(@_);
UR::DBI::after_execute;
if ($rv) {
UR::DBI->commit_all_app_db_objects($self)
}
return $rv;
}
}
}
sub commit_without_object_update
{
UR::DBI::before_execute("commit (no object updates)");
my $rv = shift->SUPER::commit(@_);
UR::DBI::after_execute();
return $rv;
}
sub rollback
{
my $self = shift;
UR::DBI::before_execute("rollback");
my $rv = $self->SUPER::rollback(@_);
UR::DBI::after_execute();
if ($rv) {
UR::DBI->rollback_all_app_db_objects($self)
}
return $rv;
}
sub rollback_without_object_update
{
UR::DBI::before_execute("rollback (w/o object updates)");
my $rv = shift->SUPER::commit(@_);
UR::DBI::after_execute();
return $rv;
}
sub disconnect
{
my $self = shift;
# Rollback if AutoCommit is 0. Oracle commits by default on disconnect.
# Rolling back when AutoCommit is on will generate a DBI warning.
if ($self->{'AutoCommit'} == 0) {
$self->rollback;
}
# Msg and disconnect.
UR::DBI::before_execute("disconnecting");
my $rv = $self->SUPER::disconnect(@_);
UR::DBI::after_execute();
# There doesn't seem to be anything less which
# sets this, but legacy tools did
if (
(defined $UR::DBI::common_dbh)
and
($self eq $UR::DBI::common_dbh)
)
{
UR::DBI::before_execute("common dbh removed");
$UR::DBI::common_dbh = undef;
UR::DBI::after_execute("common dbh removed");
}
return $rv;
}
sub prepare
{
my $self = shift;
my $sql = $_[0];
my $sth;
#print $sql_fh "PREPARE: $sql\n";
if ($sql =~ /^\s*(commit|rollback)\s*$/i)
{
unless ($sql =~ /^(commit|rollback)$/i) {
Carp::confess("Executing a statement with an embedded commit/rollback?\n$sql\n");
}
if ($sth = $self->SUPER::prepare(@_))
{
if ($1 =~ /commit/i)
{
$UR::DBI::prepared_commit{$sth} = 1;
}
elsif ($1 =~ /rollback/)
{
$UR::DBI::prepared_rollback{$sth} = 1;
}
}
}
else
{
$sth = $self->SUPER::prepare(@_) or return;
}
return $sth;
}
# For newer versions of DBI, some of the $dbh->select* methods do not
# call execute internally, so SQL dumping and logging will not occur.
# These are listed below, and the bad ones are overridden.
# selectall_hashref ok
# selectcol_arrayref ok
# selectrow_hashref ok
# selectall_arrayref bad
# selectrow_arrayref bad
# selectrow_array bad
sub selectall_arrayref
{
my $self = shift;
my @p = ($_[0],@_[2..$#_]);
UR::DBI::before_execute($self,@p);
my $ar = $self->SUPER::selectall_arrayref(@_);
my $time = UR::DBI::after_execute($self,@p);
UR::DBI::after_all_fetches_no_sth($_[0],$time,$self,@p);
return $ar;
}
sub selectcol_arrayref
{
my $self = shift;
my @p = ($_[0],@_[2..$#_]);
UR::DBI::before_execute($self,@p);
UR::DBI::_disable_dump_explain();
my $ar = $self->SUPER::selectcol_arrayref(@_);
UR::DBI::_restore_dump_explain();
my $time = UR::DBI::after_execute($self,@p);
UR::DBI::after_all_fetches_no_sth($_[0],$time,$self,@p);
return $ar;
}
sub selectall_hashref
{
my $self = shift;
my @p = ($_[0],@_[3..$#_]);
UR::DBI::before_execute($self,@p);
UR::DBI::_disable_dump_explain();
my $ar = $self->SUPER::selectall_hashref(@_);
UR::DBI::_restore_dump_explain();
my $time = UR::DBI::after_execute($self,@p);
UR::DBI::after_all_fetches_no_sth($_[0],$time,$self,@p);
return $ar;
}
sub selectrow_arrayref
{
my $self = shift;
my @p = ($_[0],@_[2..$#_]);
UR::DBI::before_execute($self,@p);
my $ar = $self->SUPER::selectrow_arrayref(@_);
my $time = UR::DBI::after_execute($self,@p);
UR::DBI::after_all_fetches_no_sth($_[0],$time,$self,@p);
return $ar;
}
sub selectrow_array
{
my $self = shift;
my @p = ($_[0],@_[2..$#_]);
UR::DBI::before_execute($self,@p);
my @a = $self->SUPER::selectrow_array(@_);
my $time = UR::DBI::after_execute($self,@p);
UR::DBI::after_all_fetches_no_sth($_[0],$time,$self,@p);
return @a if wantarray;
return $a[0];
}
sub DESTROY
{
UR::DBI::before_execute("destroying connection");
shift->SUPER::DESTROY(@_);
UR::DBI::after_execute("destroying connection");
}
#########
#
# Statement handle subclass
#
#########
package UR::DBI::st;
use strict;
use warnings;
use Time::HiRes;
use Sys::Hostname;
use Devel::GlobalDestruction;
our @ISA = qw(DBI::st);
sub _mk_mutator {
my ($class, $method) = @_;
# Make a more specific key based on the package
# to try not to conflict with anything else.
# This must start with 'private_'. See DBI docs on subclassing.
my $hash_key = join('_', 'private', lc $class, lc $method);
$hash_key =~ s/::/_/g;
my $sub = sub {
return if Devel::GlobalDestruction::in_global_destruction;
my $sth = shift;
if (@_) {
no warnings 'uninitialized';
$sth->{$hash_key} = shift;
}
no warnings;
return $sth->{$hash_key};
};
no strict;
*{$class . '::' . $method} = $sub;
}
for my $method (qw(execute_time fetch_timing_arrayref last_params_arrayref)) {
__PACKAGE__->_mk_mutator($method);
}
sub last_params
{
my $ret = shift->last_params_arrayref;
unless (defined $ret) {
$ret = [];
}
@{ $ret };
}
sub execute
{
my $sth = shift;
# (re)-initialize the timing array
if (my $a = $sth->fetch_timing_arrayref()) {
# re-executing on a previously used $sth.
UR::DBI::after_all_fetches_with_sth($sth);
}
else {
# initialize the $sth on first execute.
$sth->fetch_timing_arrayref([]);
}
$sth->last_params_arrayref([@_]);
UR::DBI::before_execute($sth->{Database},$sth->{Statement},@_);
my $rv = $sth->SUPER::execute(@_);
UR::DBI::after_execute($sth->{Database},$sth->{Statement},@_);
# record the elapsed time for execution.
$sth->execute_time($UR::DBI::elapsed_time);
if ($rv)
{
if (my $prev = $UR::DBI::prepared_commit{$sth})
{
UR::DBI->commit_all_app_db_objects($sth);
}
if (my $prev = $UR::DBI::prepared_rollback{$sth})
{
UR::DBI->rollback_all_app_db_objects($sth);
}
}
return $rv;
}
sub fetchrow_array
{
my $sth = shift;
UR::DBI::before_fetch($sth,@_);
UR::DBI::_disable_dump_explain();
my @a = $sth->SUPER::fetchrow_array(@_);
UR::DBI::_restore_dump_explain();
UR::DBI::after_fetch($sth,@_);
return @a if wantarray;
return $a[0];
}
sub fetchrow_arrayref
{
my $sth = shift;
UR::DBI::before_fetch($sth,@_);
UR::DBI::_disable_dump_explain();
my $ar = $sth->SUPER::fetchrow_arrayref(@_);
UR::DBI::_restore_dump_explain();
UR::DBI::after_fetch($sth,@_);
return $ar;
}
sub fetchall_arrayref
{
my $sth = shift;
UR::DBI::before_fetch($sth,@_);
UR::DBI::_disable_dump_explain();
my $ar = $sth->SUPER::fetchall_arrayref(@_);
UR::DBI::_restore_dump_explain();
UR::DBI::after_fetch($sth,@_);
UR::DBI::after_all_fetches_with_sth($sth,@_);
return $ar;
}
sub fetchall_hashref
{
my $sth = shift;
my @p = @_[1,$#_];
UR::DBI::before_fetch($sth,@p);
UR::DBI::_disable_dump_explain();
my $ar = $sth->SUPER::fetchall_hashref(@_);
UR::DBI::_restore_dump_explain();
UR::DBI::after_fetch($sth,@p);
UR::DBI::after_all_fetches_with_sth($sth,@_[1,$#_]);
return $ar;
}
sub fetchrow_hashref
{
my $sth = shift;
UR::DBI::before_fetch($sth,@_);
UR::DBI::_disable_dump_explain();
my $ar = $sth->SUPER::fetchrow_hashref(@_);
UR::DBI::_restore_dump_explain();
UR::DBI::after_fetch($sth,@_);
return $ar;
}
sub fetch {
my $sth = shift;
UR::DBI::before_fetch($sth,@_);
my $rv = $sth->SUPER::fetch(@_);
UR::DBI::after_fetch($sth,@_);
return $rv;
}
sub finish {
my $sth = shift;
UR::DBI::after_all_fetches_with_sth($sth);
return $sth->SUPER::finish(@_);
}
sub DESTROY
{
delete $UR::DBI::prepared_commit{$_[0]};
delete $UR::DBI::prepared_rollback{$_[0]};
#print $sql_fh "DESTROY1\n";
UR::DBI::after_all_fetches_with_sth(@_); # does nothing if called previously by finish()
#print $sql_fh "DESTROY2\n";
#Carp::cluck();
shift->SUPER::DESTROY(@_);
}
$UR::DBI::STATEMENT_ID = $$ . '@' . hostname();
$UR::DBI::EXPLAIN_PLAN_DML = "explain plan set statement_id = '$UR::DBI::STATEMENT_ID' into plan_table for ";
$UR::DBI::EXPLAIN_PLAN_SQL = qq/
select
LPAD(' ',p.LVL-1) || OPERATION OPERATION,
OPTIONS,
--(case when p.OBJECT_OWNER is null then '' else p.OBJECT_OWNER || '.' end)
-- ||
p.OBJECT_NAME
||
(case when p.OBJECT_TYPE is null then '' else ' (' || p.OBJECT_TYPE || ')' end)
"OBJECT",
(case
when i.table_name is not null then i.table_name
|| '('
|| index_column_names
|| ')'
else ''
end) "OBJECT_IS_ON",
p.COST,
p.CARDINALITY CARD,
p.BYTES,
p.OPTIMIZER,
p.CPU_COST CPU,
p.IO_COST IO,
p.TEMP_SPACE TEMP,
i.index_type "index_type",
i.last_analyzed "index_analyzed"
from
(
SELECT plan_table.*, level lvl
FROM PLAN_TABLE
CONNECT BY prior id = parent_id AND prior statement_id = statement_id
START WITH id = 0
AND statement_id = '$UR::DBI::STATEMENT_ID'
) p
full join dual on dummy = dummy
left join all_indexes i
on i.index_name = p.object_name
and i.owner = p.object_owner
left join
(
select
index_owner,
index_name,
LTRIM(MAX(SYS_CONNECT_BY_PATH(ic.column_name,',')) KEEP (DENSE_RANK LAST ORDER BY ic.column_position),',') index_column_names
from (
select ic.index_owner, ic.index_name, ic.column_name, ic.column_position
from all_ind_columns ic
) ic
group by ic.index_owner, ic.index_name
connect by
index_owner = prior index_owner
and index_name = prior index_name
and column_position = PRIOR column_position + 1
start with column_position = 1
) index_columns_stringified
on index_columns_stringified.index_owner = i.owner
and index_columns_stringified.index_name = i.index_name
where p.object_name is not null
ORDER BY p.id
/;
$UR::DBI::EXPLAIN_PLAN_CLEANUP_DML = "delete from plan_table where statement_id = '$UR::DBI::STATEMENT_ID'";
1;
__END__
=pod
=back
=head1 SEE ALSO
UR(3), UR::DataSource::RDBMS(3), UR::Context(3), UR::Object(3)
=cut
#$Header$
Report.pm 100664 023532 023421 45170 12544604516 15167 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/DBI
=pod
=head1 NAME
UR::DBI::Report - a database report interface
=head1 SYNOPSIS
##- use UR::DBI::Report;
UR::DBI::Report->use_standard_cmdline_options();
UR::DBI::Report->generate(sql => \@ARGV);
=head1 DESCRIPTION
This module is a reporting interface which takes SQL queries in a variety of forms
and prints their results with formatting options.
=cut
use strict;
use warnings;
package UR::DBI::Report;
use base 'UR::ModuleBase';
require UR;
our $VERSION = "0.44"; # UR $VERSION;
use Data::Dumper;
use Time::HiRes;
# Support some options right on the "use" line.
sub import
{
my $class = shift;
my %params = @_;
UR::DBI::Report->extend_command_line() if delete $params{extend_command_line};
die "Unknown options passed-to " . __PACKAGE__ . join(", ", keys %params) if keys %params;
}
# Applications which do no additional configuration will get these parameters by default.
our %module_default_params =
(
delimit => 'spaces',
header => 1,
count => 1,
orient => 'vert',
trunc => 35,
sloppy => 0,
nulls => 1,
data => 1,
combine => 0,
"explain-sql" => 0,
);
# Applications which call this method before init() will allow the user
# to override reporting defaults via standard command line options.
our %application_default_params = %module_default_params;
sub extend_command_line
{
# this callback processes all of the options and sets application defaults for this module
my $parse_option_callback;
$parse_option_callback =
sub
{
my ($flag,$value) = @_;
if ($flag eq 'parse')
{
$parse_option_callback->("header",!$value);
$parse_option_callback->("count",!$value);
$parse_option_callback->("delimit",($value ? "tabs" : "spaces"));
$parse_option_callback->("trunc",($value ? undef : $application_default_params{"trunc"}));
return 1;
}
$application_default_params{$flag} = $value;
return 1;
};
# ask Getopt to expect some new cmdline parameters
UR::Command::Param->add(
map {
if (ref($_)) {
$_->{module} = "Data Report Formatting"
}
$_;
}
delimit =>
{
action => $parse_option_callback,
msg => "spaces|tabs: spaces separate columns evenly, tab-delimited columns are easiliy parsed",
argument => '=s',
option => '--delimit',
},
header =>
{
action => $parse_option_callback,
msg => "Show column headers.",
argument => '!',
option => '--header',
},
data =>
{
action => $parse_option_callback,
msg => "Show returned query data (on by default!).",
argument => '!',
option => '--data',
},
count =>
{
action => $parse_option_callback,
msg => "Show row count at the end of output.",
argument => '!',
option => '--count',
},
orient =>
{
action => $parse_option_callback,
msg => "vert: (default) one row per output line, horiz: one row per output column.",
argument => '=s',
option => '--orient',
},
trunc =>
{
action => $parse_option_callback,
msg => "Set column truncation for long values. A zero setting truncates at the level of the default DBI LongReadLen; see DBI documentation for details.",
argument => '=s',
option => '--trunc',
},
sloppy =>
{
action => $parse_option_callback,
msg => "When processing multiple SQL statements and a failure occurs, just proceed to the next statement.",
argument => '!',
option => '--sloppy',
},
nulls =>
{
action => $parse_option_callback,
msg => "Show nulls. When turned-off with 'no-nulls' replaces them with a ?.",
argument => '!',
option => '--nulls',
},
parse =>
{
action => $parse_option_callback,
msg => "Equivalent to --noheader --nocount --tabs --trunc=0",
argument => '!',
option => '--parse',
},
echo =>
{
action => $parse_option_callback,
msg => "Print SQL before its first execution. Does not print multiple times on multiple executes with different params.",
argument => '!',
option => '--echo',
},
combine =>
{
action => $parse_option_callback,
msg => "When executing the same query multiple times with different params, combine the results as though it were one query.",
argument => '!',
option => '--combine',
},
"explain-sql" =>
{
action => $parse_option_callback,
msg => "Dump a query plan instead of running the query.",
argument => '!',
option => '--explain-sql',
}
);
}
#
# This method executes the specified sql statements and prints reports for each.
#
sub generate
{
my $class = shift;
my %params = (%application_default_params, @_);
my $sql_param = delete $params{sql};
my @queries = (ref($sql_param) ? (@$sql_param) : ($sql_param) );
my $dbh = delete $params{dbh};
unless ($dbh) {
Carp::confess("No dbh sent to UR::DBI::Report, and no default available anymore!");
}
$dbh->{LongTruncOk} = 1;
if ($params{trunc})
{
$dbh->{LongReadLen} = $params{trunc};
}
elsif(defined($params{trunc}))
{
warn "Setting the trunc value to 0 does not guarantee no truncating.";
warn "There is no way to completely prevent truncating in the current version of DBI.";
warn "The current trunc limit is $dbh->{LongReadLen}.";
warn "If this does not satisfy your needs, try setting trunc to a higher number";
}
# The outer loop runs once per SQL statement.
my $sql_request;
while($sql_request = shift(@queries))
{
# The SQL comes from the cmdline or STDIN.
my $sql;
if ($sql_request eq '-')
{
$sql = '';
while ()
{
next if (/^#!/);
if (/;\s*$/)
{
s/;\s*$//;
$sql .= $_;
last;
}
else
{
$sql .= $_;
}
}
}
else
{
$sql = $sql_request;
}
next if ($sql !~ /\S/);
chomp($sql);
print "SQLRUN: $sql\n" if $params{echo};
# See if we expect paramters from STDIN
my $question_marks = $sql;
$question_marks =~ s/[^\?]//msg;
my $question_mark_count = length($question_marks);
if ($params{"explain-sql"}) {
my $outfh = IO::Handle->new;
$outfh->fdopen(fileno(STDOUT), 'w');
UR::DBI::_print_query_plan($sql,$dbh,outfh => $outfh,%params);
# skip past any parameters, since we're not really executing,
# and they don't (can't) affect the query plan
if ($question_mark_count)
{
my $data;
while (1)
{
$data = ;
chomp $data;
last unless (defined($data) and length($data));
}
}
# redo if we're reading from stdin, otherwise go to the next specified cmd
if ($sql_request eq '-') {
redo;
}
else {
next;
}
}
# This will never get re-prepared
my $sth = $dbh->prepare_cached($sql);
unless($sth)
{
if ($params{sloppy})
{
App::UI->error_message($dbh->errstr);
next;
}
else
{
die $dbh->errstr;
}
}
# This flag may be set after the first parameter set runs to speed further executions.
# The inner loop runs once per required execution of the SQL.
# SQL is executed multiple times if there are ? placeholders and there are multiple lines on STDIN
my ($combine_row_count, $combine_time)=(0, 0);
my $sql_execution_count = 0;
my $statement_is_not_a_query = 0;
my $outfh = $params{outfh};
for (1)
{
# Get params from STDIN if necessary
my @params;
if ($question_mark_count)
{
# Get data from STDIN as needed for any ?s.
my $data = ;
chomp $data if defined($data);
# If we have a ? count and there is no data on this line, we're done with this SQL statement.
unless (defined($data) and length($data))
{
# We want to warn the user if a SQL statement had no params at all.
if ($sql_execution_count == 0)
{
$class->error_message("No params!");
}
# On to the next staement, if there is one.
last;
}
@params = split(/\t/, $data);
$#params = $question_mark_count - 1;
if ($params{echo})
{
print "PARAMS: @params\n";
}
}
# Note the time so we can show the elapsed time.
my $t1 = Time::HiRes::time();
# Execute the current statement with the parameters.
my $execcnt;
unless ($execcnt = $sth->execute(@params))
{
my $msg = "Failed to execute SQL:\n$sql\n" . (@params ? "Data:\n>" . join(",",@params) . "<\n" : '') . $sth->errstr;
if ($params{sloppy})
{
App::UI->error_message($msg);
}
else
{
die $msg;
}
}
# Count these for better error messaging.
$sql_execution_count++;
# Count results returned (SQL) or affected (DML).
my $rowcnt;
# This flag may not be set until we try to get the first result.
unless ($statement_is_not_a_query)
{
$rowcnt = UR::DBI::Report->print_formatted(
sth => $sth,
outfh => $outfh,
(
$params{combine}
? (position_in_combined_sql_list => $sql_execution_count)
:()
),
%params
);
$statement_is_not_a_query = 1 if defined($rowcnt) and ($rowcnt eq "0 because the statement is not a query");
}
# Flush any data pending to the output filter.
if (ref($outfh) and not $params{combine} and not $params{outfh}) {
$outfh->close;
$outfh = undef;
}
$sth->finish;
# Summarize the effect of the query/dml.
if ($params{count}) {
if($params{combine}) {
#If we're doing a combined output, we'll have to tally these up for later
$combine_row_count+=$statement_is_not_a_query?($execcnt+0):($rowcnt+0);
$combine_time+=Time::HiRes::time()-$t1;
} else {
my $td = Time::HiRes::time() - $t1;
$td =~ s/(\.\d\d\d).*/$1/;
if ($statement_is_not_a_query)
{
print (($execcnt+0) . " row(s) affected. Execution time: ${td} second(s).\n");
}
else
{
print (($rowcnt+0) . " row(s) returned. Execution time: ${td} second(s).\n");
}
}
}
# By default this block will execute just once.
# Continue if there is a question_mark_count.
# It will "last" out at the top if there is no more data on stdin.
redo if $question_mark_count;
} # end params loop
if ($params{combine}) {
$outfh->close if ref($outfh) and not $params{outfh};
if ($params{count})
{
$combine_time=~s/(\.\d\d\d).*/$1/;
print("$combine_row_count row(s) ".($statement_is_not_a_query?'affected':'returned').
". Execution time: $combine_time second(s).\n");
}
}
# If the cmdline sql was a dash, we're reading from STDIN until it exits the loop.
redo if $sql_request eq '-';
} # end SQL loop
# Done executing all SQL.
return 1;
} # end of sqlrun subroutine
# This method prints a single report for a given statement handle.
sub print_formatted
{
my $class = shift;
my %params = (%application_default_params, @_);
# sth A statement handle from which the data comes.
# sql If no handle is specified, the SQL to use.
# infh If no sth or sql is specified, a handle from which sql can be pulled.
# If sth or sql ARE specifed, a handle from which parameter values can be pulled.
my $sth = delete $params{sth};
unless ($sth) {
}
# outfh An optional handle to which the report is written.
my $outfh = delete $params{outfh};
if ($outfh) {
if ($params{delimit} =~ /^s/i && $^O ne "MSWin32" && $^O ne 'cygwin')
{
# We only handle one case of $outfh and still do tab2col.
# If it's stderr, we redirect there.
$outfh = IO::File->new('| tab2col --nocount 1>&' . fileno($outfh));
Carp::confess("Failed to pipe through tab2col!") unless $outfh;
}
}
else {
if ($params{delimit} =~ /^s/i)
{
# Handle tab-delimit via tab2col
$outfh = IO::File->new("| tab2col --nocount");
}
else
{
$outfh = IO::Handle->new;
$outfh->fdopen(fileno(STDOUT), 'w');
}
}
# This is the return value.
# Set to an integer, or to the false-valued string "0 because the statement is not a query".
my $rowcnt = 0;
# Get the column names into an array of headers.
my @headers = @{ $sth->{NAME_uc} };
# Display as needed according the requested orientation.
if ($params{orient} =~ /^v/i) # lines listed vertically
{
# Get the first row, but re-hook warnings first to see if we
# are really running a query wich can return data (not DML).
my $msg;
local $SIG{__WARN__} = sub { $msg = shift };
my $row = $sth->fetchrow_arrayref;
if ($msg =~ /ERROR no statement executing/)
{
# Set this flag so we do not re-try fetch*() on this query.
return "0 because the statement is not a query";
}
elsif ($sth->errstr) {
die $sth->errstr;
}
else
{
if ($params{data})
{
# Spacers are dashes.
my @spacers = @headers;
for (@spacers) { $_ =~ s/./-/g }
# Print the headers, a line of spacers, then one line for each result row.
if ($params{header} and not ($params{combine} and $params{position_in_combined_sql_list} > 1))
{
if (my $trunc = $params{trunc})
{
for my $row (\@headers, \@spacers)
{
print $outfh join("\t", map { substr($_,0,$trunc) } @$row) . "\n";
}
}
else
{
for my $row (\@headers, \@spacers)
{
print $outfh join("\t",@$row) . "\n";
}
}
}
# Print the initial row, and any others we can fetch().
while ($row)
{
print $outfh join("\t",@$row) . "\n";
$rowcnt++;
$row = $sth->fetchrow_arrayref;
}
}
else
{
# Just get the count
while ($row) { $rowcnt++; $row = $sth->fetchrow_arrayref }
}
}
}
elsif ($params{orient} =~ /^h/i)
{
my $msg;
local $SIG{__WARN__} = sub { $msg = shift };
my $results = $sth->fetchall_arrayref;
if ($msg =~ /ERROR no statement executing/)
{
# Set this flag so we do not re-try fetch*() on this query.
return "0 because the statement is not a query";
}
else
{
# Process the fetched data.
$rowcnt = scalar(@$results);
if ($params{data})
{
# Show the data
my $cnum = 0;
if (my $trunc = $params{trunc})
{
for my $header (@headers)
{
print $outfh $header . "\t:\t" if ($params{header});
print $outfh join("\t", map { substr($_->[$cnum],0,$trunc) } @$results) . "\n";
$cnum++;
}
}
else
{
for my $header (@headers)
{
$outfh->print($header . "\t:\t") if ($params{header});
$outfh->print(join("\t", map { $_->[$cnum] } @$results) . "\n");
$cnum++;
}
}
}
}
}
else
{
$class->error_message("Unknown orientation $params{orient}");
return;
}
return $rowcnt;
}
1;
DataSource.pm 100664 023532 023421 64470 12544604516 15354 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR package UR::DataSource;
use strict;
use warnings;
require UR;
our $VERSION = "0.44"; # UR $VERSION;
use Sys::Hostname;
{
no warnings 'once';
*namespace = \&get_namespace;
}
UR::Object::Type->define(
class_name => 'UR::DataSource',
is_abstract => 1,
doc => 'A logical database, independent of prod/dev/testing considerations or login details.',
has => [
namespace => { calculate_from => ['id'] },
is_connected => { is => 'Boolean', default_value => 0, is_optional => 1, is_transient => 1 },
get_default_handle => {
is_calculated => 1,
is_constant => 1,
doc => 'Underlying handle for this datasource',
calculate => '$self->create_default_handle_wrapper',
},
],
valid_signals => ['precreate_handle', 'create_handle', 'predisconnect_handle', 'disconnect_handle' ],
);
our @CARP_NOT = qw(UR::Context UR::DataSource::QueryPlan);
sub define { shift->__define__(@_) }
sub get_namespace {
my $class = shift->class;
return substr($class,0,index($class,"::DataSource"));
}
sub get_name {
my $class = shift->class;
return lc(substr($class,index($class,"::DataSource")+14));
}
# The default used to be to force table/column/constraint/etc names to
# upper case when storing them in the MetaDB, and in the column_name
# metadata for properties. The new behavior is to just use whatever the
# database supplies us when interrogating the data dictionary.
# For datasources/clases that still need the old behavior, override this
# to make the column_name metadata for properties forced to upper-case
sub table_and_column_names_are_upper_case { 0; }
# Basic, dumb data sources do not support joins within a single
# query. Instead the Context logic can perform a cross datasource
# join within irs own code
sub does_support_joins { 0; }
# Most datasources do not support recursive queries
# Oracle and Postgres do, but in different ways
# For data sources without support, it'll have to do multiple queries
# to get all the data
sub does_support_recursive_queries { ''; }
{
no warnings 'once';
*create_dbh = \&create_default_handle_wrapper;
}
sub create_default_handle_wrapper {
my $self = UR::Util::object(shift);
$self->__signal_observers__('precreate_handle');
my $h = $self->create_default_handle;
$self->__signal_observers__('create_handle', $h);
# Hack - This is to avoid infinite recursion in the case where the
# handle initializers below try to get the hadle by calling $ds->get_default_handle.
# The cached/calculated accessor code will look in this hash key and
# return the handle instead of recursing back into the handle creation, and
# back to here
$self->{get_default_handle} = $h;
# Backward compatability for older code that still uses _init_created_dbh
if ($self->can('_init_created_dbh')) {
$self->_init_created_dbh($h);
} else {
$self->init_created_handle($h);
}
return $h;
}
# basic, dumb datasources do not have a handle
sub create_default_handle { undef }
sub disconnect { }
# derived classes can implement this to do extra initialization after the
# handle is created
sub init_created_handle { 1; }
# Peek into the object and see if there's anything in 'get_default_handle' without actually
# creating a handle
*has_default_dbh = \&has_default_handle;
sub has_default_handle {
my $self = UR::Util::object(shift);
return exists($self->{get_default_handle});
}
*disconnect_default_dbh = \&disconnect_default_handle;
sub disconnect_default_handle {
my $self = shift;
if ($self->has_default_handle) {
$self->__signal_observers__('predisconnect_handle');
$self->disconnect();
$self->__signal_observers__('disconnect_handle');
}
1;
}
our $use_dummy_autogenerated_ids;
*use_dummy_autogenerated_ids = \$ENV{UR_USE_DUMMY_AUTOGENERATED_IDS};
sub use_dummy_autogenerated_ids {
# This allows the saved SQL from sync database to be comparable across executions.
# It also
my $class = shift;
if (@_) {
($use_dummy_autogenerated_ids) = @_;
}
$use_dummy_autogenerated_ids ||= 0; # Replace undef with 0
return $use_dummy_autogenerated_ids;
}
our $last_dummy_autogenerated_id;
sub next_dummy_autogenerated_id {
unless($last_dummy_autogenerated_id) {
my $hostname = hostname();
$hostname =~ /(\d+)/;
my $id = $1 ? $1 : 1;
$last_dummy_autogenerated_id = ($id * -10_000_000) - ($$ * 1_000);
}
#limit id to fit within 11 characters
($last_dummy_autogenerated_id) = $last_dummy_autogenerated_id =~ m/(-\d{1,10})/;
return --$last_dummy_autogenerated_id;
}
sub autogenerate_new_object_id_for_class_name_and_rule {
my $ds = shift;
if (ref $ds) {
$ds = ref($ds) . " ID " . $ds->id;
}
# Maybe we could use next_dummy_autogenerated_id instead?
die "Data source $ds did not implement autogenerate_new_object_id_for_class_name_and_rule()";
}
# UR::Context needs to know if a data source supports savepoints
sub can_savepoint {
my $class = ref($_[0]);
die "Class $class didn't supply can_savepoint()";
}
sub set_savepoint {
my $class = ref($_[0]);
die "Class $class didn't supply set_savepoint, but can_savepoint is true";
}
sub rollback_to_savepoint {
my $class = ref($_[0]);
die "Class $class didn't supply rollback_to_savepoint, but can_savepoint is true";
}
sub _get_class_data_for_loading {
my ($self, $class_meta) = @_;
my $class_data = $class_meta->{loading_data_cache};
unless ($class_data) {
$class_data = $self->_generate_class_data_for_loading($class_meta);
}
return $class_data;
}
sub _resolve_query_plan {
my ($self, $rule_template) = @_;
my $qp = UR::DataSource::QueryPlan->get(
rule_template => $rule_template,
data_source => $self,
);
$qp->_init() unless $qp->_is_initialized;
return $qp;
}
# Child classes can override this to return a different datasource
# depending on the rule passed in
sub resolve_data_sources_for_rule {
return $_[0];
}
sub _generate_class_data_for_loading {
my ($self, $class_meta) = @_;
my $class_name = $class_meta->class_name;
my $ghost_class = $class_name->ghost_class;
my @all_id_property_names = $class_meta->all_id_property_names();
my @id_properties = $class_meta->id_property_names;
my $id_property_sorter = $class_meta->id_property_sorter;
my @class_hierarchy = ($class_meta->class_name,$class_meta->ancestry_class_names);
my @parent_class_objects = $class_meta->ancestry_class_metas;
my $sub_classification_method_name;
my ($sub_classification_meta_class_name, $subclassify_by);
my @all_properties;
my $first_table_name;
my %seen;
for my $co ( $class_meta, @parent_class_objects ) {
next if ($seen{ $co->id })++;
my $table_name = $co->table_name || '__default__';
$first_table_name ||= $table_name;
$sub_classification_method_name ||= $co->sub_classification_method_name;
$sub_classification_meta_class_name ||= $co->sub_classification_meta_class_name;
$subclassify_by ||= $co->subclassify_by;
my $sort_sub = sub ($$) { return $_[0]->property_name cmp $_[1]->property_name };
push @all_properties, map { [$co, $_, $table_name, 0]} sort $sort_sub UR::Object::Property->get(class_name => $co->class_name);
}
my $sub_typing_property = $class_meta->subclassify_by;
my $class_table_name = $class_meta->table_name;
my $class_data = {
class_name => $class_name,
ghost_class => $class_name->ghost_class,
parent_class_objects => [$class_meta->ancestry_class_metas], ##
sub_classification_method_name => $sub_classification_method_name,
sub_classification_meta_class_name => $sub_classification_meta_class_name,
subclassify_by => $subclassify_by,
all_properties => \@all_properties,
all_id_property_names => [$class_meta->all_id_property_names()],
id_properties => [$class_meta->id_property_names],
id_property_sorter => $class_meta->id_property_sorter,
sub_typing_property => $sub_typing_property,
# these seem like they go in the RDBMS subclass, but for now the
# "table" concept is stretched to mean any valid structure identifier
# within the datasource.
first_table_name => $first_table_name,
class_table_name => $class_table_name,
};
return $class_data;
}
sub _generate_loading_templates_arrayref {
# Each entry represents a table alias in the query.
# This accounts for different tables, or multiple occurrances
# of the same table in a join, by grouping by alias instead of
# table.
my $class = shift;
my $db_cols = shift;
my $obj_joins = shift;
my $bxt = shift;
use strict;
use warnings;
my %obj_joins_by_source_alias;
if (0) { # ($obj_joins) {
my @obj_joins = @$obj_joins;
while (@obj_joins) {
my $foreign_alias = shift @obj_joins;
my $data = shift @obj_joins;
for my $foreign_property_name (sort keys %$data) {
next if $foreign_property_name eq '-is_required';
my $source_alias = $data->{$foreign_property_name}{'link_alias'};
my $detail = $obj_joins_by_source_alias{$source_alias}{$foreign_alias} ||= {};
# warnings come from the above because we don't have 'link_alias' in filters.
my $source_property_name = $data->{$foreign_property_name}{'link_property_name'};
if ($source_property_name) {
# join
my $links = $detail->{links} ||= [];
push @$links, $foreign_property_name, $source_property_name;
}
if (exists $data->{value}) {
# filter
my $operator = $data->{operator};
my $value = $data->{value};
my $filter = $detail->{filter} ||= [];
my $key = $foreign_property_name;
$key .= ' ' . $operator if $operator;
push @$filter, $key, $value;
}
}
}
}
else {
#Carp::cluck("no obj joins???");
}
my %templates;
my $pos = 0;
my @templates;
my %alias_object_num;
for my $col_data (@$db_cols) {
my ($class_obj, $prop, $table_alias, $object_num) = @$col_data;
unless (defined $object_num) {
die "No object num for loading template data?!";
}
#Carp::confess() unless $table_alias;
my $template = $templates[$object_num];
unless ($template) {
$template = {
object_num => $object_num,
table_alias => $table_alias,
data_class_name => $class_obj->class_name,
final_class_name => $class_obj->class_name,
property_names => [],
column_positions => [],
id_property_names => undef,
id_column_positions => [],
id_resolver => undef, # subref
};
$templates[$object_num] = $template;
$alias_object_num{$table_alias} = $object_num;
}
push @{ $template->{property_names} }, $prop->property_name;
push @{ $template->{column_positions} }, $pos;
$pos++;
}
# remove joins that resulted in no template, such as when it was to a table-less class
@templates = grep { $_ } @templates;
# Post-process the template objects a bit to get the exact id positions.
for my $template (@templates) {
my @id_property_names;
for my $id_class_name ($template->{data_class_name}, $template->{data_class_name}->inheritance) {
my $id_class_obj = UR::Object::Type->get(class_name => $id_class_name);
last if @id_property_names = $id_class_obj->id_property_names;
}
$template->{id_property_names} = \@id_property_names;
my @id_column_positions;
for my $id_property_name (@id_property_names) {
for my $n (0..$#{ $template->{property_names} }) {
if ($template->{property_names}[$n] eq $id_property_name) {
push @id_column_positions, $template->{column_positions}[$n];
last;
}
}
}
$template->{id_column_positions} = \@id_column_positions;
if (@id_column_positions == 1) {
$template->{id_resolver} = sub {
return $_[0][$id_column_positions[0]];
}
}
elsif (@id_column_positions > 1) {
my $class_name = $template->{data_class_name};
$template->{id_resolver} = sub {
my $self = shift;
return $class_name->__meta__->resolve_composite_id_from_ordered_values(@$self[@id_column_positions]);
}
}
else {
Carp::croak("Can't determine which columns will hold the ID property data for class "
. $template->{data_class_name} . ". It's ID properties are (" . join(', ', @id_property_names)
. ") which do not appear in the class' property list (" . join(', ', @{$template->{'property_names'}}).")");
}
my $source_alias = $template->{table_alias};
if (0 and my $join_data_for_source_table = $obj_joins_by_source_alias{$source_alias}) {
# there are joins which come from this entity to other entities
# as these entities are loaded, remember the individual queries covered by this object returning
# NOTE: when we join a <> b, we remember that we've loaded all of the b for a when _a_ loads, not b,
# since it's possible that there ar zero of b, and we don't want to perform the query for b
my $source_object_num = $template->{object_num};
my $source_class_name = $template->{data_class_name};
my $next_joins = $template->{next_joins} ||= [];
for my $foreign_alias (keys %$join_data_for_source_table) {
my $foreign_object_num = $alias_object_num{$foreign_alias};
Carp::confess("no alias for $foreign_alias?") if not defined $foreign_object_num;
my $foreign_template = $templates[$foreign_object_num];
my $foreign_class_name = $foreign_template->{data_class_name};
my $join_data = $join_data_for_source_table->{$foreign_alias};
my %links = map { $_ ? @$_ : () } $join_data->{links};
my %filters = map { $_ ? @$_ : () } $join_data->{filters};
my @keys = sort (keys %links, keys %filters);
my @value_position_source_property;
for (my $n = 0; $n < @keys; $n++) {
my $key = $keys[$n];
if ($links{$key} and $filters{$key}) {
Carp::confess("unexpected same key $key in filters and joins");
}
my $source_property_name = $links{$key};
next unless $source_property_name;
push @value_position_source_property, $n, $source_property_name;
}
my $bx = $foreign_class_name->define_boolexpr(map { $_ => $filters{$_} } @keys);
my ($bxt, @values) = $bx->template_and_values();
push @$next_joins, [ $bxt->id, \@values, \@value_position_source_property ];
}
}
}
return \@templates;
}
sub create_iterator_closure_for_rule_template_and_values {
my ($self, $rule_template, @values) = @_;
my $rule = $rule_template->get_rule_for_values(@values);
return $self->create_iterator_closure_for_rule($rule);
}
sub _reclassify_object_loading_info_for_new_class {
my $self = shift;
my $loading_info = shift;
my $new_class = shift;
my $new_info;
%$new_info = %$loading_info;
foreach my $template_id (keys %$loading_info) {
my $target_class_rules = $loading_info->{$template_id};
foreach my $rule_id (keys %$target_class_rules) {
my $pos = index($rule_id,'/');
$new_info->{$template_id}->{$new_class . "/" . substr($rule_id,$pos+1)} = 1;
}
}
return $new_info;
}
sub _get_object_loading_info {
my $self = shift;
my $obj = shift;
my %param_load_hash;
if ($obj->{'__load'}) {
while( my($template_id, $rules) = each %{ $obj->{'__load'} } ) {
foreach my $rule_id ( keys %$rules ) {
$param_load_hash{$template_id}->{$rule_id} = $UR::Context::all_params_loaded->{$template_id}->{$rule_id};
}
}
}
return \%param_load_hash;
}
sub _add_object_loading_info {
my $self = shift;
my $obj = shift;
my $param_load_hash = shift;
while( my($template_id, $rules) = each %$param_load_hash) {
foreach my $rule_id ( keys %$rules ) {
$obj->{'__load'}->{$template_id}->{$rule_id} = $rules->{$rule_id};
}
}
}
# same as add_object_loading_info, but manipulates the data in $UR::Context::all_params_loaded
sub _record_that_loading_has_occurred {
my $self = shift;
my $param_load_hash = shift;
while( my($template_id, $rules) = each %$param_load_hash) {
foreach my $rule_id ( keys %$rules ) {
$UR::Context::all_params_loaded->{$template_id}->{$rule_id} ||=
$rules->{$rule_id};
}
}
}
sub _first_class_in_inheritance_with_a_table {
# This is called once per subclass and cached in the subclass from then on.
my $self = shift;
my $class = shift;
$class = ref($class) if ref($class);
unless ($class) {
Carp::confess("No class?");
}
my $class_object = $class->__meta__;
my $found = "";
for ($class_object, $class_object->ancestry_class_metas)
{
if ($_->table_name)
{
$found = $_->class_name;
last;
}
}
#eval qq/
# package $class;
# sub _first_class_in_inheritance_with_a_table {
# return '$found' if \$_[0] eq '$class';
# shift->SUPER::_first_class_in_inheritance_with_a_table(\@_);
# }
#/;
#die "Error setting data in subclass: $@" if $@;
return $found;
}
sub _class_is_safe_to_rebless_from_parent_class {
my ($self, $class, $was_loaded_as_this_parent_class) = @_;
my $fcwt = $self->_first_class_in_inheritance_with_a_table($class);
unless ($fcwt) {
Carp::croak("Can't call _class_is_safe_to_rebless_from_parent_class(): Class $class has no parent classes with a table");
}
return ($was_loaded_as_this_parent_class->isa($fcwt));
}
sub ur_datasource_class_for_dbi_connect_string {
my($class, $dsn) = @_;
my(undef, $driver) = DBI->parse_dsn($dsn);
$driver
|| Carp::croak("Could not parse DBI driver out of connect string $dsn");
return 'UR::DataSource::'.$driver;
}
sub _get_current_entities {
my $self = shift;
my @class_meta = UR::Object::Type->is_loaded(
data_source_id => $self->id
);
my @objects;
for my $class_meta (@class_meta) {
next unless $class_meta->generated(); # Ungenerated classes won't have any instances
my $class_name = $class_meta->class_name;
push @objects, $UR::Context::current->all_objects_loaded($class_name);
}
return @objects;
}
sub _prepare_for_lob { };
sub _set_specified_objects_saved_uncommitted {
my ($self,$objects_arrayref) = @_;
# Sets an objects as though the has been saved but tha changes have not been committed.
# This is called automatically by _sync_databases.
my %objects_by_class;
my $class_name;
for my $object (@$objects_arrayref) {
$class_name = ref($object);
$objects_by_class{$class_name} ||= [];
push @{ $objects_by_class{$class_name} }, $object;
}
for my $class_name (sort keys %objects_by_class) {
my $class_object = $class_name->__meta__;
my @property_names =
map { $_->property_name }
grep { $_->column_name }
$class_object->all_property_metas;
for my $object (@{ $objects_by_class{$class_name} }) {
$object->{db_saved_uncommitted} ||= {};
my $db_saved_uncommitted = $object->{db_saved_uncommitted};
for my $property ( @property_names ) {
$db_saved_uncommitted->{$property} = $object->$property;
}
}
}
return 1;
}
sub _set_all_objects_saved_committed {
# called by UR::DBI on commit
my $self = shift;
return $self->_set_specified_objects_saved_committed([ $self->_get_current_entities ]);
}
sub _set_all_specified_objects_saved_committed {
my $self = shift;
my($pkg, $file, $line) = caller;
Carp::carp("Deprecated method _set_all_specified_objects_saved_committed called at file $file line $line. The new name for this method is _set_specified_objects_saved_committed");
my @changed_objects = @_;
$self->_set_specified_objects_saved_committed(\@changed_objects);
}
sub _set_specified_objects_saved_committed {
my $self = shift;
my $objects = shift;
# Two step process... set saved and committed, then fire commit observers.
# Doing so prevents problems should any of the observers themselves commit.
my @saved_objects;
for my $obj (@$objects) {
my $saved = $self->_set_object_saved_committed($obj);
push @saved_objects, $saved if $saved;
}
for my $obj (@saved_objects) {
next if $obj->isa('UR::DeletedRef');
$obj->__signal_change__('commit');
if ($obj->isa('UR::Object::Ghost')) {
$UR::Context::current->_abandon_object($obj);
}
}
return scalar(@$objects) || "0 but true";
}
sub _set_object_saved_committed {
# called by the above, and some test cases
my ($self, $object) = @_;
if ($object->{db_saved_uncommitted}) {
unless ($object->isa('UR::Object::Ghost')) {
%{ $object->{db_committed} } = (
($object->{db_committed} ? %{ $object->{db_committed} } : ()),
%{ $object->{db_saved_uncommitted} }
);
delete $object->{db_saved_uncommitted};
}
return $object;
}
else {
return;
}
}
sub _set_all_objects_saved_rolled_back {
# called by UR::DBI on commit
my $self = shift;
my @objects = $self->_get_current_entities;
for my $obj (@objects) {
unless ($self->_set_object_saved_rolled_back($obj)) {
die "An error occurred setting " . $obj->__display_name__
. " to match the rolled-back database state. Exiting...";
}
}
}
sub _set_specified_objects_saved_rolled_back {
my $self = shift;
my $objects = shift;
for my $obj (@$objects) {
unless ($self->_set_object_saved_rolled_back($obj)) {
die "An error occurred setting " . $obj->__display_name__
. " to match the rolled-back database state. Exiting...";
}
}
}
sub _set_object_saved_rolled_back {
# called by the above, and some test cases
my ($self,$object) = @_;
delete $object->{db_saved_uncommitted};
return $object;
}
# These are part of the basic DataSource API. Subclasses will want to override these
sub _sync_database {
my $class = shift;
my %args = @_;
$class = ref($class) || $class;
$class->warning_message("Data source $class does not support saving objects to storage. " .
scalar(@{$args{'changed_objects'}}) . " objects will not be saved");
return 1;
}
sub commit {
my $class = shift;
my %args = @_;
$class = ref($class) || $class;
#$class->warning_message("commit() ignored for data source $class");
return 1;
}
sub rollback {
my $class = shift;
my %args = @_;
$class = ref($class) || $class;
$class->warning_message("rollback() ignored for data source $class");
return 1;
}
# When the class initializer is create property objects, it will
# auto-fill-in column_name if the class definition has a table_name.
# File-based data sources do not have tables (and so classes using them
# do not have table_names), but the properties still need column_names
# so loading works properly.
# For now, only UR::DataSource::File and ::FileMux set this.
# FIXME this method's existence is ugly. Find a better way to fill in
# column_name for those properties, or fix the data sources to not
# require column_names to be set by the initializer
sub initializer_should_create_column_name_for_class_properties {
return 0;
}
# Subclasses should override this.
# It's called by the class initializer when the data_source property in a class
# definition contains a hashref with an 'is' key. The method should accept this
# hashref, create a data_source instance (if appropriate) and return the class_name
# of this new datasource.
sub create_from_inline_class_data {
my ($class,$class_data,$ds_data) = @_;
my %ds_data = %$ds_data;
my $ds_class_name = delete $ds_data{is};
unless (my $ds_class_meta = UR::Object::Type->get($ds_class_name)) {
die "No class $ds_class_name found!";
}
my $ds = $ds_class_name->__define__(%ds_data);
unless ($ds) {
die "Failed to construct $ds_class_name: " . $ds_class_name->error_message();
}
return $ds;
}
sub ur_data_type_for_data_source_data_type {
my($class,$type) = @_;
return [undef,undef]; # The default that should give reasonable behavior
}
# prepare_for_fork, do_after_fork_in_child, and finish_up_after_fork are no-op
# here in the UR::DataSource base class and should be implented in subclasses
# as needed.
sub prepare_for_fork { return 1 }
sub do_after_fork_in_child { return 1 }
sub finish_up_after_fork { return 1 }
sub _resolve_owner_and_table_from_table_name {
my($self, $table_name) = @_;
# Basic data sources don't know about owners/schemas
return (undef, $table_name);
}
sub _resolve_table_and_column_from_column_name {
my($self, $column_name) = @_;
# Basic data sources don't know about tables
return (undef,$column_name);
}
1;
DataSource.pod 100664 023532 023421 22426 12544604516 15515 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR =pod
=head1 NAME
UR::DataSource - manage the the relationship between objects and a specific storage system
=head1 SYNOPSIS
package MyApp::DataSource::DB;
class MyApp::DataSource::DB {
is => ['UR::DataSource::Oracle','UR::Singleton'],
};
sub server { 'main_db_server' }
sub login { 'db_user' }
sub auth { 'db_passwd' }
sub owner { 'db_owner' }
1;
=head1 DESCRIPTION
Data source instances represent a logical souce of data to the application.
Most of them are likely to be some kind of relational database, but not all
are. UR::DataSource is an abstract base class inherited by other data
sources.
In normal use, your data sources will probably inherit from an abstract
data source class such as L or
L, as well as L. This makes it easy
to link classes to this data source, since the class name will be the
same as its ID, and the module autoloader will instantiate it automatically.
=head1 INHERITANCE
L
=head1 Methods
User applications will seldom interact with data sources directly.
=over 4
=item autogenerate_new_object_id_for_class_name_and_rule
my $id = $datasource->autogenerate_new_object_id_for_class_name_and_rule($class,$boolexpr);
L calls this when the application calls create() on a
class to create a new instance, but does not specify a value for the ID
property. The default implementation throws an exception with C,
but L is able to query a sequence in the database
to generate unique IDs. A developer implementing a new data source will
need to override this method and provide a sensible implementation.
=item next_dummy_autogenerated_id
my $int = $datasource->next_dummy_autogenerated_id()
In a testing situation, is often preferable to avoid using the database's
sequence for ID autogeneration but still make ID values that are unique.
L calls this method if the
L (see below) flag is true. The IDs generated
by this method are unique during the life of the process. In addition,
objects with dummy-generated IDs will never be saved to a real data source
during UR::Context::commit().
=item use_dummy_autogenerated_ids
$bool = $datasource->use_dummy_autogenerated_ids();
$datasource->use_dummy_autogenerated_ids($bool);
Get or set a flag controlling how object IDs are autogenerated. Data source
child classes should look at the value of this flag inside their
implementation of C. If
true, they should call C and return that value
instead of attempting to generate an ID on their own. This flag is also
tied to the UR_USE_DUMMY_AUTOGENERATED_IDS environment variable.
=item resolve_data_sources_for_rule
$possibly_other_data_source = $data_source->resolve_data_sources_for_rule($boolexpr);
When L is determining which data source to use to process a
get() request, it looks at the class metadata for its data source, and then
calls C to give that data source a chance to
defer to another data source.
=item create_iterator_closure_for_rule_template_and_values
$subref = $datasource->create_iterator_closure_for_rule_template_and_values(
$boolexpr_tmpl,
@values
);
A front-end for the more widely used L
=item create_iterator_closure_for_rule
$subref = $datasource->create_iterator_closure_for_rule($boolexpr);
This is the main entry point L uses to get data from its
underlying data sources. There is no default implementation; each subclass
implementing specific data source types must supply its own code.
The method must accept a L $boolexpr (rule), and return a
subref. Each time the subref is called it must return one arrayref of data
satisfying the rule, and undef when there is no more data to return.
=item _sync_database
$bool = $datasource->_sync_database(changed_objects => $listref);
Called by L commit(). $listref will contain all the changed
objects that should be saved to that data source. The default implementation
prints a warning message and returns true without saving anything.
L has a functioning _sync_database() capable of
generating SQL to update, insert and delete rows from the database's tables.
The data source should return true if all the changes were successfully
made, false if there were problems.
=item commit
$bool = $datasource->commit()
Called by L commit(). After all data sources return true from
_sync_database(), C must make those changes permanent. For
RDBMS-type data sources, this commits the transaction.
Return true if the commit is successful, false otherwise.
=item rollback
$bool = $datasource->rollback()
Called by L if any data sources has problems during
_sync_database or commit. It is also called by L.
Data sources should reverse any changes applied during a prior
C<_sync_database> that has not been made permanent by C.
=item get_default_handle
$scalar = $datasource->get_default_handle();
Should return the "handle" associated with any underlying logical data. For
an RDBMS data source, this is the L database handle. For a file-based
data source, this is the file handle.
=item create_from_inline_class_data
$datasource = $data_source_class_name->create_from_inline_class_data(
$class_data_hashref,
$datasource_data_hashref
);
Called by the class initializer when a class definition contains an in-line
data source definition. See
L.
=item _ignore_table
$bool = $datasource->_ignore_table($table_name);
Used to indicate whether the C command should create a
class for the named table or not. If _ignore_table() returns true, then
it will not create a class.
=back
=head1 Internal API Methods
=over 4
=item _get_class_data_for_loading
=item _generate_class_data_for_loading
$hashref = $datasource->_resolve_query_plan($class_meta);
These two methods are called by L as part of the object loading
process. C<_generate_class_data_for_loading> collects information about a
class and its metadata, such as property names, subclassing information and
tables connected to the class, and stores that data inside the class's
metadata object.
C<_get_class_data_for_loading> is the main entry point; it calls
C<_generate_class_data_for_loading> if the data has not been generated and
cached yet, and caches the data in the class metadata object.
=item _resolve_query_plan
=item _generate_template_data_for_loading
$hashref = $datasource->_resolve_query_plan($boolexpr_tmpl);
These two methods are called by L as part of the object loading
process. C<_generate_template_data_for_loading> collects information from
the L $boolexpr_tmpl (rule template) and returns a
hashref used later by the data source. This hashref includes hints about
what classes will be involved in loading the resulting data, how those
classes are joined together and how columns in the underlying query against
the data source will map to properties of the class.
C<_resolve_query_plan> is the main entry point; it calls
C<_generate_template_data_for_loading> if the data has not been generated and
cached yet, and caches the data in the rule template object.
=item _generate_loading_templates_arrayref
my $listref = $datasource->_generate_loading_templates_arrayref($listref);
Called by _generate_template_data_for_loading(). The input is a listref of
listrefs about properties involved in a query. The second-level data is
sets of quads:
=over
=item 1.
The class object for this property
=item 2.
The property metadata object
=item 3.
The database table name the data will come from
=item 4
The "object number", starting with 0. This is used in
inheritance or delegation where a table join will be required.
=back
It returns a listref of hashrefs, one hashref for every class involved in
the request; usually just 1, but can be more than one if inheritance or
delegation is involved. The data includes information about the class's
properties, ID properties, and which columns of the result set the
values will be found.
=back
=head1 MetaDB
Each Namespace created through C will have a data source
called the MetaDB. For example, the MyApp namespace's MetaDB is called
MyApp::DataSource::Meta. The MetaDB is used to store information about the
schemas of other data sources in the database. UR itself has a MetaDB with
information about the MetaDB's schema, called L.
=head1 SEE ALSO
=over 4
=item L
The base class for relational database Data Sources, such as
L, L, L
and L
=item L,
The base class for comma/tab delimited files
=item L
The base class for file multiplexor data sources.
=back
L, L
CSV.pm 100664 023532 023421 23211 12544604516 15773 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/DataSource package UR::DataSource::CSV;
use strict;
use warnings;
# There are still a few issues with actually using this thing:
#
# when running
# ur define datasource rdbms --dsn DBD:CSV:f_dir=/tmp/trycsv
# the f_dir=... part doesn't get put in as a "server" attribute.
# You have to add in it by hand as sub server {}
#
# after ur update classes, there aren't any id properties defined
# for your new classes, because there's no conclusive way to pick
# the right one - no unique constraints
#
# _get_sequence_name_for_table_and_column() and _get_next_value_from_sequence()
# aren't implemented yet, so creating new entities and sync_databases
# won't work
#
# There's a bug in even the latest SQL::Statement on CPAN where the processing
# of JOIN clauses uses a case sensitive match against upper-case stuff, when it
# should be lower-case. It also cannot handle more than one join in the same
# statement
#
# with that out of the way... on to the show!
require UR;
our $VERSION = "0.44"; # UR $VERSION;
use File::Basename;
UR::Object::Type->define(
class_name => 'UR::DataSource::CSV',
is => ['UR::DataSource::RDBMS'],
is_abstract => 1,
);
# RDBMS API
sub driver { "CSV" }
sub owner {
undef
}
sub login {
undef
}
sub auth {
undef
}
sub path {
my $server = shift->server;
my @server_opts = split(';', $server);
foreach my $opt ( @server_opts ) {
my($key,$value) = split('=',$opt);
if ($key eq 'f_dir') {
return $value;
}
}
return;
}
sub can_savepoint { 0;} # Dosen't support savepoints
sub _dbi_connect_args {
my $self = shift;
my @connection = $self->SUPER::_dbi_connect_args(@_);
delete $connection[3]->{'AutoCommit'}; # DBD::CSV doesn't support autocommit being off
return @connection;
}
sub _get_sequence_name_for_table_and_column {
Carp::croak("Not implemented yet");
my $self = shift->_singleton_object;
my ($table_name,$column_name) = @_;
my $dbh = $self->get_default_handle();
# See if the sequence generator "table" is already there
my $seq_table = sprintf('URMETA_%s_%s_seq', $table_name, $column_name);
unless ($self->{'_has_sequence_generator'}->{$seq_table} or
grep {$_ eq $seq_table} $self->get_table_names() ) {
unless ($dbh->do("CREATE TABLE IF NOT EXISTS $seq_table (next_value integer PRIMARY KEY AUTOINCREMENT)")) {
die "Failed to create sequence generator $seq_table: ".$dbh->errstr();
}
}
$self->{'_has_sequence_generator'}->{$seq_table} = 1;
return $seq_table;
}
sub _get_next_value_from_sequence {
Carp::croak('Not implemented yet');
my($self,$sequence_name) = @_;
my $dbh = $self->get_default_handle();
# FIXME can we use a statement handle with a wildcard as the table name here?
unless ($dbh->do("INSERT into $sequence_name values(null)")) {
die "Failed to INSERT into $sequence_name during id autogeneration: " . $dbh->errstr;
}
my $new_id = $dbh->last_insert_id(undef,undef,$sequence_name,'next_value');
unless (defined $new_id) {
die "last_insert_id() returned undef during id autogeneration after insert into $sequence_name: " . $dbh->errstr;
}
unless($dbh->do("DELETE from $sequence_name where next_value = $new_id")) {
die "DELETE from $sequence_name for next_value $new_id failed during id autogeneration";
}
return $new_id;
}
# Given a table name, return the complete pathname to it
# As ur update classes calls this, $table has been uppercased
# already (because most data sources uppercase table names),
# so we need to figure out which file they're talking about
sub _find_pathname_for_table {
my $self = shift;
my $table = shift;
my $path = $self->path;
my @all_files = glob("$path/*");
# note: this only finds the first one
foreach my $pathname ( @all_files ) {
if (File::Basename::basename($pathname) eq $table) {
return $pathname;
}
}
return;
}
# column_info doesn't work against a DBD::CSV handle
sub get_column_details_from_data_dictionary {
my($self,$catalog,$schema,$table,$column) = @_;
# Convert the SQL wildcards to glob wildcards
$table =~ tr/%_/*?/;
# Convert the SQL wildcards to regex wildcards
$column =~ s/%/\\w*/;
$column =~ s/_/\\w/;
my $column_regex = qr($column);
my(@matching_files) = $self->_find_pathname_for_table($table);
my @found_columns;
foreach my $file ( @matching_files ) {
my $table_name = File::Basename::basename($file);
my $fh = IO::File->new($file);
unless ($fh) {
$self->warning_message("Can't open file $file for reading: $!");
next;
}
my $header = $fh->getline();
$header =~ s/\r|\n//g; # Remove newline/CR
my @columns = split($self->get_default_handle->{'csv_sep_char'} ||',' , $header);
my $column_order = 0;
foreach my $column_name ( @columns ) {
$column_order++;
next unless $column_name =~ m/$column_regex/;
push @found_columns, { TABLE_CAT => $catalog,
TABLE_SCHEM => $schema,
TABLE_NAME => $table_name,
COLUMN_NAME => $column_name,
DATA_TYPE => 'STRING', # what else could we put here?
TYPE_NAME => 'STRING',
NULLABLE => 1, # all columns are nullable in CSV files
IS_NULLABLE => 'YES',
REMARKS => '',
COLUMN_DEF => '',
SQL_DATA_TYPE => '', # FIXME shouldn't this be something related to DATA_TYPE
SQL_DATETIME_SUB => '',
CHAH_OCTET_LENGTH => undef, # FIXME this should be the same as column_size, right?
ORDINAL_POSITION => $column_order,
}
}
}
my $sponge = DBI->connect("DBI:Sponge:", '','')
or return $self->get_default_handle->set_err($DBI::err, "DBI::Sponge: $DBI::errstr");
my @returned_names = qw( TABLE_CAT TABLE_SCHEM TABLE_NAME COLUMN_NAME DATA_TYPE TYPE_NAME COLUMN_SIZE
BUFFER_LENGTH DECIMAL_DIGITS NUM_PREC_RADIX NULLABLE REMARKS COLUMN_DEF
SQL_DATA_TYPE SQL_DATETIME_SUB CHAR_OCTET_LENGTH ORDINAL_POSITION IS_NULLABLE );
my $returned_sth = $sponge->prepare("column_info $table", {
rows => [ map { [ @{$_}{@returned_names} ] } @found_columns ],
NUM_OF_FIELDS => scalar @returned_names,
NAME => \@returned_names,
}) or return $self->get_default_handle->set_err($sponge->err(), $sponge->errstr());
return $returned_sth;
}
# DBD::CSV doesn't support foreign key tracking
# returns a statement handle with no data to read
sub get_foreign_key_details_from_data_dictionary {
my($self,$fk_catalog,$fk_schema,$fk_table,$pk_catalog,$pk_schema,$pk_table) = @_;
my $sponge = DBI->connect("DBI:Sponge:", '','')
or return $self->get_default_handle->DBI::set_err($DBI::err, "DBI::Sponge: $DBI::errstr");
my @returned_names = qw( FK_NAME UK_TABLE_NAME UK_COLUMN_NAME FK_TABLE_NAME FK_COLUMN_NAME );
my $table = $pk_table || $fk_table;
my $returned_sth = $sponge->prepare("foreign_key_info $table", {
rows => [],
NUM_OF_FIELDS => scalar @returned_names,
NAME => \@returned_names,
}) or return $self->get_default_handle->DBI::set_err($sponge->err(), $sponge->errstr());
return $returned_sth;
}
sub get_bitmap_index_details_from_data_dictionary {
# DBD::CSV dosen't support bitmap indicies, so there aren't any
return [];
}
sub get_unique_index_details_from_data_dictionary {
# DBD::CSV doesn't support unique constraints
return {};
}
sub get_table_details_from_data_dictionary {
my($self,$catalog,$schema,$table,$type) = @_;
# DBD::CSV's table_info seems to always give you back all the "tables" even
# if you only asked for details on one of them
my $sth = $self->SUPER::get_table_details_from_data_dictionary($catalog,$schema,$table,$type);
# Yeah, it's kind of silly to have to read in all the data and repackage it
# back into another sth
my @returned_details;
while (my $row = $sth->fetchrow_arrayref()) {
next unless ($row->[2] eq $table);
push @returned_details, $row;
}
my $sponge = DBI->connect("DBI:Sponge:", '','')
or return $self->get_default_handle->DBI::set_err($DBI::err, "DBI::Sponge: $DBI::errstr");
my @returned_names = qw( TABLE_CAT TABLE_SCHEM TABLE_NAME TABLE_TYPE REMARKS );
my $returned_sth = $sponge->prepare("table_info $table", {
rows => \@returned_details,
NUM_OF_FIELDS => scalar @returned_names,
NAME => \@returned_names,
}) or return $self->get_default_handle->DBI::set_err($sponge->err(), $sponge->errstr());
$returned_sth;
}
# By default, make a text dump of the database at commit time.
# This should really be a datasource property
sub dump_on_commit {
0;
}
1;
=pod
=head1 NAME
UR::DataSource::CSV - Parent class for data sources using DBD::CSV
=head1 DESCRIPTION
UR::DataSource::CSV is a subclass of L and can be
used for interacting with CSV files. Because of the limitations of the
underlying modules (such as SQL::Statement only supporting one join at a
time), this module is deprecated.
L implements a non-SQL interface for data files, and
is the proper way to use a file as a data source for class data.
=cut
Code.db 100664 023532 023421 12000 12544604516 16155 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/DataSource SQLite format 3 @
7 ï%Å7 K/)indexmethod_name_usage_i_method_namemethod_name_usageCREATE INDEX method_name_usage_i_method_name on method_name_usage(method_name)^5}indexmethod_i_method_namemethodCREATE INDEX method_i_method_name on method(method_name)G//‚=tablemethod_name_usagemethod_name_usageCREATE TABLE method_name_usage (
file_name varchar2(255),
method_name varchar2(255),
line_number integer
)‚ƒwtablemethodmethodCREATE TABLE method (
file_name varchar2(255),
class_name varchar2(255),
method_name varchar2(255),
line_number integer,
line_count integer,
is_deprecated bool
)
Code.pm 100664 023532 023421 2657 12544604516 16205 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/DataSource
package UR::DataSource::Code;
use strict;
use warnings;
require UR;
our $VERSION = "0.44"; # UR $VERSION;
use File::Copy qw//;
##- use UR;
UR::Object::Type->define(
class_name => 'UR::DataSource::Code',
is => ['UR::DataSource::SQLite'],
);
sub server {
my $self = shift->_singleton_object();
my $path = $self->__meta__->module_path;
$path =~ s/\.pm$/.db/ or Carp::confess("Bad module path for resolving server!");
unless (-e $path) {
# initialize a new database from the one in the base class
# should this be moved to connect time?
my $template_database_file = UR::DataSource::Code->server();
if ($self->class eq __PACKAGE__) {
Carp::confess("Missing template database file: $path!");
}
unless (-e $template_database_file) {
Carp::confess("Missing template database file: $path! Cannot initialize database for " . $self->class);
}
unless(File::Copy::copy($template_database_file,$path)) {
Carp::confess("Error copying $path to $template_database_file to initialize database!");
}
unless(-e $path) {
Carp::confess("File $path not found after copy from $template_database_file. Cannot initialize database!");
}
}
return $path;
}
sub resolve_class_name_for_table_name_fixups {
my $self = shift->_singleton_object;
print "fixup @_";
return $self->class . "::", @_;
}
1;
Code.schema 100664 023532 023421 1033 12544604516 17014 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/DataSource CREATE TABLE method (
file_name varchar2(255),
class_name varchar2(255),
method_name varchar2(255),
line_number integer,
line_count integer,
is_deprecated bool
);
CREATE TABLE method_name_usage (
file_name varchar2(255),
method_name varchar2(255),
line_number integer
);
CREATE INDEX method_i_method_name on method(method_name);
CREATE INDEX method_name_usage_i_method_name on method_name_usage(method_name);
Default.pm 100664 023532 023421 10713 12544604516 16727 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/DataSource package UR::DataSource::Default;
# NOTE: UR::DataSource::QueryPlan currently has conditional logic for this class
use strict;
use warnings;
use UR;
our $VERSION = "0.44"; # UR $VERSION;
class UR::DataSource::Default {
is => ['UR::DataSource','UR::Singleton'],
doc => 'allows the class to describe its own loading strategy'
};
sub create_iterator_closure_for_rule {
my($self,$rule) = @_;
my $subject_class_name = $rule->subject_class_name;
unless ($subject_class_name->can('__load__')) {
Carp::croak("Can't load from class $subject_class_name: UR::DataSource::Default requires the class to implement __load__");
}
my $template = $rule->template;
my ($query_plan) = $self->_resolve_query_plan($template);
my $expected_headers = $query_plan->{loading_templates}[0]{property_names};
my ($headers, $content) = $subject_class_name->__load__($rule,$expected_headers);
my $iterator;
if (ref($content) eq 'ARRAY') {
$iterator = sub {
my $next_row = shift @$content;
$content = undef if @$content == 0;
return $next_row;
};
}
elsif (ref($content) eq 'CODE') {
$iterator = $content;
}
else {
Carp::confess("Expected an arrayref of properties, and then content in the form of an arrayref (rows,columns) or coderef/iterator returning rows from $subject_class_name __load__!\n");
}
if ("@$headers" ne "@$expected_headers") {
# translate the headers into the appropriate order
my @mapping = eval { _map_fields($headers,$expected_headers);};
if ($@) {
Carp::croak("Loading data for class $subject_class_name and boolexpr $rule failed: $@");
}
# print Data::Dumper::Dumper($headers,$expected_headers,\@mapping);
my $orig_iterator = $iterator;
$iterator = sub {
my $result = $orig_iterator->();
return unless $result;
my @result2 = @$result[@mapping];
return \@result2;
};
}
return $iterator;
}
sub can_savepoint { 0 }
sub _map_fields {
my ($from,$to) = @_;
my $n = 0;
my %from = map { $_ => $n++ } @$from;
my @pos;
for my $field (@$to) {
my $pos = $from{$field};
unless (defined $pos) {
#print "@$from\n@$to\n" . Carp::longmess() . "\n";
die("Can't resolve value for '$field' from the headers returned by its __load__: ". join(', ', @$from));
}
push @pos, $pos;
}
return @pos;
}
# Nothing to be done for rollback
sub rollback { 1;}
my @saved_objects;
sub _sync_database {
my $self = shift;
my %params = @_;
my $changed_objects = $params{changed_objects};
my %class_can_save;
my $err = do {
local $@;
eval {
for my $obj (@$changed_objects) {
my $obj_class = $obj->class;
unless (exists $class_can_save{$obj_class}) {
$class_can_save{$obj_class} = $obj->can('__save__');
}
if ($class_can_save{$obj_class}) {
push @saved_objects, $obj;
$obj->__save__;
}
}
};
$@;
};
if ($err) {
my @failed_rollback;
do {
my $rollback_error;
while (my $obj = shift @saved_objects) {
local $@;
eval {
$obj->__rollback__;
};
if ($@) {
$rollback_error = $@;
push @failed_rollback, $obj;
}
}
if (@failed_rollback) {
$self->error_message('Rollback failed: ' . Data::Dumper::Dumper(\@failed_rollback));
Carp::croak "Failed to save, and ERRORS DURING ROLLBACK:\n$err\n $rollback_error\n";
}
};
die $err;
}
return 1;
}
sub commit {
my @failed_commit;
while (my $obj = shift @saved_objects) {
local $@;
eval {
$obj->__commit__;
};
if ($@) {
push @failed_commit, $@ => $obj;
}
}
if (@failed_commit) {
my @failure_messages;
for (my $i = 0; $i < @failed_commit; $i += 2) {
my($exception, $obj) = @failed_commit[$i .. $i+1];
push @failure_messages, "$exception: ".Data::Dumper::Dumper($obj);
}
Carp::croak "Commit failed:\n" . join("\n", @failure_messages);
}
return 1;
}
1;
File.pm 100664 023532 023421 145650 12544604516 16253 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/DataSource package UR::DataSource::File;
# NOTE! This module is deprecated. Use UR::DataSource::Filesystem instead.
# A data source implementation for text files where the fields
# are delimited by commas (or anything else really). Usually,
# the lines in the file will be sorted by one or more columns,
# but it isn't strictly necessary
#
# For now, it's structured around files where the record is delimited by
# newlines, and the fields are delimited by qr(\s*,\s*). Those are
# overridable in concrete data sources by specifying record_seperator() and
# delimiter().
# FIXME - work out a way to support record-oriented data as well as line-oriented data
use UR;
use strict;
use warnings;
our $VERSION = "0.44"; # UR $VERSION;
use Fcntl qw(:DEFAULT :flock);
use Errno qw(EINTR EAGAIN EOPNOTSUPP);
use File::Temp;
use File::Basename;
use IO::File qw();
our @CARP_NOT = qw( UR::Context UR::DataSource::FileMux UR::Object::Type );
class UR::DataSource::File {
is => ['UR::DataSource'],
has => [
delimiter => { is => 'String', default_value => '\s*,\s*', doc => 'Delimiter between columns on the same line' },
record_separator => { is => 'String', default_value => "\n", doc => 'Delimiter between lines in the file' },
column_order => { is => 'ARRAY', doc => 'Names of the columns in the file, in order' },
skip_first_line => { is => 'Integer', default_value => 0, doc => 'Number of lines at the start of the file to skip' },
handle_class => { is => 'String', default_value => 'IO::File', doc => 'Class to use for new file handles' },
quick_disconnect => { is => 'Boolean', default_value => 1, doc => 'Do not hold the file handle open between requests' },
],
has_optional => [
server => { is => 'String', doc => 'pathname to the data file' },
file_list => { is => 'ARRAY', doc => 'list of pathnames of equivalent files' },
sort_order => { is => 'ARRAY', doc => 'Names of the columns by which the data file is sorted' },
constant_values => { is => 'ARRAY', doc => 'Property names which are not in the data file(s), but are part of the objects loaded from the data source' },
# REMOVE
#file_cache_index => { is => 'Integer', doc => 'index into the file cache where the next read will be placed' },
_open_query_count => { is => 'Integer', doc => 'number of queries currently using this data source, used internally' },
],
doc => 'A data source for line-oriented files',
};
sub can_savepoint { 0;} # Doesn't support savepoints
sub create_default_handle {
my $self = shift;
if ($ENV{'UR_DBI_MONITOR_SQL'}) {
my $time = time();
UR::DBI->sql_fh->printf("\nFILE OPEN AT %d [%s]\n",$time, scalar(localtime($time)));
}
my $filename = $self->server;
unless (-e $filename) {
# file doesn't exist
$filename = '/dev/null';
}
my $handle_class = $self->handle_class;
my $fh = $handle_class->new($filename);
unless($fh) {
$self->error_message("Can't open ".$self->server." for reading: $!");
return;
}
if ($ENV{'UR_DBI_MONITOR_SQL'}) {
UR::DBI->sql_fh->printf("FILE: opened %s fileno %d\n\n",$self->server, $fh->fileno);
}
$self->is_connected(1);
return $fh;
}
sub disconnect {
my $self = shift;
if ($self->has_default_handle) {
my $fh = $self->get_default_handle;
flock($fh,LOCK_UN);
$fh->close();
$self->__invalidate_get_default_handle__;
$self->is_connected(0);
}
}
sub _file_position {
my $self = shift;
my $fh = $self->get_default_handle;
return $fh ? $fh->tell() : undef;
}
sub prepare_for_fork {
my $self = shift;
# make sure this is clear before we fork
$self->{'_fh_position'} = undef;
if ($self->has_default_handle) {
$self->{'_fh_position'} = $self->_file_position();
UR::DBI->sql_fh->printf("FILE: preparing to fork; closing file %s and noting position at %s\n",$self->server, $self->{'_fh_position'}) if $ENV{'UR_DBI_MONITOR_SQL'};
}
$self->disconnect_default_handle;
}
sub finish_up_after_fork {
my $self = shift;
if (defined $self->{'_fh_position'}) {
UR::DBI->sql_fh->printf("FILE: resetting after fork; reopening file %s and fast-forwarding to %s\n",$self->server, $self->{'_fh_position'}) if $ENV{'UR_DBI_MONITOR_SQL'};
my $fh = $self->get_default_handle;
$fh->seek($self->{'_fh_position'},0);
}
}
sub _regex {
my $self = shift;
unless ($self->{'_regex'}) {
my $delimiter = $self->delimiter;
my $r = eval { qr($delimiter) };
if ($@ || !$r) {
$self->error_message("Unable to interepret delimiter '".$self->delimiter.": $@");
return;
}
$self->{'_regex'} = $r;
}
return $self->{'_regex'};
}
# We're overriding server() so everyone else can have a single way of getting
# the file's pathname instead of having to know about both server and file_list
sub server {
my $self = shift;
unless ($self->{'_cached_server'}) {
if ($self->__server()) {
$self->{'_cached_server'} = $self->__server();
} elsif ($self->file_list) {
my $files = $self->file_list;
my $count = scalar(@$files);
my $idx = $$ % $count;
$self->{'_cached_server'} = $files->[$idx];
} else {
die "Data source ",$self->id," didn't specify either server or file_list";
}
}
return $self->{'_cached_server'};
}
# Should be divisible by 3
our $MAX_CACHE_SIZE = 99;
# The offset cache is an arrayref containing three pieces of data:
# 0: If this cache slot is being used by a loading iterator
# 1: concatenated data from the sorted columns for comparison with where you are in the file
# 2: the seek position that line came from
sub _offset_cache {
my $self = shift;
unless ($self->{'_offset_cache'}) {
$self->{'_offset_cache'} = [];
}
return $self->{'_offset_cache'};
}
our %iterator_data_source;
our %iterator_cache_slot_refs;
sub _allocate_offset_cache_slot {
my $self = shift;
my $cache = $self->_offset_cache();
my $next = scalar(@$cache);
#print STDERR "_allocate_offset_cache_slot ".$self->server." current size is $next ";
if ($next > $MAX_CACHE_SIZE) {
#print STDERR "searching... \n";
my $last_offset_cache_slot = $self->{'_last_offset_cache_slot'};
if ($last_offset_cache_slot >= $MAX_CACHE_SIZE) {
$next = 0;
} else {
$next = $last_offset_cache_slot + 3;
}
# Search for an unused slot
while ($cache->[$next] and $next != $last_offset_cache_slot) {
$next += 3;
$next = 0 if ($next > $MAX_CACHE_SIZE);
}
if ($next > $MAX_CACHE_SIZE or $next eq $last_offset_cache_slot) {
#print STDERR scalar(keys(%iterator_data_source))." items in iterator_data_source ".scalar(keys(%iterator_cache_slot))." in iterator_cache_slot\n";
Carp::carp("Unable to find an open file offset cache slot because there are too many outstanding loading iterators. Temporarily expanding the cache...");
# We'll let it go ahead and expand the list
$next = $MAX_CACHE_SIZE;
$MAX_CACHE_SIZE += 3;
}
}
$cache->[$next] = 1;
$cache->[$next+1] = undef;
$cache->[$next+2] = undef;
$self->{'_last_offset_cache_slot'} = $next;
#print STDERR "using slot $next current size ".scalar(@$cache)."\n";
return $next;
}
sub _free_offset_cache_slot {
my($self, $cache_slot) = @_;
my $cache = $self->_offset_cache();
unless ($cache_slot < scalar(@$cache)) {
$self->warning_message("Freeing offset cache slot past the end. Current size ".scalar(@$cache).", requested $cache_slot");
return;
}
unless (defined $cache->[$cache_slot]) {
$self->warning_message("Freeing unused offset cache slot $cache_slot");
return;
}
if ($cache->[$cache_slot+1] and scalar(@{$cache->[$cache_slot+1]}) == 0) {
# There's no data in here. Must have happened when the reader went all the
# way to the end of the file and found nothing. Remove this entry completely
# because it's not helpful
splice(@$cache, $cache_slot,3);
} else {
# There is data in here, mark it as a free slot
$cache->[$cache_slot] = 0;
}
return 1;
}
sub _invalidate_cache {
my $self = shift;
$self->{'_offset_cache'} = [];
return 1;
}
sub _generate_loading_templates_arrayref {
my($self,$old_sql_cols) = @_;
my $columns_in_file = $self->column_order;
my %column_to_position_map;
for (my $i = 0; $i < @$columns_in_file; $i++) {
$column_to_position_map{$columns_in_file->[$i]} = $i;
}
# strip out columns that don't exist in the file
my $sql_cols;
foreach my $column_data ( @$old_sql_cols ) {
my $propertys_column_name = $column_data->[1]->column_name;
next unless ($propertys_column_name and exists($column_to_position_map{$propertys_column_name}));
push @$sql_cols, $column_data;
}
unless ($sql_cols) {
$self->error_message("Couldn't determine column information for data source " . $self->id);
return;
}
# reorder the requested columns to be in the same order as the file
my @sql_cols_with_column_name =
map{ [ $column_to_position_map{ $_->[1]->column_name }, $_ ] }
@$sql_cols;
my @sorted_sql_cols =
map { $_->[1] }
sort { $a->[0] <=> $b->[0] }
@sql_cols_with_column_name;
$sql_cols = \@sorted_sql_cols;
my $templates = $self->SUPER::_generate_loading_templates_arrayref($sql_cols);
if (my $constant_values = $self->constant_values) {
# Find the first unused index in the loading template
my $next_template_slot = -1;
foreach my $tmpl ( @$templates ) {
foreach my $col ( @{$tmpl->{'column_positions'}} ) {
if ($col >= $next_template_slot) {
$next_template_slot = $col + 1;
}
}
}
if ($next_template_slot == -1) {
die "Couldn't determine last column in loading template for data source" . $self->id;
}
foreach my $prop ( @$constant_values ) {
push @{$templates->[0]->{'column_positions'}}, $next_template_slot++;
push @{$templates->[0]->{'property_names'}}, $prop;
}
}
return $templates;
}
sub _things_in_list_are_numeric {
my $self = shift;
foreach ( @{$_[0]} ) {
return 0 if (! Scalar::Util::looks_like_number($_));
}
return 1;
}
# Construct a closure to perform a test on the $index-th column of
# @$$next_candidate_row. The closures return 0 is the test is successful,
# -1 if unsuccessful but the file's value was less than $value, and 1
# if unsuccessful and greater. The iterator that churns throug the file
# knows that if it's comparing an ID/sorted column, and the comparator
# returns 1 then we've gone past the point where we can expect to ever
# find another successful match and we should stop looking
my $ALWAYS_FALSE = sub { -1 };
sub _comparator_for_operator_and_property {
my($self,$property,$next_candidate_row, $index, $operator,$value) = @_;
no warnings 'uninitialized'; # we're handling ''/undef/null specially below where it matters
if ($operator eq 'between') {
if ($value->[0] eq '' or $value->[1] eq '') {
return $ALWAYS_FALSE;
}
if ($property->is_numeric and $self->_things_in_list_are_numeric($value)) {
if ($value->[0] > $value->[1]) {
# Will never be true
Carp::carp "'between' comparison will never be true with values ".$value->[0]," and ".$value->[1];
return $ALWAYS_FALSE;
}
# numeric 'between' comparison
return sub {
return -1 if ($$next_candidate_row->[$index] eq '');
if ($$next_candidate_row->[$index] < $value->[0]) {
return -1;
} elsif ($$next_candidate_row->[$index] > $value->[1]) {
return 1;
} else {
return 0;
}
};
} else {
if ($value->[0] gt $value->[1]) {
Carp::carp "'between' comparison will never be true with values ".$value->[0]," and ".$value->[1];
return $ALWAYS_FALSE;
}
# A string 'between' comparison
return sub {
return -1 if ($$next_candidate_row->[$index] eq '');
if ($$next_candidate_row->[$index] lt $value->[0]) {
return -1;
} elsif ($$next_candidate_row->[$index] gt $value->[1]) {
return 1;
} else {
return 0;
}
};
}
} elsif ($operator eq 'in') {
if (! @$value) {
return $ALWAYS_FALSE;
}
if ($property->is_numeric and $self->_things_in_list_are_numeric($value)) {
# Numeric 'in' comparison returns undef if we're within the range of the list
# but don't actually match any of the items in the list
@$value = sort { $a <=> $b } @$value; # sort the values first
return sub {
return -1 if ($$next_candidate_row->[$index] eq '');
if ($$next_candidate_row->[$index] < $value->[0]) {
return -1;
} elsif ($$next_candidate_row->[$index] > $value->[-1]) {
return 1;
} else {
foreach ( @$value ) {
return 0 if $$next_candidate_row->[$index] == $_;
}
return -1;
}
};
} else {
# A string 'in' comparison
@$value = sort { $a cmp $b } @$value;
return sub {
if ($$next_candidate_row->[$index] lt $value->[0]) {
return -1;
} elsif ($$next_candidate_row->[$index] gt $value->[-1]) {
return 1;
} else {
foreach ( @$value ) {
return 0 if $$next_candidate_row->[$index] eq $_;
}
return -1;
}
};
}
} elsif ($operator eq 'not in') {
if (! @$value) {
return $ALWAYS_FALSE;
}
if ($property->is_numeric and $self->_things_in_list_are_numeric($value)) {
return sub {
return -1 if ($$next_candidate_row->[$index] eq '');
foreach ( @$value ) {
return -1 if $$next_candidate_row->[$index] == $_;
}
return 0;
}
} else {
return sub {
foreach ( @$value ) {
return -1 if $$next_candidate_row->[$index] eq $_;
}
return 0;
}
}
} elsif ($operator eq 'like') {
# 'like' is always a string comparison. In addition, we can't know if we're ahead
# or behind in the file's ID columns, so the only two return values are 0 and 1
return $ALWAYS_FALSE if ($value eq ''); # property like NULL is always false
# Convert SQL-type wildcards to Perl-type wildcards
# Convert a % to a *, and _ to ., unless they're preceeded by \ to escape them.
# Not that this isn't precisely correct, as \\% should really mean a literal \
# followed by a wildcard, but we can't be correct in all cases without including
# a real parser. This will catch most cases.
$value =~ s/(?[$index] eq '');
if ($$next_candidate_row->[$index] =~ $regex) {
return 0;
} else {
return 1;
}
};
} elsif ($operator eq 'not like') {
return $ALWAYS_FALSE if ($value eq ''); # property like NULL is always false
$value =~ s/(?[$index] eq '');
if ($$next_candidate_row->[$index] =~ $regex) {
return 1;
} else {
return 0;
}
};
# FIXME - should we only be testing the numericness of the property?
} elsif ($property->is_numeric and $self->_things_in_list_are_numeric([$value])) {
# Basic numeric comparisons
if ($operator eq '=') {
return sub {
return -1 if ($$next_candidate_row->[$index] eq ''); # null always != a number
return $$next_candidate_row->[$index] <=> $value;
};
} elsif ($operator eq '<') {
return sub {
return -1 if ($$next_candidate_row->[$index] eq ''); # null always != a number
$$next_candidate_row->[$index] < $value ? 0 : 1;
};
} elsif ($operator eq '<=') {
return sub {
return -1 if ($$next_candidate_row->[$index] eq ''); # null always != a number
$$next_candidate_row->[$index] <= $value ? 0 : 1;
};
} elsif ($operator eq '>') {
return sub {
return -1 if ($$next_candidate_row->[$index] eq ''); # null always != a number
$$next_candidate_row->[$index] > $value ? 0 : -1;
};
} elsif ($operator eq '>=') {
return sub {
return -1 if ($$next_candidate_row->[$index] eq ''); # null always != a number
$$next_candidate_row->[$index] >= $value ? 0 : -1;
};
} elsif ($operator eq 'true') {
return sub {
$$next_candidate_row->[$index] ? 0 : -1;
};
} elsif ($operator eq 'false') {
return sub {
$$next_candidate_row->[$index] ? -1 : 0;
};
} elsif ($operator eq '!=' or $operator eq 'ne') {
return sub {
return 0 if ($$next_candidate_row->[$index] eq ''); # null always != a number
$$next_candidate_row->[$index] != $value ? 0 : -1;
}
}
} else {
# Basic string comparisons
if ($operator eq '=') {
return sub {
return -1 if ($$next_candidate_row->[$index] eq '' xor $value eq '');
return $$next_candidate_row->[$index] cmp $value;
};
} elsif ($operator eq '<') {
return sub {
$$next_candidate_row->[$index] lt $value ? 0 : 1;
};
} elsif ($operator eq '<=') {
return sub {
return -1 if ($$next_candidate_row->[$index] eq '' or $value eq '');
$$next_candidate_row->[$index] le $value ? 0 : 1;
};
} elsif ($operator eq '>') {
return sub {
$$next_candidate_row->[$index] gt $value ? 0 : -1;
};
} elsif ($operator eq '>=') {
return sub {
return -1 if ($$next_candidate_row->[$index] eq '' or $value eq '');
$$next_candidate_row->[$index] ge $value ? 0 : -1;
};
} elsif ($operator eq 'true') {
return sub {
$$next_candidate_row->[$index] ? 0 : -1;
};
} elsif ($operator eq 'false') {
return sub {
$$next_candidate_row->[$index] ? -1 : 0;
};
} elsif ($operator eq '!=' or $operator eq 'ne') {
return sub {
$$next_candidate_row->[$index] ne $value ? 0 : -1;
}
}
}
}
sub create_iterator_closure_for_rule {
my($self,$rule) = @_;
my $class_name = $rule->subject_class_name;
my $class_meta = $class_name->__meta__;
my $rule_template = $rule->template;
my $csv_column_order_names = $self->column_order;
my $csv_column_count = scalar @$csv_column_order_names;
my $operators_for_properties = $rule_template->operators_for_properties();
my $values_for_properties = $rule->legacy_params_hash;
foreach ( values %$values_for_properties ) {
if (ref eq 'HASH' and exists $_->{'value'}) {
$_ = $_->{'value'};
}
}
my $sort_order_names = $self->sort_order;
my %sort_column_names = map { $_ => 1 } @$sort_order_names;
my @non_sort_column_names = grep { ! exists($sort_column_names{$_}) } @$csv_column_order_names;
my %column_name_to_index_map;
for (my $i = 0; $i < @$csv_column_order_names; $i++) {
$column_name_to_index_map{$csv_column_order_names->[$i]} = $i;
}
# Index in the split-file-data for each sorted column in order
my @sort_order_column_indexes = map { $column_name_to_index_map{$_} } @$sort_order_names;
my(%property_meta_for_column_name);
foreach my $column_name ( @$csv_column_order_names ) {
my $prop = UR::Object::Property->get(class_name => $class_name, column_name => $column_name);
our %WARNED_ABOUT_COLUMN;
unless ( $prop or $WARNED_ABOUT_COLUMN{$class_name . '::' . $column_name}++) {
$self->warning_message("Couldn't find a property in class $class_name that goes with column $column_name");
next;
}
$property_meta_for_column_name{$column_name} = $prop;
}
my @rule_columns_in_order; # The order we should perform rule matches on - value is the index in @next_file_row to test
my @comparison_for_column; # closures to call to perform the match - same order as @rule_columns_in_order
my $last_sort_column_in_rule = -1; # Last index in @rule_columns_in_order that applies when trying "the shortcut"
my $looking_for_sort_columns = 1;
my $next_candidate_row; # This will be filled in by the closure below
foreach my $column_name ( @$sort_order_names, @non_sort_column_names ) {
my $property_meta = $property_meta_for_column_name{$column_name};
unless ($property_meta) {
Carp::croak("Class $class_name has no property connected to column named '$column_name' in data source ".$self->id);
}
my $property_name = $property_meta->property_name;
if (! $operators_for_properties->{$property_name}) {
$looking_for_sort_columns = 0;
next;
} elsif ($looking_for_sort_columns && $sort_column_names{$column_name}) {
$last_sort_column_in_rule++;
} else {
# There's been a gap in the ID column list in the rule, stop looking for
# further ID columns
$looking_for_sort_columns = 0;
}
push @rule_columns_in_order, $column_name_to_index_map{$column_name};
my $operator = $operators_for_properties->{$property_name};
my $rule_value = $values_for_properties->{$property_name};
my $comparison_function = $self->_comparator_for_operator_and_property($property_meta,
\$next_candidate_row,
$column_name_to_index_map{$column_name},
$operator,
$rule_value);
unless ($comparison_function) {
Carp::croak("Unknown operator '$operator' in file data source filter");
}
push @comparison_for_column, $comparison_function;
}
my $split_regex = $self->_regex();
# FIXME - another performance boost might be to do some kind of binary search
# against the file to set the initial/next position?
my $file_pos = 0;
# search in the offset cache for something helpful
my $offset_cache = $self->_offset_cache();
# If the rule doesn't touch the sorted columns, then we can't use the offset cache for help :(
if ($last_sort_column_in_rule >= 0) {
# Starting at index 1 because we're interested in the file and seek data, not if it's in use
# offset 0 is the in-use flag, offset 1 is a ref to the file data and offset 2 is the file seek pos
SEARCH_CACHE:
for (my $i = 1; $i < @$offset_cache; $i+=3) {
next unless (defined($offset_cache->[$i]) && defined($offset_cache->[$i+1]));
$next_candidate_row = $offset_cache->[$i];
my $matched = 0;
COMPARE_VALUES:
for (my $c = 0; $c <= $last_sort_column_in_rule; $c++) {
my $comparison = $comparison_for_column[$c]->();
next SEARCH_CACHE if $comparison > 0;
if ($comparison < 0) {
$matched = 1;
last COMPARE_VALUES;
}
}
# If we made it this far, then the file data in this slot is earlier in the file
# than the data we're looking for. So, if the seek pos data is later than what
# we've found yet, use it instead
if ($matched and $offset_cache->[$i+1] > $file_pos) {
$file_pos = $offset_cache->[$i+1];
}
}
}
my($monitor_start_time,$monitor_printed_first_fetch);
if ($ENV{'UR_DBI_MONITOR_SQL'}) {
$monitor_start_time = Time::HiRes::time();
$monitor_printed_first_fetch = 0;
my @filters_list;
for (my $i = 0; $i < @rule_columns_in_order; $i++) {
my $column = $rule_columns_in_order[$i];
my $column_name = $csv_column_order_names->[$column];
my $is_sorted = $i <= $last_sort_column_in_rule ? ' (sorted)' : '';
my $operator = $operators_for_properties->{$column_name} || '=';
my $rule_value = $values_for_properties->{$column_name};
if (ref $rule_value eq 'ARRAY') {
$rule_value = '[' . join(',', @$rule_value) . ']';
}
my $filter_string = $column_name . " $operator $rule_value" . $is_sorted;
push @filters_list, $filter_string;
}
my $filter_list = join("\n\t", @filters_list);
UR::DBI->sql_fh->printf("\nFILE: %s\nFILTERS %s\n\n", $self->server, $filter_list);
}
$self->{'_last_read_fingerprint'} ||= '';
my $record_separator = $self->record_separator;
my $cache_slot = $self->_allocate_offset_cache_slot();
my $cache_insert_counter = 100; # a "breadcrumb" will be left in the offset cache after this many lines are read
my $lines_read = 0;
my $printed_first_match = 0;
my $lines_matched = 0;
my $fh; # File handle we'll be reading from
my $read_fingerprint; # The stringified version of $iterator (to avoid circular references), filled in below
my $iterator = sub {
unless (ref($fh)) {
$fh = $self->get_default_handle();
# Lock the file for reading... For more fine-grained locking we could move this to
# after READ_LINE_FROM_FILE: but that would slow down read operations a bit. If
# there ends up being a problem with lock contention, go ahead and move it before $line = <$fh>;
#flock($fh,LOCK_SH);
}
if ($monitor_start_time && ! $monitor_printed_first_fetch) {
UR::DBI->sql_fh->printf("FILE: FIRST FETCH TIME: %.4f s\n", Time::HiRes::time() - $monitor_start_time);
$monitor_printed_first_fetch = 1;
}
if ($self->{'_last_read_fingerprint'} ne $read_fingerprint) {
UR::DBI->sql_fh->printf("FILE: Resetting file position to $file_pos\n") if $ENV{'UR_DBI_MONITOR_SQL'};
# The last read was from a different request, reset the position
$fh->seek($file_pos,0);
if ($file_pos == 0) {
my $skip = $self->skip_first_line;
while ($skip-- > 0) {
scalar(<$fh>);
}
}
$file_pos = $self->_file_position();
$self->{'_last_read_fingerprint'} = $read_fingerprint;
}
local $/; # Make sure some wise guy hasn't changed this out from under us
$/ = $record_separator;
my $line;
READ_LINE_FROM_FILE:
until($line) {
# Hack for OSX 10.5.
# At EOF, the getline below will return undef. Most builds of Perl
# will also set $! to 0 at EOF so you can distinguish between the cases
# of EOF (which may have actually happened a while ago because of buffering)
# and an actual read error. OSX 10.5's Perl does not, and so $!
# retains whatever value it had after the last failed syscall, likely
# a stat() while looking for a Perl module. This should have no effect
# other platforms where you can't trust $! at arbitrary points in time
# anyway
$! = 0;
$line = <$fh>;
unless (defined $line) {
if ($!) {
redo READ_LINE_FROM_FILE if ($! == EAGAIN or $! == EINTR);
my $pathname = $self->server();
Carp::confess("getline() failed for DataSource $self pathname $pathname boolexpr $rule: $!");
}
# at EOF. Close up shop and return
#flock($fh,LOCK_UN);
$fh = undef;
if ($monitor_start_time) {
UR::DBI->sql_fh->printf("FILE: at EOF\nFILE: $lines_read lines read for this request. $lines_matched matches\nFILE: TOTAL EXECUTE-FETCH TIME: %.4f s\n", Time::HiRes::time() - $monitor_start_time);
}
return;
}
$lines_read++;
my $last_read_size = length($line);
chomp $line;
# FIXME - to support record-oriented files, we need some replacement for this...
$next_candidate_row = [ split($split_regex, $line, $csv_column_count) ];
$#{$a} = $csv_column_count-1;
$file_pos = $self->_file_position();
my $file_pos_before_read = $file_pos - $last_read_size;
# Every so many lines read, leave a breadcrumb about what we've seen
unless ($lines_read % $cache_insert_counter) {
$offset_cache->[$cache_slot+1] = $next_candidate_row;
$offset_cache->[$cache_slot+2] = $file_pos_before_read;
$self->_free_offset_cache_slot($cache_slot);
# get a new slot
$cache_slot = $self->_allocate_offset_cache_slot();
$offset_cache->[$cache_slot+1] = $next_candidate_row;
$offset_cache->[$cache_slot+2] = $file_pos_before_read;
$cache_insert_counter <<= 2; # Double the insert counter
}
for (my $i = 0; $i < @rule_columns_in_order; $i++) {
my $comparison = $comparison_for_column[$i]->();
if ($comparison > 0 and $i <= $last_sort_column_in_rule) {
# We've gone past the last thing that could possibly match
if ($monitor_start_time) {
UR::DBI->sql_fh->printf("FILE: $lines_read lines read for this request. $lines_matched matches\nFILE: TOTAL EXECUTE-FETCH TIME: %.4f s\n", Time::HiRes::time() - $monitor_start_time);
}
#flock($fh,LOCK_UN);
# Save the info from the last row we read
$offset_cache->[$cache_slot+1] = $next_candidate_row;
$offset_cache->[$cache_slot+2] = $file_pos_before_read;
return;
} elsif ($comparison) {
# comparison didn't match, read another line from the file
redo READ_LINE_FROM_FILE;
}
# That comparison worked... stay in the for() loop for other comparisons
}
# All the comparisons return '0', meaning they passed
# Now see if the offset cache file data is different than the row we just read
COMPARE_TO_CACHE:
foreach my $column ( @sort_order_column_indexes) {
no warnings 'uninitialized';
if ($offset_cache->[$cache_slot+1]->[$column] ne $next_candidate_row->[$column]) {
# They're different. Update the offset cache data
$offset_cache->[$cache_slot+1] = $next_candidate_row;
$offset_cache->[$cache_slot+2] = $file_pos_before_read;
last COMPARE_TO_CACHE;
}
}
if (! $printed_first_match and $monitor_start_time) {
UR::DBI->sql_fh->printf("FILE: First match after reading $lines_read lines\n");
$printed_first_match=1;
}
$lines_matched++;
return $next_candidate_row;
}
}; # end sub $iterator
$read_fingerprint = $iterator . '';
Sub::Name::subname('UR::DataSource::File::__datasource_iterator(closure)__', $iterator);
my $count = $self->_open_query_count() || 0;
$self->_open_query_count($count+1);
bless $iterator, 'UR::DataSource::File::Tracker';
$iterator_data_source{$iterator} = $self;
$iterator_cache_slot_refs{$iterator} = \$cache_slot;
return $iterator;
}
sub UR::DataSource::File::Tracker::DESTROY {
my $iterator = shift;
my $ds = delete $iterator_data_source{$iterator};
return unless $ds; # The data source may have gone out of scope first during global destruction
my $cache_slot_ref = delete $iterator_cache_slot_refs{$iterator};
if (defined($cache_slot_ref) and defined($$cache_slot_ref)) {
# Mark this slot unused
#print STDERR "Freeing cache slot $cache_slot\n";
#$ds->_offset_cache->[$$cache_slot_ref] = 0;
$ds->_free_offset_cache_slot($$cache_slot_ref);
}
my $count = $ds->_open_query_count();
$ds->_open_query_count(--$count);
return unless ($ds->quick_disconnect);
if ($count == 0 && $ds->has_default_handle) {
# All open queries have supposedly been fulfilled. Close the
# file handle and undef it so get_default_handle() will re-open if necessary
my $fh = $ds->get_default_handle;
UR::DBI->sql_fh->printf("FILE: CLOSING fileno ".fileno($fh)."\n") if ($ENV{'UR_DBI_MONITOR_SQL'});
#flock($fh,LOCK_UN);
$fh->close();
$ds->__invalidate_get_default_handle__;
}
}
# Names of creation params that we should force to be listrefs
our %creation_param_is_list = map { $_ => 1 } qw( column_order file_list sort_order constant_values );
sub create_from_inline_class_data {
my($class, $class_data, $ds_data) = @_;
# User didn't specify columns in the file. Assumme every property is a column, and in the same order
unless (exists $ds_data->{'column_order'}) {
Carp::croak "data_source has no column_order specified";
}
$ds_data->{'server'} ||= $ds_data->{'path'} || $ds_data->{'file'};
my %ds_creation_params;
foreach my $param ( qw( delimiter record_separator column_order skip_first_line server file_list sort_order constant_values ) ) {
if (exists $ds_data->{$param}) {
if ($creation_param_is_list{$param} and ref($ds_data->{$param}) ne 'ARRAY') {
$ds_creation_params{$param} = \( $ds_data->{$param} );
} else {
$ds_creation_params{$param} = $ds_data->{$param};
}
}
}
my($namespace, $class_name) = ($class_data->{'class_name'} =~ m/^(\w+?)::(.*)/);
my $ds_id = "${namespace}::DataSource::${class_name}";
my $ds_type = delete $ds_data->{'is'};
my $ds = $ds_type->create( %ds_creation_params, id => $ds_id );
return $ds;
}
# The string used to join fields of a row together
#
# Since the 'delimiter' property is interpreted as a regex in the reading
# code, we'll try to be smart about making a real string from that.
#
# subclasses can override this to provide a different implementation
sub join_pattern {
my $self = shift;
my $join_pattern = $self->delimiter;
# make some common substitutions...
if ($join_pattern eq '\s*,\s*') {
# The default...
return ', ';
}
$join_pattern =~ s/\\s*//g; # Turn 0-or-more whitespaces to nothing
$join_pattern =~ s/\\t/\t/; # tab
$join_pattern =~ s/\\s/ /; # whitespace
return $join_pattern;
}
sub _sync_database {
my $self = shift;
my %params = @_;
unless (ref($self)) {
if ($self->isa("UR::Singleton")) {
$self = $self->_singleton_object;
}
else {
die "Called as a class-method on a non-singleton datasource!";
}
}
my $read_fh = $self->get_default_handle();
unless ($read_fh) {
Carp::croak($self->class . ": Can't _sync_database(): Can't open file " . $self->server . " for reading: $!");
}
my $original_data_file = $self->server;
my $original_data_dir = File::Basename::dirname($original_data_file);
my $use_quick_rename;
unless (-d $original_data_dir){
File::Path::mkpath($original_data_dir);
}
if (-w $original_data_dir) {
$use_quick_rename = 1; # We can write to the data dir
} elsif (! -w $original_data_file) {
$self->error_message("Neither the directory nor the file for $original_data_file are writable - cannot sync_database");
return;
}
my $split_regex = $self->_regex();
my $join_pattern = $self->join_pattern;
my $record_separator = $self->record_separator;
local $/; # Make sure some wise guy hasn't changed this out from under us
$/ = $record_separator;
my $csv_column_order_names = $self->column_order;
my $csv_column_count = scalar(@$csv_column_order_names);
my %column_name_to_index_map;
for (my $i = 0; $i < @$csv_column_order_names; $i++) {
$column_name_to_index_map{$csv_column_order_names->[$i]} = $i;
}
my $changed_objects = delete $params{changed_objects};
# We're going to assumme all the passed-in objects are of the same class *gulp*
my $class_name = $changed_objects->[0]->class;
my $class_meta = UR::Object::Type->get(class_name => $class_name);
my %column_name_to_property_meta = map { $_->column_name => $_ }
grep { $_->column_name }
$class_meta->all_property_metas;
my @property_names_in_column_order;
foreach my $column_name ( @$csv_column_order_names ) {
my $prop_meta = $column_name_to_property_meta{$column_name};
unless ($prop_meta) {
die "Data source " . $self->class . " id " . $self->id .
" could not resolve a $class_name property for the data source's column named $column_name";
}
push @property_names_in_column_order, $prop_meta->property_name;
}
my $insert = [];
my $update = {};
my $delete = {};
foreach my $obj ( @$changed_objects ) {
if ($obj->isa('UR::Object::Ghost')) {
# This should be removed from the file
my $original = $obj->{'db_committed'};
my $line = join($join_pattern, @{$original}{@property_names_in_column_order}) . $record_separator;
$delete->{$line} = $obj;
} elsif ($obj->{'db_committed'}) {
# This object is changed since it was read in the file
my $original = $obj->{'db_committed'};
my $original_line = join($join_pattern, @{$original}{@property_names_in_column_order}) . $record_separator;
my $changed_line = join($join_pattern, @{$obj}{@property_names_in_column_order}) . $record_separator;
$update->{$original_line} = $changed_line;
} else {
# This object is new and should be added to the file
push @$insert, [ @{$obj}{@property_names_in_column_order} ];
}
}
my $sort_order_names = $self->sort_order;
foreach my $sort_column_name ( @$sort_order_names ) {
unless (exists $column_name_to_index_map{$sort_column_name}) {
Carp::croak("Column name '$sort_column_name' appears in the sort_order list, but not in the column_order list for data source ".$self->id);
}
}
my $file_is_sorted = scalar(@$sort_order_names);
my %column_sorts_numerically = map { $_->column_name => $_->is_numeric }
values %column_name_to_property_meta;
my $row_sort_sub = sub ($$) {
my $comparison;
foreach my $column_name ( @$sort_order_names ) {
my $i = $column_name_to_index_map{$column_name};
if ($column_sorts_numerically{$column_name}) {
$comparison = $_[0]->[$i] <=> $_[1]->[$i];
} else {
$comparison = $_[0]->[$i] cmp $_[1]->[$i];
}
return $comparison if $comparison != 0;
}
return 0;
};
if ($sort_order_names && $file_is_sorted && scalar(@$insert)) {
# the inserted things should be sorted the same way as the file
my @sorted = sort $row_sort_sub @$insert;
$insert = \@sorted;
}
my $write_fh;
my $temp_file_name;
if ($use_quick_rename) {
$temp_file_name = sprintf("%s/.%d.%d" , $original_data_dir, time(), $$);
$write_fh = IO::File->new($temp_file_name, O_WRONLY|O_CREAT);
} else {
$write_fh = File::Temp->new(UNLINK => 1);
$temp_file_name = $write_fh->filename if ($write_fh);
}
unless ($write_fh) {
Carp::croak "Can't create temporary file for writing: $!";
}
my $monitor_start_time;
if ($ENV{'UR_DBI_MONITOR_SQL'}) {
$monitor_start_time = Time::HiRes::time();
my $time = time();
UR::DBI->sql_fh->printf("\nFILE: SYNC_DATABASE AT %d [%s]. Started transaction for %s to temp file %s\n",
$time, scalar(localtime($time)), $original_data_file, $temp_file_name);
}
unless (flock($read_fh,LOCK_SH)) {
unless ($! == EOPNOTSUPP ) {
Carp::croak($self->class(). ": Can't get exclusive lock for file ".$self->server.": $!");
}
}
# write headers to the new file
for (my $i = 0; $i < $self->skip_first_line; $i++) {
my $line = <$read_fh>;
$write_fh->print($line);
}
my $line;
READ_A_LINE:
while(1) {
unless ($line) {
$line = <$read_fh>;
last unless defined $line;
}
if ($file_is_sorted && scalar(@$insert)) {
# there are sorted things waiting to insert
my $chomped = $line;
chomp $chomped;
my $row = [ split($split_regex, $chomped, $csv_column_count) ];
my $comparison = $row_sort_sub->($row, $insert->[0]);
if ($comparison > 0) {
# write the object's data
no warnings 'uninitialized'; # Some of the object's data may be undef
my $new_row = shift @$insert;
my $new_line = join($join_pattern, @$new_row) . $record_separator;
if ($ENV{'UR_DBI_MONITOR_SQL'}) {
UR::DBI->sql_fh->print("INSERT >>$new_line<<\n");
}
$write_fh->print($new_line);
# Don't undef the last line read, meaning it could still be written to the output...
next READ_A_LINE;
}
}
if (my $obj = delete $delete->{$line}) {
if ($ENV{'UR_DBI_MONITOR_SQL'}) {
UR::DBI->sql_fh->print("DELETE >>$line<<\n");
}
$line = undef;
next;
} elsif (my $changed = delete $update->{$line}) {
if ($ENV{'UR_DBI_MONITOR_SQL'}) {
UR::DBI->sql_fh->print("UPDATE replace >>$line<< with >>$changed<<\n");
}
$write_fh->print($changed);
$line = undef;
next;
} else {
# This line from the file was unchanged in the app
$write_fh->print($line);
$line = undef;
}
}
if (keys %$delete) {
$self->warning_message("There were ",scalar(keys %$delete)," deleted $class_name objects that did not match data in the file");
}
if (keys %$update) {
$self->warning_message("There were ",scalar(keys %$update)," updated $class_name objects that did not match data in the file");
}
# finish out by writing the rest of the new data
foreach my $new_row ( @$insert ) {
no warnings 'uninitialized'; # Some of the object's data may be undef
my $new_line = join($join_pattern, @$new_row) . $record_separator;
if ($ENV{'UR_DBI_MONITOR_SQL'}) {
UR::DBI->sql_fh->print("INSERT >>$new_line<<\n");
}
$write_fh->print($new_line);
}
$write_fh->close();
if ($use_quick_rename) {
if ($ENV{'UR_DBI_MONITOR_SQL'}) {
UR::DBI->sql_fh->print("FILE: COMMIT rename $temp_file_name over $original_data_file\n");
}
unless(rename($temp_file_name, $original_data_file)) {
$self->error_message("Can't rename the temp file over the original file: $!");
return;
}
} else {
# We have to copy the data from the temp file to the original file
if ($ENV{'UR_DBI_MONITOR_SQL'}) {
UR::DBI->sql_fh->print("FILE: COMMIT write over $original_data_file in place\n");
}
my $new_write_fh = IO::File->new($original_data_file, O_WRONLY|O_TRUNC);
unless ($new_write_fh) {
$self->error_message("Can't open $original_data_file for writing: $!");
return;
}
my $temp_file_fh = IO::File->new($temp_file_name);
unless ($temp_file_fh) {
$self->error_message("Can't open $temp_file_name for reading: $!");
return;
}
while(<$temp_file_fh>) {
$new_write_fh->print($_);
}
$new_write_fh->close();
}
# Because of the rename/copy process during syncing, the previously opened filehandle may
# not be valid anymore. get_default_handle will reopen the file next time it's needed
$self->_invalidate_cache();
$self->__invalidate_get_default_handle__;
if ($ENV{'UR_DBI_MONITOR_SQL'}) {
UR::DBI->sql_fh->printf("FILE: TOTAL COMMIT TIME: %.4f s\n", Time::HiRes::time() - $monitor_start_time);
}
flock($read_fh, LOCK_UN);
$read_fh->close();
# FIXME - this is ugly... With RDBMS-type data sources, they will call $dbh->commit() which
# gets to UR::DBI->commit(), which calls _set_object_saved_committed for them. Since we're
# not using DBI we have to do this 2-part thing ourselves. In the future, we might break
# out things so the saving to the temp file goes in _sync_database(), and moving the temp
# file over the original goes in commit()
unless ($self->_set_specified_objects_saved_uncommitted($changed_objects)) {
Carp::croak("Error setting objects to a saved state after sync_database. Exiting.");
return;
}
$self->_set_specified_objects_saved_committed($changed_objects);
return 1;
}
sub initializer_should_create_column_name_for_class_properties {
1;
}
1;
=pod
=head1 NAME
UR::DataSource::File - Parent class for file-based data sources
=head1 DEPRECATED
This module is deprecated. Use UR::DataSource::Filesystem instead.
=head1 SYNOPSIS
package MyNamespace::DataSource::MyFile;
class MyNamespace::DataSource::MyFile {
is => ['UR::DataSource::File', 'UR::Singleton'],
};
sub server { '/path/to/file' }
sub delimiter { "\t" }
sub column_order { ['thing_id', 'thing_name', 'thing_color' ] }
sub sort_order { ['thing_id'] }
package main;
class MyNamespace::Thing {
id_by => 'thing_id',
has => [ 'thing_id', 'thing_name', 'thing_color' ],
data_source => 'MyNamespace::DataSource::MyFile',
}
my @objs = MyNamespace::Thing->get(thing_name => 'Bob');
=head1 DESCRIPTION
Classes which wish to retrieve their data from a regular file can use a UR::DataSource::File-based
data source. The modules implementing these data sources live under the DataSource subdirectory
of the application's Namespace, by convention. Besides defining a class for your data source
inheriting from UR::DataSource::File, it should have the following methods, either as properties
or functions in the package.
=head2 Configuration
These methods determine the configuration for your data source.
=over 4
=item server()
server() should return a string representing the pathname of the file where the data is stored.
=item file_list()
The file_list() method should return a listref of pathnames to one or more identical files
where data is stored. Use file_list() instead of server() when you want to load-balance several NFS
servers, for example.
You must have either server() or file_list() in your module, but not both. The existence of server()
takes precedence over file_list().
=item delimiter()
delimiter() should return a string representing how the fields in each record are split into
columns. This string is interpreted as a regex internally. The default delimiter is "\s*,\s*"
meaning that the file is separated by commas.
=item record_separator()
record_separator() should return a string that gets stored in $/ before getline() is called on the
file's filehandle. The default record_separator() is "\n" meaning that the file's records are
separated by newlines.
=item skip_first_line()
skip_first_line() should return a boolean value. If true, the first line of the file is ignored, for
example if the first line defines the columns in the file.
=item column_order()
column_order() should return a listref of column names in the file. column_order is required; there
is no default.
=item sort_order()
If the data file is sorted in some way, sort_order() should return a listref of column names (which must
exist in column_order()) by which the file is sorted. This gives the system a hint about how the file
is structured, and is able to make shortcuts when reading the file to speed up data access. The default
is to assumme the file is not sorted.
=back
=head1 INHERITANCE
UR::DataSource
=head1 SEE ALSO
UR, UR::DataSource
=cut
FileMux.pm 100664 023532 023421 74666 12544604516 16735 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/DataSource package UR::DataSource::FileMux;
# NOTE! This module is deprecated. Use UR::DataSource::Filesystem instead.
use UR;
use strict;
use warnings;
our $VERSION = "0.44"; # UR $VERSION;
class UR::DataSource::FileMux {
is => ['UR::DataSource'],
doc => 'A factory for other datasource factories that is able to pivot depending on parameters in the rule used for get()',
has => [
delimiter => { is => 'String', default_value => '\s*,\s*', doc => 'Delimiter between columns on the same line' },
record_separator => { is => 'String', default_value => "\n", doc => 'Delimiter between lines in the file' },
column_order => { is => 'ARRAY', doc => 'Names of the columns in the file, in order' },
cache_size => { is => 'Integer', default_value => 100 },
skip_first_line => { is => 'Integer', default_value => 0 },
handle_class => { is => 'String', default_value => 'IO::File', doc => 'Class to use for new file handles' },
quick_disconnect => { is => 'Boolean', default_value => 1, doc => 'Do not hold the file handle open between requests' },
file_resolver => { is => 'CODE', doc => 'subref that will return a pathname given a rule' },
constant_values => { is => 'ARRAY', default_value => undef, doc => 'Property names which are not in the data file(s), but are part of the objects loaded from the data source' },
],
has_optional => [
server => { is => 'String', doc => 'pathname to the data file' },
file_list => { is => 'ARRAY', doc => 'list of pathnames of equivalent files' },
sort_order => { is => 'ARRAY', doc => 'Names of the columns by which the data file is sorted' },
required_for_get => { is => 'ARRAY', doc => 'Property names which must appear in any get() request using this data source. It is used to build the argument list for the file_resolver sub' },
delegate_file_ds => { is => 'UR:DataFile::FileMuxFile', reverse_as => 'controlling_filemux', is_many => 1 },
],
};
UR::Object::Type->define(
class_name => 'UR::DataSource::FileMuxFile',
is => 'UR::DataSource::File',
has_transient => [
controlling_filemux => { is => 'UR::DataSource::FileMux', id_by => 'controlling_filemux_id' },
],
)->is_uncachable(1);
# FileMux doesn't have a 'default_handle'
sub create_default_handle {
return undef;
}
sub disconnect {
my $self = shift;
my @delegates = $self->delegate_file_ds();
$_->disconnect_default_handle foreach @delegates;
}
# The concreate data sources will be of this type
sub _delegate_data_source_class {
'UR::DataSource::FileMuxFile';
}
sub sql_fh {
return UR::DBI->sql_fh();
}
sub can_savepoint { 0;} # Doesn't support savepoints
my %WORKING_RULES; # Avoid recusion when infering values from rules
sub create_iterator_closure_for_rule {
my($self,$rule) = @_;
if ($WORKING_RULES{$rule->id}++) {
my $subject_class = $rule->subject_class_name;
$self->error_message("Recursive entry into create_iterator_closure_for_rule() for class $subject_class rule_id ".$rule->id);
$WORKING_RULES{$rule->id}--;
return;
}
my $context = UR::Context->get_current;
my $required_for_get = $self->required_for_get;
if ($ENV{'UR_DBI_MONITOR_SQL'}) {
$self->sql_fh->printf("FILEMux: Resolving values for %d params (%s)\n",
scalar(@$required_for_get),
join(',',@$required_for_get));
}
my @all_resolver_params;
for(my $i = 0; $i < @$required_for_get; $i++) {
my $param_name = $required_for_get->[$i];
my @values = $context->infer_property_value_from_rule($param_name, $rule);
unless (@values) {
# Hack: the above infer...rule() returned 0 objects, so $all_params_loaded made
# a note of it. Later on, if the user supplies more params such that it would be
# able to resolve a file, we'll never get here, because the Context will see that a
# superset of the params (this current invocation without sufficient params) was already
# tried and results should be entirely in the cache - ie. no objects.
# So... remove the evidence that we tried this in case the user is catching the die
# below and will continue on
$context->_forget_loading_was_done_with_template_and_rule($rule->template_id, $rule->id);
Carp::croak "Can't resolve data source: no $param_name specified in rule $rule";
}
if (@values == 1 and ref($values[0]) eq 'ARRAY') {
@values = @{$values[0]};
}
if ($ENV{'UR_DBI_MONITOR_SQL'}) {
$self->sql_fh->print(" FILEMux: $param_name: (",join(',',@values),")\n");
}
unless ($rule->specifies_value_for($param_name)) {
if (scalar(@values) == 1) {
$rule = $rule->add_filter($param_name => $values[0]);
} else {
$rule = $rule->add_filter($param_name => \@values);
}
}
$all_resolver_params[$i] = \@values;
}
my @resolver_param_combinations = UR::Util::combinations_of_values(@all_resolver_params);
# Each combination of params ends up being from a different data source. Make an
# iterator pulling from each of them
my $file_resolver = $self->{'file_resolver'};
if (ref($file_resolver) ne 'CODE') {
# Hack! The data source is probably a singleton class and there's a file_resolver method
# defined
$file_resolver = $self->can('file_resolver');
}
my $concrete_ds_type = $self->_delegate_data_source_class;
#my %sub_ds_params = $self->_common_params_for_concrete_data_sources();
my @constant_value_properties = @{$self->constant_values};
my @data_source_construction_data;
foreach my $resolver_params ( @resolver_param_combinations ) {
push @data_source_construction_data, { subject_class_name => $rule->subject_class_name,
file_resolver => $file_resolver,
file_resolver_params => $resolver_params,
};
}
delete $WORKING_RULES{$rule->id};
my($monitor_start_time,$monitor_printed_first_fetch);
if ($ENV{'UR_DBI_MONITOR_SQL'}) {
$monitor_start_time = Time::HiRes::time();
$monitor_printed_first_fetch = 0;
}
my $base_sub_ds_name = $self->id;
# Fill in @ds_iterators with iterators for all the underlying data sources
# pre-fill @ds_next_row with the next object from each data source
# @ds_constant_values is the constant_values for objects of those data sources
my(@ds_iterators, @ds_next_row, @ds_constant_values);
foreach my $data_source_construction_data ( @data_source_construction_data ) {
my $subject_class_name = $data_source_construction_data->{'subject_class_name'};
my $file_resolver = $data_source_construction_data->{'file_resolver'};
my $file_resolver_params = $data_source_construction_data->{'file_resolver_params'};
my @sub_ds_name_parts;
my $this_ds_rule_params = $rule->legacy_params_hash;
for (my $i = 0; $i < @$required_for_get; $i++) {
my $param_name = $required_for_get->[$i];
my $param_value = $file_resolver_params->[$i];
push @sub_ds_name_parts, $param_name . $param_value;
$this_ds_rule_params->{$param_name} = $param_value;
}
my $sub_ds_id = join('::', $base_sub_ds_name, @sub_ds_name_parts);
my $resolved_file = $file_resolver->(@$file_resolver_params);
unless ($resolved_file) {
Carp::croak "Can't create data source: file resolver for $sub_ds_id returned false for params "
. join(',',@$file_resolver_params);
}
my $this_ds_obj = $self->get_or_create_data_source($concrete_ds_type, $sub_ds_id, $resolved_file);
my $this_ds_rule = UR::BoolExpr->resolve($subject_class_name,%$this_ds_rule_params);
my @constant_values = map { $this_ds_rule->value_for($_) }
@constant_value_properties;
my $ds_iterator = $this_ds_obj->create_iterator_closure_for_rule($this_ds_rule);
my $initial_obj = $ds_iterator->();
next unless $initial_obj;
push @ds_constant_values, \@constant_values;
push @ds_iterators, $ds_iterator;
push @ds_next_row, $initial_obj;
}
unless (scalar(@ds_constant_values) == scalar(@ds_iterators)
and
scalar(@ds_constant_values) == scalar(@ds_next_row) )
{
Carp::croak("Internal error in UR::DataSource::FileMux: arrays for iterators, constant_values and next_row have differing sizes");
}
# Create a closure that can sort the next possible rows in @ds_next_row and return the index of
# the one that sorts earliest
my $sorter;
if (@ds_iterators == 0 ) {
# No underlying data sources, no data to return
return sub {};
} elsif (@ds_iterators == 1 ) {
# Only one underlying data source.
$sorter = sub { 0 };
} else {
# more than one underlying data source, make a real sorter
my %column_name_to_row_index;
my $column_order_names = $self->column_order;
my $constant_values = $self->constant_values;
push @$column_order_names, @$constant_values;
for (my $i = 0; $i < @$column_order_names; $i++) {
$column_name_to_row_index{$column_order_names->[$i]} = $i;
}
my $sort_order = $self->sort_order;
if (! $sort_order or ! @$sort_order ) {
# They didn't specify sorting, Try finding out the class' ID properties
# and sort by them
my $subject_class_meta = $rule->subject_class_name->__meta__;
my @id_properties = $subject_class_meta->direct_id_property_names;
$sort_order = [];
foreach my $property_name ( @id_properties ) {
my $property_meta = $subject_class_meta->property_meta_for_name($property_name);
my $column_name = $property_meta->column_name;
next unless $column_name;
next unless ($column_name_to_row_index{$column_name});
push @$sort_order, $column_name;
}
}
my @row_index_sort_order = map { $column_name_to_row_index{$_} } @$sort_order;
$sorter = sub {
my $lowest_obj_idx = 0;
COMPARE_OBJECTS:
for(my $compare_obj_idx = 1; $compare_obj_idx < @ds_next_row; $compare_obj_idx++) {
COMPARE_COLUMNS:
for (my $i = 0; $i < @row_index_sort_order; $i++) {
my $column_num = $row_index_sort_order[$i];
my $comparison = $ds_next_row[$lowest_obj_idx]->[$column_num] <=> $ds_next_row[$compare_obj_idx]->[$column_num]
||
$ds_next_row[$lowest_obj_idx]->[$column_num] cmp $ds_next_row[$compare_obj_idx]->[$column_num];
if ($comparison == -1) {
next COMPARE_OBJECTS;
} elsif ($comparison == 1) {
$lowest_obj_idx = $compare_obj_idx;
next COMPARE_OBJECTS;
}
}
}
return $lowest_obj_idx;
};
}
my $iterator = sub {
if ($monitor_start_time and ! $monitor_printed_first_fetch) {
$self->sql_fh->printf("FILEMux: FIRST FETCH TIME: %.4f s\n", Time::HiRes::time() - $monitor_start_time);
$monitor_printed_first_fetch = 1;
}
while (@ds_next_row) {
my $next_row_idx = $sorter->();
my $next_row_to_return = $ds_next_row[$next_row_idx];
push @$next_row_to_return, @{$ds_constant_values[$next_row_idx]};
my $refill_row = $ds_iterators[$next_row_idx]->();
if ($refill_row) {
$ds_next_row[$next_row_idx] = $refill_row;
} else {
# This iterator is exhausted
splice(@ds_iterators, $next_row_idx, 1);
splice(@ds_constant_values, $next_row_idx, 1);
splice(@ds_next_row, $next_row_idx, 1);
}
return $next_row_to_return;
}
if ($monitor_start_time) {
$self->sql_fh->printf("FILEMux: TOTAL EXECUTE-FETCH TIME: %.4f s\n",
Time::HiRes::time() - $monitor_start_time);
}
return;
};
Sub::Name::subname('UR::DataSource::FileMux::__datasource_iterator(closure)__', $iterator);
return $iterator;
}
sub get_or_create_data_source {
my($self, $concrete_ds_type, $sub_ds_id, $file_path) = @_;
my $sub_ds;
unless ($sub_ds = $concrete_ds_type->get($sub_ds_id)) {
if ($ENV{'UR_DBI_MONITOR_SQL'}) {
$self->sql_fh->print("FILEMux: $file_path is data source $sub_ds_id\n");
}
my %sub_ds_params = $self->_common_params_for_concrete_data_sources();
$concrete_ds_type->define(
id => $sub_ds_id,
%sub_ds_params,
server => $file_path,
controlling_filemux_id => $self->id,
);
$UR::Context::all_objects_cache_size++;
$sub_ds = $concrete_ds_type->get($sub_ds_id);
unless ($sub_ds) {
Carp::croak "Can't create data source: retrieving newly defined data source $sub_ds_id returned nothing";
}
# Since these $sub_ds objects have no data_source, this will indicate to
# UR::Context::prune_object_cache() that it's ok to go ahead and drop them
$sub_ds->__weaken__();
}
return $sub_ds;
}
sub _generate_loading_templates_arrayref {
my $self = shift;
my $delegate_class = $self->_delegate_data_source_class();
$delegate_class->class; # trigger the autoloader, if necessary
my $sub = $delegate_class->can('_generate_loading_templates_arrayref');
unless ($sub) {
Carp::croak(qq(FileMux can't locate method "_generate_loading_templates_arrayref" via package $delegate_class. Is $delegate_class a File-type DataSource?));
}
$self->$sub(@_);
}
sub _normalize_file_resolver_details {
my($class, $class_data, $ds_data) = @_;
my $path_resolver_coderef;
my @required_for_get;
my $class_name = $class_data->{'class_name'};
if (exists $ds_data->{'required_for_get'}) {
@required_for_get = @{$ds_data->{'required_for_get'}};
my $user_supplied_resolver = $ds_data->{'file_resolver'} || $ds_data->{'resolve_file_with'} ||
$ds_data->{'resolve_path_with'};
if (ref($user_supplied_resolver) eq 'CODE') {
$path_resolver_coderef = $user_supplied_resolver;
} elsif (! ref($user_supplied_resolver)) {
# It's a functcion name
$path_resolver_coderef = $class_name->can($user_supplied_resolver);
unless ($path_resolver_coderef) {
die "Can't locate function $user_supplied_resolver via class $class_name during creation of inline data source";
}
} else {
$class->error_message("The data_source specified 'required_for_get', but the file resolver was not a coderef or function name");
return;
}
} else {
my $resolve_path_with = $ds_data->{'resolve_path_with'} || $ds_data->{'path'} ||
$ds_data->{'server'} || $ds_data->{'file_resolver'};
unless ($resolve_path_with or $ds_data->{'file_list'}) {
$class->error_message("A data_source's definition must include 'resolve_path_with', 'path', 'server', or 'file_list'");
return;
}
if (! ref($resolve_path_with)) {
# a simple string
if ($class_name->can($resolve_path_with) or grep { $_ eq $resolve_path_with } @{$class_data->{'has'}}) {
# a method or property name
no strict 'refs';
$path_resolver_coderef = \&{ $class_name . "::$resolve_path_with"};
} else {
# a hardcoded pathname
$path_resolver_coderef = sub { $resolve_path_with };
}
} elsif (ref($resolve_path_with) eq 'CODE') {
$path_resolver_coderef = $resolve_path_with;
} elsif (ref($resolve_path_with) ne 'ARRAY') {
$class->error_message("A data_source's 'resolve_path_with' must be a coderef, arrayref, pathname or method name");
return;
} elsif (ref($resolve_path_with) eq 'ARRAY') {
# A list of things
if (ref($resolve_path_with->[0]) eq 'CODE') {
# A coderef, then property list
@required_for_get = @{$ds_data->{'resolve_path_with'}};
$path_resolver_coderef = shift @required_for_get;
} elsif (grep { $_ eq $resolve_path_with->[0] }
keys(%{$class_data->{'has'}}) ) {
# a list of property names, join them with /s
unless ($ds_data->{'base_path'}) {
$class->warning_message("$class_name inline data source: 'resolve_path_with' is a list of method names, but 'base_path' is undefined'");
}
@required_for_get = @{$resolve_path_with};
my $base_path = $ds_data->{'base_path'};
$path_resolver_coderef = sub { no warnings 'uninitialized';
return join('/', $base_path, @_)
};
} elsif ($class_name->can($resolve_path_with->[0])) {
# a method compiled into the class, but not one that's a property
@required_for_get = @{$resolve_path_with};
my $fcn_name = shift @required_for_get;
my $path_resolver_coderef = $class_name->can($fcn_name);
unless ($path_resolver_coderef) {
die "Can't locate function $fcn_name via class $class_name during creation of inline data source";
}
} elsif (! ref($resolve_path_with->[0])) {
# treat the first element as a sprintf format
@required_for_get = @{$resolve_path_with};
my $format = shift @required_for_get;
$path_resolver_coderef = sub { no warnings 'uninitialized';
return sprintf($format, @_);
};
} else {
$class->error_message("Unrecognized layout for 'resolve_path_with'");
return;
}
} else {
$class->error_message("Unrecognized layout for 'resolve_path_with'");
return;
}
}
return ($path_resolver_coderef, @required_for_get);
}
# Properties we'll copy from $self when creating a concrete data source
sub _common_params_for_concrete_data_sources {
my $self = shift;
my %params;
foreach my $param ( qw( delimiter skip_first_line column_order sort_order record_separator constant_values handle_class quick_disconnect ) ) {
next unless defined $self->$param;
my @vals = $self->$param;
if (@vals > 1) {
$params{$param} = \@vals;
} else {
$params{$param} = $vals[0];
}
}
return %params;
}
sub initializer_should_create_column_name_for_class_properties {
1;
}
# Called by the class initializer
sub create_from_inline_class_data {
my($class, $class_data, $ds_data) = @_;
unless ($ds_data->{'column_order'}) {
die "Can't create inline data source for ".$class_data->{'class_name'}.": 'column_order' is a required param";
}
my($file_resolver, @required_for_get) = $class->_normalize_file_resolver_details($class_data, $ds_data);
return unless $file_resolver;
if (!exists($ds_data->{'constant_values'}) and @required_for_get) {
# If there are required_for_get params, but the user didn't specify any constant_values,
# then all the required_for_get items that are real properties become constant_values
$ds_data->{'constant_values'} = [];
my %columns_from_ds = map { $_ => 1 } @{$ds_data->{'column_order'}};
foreach my $param_name ( @required_for_get ) {
my $param_data = $class_data->{'has'}->{$param_name};
next unless $param_data;
my $param_column = $param_data->{'column_name'};
next unless $param_column;
unless ($columns_from_ds{$param_column}) {
push @{$ds_data->{'constant_values'}}, $param_name;
}
}
}
my %ds_creation_params;
foreach my $param ( qw( delimiter record_separator column_order cache_size skip_first_line sort_order constant_values ) ) {
if (exists $ds_data->{$param}) {
$ds_creation_params{$param} = $ds_data->{$param};
}
}
my($namespace, $class_name) = ($class_data->{'class_name'} =~ m/^(\w+?)::(.*)/);
my $ds_id = "${namespace}::DataSource::${class_name}";
my $ds_type = delete $ds_data->{'is'};
my $ds = $ds_type->create(
%ds_creation_params,
id => $ds_id,
required_for_get => \@required_for_get,
file_resolver => $file_resolver
);
return $ds;
}
sub _sync_database {
my $self = shift;
my %params = @_;
unless (ref($self)) {
if ($self->isa("UR::Singleton")) {
$self = $self->_singleton_object;
}
else {
die "Called as a class-method on a non-singleton datasource!";
}
}
my $changed_objects = delete $params{'changed_objects'};
my $context = UR::Context->get_current;
my $required_for_get = $self->required_for_get;
my $file_resolver = $self->{'file_resolver'};
if (ref($file_resolver) ne 'CODE') {
# Hack! The data source is probably a singleton class and there's a file_resolver method
# defined
$file_resolver = $self->can('file_resolver');
}
my $monitor_start_time;
if ($ENV{'UR_DBI_MONITOR_SQL'}) {
$monitor_start_time = Time::HiRes::time();
my $time = time();
$self->sql_fh->printf("FILEMux: SYNC_DATABASE AT %d [%s].\n", $time, scalar(localtime($time)));
}
my $concrete_ds_type = $self->_delegate_data_source_class;
my %sub_ds_params = $self->_common_params_for_concrete_data_sources();
my %datasource_for_dsid;
my %objects_by_datasource;
foreach my $obj ( @$changed_objects ) {
my @obj_values;
for (my $i = 0; $i < @$required_for_get; $i++) {
my $property = $required_for_get->[$i];
my $value = $obj->$property;
unless ($value) {
my $class = $obj->class;
my $id = $obj->id;
$self->error_message("No value for required-for-get property $property on object of class $class id $id");
return;
}
if (ref $value) {
my $class = $obj->class;
my $id = $obj->id;
$self->error_message("Pivoting based on a non-scalar property is not supported. $class object id $id property $property did not return a scalar value");
return;
}
push @obj_values, $value;
}
my @sub_ds_name_parts;
for (my $i = 0; $i < @obj_values; $i++) {
push @sub_ds_name_parts, $required_for_get->[$i] . $obj_values[$i];
}
my $sub_ds_id = join('::', $self->id, @sub_ds_name_parts);
my $sub_ds = $datasource_for_dsid{$sub_ds_id} || $concrete_ds_type->get($sub_ds_id);
unless ($sub_ds) {
my $file_path = $file_resolver->(@obj_values);
unless (defined $file_path) {
die "Can't resolve data source: resolver for " .
$self->class .
" returned undef for params " . join(',',@obj_values);
}
if ($ENV{'UR_DBI_MONITOR_SQL'}) {
$self->sql_fh->print("FILEMux: $file_path is data source $sub_ds_id\n");
}
$concrete_ds_type->define(
id => $sub_ds_id,
%sub_ds_params,
server => $file_path,
controlling_filemux_id => $self->id,
);
$UR::Context::all_objects_cache_size++;
$sub_ds = $concrete_ds_type->get($sub_ds_id);
# Since these $sub_ds objects have no data_source, this will indicate to
# UR::Context::prune_object_cache() that it's ok to go ahead and drop them
$sub_ds->__weaken__();
}
unless ($sub_ds) {
die "Can't get data source with ID $sub_ds_id";
}
$datasource_for_dsid{$sub_ds_id} ||= $sub_ds;
unless ($objects_by_datasource{$sub_ds_id}) {
$objects_by_datasource{$sub_ds_id}->{'ds_obj'} = $sub_ds;
$objects_by_datasource{$sub_ds_id}->{'changed_objects'} = [];
}
push(@{$objects_by_datasource{$sub_ds_id}->{'changed_objects'}}, $obj);
}
foreach my $h ( values %objects_by_datasource ) {
my $sub_ds = $h->{'ds_obj'};
my $changed_objects = $h->{'changed_objects'};
$sub_ds->_sync_database(changed_objects => $changed_objects);
}
if ($ENV{'UR_DBI_MONITOR_SQL'}) {
$self->sql_fh->printf("FILEMux: TOTAL COMMIT TIME: %.4f s\n", Time::HiRes::time() - $monitor_start_time);
}
return 1;
}
1;
=pod
=head1 NAME
UR::DataSource::FileMux - Parent class for datasources which can multiplex many files together
=head1 DEPRECATED
This module is deprecated. Use UR::DataSource::Filesystem instead.
=head1 SYNOPSIS
package MyNamespace::DataSource::MyFileMux;
class MyNamespace::DataSource::MyFileMux {
is => ['UR::DataSource::FileMux', 'UR::Singleton'],
};
sub column_order { ['thing_id', 'thing_name', 'thing_color'] }
sub sort_order { ['thing_id'] }
sub delimiter { "\t" }
sub constant_values { ['thing_type'] }
sub required_for_get { ['thing_type'] }
sub file_resolver {
my $thing_type = shift;
return '/base/path/to/files/' . $thing_type;
}
package main;
class MyNamespace::ThingMux {
id_by => ['thing_id', 'thing_type' ],
has => ['thing_id', 'thing_type', 'thing_name','thing_color'],
data_source => 'MyNamespace::DataSource::MyFileMux',
};
my @objs = MyNamespace::Thing->get(thing_type => 'people', thing_name => 'Bob');
=head1 DESCRIPTION
UR::DataSource::FileMux provides a framework for file-based data sources where the
data files are split up between one or more parameters of the class. For example,
in the synopsis above, the data for the class is stored in several files in the
directory /base/path/to/files/. Each file may have a name such as 'people' and 'cars'.
When a get() request is made on the class, the parameter 'thing_type' must be present
in the rule, and the value of that parameter is used to complete the file's pathname,
via the file_resolver() function. Note that even though the 'thing_type' parameter
is not actually stored in the file, its value for the loaded objects gets filled in
because that paremeter exists in the constant_values() configuration list, and in
the get() request.
=head2 Configuration
These methods determine the configuration for your data source and should appear as
properties of the data source or as functions in the package.
=over 4
=item delimiter()
=item record_separator()
=item skip_first_line()
=item column_order()
=item sort_order()
These configuration items behave the same as in a UR::DataSource::File-based data source.
=item required_for_get()
required_for_get() should return a listref of parameter names. Whenever a get() request is
made on the class, the listed parameters must appear in the rule, or be derivable via
UR::Context::infer_property_value_from_rule().
=item file_resolver()
file_resolver() is called as a function (not a method). It should accept the same number
of parameters as are mentioned in required_for_get(). When a get() request is made,
those named parameters are extracted from the rule and passed in to the file_resolver()
function in the same order. file_resolver() must return a string that is used as the
pathname to the file that contains the needed data. The function must not have any
other side effects.
In the case where the data source is a regular object (not a UR::Singleton'), then
the file_resover parameter should return a coderef.
=item constant_values()
constant_values() should return a listref of parameter names. These parameter names are used by
the object loader system to fill in data that may not be present in the data files. If the
class has parameters that are not actually stored in the data files, then the parameter
values are extracted from the rule and stored in the loaded object instances before being
returned to the user.
In the synopsis above, thing_type is not stored in the data files, even though it exists
as a parameter of the MyNamespace::ThingMux class.
=back
=head2 Theory of Operation
As part of the data-loading infrastructure inside UR, the parameters in a get()
request are transformed into a UR::BoolExpr instance, also called a rule.
UR::DataSource::FilMux hooks into that infrastructure by implementing
create_iterator_closure_for_rule(). It first collects the values for all the
parameters mentioned in required_for_get() by passing the rule and needed
parameter to infer_property_value_from_rule() of the current Context. If any
of the needed parameters is not resolvable, an excpetion is raised.
Some of the rule's parameters may have multiple values. In those cases, all the
combinations of values are expanded. For example of param_a has 2 values, and
param_b has 3 values, then there are 6 possible combinations.
For each combination of values, the file_resolver() function is called and
returns a pathname. For each pathname, a file-specific data source is created
(if it does not already exist), the server() configuration parameter created
to return that pathname. Other parameters are copied from the values in the
FileMux data source, such as column_names and delimiter.
create_iterator_closure_for_rule() is called on each of those data sources.
Finally, an iterator is created to wrap all of those iterators, and is returned.
=head1 INHERITANCE
UR::DataSource
=head1 SEE ALSO
UR, UR::DataSource, UR::DataSource::File
=cut
Filesystem.pm 100664 023532 023421 240021 12544604516 17504 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/DataSource package UR::DataSource::Filesystem;
use UR;
use strict;
use warnings;
our $VERSION = "0.44"; # UR $VERSION;
use File::Basename;
use File::Path;
use List::Util;
use Scalar::Util;
use Errno qw(EINTR EAGAIN EOPNOTSUPP);
# lets you specify the server in several ways:
# path => '/path/name'
# means there is one file storing the data
# path => [ '/path1/name', '/path2/name' ]
# means the first tile we need to open the file, pick one (for load balancing)
# path => '/path/to/directory/'
# means that directory contains one or more files, and the classes using
# this datasource can have table_name metadata to pick the file
# path => '/path/$param1/${param2}.ext'
# means the values for $param1 and $param2 should come from the input rule.
# If the rule doesn't specify the param, then it should glob for the possible
# names at that point in the filesystem
# path => '/path/&method/filename'
# means the value for that part of the path should come from a method call
# run as $subject_class_name->$method($rule)
# path => '/path/*/path/$name/
# means it should glob at the appropriate time for the '*', but no use the
# paths found matching the glob to infer any values
# maybe suppert a URI scheme like
# file:/path/$to/File.ext?columns=[a,b,c]&sorted_columns=[a,b]
# TODO
# * Support non-equality operators for properties that are part of the path spec
class UR::DataSource::Filesystem {
is => 'UR::DataSource',
has => [
path => { doc => 'Path spec for the path on the filesystem containing the data' },
delimiter => { is => 'String', default_value => '\s*,\s*', doc => 'Delimiter between columns on the same line' },
record_separator => { is => 'String', default_value => "\n", doc => 'Delimiter between lines in the file' },
header_lines => { is => 'Integer', default_value => 0, doc => 'Number of lines at the start of the file to skip' },
columns_from_header => { is => 'Boolean', default_value => 0, doc => 'The column names are in the first line of the file' },
handle_class => { is => 'String', default_value => 'IO::File', doc => 'Class to use for new file handles' },
],
has_optional => [
columns => { is => 'ARRAY', doc => 'Names of the columns in the file, in order' },
sorted_columns => { is => 'ARRAY', doc => 'Names of the columns by which the data file is sorted' },
],
doc => 'A data source for treating files as relational data',
};
sub can_savepoint { 0;} # Doesn't support savepoints
# Filesystem datasources don't have a "default_handle"
sub create_default_handle { undef }
sub _regex {
my $self = shift;
unless ($self->{'_regex'}) {
my $delimiter = $self->delimiter;
my $r = eval { qr($delimiter) };
if ($@ || !$r) {
$self->error_message("Unable to interepret delimiter '".$self->delimiter.": $@");
return;
}
$self->{'_regex'} = $r;
}
return $self->{'_regex'};
}
sub _logger {
my $self = shift;
my $varname = shift;
if ($ENV{$varname}) {
my $log_fh = UR::DBI->sql_fh;
return sub {
my $msg = shift;
my $time = time();
$msg =~ s/\b\$time\b/$time/g;
my $localtime = scalar(localtime $time);
$msg =~ s/\b\$localtime\b/$localtime/;
$log_fh->print($msg);
};
} else {
return \&UR::Util::null_sub;
}
}
# The behavior for handling the filehandles after fork is contained in
# the read_record_from_file closure. There's nothing special for the
# data source to do
sub prepare_for_fork {
return 1;
}
sub finish_up_after_fork {
return 1;
}
# Like UR::BoolExpr::specifies_value_for, but works on either a BoolExpr
# or another object. In the latter case, it returns true if the object's
# class has the given property
sub __specifies_value_for {
my($self, $thing, $property_name) = @_;
return $thing->isa('UR::BoolExpr')
? $thing->specifies_value_for($property_name)
: $thing->__meta__->property_meta_for_name($property_name);
}
# Like UR::BoolExpr::value_for, but works on either a BoolExpr
# or another object.
sub __value_for {
my($self, $thing, $property_name) = @_;
return $thing->isa('UR::BoolExpr')
? $thing->value_for($property_name)
: $thing->$property_name;
}
# Like UR::BoolExpr::subject_class_name, but works on either a BoolExpr
# or another object.
sub __subject_class_name {
my($self, $thing) = @_;
return $thing->isa('UR::BoolExpr')
? $thing->subject_class_name()
: $thing->class;
}
sub _replace_vars_with_values_in_pathname {
my($self, $rule_or_obj, $string, $prop_values_hash) = @_;
$prop_values_hash ||= {};
# Match something like /some/path/$var/name or /some/path${var}.ext/name
if ($string =~ m/\$\{?(\w+)\}?/) {
my $varname = $1;
my $subject_class_name = $self->__subject_class_name($rule_or_obj);
unless ($subject_class_name->__meta__->property_meta_for_name($varname)) {
Carp::croak("Invalid 'server' for data source ".$self->id
. ": Path spec $string requires a value for property $varname "
. " which is not a property of class $subject_class_name");
}
my @string_replacement_values;
if ($self->__specifies_value_for($rule_or_obj, $varname)) {
my @property_values = $self->__value_for($rule_or_obj, $varname);
if (@property_values == 1 and ref($property_values[0]) eq 'ARRAY') {
@property_values = @{$property_values[0]};
}
# Make a listref that has one element per value for that property in the rule (in-clause
# rules may have more than one value)
# Each element has 2 parts, first is the value, second is the accumulated prop_values_hash
# where we've added the occurance of this property havine one of the values
@property_values = map { [ $_, { %$prop_values_hash, $varname => $_ } ] } @property_values;
# Escape any shell glob characters in the values: [ ] { } ~ ? * and \
# we don't want a property with value '?' to be a glob wildcard
@string_replacement_values = map { $_->[0] =~ s/([[\]{}~?*\\])/\\$1/; $_ } @property_values;
} else {
# The rule doesn't have a value for this property.
# Put a shell wildcard in here, and a later glob will match things
# The '.__glob_positions__' key holds a list of places we've inserted shell globs.
# Each element is a 2-element list: index 0 is the string position, element 1 if the variable name.
# This is needed so the later glob expansion can tell the difference between globs
# that are part of the original path spec, and globs put in here
my @glob_positions = @{ $prop_values_hash->{'.__glob_positions__'} || [] };
my $glob_pos = $-[0];
push @glob_positions, [$glob_pos, $varname];
@string_replacement_values = ([ '*', { %$prop_values_hash, '.__glob_positions__' => \@glob_positions} ]);
}
my @return = map {
my $s = $string;
substr($s, $-[0], $+[0] - $-[0], $_->[0]);
[ $s, $_->[1] ];
}
@string_replacement_values;
# recursion to process the next variable replacement
return map { $self->_replace_vars_with_values_in_pathname($rule_or_obj, @$_) } @return;
} else {
return [ $string, $prop_values_hash ];
}
}
sub _replace_subs_with_values_in_pathname {
my($self, $rule_or_obj, $string, $prop_values_hash) = @_;
$prop_values_hash ||= {};
my $subject_class_name = $self->__subject_class_name($rule_or_obj);
# Match something like /some/path/&sub/name or /some/path&{sub}.ext/name
if ($string =~ m/\&\{?(\w+)\}?/) {
my $subname = $1;
unless ($subject_class_name->can($subname)) {
Carp::croak("Invalid 'server' for data source ".$self->id
. ": Path spec $string requires a value for method $subname "
. " which is not a method of class " . $self->__subject_class_name($rule_or_obj));
}
my @property_values = eval { $subject_class_name->$subname($rule_or_obj) };
if ($@) {
Carp::croak("Can't resolve final path for 'server' for data source ".$self->id
. ": Method call to ${subject_class_name}::${subname} died with: $@");
}
if (@property_values == 1 and ref($property_values[0]) eq 'ARRAY') {
@property_values = @{$property_values[0]};
}
# Make a listref that has one element per value for that property in the rule (in-clause
# rules may have more than one value)
# Each element has 2 parts, first is the value, second is the accumulated prop_values_hash
# where we've added the occurance of this property havine one of the values
@property_values = map { [ $_, { %$prop_values_hash } ] } @property_values;
# Escape any shell glob characters in the values: [ ] { } ~ ? * and \
# we don't want a return value '?' or '*' to be a glob wildcard
my @string_replacement_values = map { $_->[0] =~ s/([[\]{}~?*\\])/\\$1/; $_ } @property_values;
# Given a pathname returned from the glob, return a new glob_position_list
# that has fixed up the position information accounting for the fact that
# the globbed pathname is a different length than the original spec
my $original_path_length = length($string);
my $glob_position_list = $prop_values_hash->{'.__glob_positions__'};
my $subname_replacement_position = $-[0];
my $fix_offsets_in_glob_list = sub {
my $pathname = shift;
# alter the position only if it is greater than the position of
# the subname we're replacing
return map { [ $_->[0] < $subname_replacement_position
? $_->[0]
: $_->[0] + length($pathname) - $original_path_length,
$_->[1] ]
}
@$glob_position_list;
};
my @return = map {
my $s = $string;
substr($s, $-[0], $+[0] - $-[0], $_->[0]);
$_->[1]->{'.__glob_positions__'} = [ $fix_offsets_in_glob_list->($s) ];
[ $s, $_->[1] ];
}
@string_replacement_values;
# recursion to process the next method call
return map { $self->_replace_subs_with_values_in_pathname($rule_or_obj, @$_) } @return;
} else {
return [ $string, $prop_values_hash ];
}
}
sub _replace_glob_with_values_in_pathname {
my($self, $string, $prop_values_hash) = @_;
# a * not preceeded by a backslash, delimited by /
if ($string =~ m#([^/]*?[^\\/]?(\*)[^/]*)#) {
my $glob_pos = $-[2];
my $path_segment_including_glob = substr($string, 0, $+[0]);
my $remaining_path = substr($string, $+[0]);
my @glob_matches = map { $_ . $remaining_path }
glob($path_segment_including_glob);
my $resolve_glob_values_for_each_result;
my $glob_position_list = $prop_values_hash->{'.__glob_positions__'};
# Given a pathname returned from the glob, return a new glob_position_list
# that has fixed up the position information accounting for the fact that
# the globbed pathname is a different length than the original spec
my $original_path_length = length($string);
my $fix_offsets_in_glob_list = sub {
my $pathname = shift;
return map { [ $_->[0] + length($pathname) - $original_path_length, $_->[1] ] } @$glob_position_list;
};
if ($glob_position_list->[0]->[0] == $glob_pos) {
# This * was put in previously by a $propname in the spec that wasn't mentioned in the rule
my $path_delim_pos = index($path_segment_including_glob, '/', $glob_pos);
$path_delim_pos = length($path_segment_including_glob) if ($path_delim_pos == -1); # No more /s
my $regex_as_str = $path_segment_including_glob;
# Find out just how many *s we're dealing with and where they are, up to the next /
# remove them from the glob_position_list because we're going to resolve their values
my(@glob_positions, @property_names);
while (@$glob_position_list
and
$glob_position_list->[0]->[0] < $path_delim_pos
) {
my $this_glob_info = shift @{$glob_position_list};
push @glob_positions, $this_glob_info->[0];
push @property_names, $this_glob_info->[1];
}
# Replace the *s found with regex captures
my $glob_replacement = '([^/]*)';
my $glob_rpl_offset = 0;
my $offset_inc = length($glob_replacement) - 1; # replacing a 1-char string '*' with a 7-char string '([^/]*)'
$regex_as_str = List::Util::reduce( sub {
substr($a, $b + $glob_rpl_offset, 1, $glob_replacement);
$glob_rpl_offset += $offset_inc;
$a;
},
($regex_as_str, @glob_positions) );
my $regex = qr{$regex_as_str};
my @property_values_for_each_glob_match = map { [ $_, [ $_ =~ $regex] ] } @glob_matches;
# Fill in the property names into .__glob_positions__
# we've resolved in this iteration, and apply offset fixups for the
# difference in string length between the pre- and post-glob pathnames
$resolve_glob_values_for_each_result = sub {
return map {
my %h = %$prop_values_hash;
@h{@property_names} = @{$_->[1]};
$h{'.__glob_positions__'} = [ $fix_offsets_in_glob_list->($_->[0]) ];
[$_->[0], \%h];
}
@property_values_for_each_glob_match;
};
} else {
# This is a glob put in the original path spec
# The new path comes from the @glob_matches list.
# Apply offset fixups for the difference in string length between the
# pre- and post-glob pathnames
$resolve_glob_values_for_each_result = sub {
return map { [
$_,
{ %$prop_values_hash,
'.__glob_positions__' => [ $fix_offsets_in_glob_list->($_) ]
}
]
}
@glob_matches;
};
}
my @resolved_paths_and_property_values = $resolve_glob_values_for_each_result->();
# Recursion to process the next glob
return map { $self->_replace_glob_with_values_in_pathname( @$_ ) }
@resolved_paths_and_property_values;
} else {
delete $prop_values_hash->{'.__glob_positions__'};
return [ $string, $prop_values_hash ];
}
}
sub resolve_file_info_for_rule_and_path_spec {
my($self, $rule, $path_spec) = @_;
$path_spec ||= $self->path;
return map { $self->_replace_glob_with_values_in_pathname(@$_) }
map { $self->_replace_subs_with_values_in_pathname($rule, @$_) }
$self->_replace_vars_with_values_in_pathname($rule, $path_spec);
}
# We're overriding path() so the first time it's called, it will
# pick one from the list and then stay with that one for the life
# of the program
sub path {
my $self = shift;
unless ($self->{'__cached_path'}) {
my $path = $self->__path();
if (ref($path) and ref($path) eq 'ARRAY') {
my $count = @$path;
my $idx = $$ % $count;
$self->{'_cached_path'} = $path->[$idx];
} else {
$self->{'_cached_path'} = $path;
}
}
return $self->{'_cached_path'};
}
# Names of creation params that we should force to be listrefs
our %creation_param_is_list = map { $_ => 1 } qw( columns sorted_columns );
sub create_from_inline_class_data {
my($class, $class_data, $ds_data) = @_;
#unless (exists $ds_data->{'columns'}) {
# User didn't specify columns in the file. Assumme every property is a column, and in the same order
# We'll have to ask the class object for the column list the first time there's a query
#}
my %ds_creation_params;
foreach my $param ( qw( path delimiter record_separator columns header_lines
columns_from_header handle_class sorted_columns )
) {
if (exists $ds_data->{$param}) {
if ($creation_param_is_list{$param} and ref($ds_data->{$param}) ne 'ARRAY') {
$ds_creation_params{$param} = \( $ds_data->{$param} );
} else {
$ds_creation_params{$param} = $ds_data->{$param};
}
}
}
my $ds_id = UR::Object::Type->autogenerate_new_object_id_uuid();
my $ds_type = delete $ds_data->{'is'} || __PACKAGE__;
my $ds = $ds_type->create( %ds_creation_params, id => $ds_id );
return $ds;
}
sub _things_in_list_are_numeric {
my $self = shift;
foreach ( @{$_[0]} ) {
return 0 if (! Scalar::Util::looks_like_number($_));
}
return 1;
}
# Construct a closure to perform an operator test against the given value
# The closures return 0 is the test is successful, -1 if unsuccessful but
# the file's value was less than $value, and 1 if unsuccessful and greater.
# The iterator that churns through the file knows that if it's comparing an
# ID/sorted column, and the comparator returns 1 then we've gone past the
# point where we can expect to ever find another successful match and we
# should stop looking
my $ALWAYS_FALSE = sub { -1 };
sub _comparator_for_operator_and_property {
my($self,$property,$operator,$value) = @_;
no warnings 'uninitialized'; # we're handling ''/undef/null specially below where it matters
if ($operator eq 'between') {
if ($value->[0] eq '' or $value->[1] eq '') {
return $ALWAYS_FALSE;
}
if ($property->is_numeric and $self->_things_in_list_are_numeric($value)) {
if ($value->[0] > $value->[1]) {
# Will never be true
Carp::carp "'between' comparison will never be true with values ".$value->[0]," and ".$value->[1];
return $ALWAYS_FALSE;
}
# numeric 'between' comparison
return sub {
return -1 if (${$_[0]} eq '');
if (${$_[0]} < $value->[0]) {
return -1;
} elsif (${$_[0]} > $value->[1]) {
return 1;
} else {
return 0;
}
};
} else {
if ($value->[0] gt $value->[1]) {
Carp::carp "'between' comparison will never be true with values ".$value->[0]," and ".$value->[1];
return $ALWAYS_FALSE;
}
# A string 'between' comparison
return sub {
return -1 if (${$_[0]} eq '');
if (${$_[0]} lt $value->[0]) {
return -1;
} elsif (${$_[0]} gt $value->[1]) {
return 1;
} else {
return 0;
}
};
}
} elsif ($operator eq 'in') {
if (! @$value) {
return $ALWAYS_FALSE;
}
if ($property->is_numeric and $self->_things_in_list_are_numeric($value)) {
# Numeric 'in' comparison returns undef if we're within the range of the list
# but don't actually match any of the items in the list
@$value = sort { $a <=> $b } @$value; # sort the values first
return sub {
return -1 if (${$_[0]} eq '');
if (${$_[0]} < $value->[0]) {
return -1;
} elsif (${$_[0]} > $value->[-1]) {
return 1;
} else {
foreach ( @$value ) {
return 0 if ${$_[0]} == $_;
}
return -1;
}
};
} else {
# A string 'in' comparison
@$value = sort { $a cmp $b } @$value;
return sub {
if (${$_[0]} lt $value->[0]) {
return -1;
} elsif (${$_[0]} gt $value->[-1]) {
return 1;
} else {
foreach ( @$value ) {
return 0 if ${$_[0]} eq $_;
}
return -1;
}
};
}
} elsif ($operator eq 'not in') {
if (! @$value) {
return $ALWAYS_FALSE;
}
if ($property->is_numeric and $self->_things_in_list_are_numeric($value)) {
return sub {
return -1 if (${$_[0]} eq '');
foreach ( @$value ) {
return -1 if ${$_[0]} == $_;
}
return 0;
}
} else {
return sub {
foreach ( @$value ) {
return -1 if ${$_[0]} eq $_;
}
return 0;
}
}
} elsif ($operator eq 'like') {
# 'like' is always a string comparison. In addition, we can't know if we're ahead
# or behind in the file's ID columns, so the only two return values are 0 and 1
return $ALWAYS_FALSE if ($value eq ''); # property like NULL is always false
# Convert SQL-type wildcards to Perl-type wildcards
# Convert a % to a *, and _ to ., unless they're preceeded by \ to escape them.
# Not that this isn't precisely correct, as \\% should really mean a literal \
# followed by a wildcard, but we can't be correct in all cases without including
# a real parser. This will catch most cases.
$value =~ s/(?is_numeric and $self->_things_in_list_are_numeric([$value])) {
# Basic numeric comparisons
if ($operator eq '=') {
return sub {
return -1 if (${$_[0]} eq ''); # null always != a number
return ${$_[0]} <=> $value;
};
} elsif ($operator eq '<') {
return sub {
return -1 if (${$_[0]} eq ''); # null always != a number
${$_[0]} < $value ? 0 : 1;
};
} elsif ($operator eq '<=') {
return sub {
return -1 if (${$_[0]} eq ''); # null always != a number
${$_[0]} <= $value ? 0 : 1;
};
} elsif ($operator eq '>') {
return sub {
return -1 if (${$_[0]} eq ''); # null always != a number
${$_[0]} > $value ? 0 : -1;
};
} elsif ($operator eq '>=') {
return sub {
return -1 if (${$_[0]} eq ''); # null always != a number
${$_[0]} >= $value ? 0 : -1;
};
} elsif ($operator eq 'true') {
return sub {
${$_[0]} ? 0 : -1;
};
} elsif ($operator eq 'false') {
return sub {
${$_[0]} ? -1 : 0;
};
} elsif ($operator eq '!=' or $operator eq 'ne') {
return sub {
return 0 if (${$_[0]} eq ''); # null always != a number
${$_[0]} != $value ? 0 : -1;
}
}
} else {
# Basic string comparisons
if ($operator eq '=') {
return sub {
return -1 if (${$_[0]} eq '' xor $value eq '');
return ${$_[0]} cmp $value;
};
} elsif ($operator eq '<') {
return sub {
${$_[0]} lt $value ? 0 : 1;
};
} elsif ($operator eq '<=') {
return sub {
return -1 if (${$_[0]} eq '' or $value eq '');
${$_[0]} le $value ? 0 : 1;
};
} elsif ($operator eq '>') {
return sub {
${$_[0]} gt $value ? 0 : -1;
};
} elsif ($operator eq '>=') {
return sub {
return -1 if (${$_[0]} eq '' or $value eq '');
${$_[0]} ge $value ? 0 : -1;
};
} elsif ($operator eq 'true') {
return sub {
${$_[0]} ? 0 : -1;
};
} elsif ($operator eq 'false') {
return sub {
${$_[0]} ? -1 : 0;
};
} elsif ($operator eq '!=' or $operator eq 'ne') {
return sub {
${$_[0]} ne $value ? 0 : -1;
}
}
}
}
sub _properties_from_path_spec {
my($self) = @_;
unless (exists $self->{'__properties_from_path_spec'}) {
my $path = $self->path;
$path = $path->[0] if ref($path);
my @property_names;
while($path =~ m/\G\$\{?(\w+)\}?/) {
push @property_names, $1;
}
$self->{'__properties_from_path_spec'} = \@property_names;
}
return @{ $self->{'__properties_from_path_spec'} };
}
sub _generate_loading_templates_arrayref {
my($self, $old_sql_cols) = @_;
# Each elt in @$column_data is a quad:
# [ $class_meta, $property_meta, $table_name, $object_num ]
# Keep only the properties with columns (mostly just to remove UR::Object::id
my @sql_cols = grep { $_->[1]->column_name }
@$old_sql_cols;
my $template_data = $self->SUPER::_generate_loading_templates_arrayref(\@sql_cols);
return $template_data;
}
sub _resolve_column_names_from_pathname {
my($self,$pathname,$fh) = @_;
unless (exists($self->{'__column_names_from_pathname'}->{$pathname})) {
if (my $column_names_in_order = $self->columns) {
$self->{'__column_names_from_pathname'}->{$pathname} = $column_names_in_order;
} else {
my $record_separator = $self->record_separator();
my $line = $fh->getline();
$line =~ s/$record_separator$//; # chomp, but for any value
# FIXME - to support record-oriented files, we need some replacement for this...
my $split_regex = $self->_regex();
my @headers = split($split_regex, $line);
$self->{'__column_names_from_pathname'}->{$pathname} = \@headers;
}
}
return $self->{'__column_names_from_pathname'}->{$pathname};
}
sub file_is_sorted_as_requested {
my($self, $query_plan) = @_;
my $sorted_columns = $self->sorted_columns || [];
my $order_by_columns = $query_plan->order_by_columns();
for (my $i = 0; $i < @$order_by_columns; $i++) {
next if ($order_by_columns->[$i] eq '$.'); # input line number is always sorted
next if ($order_by_columns->[$i] eq '__FILE__');
return 0 if $i > $#$sorted_columns;
if ($sorted_columns->[$i] ne $order_by_columns->[$i]) {
return 0;
}
}
return 1;
}
# FIXME - this is a copy of parts of _generate_class_data_for_loading from UR::DS::RDBMS
sub _generate_class_data_for_loading {
my ($self, $class_meta) = @_;
my $parent_class_data = $self->SUPER::_generate_class_data_for_loading($class_meta);
my @class_hierarchy = ($class_meta->class_name,$class_meta->ancestry_class_names);
my $order_by_columns;
do {
my @id_column_names;
for my $inheritance_class_name (@class_hierarchy) {
my $inheritance_class_object = UR::Object::Type->get($inheritance_class_name);
unless ($inheritance_class_object->table_name) {
next;
}
@id_column_names =
#map {
# my $t = $inheritance_class_object->table_name;
# ($t) = ($t =~ /(\S+)\s*$/);
# $t . '.' . $_
#}
grep { defined }
map {
my $p = $inheritance_class_object->property_meta_for_name($_);
die ("No property $_ found for " . $inheritance_class_object->class_name . "?") unless $p;
$p->column_name;
}
map { $_->property_name }
grep { $_->column_name }
$inheritance_class_object->direct_id_property_metas;
last if (@id_column_names);
}
$order_by_columns = \@id_column_names;
};
my(@all_table_properties, @direct_table_properties, $first_table_name, $subclassify_by);
for my $co ( $class_meta, @{ $parent_class_data->{parent_class_objects} } ) {
my $table_name = $co->table_name;
next unless $table_name;
$first_table_name ||= $co->table_name;
# $sub_classification_method_name ||= $co->sub_classification_method_name;
# $sub_classification_meta_class_name ||= $co->sub_classification_meta_class_name;
$subclassify_by ||= $co->subclassify_by;
my $sort_sub = sub ($$) { return $_[0]->property_name cmp $_[1]->property_name };
push @all_table_properties,
map { [$co, $_, $table_name, 0 ] }
sort $sort_sub
grep { defined $_->column_name && $_->column_name ne '' }
UR::Object::Property->get( class_name => $co->class_name );
@direct_table_properties = @all_table_properties if $class_meta eq $co;
}
my $class_data = {
%$parent_class_data,
order_by_columns => $order_by_columns,
direct_table_properties => \@direct_table_properties,
all_table_properties => \@all_table_properties,
};
return $class_data;
}
# Needed for the QueryPlan's processing of order-by params
# Params are a list of the 4-tuples [class-meta, prop-meta, table-name, object-num]
sub _select_clause_columns_for_table_property_data {
my $self = shift;
return [ map { $_->[1]->column_name } @_ ];
}
# Used to populate the %value_extractor_for_column_name hash
# It should return a sub that, when given a row of data from the source,
# returns the proper data from that row.
#
# It's expected to return a sub that accepts ($self, $row, $fh, $filename)
# and return a reference to the right data. In most cases, it'll just pluck
# out the $column_idx'th element from $@row, but we're using it
# to attach special meaning to the $. token
sub _create_value_extractor_for_column_name {
my($self, $rule, $column_name, $column_idx) = @_;
if ($column_name eq '$.') {
return sub {
my($self, $row, $fh, $filename) = @_;
my $line_no = $fh->input_line_number();
return \$line_no;
};
} elsif ($column_name eq '__FILE__') {
return sub {
my($self,$row,$fh,$filename) = @_;
return \$filename;
};
} else {
return sub {
my($self, $row, $fh, $filename) = @_;
return \$row->[$column_idx];
};
}
}
sub create_iterator_closure_for_rule {
my($self,$rule) = @_;
my $class_name = $rule->subject_class_name;
my $class_meta = $class_name->__meta__;
my $rule_template = $rule->template;
# We're defering to the class metadata here because we don't yet know the
# pathnames of the files we'll be reading from. If the columns_from_header flag
# is set, then there's no way of knowing what the columns are until then
my @column_names = grep { defined }
map { $class_meta->column_for_property($_) }
$class_meta->all_property_names;
# FIXME - leaning on the sorted_columns property here means:
# 1) It's useless when used where the path spec is a directory and
# classes have table_names, since each file is likely to have different
# columns
# 2) If we ultimately end up reading from more than one file, all the files
# must be sorted in the same way. It's possible the user has sorted each
# file differently, though in practice it would make for a lot of trouble
my %column_is_sorted_descending;
my @sorted_column_names = map { if (index($_, '-') == 0) {
my $col = $_;
substr($col, 0, 1, '');
$column_is_sorted_descending{$col} = 1;
$col;
} else {
$_;
}
}
@{ $self->sorted_columns || [] };
my %sorted_column_names = map { $_ => 1 } @sorted_column_names;
my @unsorted_column_names = grep { ! exists $sorted_column_names{$_} } @column_names;
my @rule_column_names_in_order; # The order we should perform rule matches on - value is the name of the column in the file
my @comparison_for_column; # closures to call to perform the match - same order as @rule_column_names_in_order
my %rule_column_name_to_comparison_index;
my(%property_for_column, %operator_for_column, %value_for_column); # These are used for logging
my $resolve_comparator_for_column_name = sub {
my $column_name = shift;
my $property_name = $class_meta->property_for_column($column_name);
return unless $rule->specifies_value_for($property_name);
my $operator = $rule->operator_for($property_name)
|| '=';
my $rule_value = $rule->value_for($property_name);
$property_for_column{$column_name} = $property_name;
$operator_for_column{$column_name} = $operator;
$value_for_column{$column_name} = $rule_value;
my $comp_function = $self->_comparator_for_operator_and_property(
$class_meta->property($property_name),
$operator,
$rule_value);
push @rule_column_names_in_order, $column_name;
push @comparison_for_column, $comp_function;
$rule_column_name_to_comparison_index{$column_name} = $#comparison_for_column;
return 1;
};
my $sorted_columns_in_rule_count; # How many columns we can consider when trying "the shortcut" for sorted data
my %column_is_used_in_sorted_capacity;
foreach my $column_name ( @sorted_column_names ) {
if (! $resolve_comparator_for_column_name->($column_name)
and ! defined($sorted_columns_in_rule_count)
) {
# The first time we don't match a sorted column, record the index
$sorted_columns_in_rule_count = scalar(@rule_column_names_in_order);
} else {
$column_is_used_in_sorted_capacity{$column_name} = ' (sorted)';
}
}
$sorted_columns_in_rule_count ||= scalar(@rule_column_names_in_order);
foreach my $column_name ( @unsorted_column_names ) {
$resolve_comparator_for_column_name->($column_name);
}
# sort them by filename
my @possible_file_info_list = sort { $a->[0] cmp $b->[0] }
$self->resolve_file_info_for_rule_and_path_spec($rule);
my $table_name = $class_meta->table_name;
if (defined($table_name) and $table_name ne '__default__') {
# Tack the final file name onto the end if the class has a table name
@possible_file_info_list = map { [ $_->[0] . "/$table_name", $_->[1] ] } @possible_file_info_list;
}
my $handle_class = $self->handle_class;
my $use_quick_read = $handle_class eq 'IO::Handle';
my $split_regex = $self->_regex();
my $logger = $self->_logger('UR_DBI_MONITOR_SQL');
my $record_separator = $self->record_separator;
my $monitor_start_time = Time::HiRes::time();
{ no warnings 'uninitialized';
$logger->("\nFILE: starting query covering " . scalar(@possible_file_info_list)." files:\n\t"
. join("\n\t", map { $_->[0] } @possible_file_info_list )
. "\nFILTERS: "
. (scalar(@rule_column_names_in_order)
? join("\n\t", map {
$_ . $column_is_used_in_sorted_capacity{$_}
. " $operator_for_column{$_} "
. (ref($value_for_column{$_}) eq 'ARRAY'
? '[' . join(',',@{$value_for_column{$_}}) .']'
: $value_for_column{$_} )
}
@rule_column_names_in_order)
: '*none*')
. "\n\n"
);
}
my $query_plan = $self->_resolve_query_plan($rule_template);
if (@{ $query_plan->{'loading_templates'} } > 1) {
Carp::croak(__PACKAGE__ . " does not support joins. The rule was $rule");
}
my $loading_template = $query_plan->{loading_templates}->[0];
my @property_names_in_loading_template_order = @{ $loading_template->{'property_names'} };
my @column_names_in_loading_template_order = map { $class_meta->column_for_property($_) }
@property_names_in_loading_template_order;
my %property_name_to_resultset_index_map;
my %column_name_to_resultset_index_map;
for (my $i = 0; $i < @property_names_in_loading_template_order; $i++) {
my $property_name = $property_names_in_loading_template_order[$i];
$property_name_to_resultset_index_map{$property_name} = $i;
$column_name_to_resultset_index_map{$class_meta->column_for_property($property_name)} = $i;
}
my @iterator_for_each_file;
foreach ( @possible_file_info_list ) {
my $pathname = $_->[0];
my $property_values_from_path_spec = $_->[1];
my @properties_from_path_spec = keys %$property_values_from_path_spec;
my @values_from_path_spec = values %$property_values_from_path_spec;
my $pid = $$; # For tracking whether there's been a fork()
my $fh = $handle_class->new($pathname);
unless ($fh) {
$logger->("FILE: Skipping $pathname because it did not open: $!\n");
next; # missing or unopenable files is not fatal
}
my $column_names_in_order = $self->_resolve_column_names_from_pathname($pathname,$fh);
# %value_for_column_name holds subs that return the value for that column. For values
# determined from the path resolver, save that value here. Most other values get plucked out
# of the line read from the file. The remaining values are special tokens like $. and __FILE__.
# These subs are used both for testing whether values read from the data source pass the rule
# and for constructing the resultset passed up to the Context
my %value_for_column_name;
my %column_name_to_index_map;
my $ordered_column_names_count = scalar(@$column_names_in_order);
for (my $i = 0; $i < $ordered_column_names_count; $i++) {
my $column_name = $column_names_in_order->[$i];
next unless (defined $column_name);
$column_name_to_index_map{$column_name} = $i;
$value_for_column_name{$column_name}
= $self->_create_value_extractor_for_column_name($rule, $column_name, $i);
}
foreach ( '$.', '__FILE__' ) {
$value_for_column_name{$_} = $self->_create_value_extractor_for_column_name($rule, $_, undef);
$column_name_to_index_map{$_} = undef;
}
while (my($prop, $value) = each %$property_values_from_path_spec) {
my $column = $class_meta->column_for_property($prop);
$value_for_column_name{$column} = sub { return \$value };
$column_name_to_index_map{$column} = undef;
}
# Convert the column_name keys here to indexes into the comparison list
my %column_for_this_comparison_is_sorted_descending =
map { $rule_column_name_to_comparison_index{$_} => $column_is_sorted_descending{$_} }
grep { exists $rule_column_name_to_comparison_index{$_} }
keys %column_is_sorted_descending;
# rule properties that aren't actually columns in the file should be
# satisfied by the path resolution already, so we can strip them out of the
# list of columns to test
my @rule_columns_in_order = map { $column_name_to_index_map{$_} }
grep { exists $column_name_to_index_map{$_} }
@rule_column_names_in_order;
# And also strip out any items in @comparison_for_column for non-column data
my @comparison_for_column_this_file = map { $comparison_for_column[ $rule_column_name_to_comparison_index{$_} ] }
grep { exists $column_name_to_index_map{$_} }
@rule_column_names_in_order;
# Burn through the requsite number of header lines
my $lines_read = $fh->input_line_number;
my $throwaway_line_count = $self->header_lines;
while($throwaway_line_count > $lines_read) {
$lines_read++;
scalar($fh->getline());
}
my $lines_matched = 0;
my $log_first_fetch;
$log_first_fetch = sub {
$logger->(sprintf("FILE: $pathname FIRST FETCH TIME: %.4f s\n\n", Time::HiRes::time() - $monitor_start_time));
$log_first_fetch = \&UR::Util::null_sub;
};
my $log_first_match;
$log_first_match = sub {
$logger->("FILE: $pathname First match after reading $lines_read lines\n\n");
$log_first_match = \&UR::Util::null_sub;
};
my $next_record;
# This sub reads the next record (line) from the file, splits the line into
# columns and puts the data into @$next_record
my $record_separator_re = qr($record_separator$);
my $read_record_from_file = sub {
# Make sure some wise guy hasn't changed this out from under us
local $/ = $record_separator;
if ($pid != $$) {
# There's been a fork() between the original opening and now
# This filehandle is no longer valid to read from, but tell()
# should still report the right position
my $pos = $fh->tell();
$logger->("FILE: reopening file $pathname and seeking to position $pos after fork()\n");
my $fh = $handle_class->new($pathname);
unless ($fh) {
$logger->("FILE: Reopening $pathname after fork() failed: $!\n");
return; # behave if we're at EOF
}
$fh->seek($pos, 0); # fast-forward to the old position
$pid = $$;
}
my $line;
READ_LINE_FROM_FILE:
while(! defined($line)) {
# Hack for OSX 10.5.
# At EOF, the getline below will return undef. Most builds of Perl
# will also set $! to 0 at EOF so you can distinguish between the cases
# of EOF (which may have actually happened a while ago because of buffering)
# and an actual read error. OSX 10.5's Perl does not, and so $!
# retains whatever value it had after the last failed syscall, likely
# a stat() while looking for a Perl module. This should have no effect
# other platforms where you can't trust $! at arbitrary points in time
# anyway
$! = 0;
$line = $use_quick_read ? <$fh> : $fh->getline();
if ($line and $line !~ $record_separator_re) {
# Was a short read - probably at EOF
# If the record_separator is a multi-char string, and the last
# characters of $line are the first characters of the
# record_separator, it's likely (though not certain) that the right
# Thing to do is to remove the partial record separator.
for (my $keep_chars = length($record_separator); $keep_chars > 0; $keep_chars--) {
my $match_rs = substr($record_separator, 0, $keep_chars);
if ($line =~ m/$match_rs$/) {
substr($line, 0 - $keep_chars) = '';
last;
}
}
}
unless (defined $line) {
if ($! && ! $fh->eof()) {
redo READ_LINE_FROM_FILE if ($! == EAGAIN or $! == EINTR);
Carp::croak("read failed for file $pathname: $!");
}
# at EOF. Close up shop and remove this fh from the list
#flock($fh,LOCK_UN);
$fh = undef;
$next_record = undef;
$logger->("FILE: $pathname at EOF\n"
. "FILE: $lines_read lines read for this request. $lines_matched matches in this file\n"
. sprintf("FILE: TOTAL EXECUTE-FETCH TIME: %.4f s\n\n", Time::HiRes::time() - $monitor_start_time)
);
return;
}
}
$lines_read++;
$line =~ s/$record_separator$//; # chomp, but for any value
# FIXME - to support record-oriented files, we need some replacement for this...
$next_record = [ split($split_regex, $line, $ordered_column_names_count) ];
};
my $number_of_comparisons = @comparison_for_column_this_file;
# The file filter iterator.
# This sub looks at @$next_record and applies the comparator functions in order.
# If it passes all of them, it constructs a resultset row and passes it up to the
# multiplexer iterator
my $file_filter_iterator = sub {
$log_first_fetch->();
FOR_EACH_LINE:
for(1) {
$read_record_from_file->();
unless ($next_record) {
# Done reading from this file
return;
}
for (my $i = 0; $i < $number_of_comparisons; $i++) {
my $comparison = $comparison_for_column_this_file[$i]->(
$value_for_column_name{ $rule_column_names_in_order[$i] }->($self, $next_record, $fh, $pathname)
);
if ( ( ($column_for_this_comparison_is_sorted_descending{$i} and $comparison < 0) or $comparison > 0)
and $i < $sorted_columns_in_rule_count
) {
# We've gone past the last thing that could possibly match
$logger->("FILE: $pathname $lines_read lines read for this request. $lines_matched matches\n"
. sprintf("FILE: TOTAL EXECUTE-FETCH TIME: %.4f s\n", Time::HiRes::time() - $monitor_start_time));
#flock($fh,LOCK_UN);
return;
} elsif ($comparison) {
# comparison didn't match, read another line from the file
redo FOR_EACH_LINE;
}
# That comparison worked... stay in the for() loop for other comparisons
}
}
# All the comparisons return '0', meaning they passed
$log_first_match->();
$lines_matched++;
my @resultset = map { ref($_) ? $$_ : $_ }
map { ref($value_for_column_name{$_})
? $value_for_column_name{$_}->($self, $next_record, $fh, $pathname)
: $value_for_column_name{$_} # constant value from path spec
}
@column_names_in_loading_template_order;
return \@resultset;
};
# Higher layers in the loading logic require rows from the data source to be returned
# in ID order. If the file contents is not sorted primarily by ID, then we need to do
# the less efficient thing by first reading in all the matching rows in one go, sorting
# them by ID, then iterating over the results
unless ($self->file_is_sorted_as_requested($query_plan)) {
my @resultset_indexes_to_sort = map { $column_name_to_resultset_index_map{$_} }
@{ $query_plan->order_by_columns() };
$file_filter_iterator
= $self->_create_iterator_for_custom_sorted_columns($file_filter_iterator, $query_plan, \%column_name_to_resultset_index_map);
}
push @iterator_for_each_file, $file_filter_iterator;
}
if (! @iterator_for_each_file) {
return \&UR::Util::null_sub; # No matching files
} elsif (@iterator_for_each_file == 1) {
return $iterator_for_each_file[0]; # If there's only 1 file, no need to multiplex
}
my @next_record_for_each_file; # in the same order as @iterator_for_each_file
my %column_is_numeric = map { $_->column_name => $_->is_numeric }
map { $class_meta->property_meta_for_name($_) }
map { $class_meta->property_for_column($_) }
map { index($_, '-') == 0 ? substr($_, 1) : $_ }
@{ $query_plan->order_by_columns };
my @resultset_index_sort_sub
= map { &_resolve_sorter_for( is_numeric => $column_is_numeric{$_},
is_descending => $column_is_sorted_descending{$_},
column_index => $property_name_to_resultset_index_map{$_});
}
@sorted_column_names;
my %resultset_idx_is_sorted_descending = map { $column_name_to_resultset_index_map{$_} => 1 }
keys %column_is_sorted_descending;
my $resultset_sorter = sub {
my($idx_a,$idx_b) = shift;
foreach my $sort_sub ( @resultset_index_sort_sub ) {
my $cmp = $sort_sub->($next_record_for_each_file[$idx_a], $next_record_for_each_file[$idx_b]);
return $cmp if $cmp; # done if they're not equal
}
return 0;
};
# This is the iterator returned to the Context, and knows about all the individual
# file filter iterators. It compares the next resultset from each of them and
# returns the next resultset to the Context
my $multiplex_iterator = sub {
return unless @iterator_for_each_file; # if they're all run out
my $lowest_slot;
for(my $i = 0; $i < @iterator_for_each_file; $i++) {
unless(defined $next_record_for_each_file[$i]) {
$next_record_for_each_file[$i] = $iterator_for_each_file[$i]->();
unless (defined $next_record_for_each_file[$i]) {
# That iterator is exhausted, splice it out
splice(@iterator_for_each_file, $i, 1);
splice(@next_record_for_each_file, $i, 1);
return unless (@iterator_for_each_file); # This can happen here if none of the files have matching data
redo;
}
}
unless (defined $lowest_slot) {
$lowest_slot = $i;
next;
}
my $cmp = $resultset_sorter->($lowest_slot, $i);
if ($cmp > 0) {
$lowest_slot = $i;
}
}
my $retval = $next_record_for_each_file[$lowest_slot];
$next_record_for_each_file[$lowest_slot] = undef;
return $retval;
};
return $multiplex_iterator;
}
# Constructors for subs to sort appropriately
sub _resolve_sorter_for {
my %params = @_;
my $col_idx = $params{'column_index'};
my $is_descending = (exists($params{'is_descending'}) && $params{'is_descending'})
||
(exists($params{'is_ascending'}) && $params{'is_ascending'});
my $is_numeric = (exists($params{'is_numeric'}) && $params{'is_numeric'})
||
(exists($params{'is_string'}) && $params{'is_string'});
if ($is_descending) {
if ($is_numeric) {
return sub($$) { $_[1]->[$col_idx] <=> $_[0]->[$col_idx] };
} else {
return sub($$) { $_[1]->[$col_idx] cmp $_[0]->[$col_idx] };
}
} else {
if ($is_numeric) {
return sub($$) { $_[0]->[$col_idx] <=> $_[1]->[$col_idx] };
} else {
return sub($$) { $_[0]->[$col_idx] cmp $_[1]->[$col_idx] };
}
}
}
# Higher layers in the loading logic require rows from the data source to be returned
# in ID order. If the file contents is not sorted primarily by ID, then we need to do
# the less efficient thing by first reading in all the matching rows in one go, sorting
# them by ID, then iterating over the results
sub _create_iterator_for_custom_sorted_columns {
my($self, $iterator_this_file, $query_plan, $column_name_to_resultset_index_map) = @_;
my @matching;
while (my $row = $iterator_this_file->()) {
push @matching, $row; # save matches as [id, rowref]
}
unless (@matching) {
return \&UR::Util::null_sub; # Easy, no matches
}
my $class_meta = $query_plan->class_name->__meta__;
my %column_is_numeric = map { $_->column_name => $_->is_numeric }
map { $class_meta->property_meta_for_name($_) }
map { $class_meta->property_for_column($_) }
map { index($_, '-') == 0 ? substr($_,1) : $_ }
@{ $query_plan->order_by_columns };
my @sorters;
{ no warnings 'numeric';
no warnings 'uninitialized';
@sorters = map { &_resolve_sorter_for(%$_) }
map { my $col_name = $_;
my $descending = 0;
if (index($col_name, '-') == 0) {
$descending = 1;
substr($col_name, 0, 1, ''); # remove the -
}
my $col_idx = $column_name_to_resultset_index_map->{$col_name};
{ column_index => $col_idx, is_descending => $descending, is_numeric => $column_is_numeric{$col_name} };
}
@{ $query_plan->order_by_columns };
}
my $sort_by_order_by_columns;
if (@sorters == 1) {
$sort_by_order_by_columns = $sorters[0];
} else {
$sort_by_order_by_columns
= sub($$) {
foreach (@sorters) {
if (my $rv = $_->(@_)) {
return $rv;
}
}
return 0;
};
}
@matching = sort $sort_by_order_by_columns
@matching;
return sub {
return shift @matching;
};
}
sub initializer_should_create_column_name_for_class_properties {
1;
}
# The string used to join fields of a row together when writing
#
# Since the 'delimiter' property is interpreted as a regex in the reading
# code, we'll try to be smart about making a real string from that.
#
# subclasses can override this to provide a different implementation
sub column_join_string {
my $self = shift;
my $join_pattern = $self->delimiter;
# make some common substitutions...
if ($join_pattern eq '\s*,\s*') {
# The default...
return ', ';
}
$join_pattern =~ s/\\s*//g; # Turn 0-or-more whitespaces to nothing
$join_pattern =~ s/\\t/\t/; # tab
$join_pattern =~ s/\\s/ /; # whitespace
return $join_pattern;
}
sub _sync_database {
my $self = shift;
my %params = @_;
unless (ref($self)) {
if ($self->isa("UR::Singleton")) {
$self = $self->_singleton_object;
}
else {
Carp::croak("Cannot call _sync_database as a class method on a non-singleton class");
}
}
$DB::single=1;
my $changed_objects = delete $params{'changed_objects'};
my $path_spec = $self->path;
# First, bin up the changed objects by their class' table_name
my %objects_for_path;
foreach my $obj ( @$changed_objects ) {
my @path = $self->resolve_file_info_for_rule_and_path_spec($obj, $path_spec);
if (!@path) {
$self->error_message("Couldn't resolve destination file for object "
.$obj->class." ID ".$obj->id.": ".Data::Dumper::Dumper($obj));
return;
} elsif (@path > 1) {
$self->error_message("Got multiple filenames when resolving destination file for object "
. $obj->class." ID ".$obj->id.": ".join(', ', @path));
}
$objects_for_path{ $path[0]->[0] } ||= [];
push @{ $objects_for_path{ $path[0]->[0] } }, $obj;
}
my %objects_for_pathname;
foreach my $path ( keys %objects_for_path ) {
foreach my $obj ( @{ $objects_for_path{$path} } ) {
my $class_meta = $obj->__meta__;
my $table_name = $class_meta->table_name;
my $pathname = $path;
if (defined($table_name) and $table_name ne '__default__') {
$pathname .= '/' . $table_name;
}
$objects_for_pathname{$pathname} ||= [];
push @{ $objects_for_pathname{$pathname} }, $obj;
}
}
my %column_is_sorted_descending;
my @sorted_column_names = map { if (index($_, '-') == 0) {
my $s = $_;
substr($s, 0, 1, '');
$column_is_sorted_descending{$s} = $s;
} else {
$_;
}
}
@{ $self->sorted_columns() || [] };
my $handle_class = $self->handle_class;
my $use_quick_read = $handle_class->isa('IO::Handle');
my $join_string = $self->column_join_string;
my $record_separator = $self->record_separator;
my $split_regex = $self->_regex();
local $/; # Make sure some wise guy hasn't changed this out from under us
$/ = $record_separator;
my $logger = $self->_logger('UR_DBI_MONITOR_SQL');
my $total_save_time = Time::HiRes::time();
$logger->("FILE: Saving changes to ".scalar(keys %objects_for_pathname) . " files:\n\t"
. join("\n\t", keys(%objects_for_pathname)) . "\n\n");
foreach my $pathname ( keys %objects_for_pathname ) {
my $use_quick_rename;
my $containing_directory = File::Basename::dirname($pathname);
unless (-d $containing_directory) {
File::Path::mkpath($containing_directory);
}
if (-w $containing_directory) {
$use_quick_rename = 1;
} elsif (! -w $pathname) {
Carp::croak("Cannot save to file $pathname: Neither the directory nor the file are writable");
}
my $read_fh = $handle_class->new($pathname);
# Objects going to the same file should all be of a common class
my $class_meta = $objects_for_pathname{$pathname}->[0]->__meta__;
my @property_names_that_are_sorted = map { $class_meta->property_for_column($_) }
@sorted_column_names;
# Returns true of the passed-in object has a change in one of the sorted columns
my $object_has_changed_sorted_column = sub {
my $obj = shift;
foreach my $prop ( @property_names_that_are_sorted ) {
if (UR::Context->_get_committed_property_value($obj, $prop) ne $obj->$prop) {
return 1;
}
}
return 0;
};
my $column_names_in_file = $self->_resolve_column_names_from_pathname($pathname, $read_fh);
my $column_names_count = @$column_names_in_file;
my %column_name_to_index;
for (my $i = 0; $i < @$column_names_in_file; $i++) {
$column_name_to_index{$column_names_in_file->[$i]} = $i;
}
# This lets us take a hash slice of the object and get a row for the file
my @property_names_in_column_order = map { $class_meta->property_for_column($_) }
@$column_names_in_file;
my %column_name_is_numeric = map { $_->column_name => $_->is_numeric }
map { $class_meta->property_meta_for_name($_) }
map { $class_meta->property_for_column($_) }
@$column_names_in_file;
my $insert = [];
my $update = {};
my $delete = {};
foreach my $obj ( @{ $objects_for_pathname{$pathname} } ) {
if ($obj->isa('UR::Object::Ghost')) {
# This should be removed from the file
my $original = $obj->{'db_committed'};
my $line = join($join_string, @{$original}{@property_names_in_column_order}) . $record_separator;
$delete->{$line} = $obj;
} elsif ($obj->{'db_committed'}) {
# this is a changed object
my $original = $obj->{'db_committed'};
if ($object_has_changed_sorted_column->($obj)) {
# One of hte sorted columns has changed. Model this as a delete and insert
push @$insert, [ @{$obj}{@property_names_in_column_order} ];
my $line = join($join_string, @{$original}{@property_names_in_column_order}) . $record_separator;
$delete->{$line} = $obj;
} else {
# This object is changed since it was read in the file
my $original_line = join($join_string, @{$original}{@property_names_in_column_order}) . $record_separator;
my $changed_line = join($join_string, @{$obj}{@property_names_in_column_order}) . $record_separator;
$update->{$original_line} = $changed_line;
}
} else {
# This object is new and should be added to the file
push @$insert, [ @{$obj}{@property_names_in_column_order} ];
}
}
my %column_is_sorted_descending;
my @sorted_column_names = map { if (index($_, '-') == 0) {
my $s = $_;
substr($s, 0, 1, '');
$column_is_sorted_descending{$s} = $s;
} else {
$_;
}
}
@{ $self->sorted_columns() || [] };
my $row_sort_sub;
if (@sorted_column_names) {
my @comparison_subs = map { &_resolve_sorter_for(is_numeric => $column_name_is_numeric{$_},
is_descending => $column_is_sorted_descending{$_},
column_index => $column_name_to_index{$_})
}
@sorted_column_names;
$row_sort_sub = sub ($$) {
foreach my $comparator ( @comparison_subs ) {
my $cmp = $comparator->($_[0], $_[1]);
return $cmp if $cmp;
}
return 0;
};
# Put the rows-to-insert in sorted order
my @insert_sorted = sort $row_sort_sub @$insert;
$insert = \@insert_sorted;
}
my $write_fh = $use_quick_rename
? File::Temp->new(DIR => $containing_directory)
: File::Temp->new();
unless ($write_fh) {
Carp::croak("Can't save changes for $pathname: Can't create temporary file for writing: $!");
}
my $monitor_start_rime = Time::HiRes::time();
my $time = time();
$logger->(sprintf("\nFILE: SYNC DATABASE AT %s [%s]. Started transaction for %s to temp file %s\n",
$time, scalar(localtime($time)), $pathname, $write_fh->filename));
# Write headers to the new file
for (my $i = 0; $i < $self->header_lines; $i++) {
my $line = $use_quick_read ? <$read_fh> : $read_fh->getline();
$write_fh->print($line);
}
my $line;
READ_A_LINE:
while(1) {
unless ($line) {
$line = $use_quick_read ? <$read_fh> : $read_fh->getline();
last unless defined $line;
}
if (@sorted_column_names and scalar(@$insert)) {
# There are sorted things waiting to insert
my $chomped = $line;
$chomped =~ s/$record_separator$//; # chomp, but for any value
my $row = [ split($split_regex, $chomped, $column_names_count) ];
my $cmp = $row_sort_sub->($row, $insert->[0]);
if ($cmp > 0) {
# write the object's data
no warnings 'uninitialized'; # Some of the object's data may be undef
my $new_row = shift @$insert;
my $new_line = join($join_string, @$new_row) . $record_separator;
$logger->("FILE: INSERT >>$new_line<<\n");
$write_fh->print($new_line);
# Don't undef the last line read, meaning it could still be written to the output...
next READ_A_LINE;
}
}
if (my $obj = delete $delete->{$line}) {
$logger->("FILE: DELETE >>$line<<\n");
} elsif (my $changed = delete $update->{$line}) {
$logger->("FILE: UPDFATE replace >>$line<< with >>$changed<<\n");
$write_fh->print($changed);
} else {
# This line form the file was unchanged in the app
$write_fh->print($line);
}
$line = undef;
}
if (keys %$delete) {
$self->warning_message("There were " . scalar( keys %$delete)
. " deleted " . $class_meta->class_name
. " objects that did not match data in file $pathname");
}
if (keys %$update) {
$self->warning_message("There were " . scalar( keys %$delete)
. " updated " . $class_meta->class_name
. " objects that did not match data in file $pathname");
}
# finish out by writing the rest of the new data
foreach my $new_row ( @$insert ) {
no warnings 'uninitialized'; # Some of the object's data may be undef
my $new_line = join($join_string, @$new_row) . $record_separator;
$logger->("FILE: INSERT >>$new_line<<\n");
$write_fh->print($new_line);
}
my $changed_objects = $objects_for_pathname{$pathname};
unless ($self->_set_specified_objects_saved_uncommitted( $changed_objects )) {
Carp::croak("Error setting objects to a saved state after syncing");
}
# These closures will keep $write_fh in scope and delay their removal until
# commit() or rollback(). Call these with no args to commit, and one arg (doesn't
# matter what) to roll back
my $commit = $use_quick_rename
? sub {
if (@_) {
$self->_set_specified_objects_saved_rolled_back($changed_objects);
} else {
my $temp_filename = $write_fh->filename;
$logger->("FILE: COMMIT rename $temp_filename => $pathname\n");
unless (rename($temp_filename, $pathname)) {
$self->error_message("Can't rename $temp_filename to $pathname: $!");
return;
}
$self->_set_specified_objects_saved_committed($changed_objects);
}
return 1;
}
:
sub {
if (@_) {
$self->_set_specified_objects_saved_rolled_back($changed_objects);
} else {
my $temp_filename = $write_fh->filename;
$logger->("FILE: COMMIT copy " . $temp_filename . " => $pathname\n");
my $read_fh = IO::File->new($temp_filename);
unless ($read_fh) {
$self->error_message("Can't open file $temp_filename for reading: $!");
return;
}
my $copy_fh = IO::File->new($pathname, 'w');
unless ($copy_fh) {
$self->error_message("Can't open file $pathname for writing: $!");
return;
}
while(<$read_fh>) {
$copy_fh->print($_);
}
$copy_fh->close();
$read_fh->close();
$self->_set_specified_objects_saved_committed($changed_objects);
}
return 1;
};
$write_fh->close();
$self->{'__saved_uncommitted'} ||= [];
push @{ $self->{'__saved_uncommitted'} }, $commit;
$time = time();
$logger->("\nFILE: SYNC DATABASE finished ".$write_fh->filename . "\n");
}
$logger->(sprintf("Saved changes to %d files in %.4f s\n",
scalar(@{ $self->{'__saved_uncommitted'}}), Time::HiRes::time() - $total_save_time));
return 1;
}
sub commit {
my $self = shift;
if (! ref($self) and $self->isa('UR::Singleton')) {
$self = $self->_singleton_object;
}
if ($self->{'__saved_uncommitted'}) {
foreach my $commit ( @{ $self->{'__saved_uncommitted'}}) {
$commit->();
}
}
delete $self->{'__saved_uncommitted'};
return 1;
}
sub rollback {
my $self = shift;
if (! ref($self) and $self->isa('UR::Singleton')) {
$self = $self->_singleton_object;
}
if ($self->{'__saved_uncommitted'}) {
foreach my $commit ( @{ $self->{'__saved_uncommitted'}}) {
$commit->('rollback');
}
}
delete $self->{'__saved_uncommitted'};
return 1;
}
1;
__END__
=pod
=head1 NAME
UR::DataSource::Filesystem - Get and save objects to delimited text files
=head1 SYNOPSIS
# Create an object for the data file
my $people_data = UR::DataSource::Filesystem->create(
columns => ['person_id','name','age','street_address'],
sorted_columns => ['age','person_id'],
path => '/var/lib/people/$state/$city/people.txt',
delimiter => "\t", # between columns in the file
record_separator => "\n", # between lines in the file
);
# Define an entity class for the people in the file
class MyProgram::Person {
id_by => 'person_id',
has => [
name => { is => 'String' },
age => { is => 'Number' },
street_address => { is => 'String' },
city => { is => 'String' },
state => { is => 'String' },
],
data_source_id => $people_data->id,
};
# Get all people that live in any city named Springfield older than 40
my @springfielders = MyProgram::Person->get(city => 'Springfield', 'age >' => 40);
=head1 DESCRIPTION
A Filesystem data source object represents one or more files on the fileystem.
In the simplest case, the object's 'path' property names a file that stores
the data.
=head2 Properties
These properties determine the configuration for the data source.
=over 4
=item path
path is a string representing the path to the files. Besides just being a
simple pathname to one file, the string can also be a specification of
many similar files, or a directory containing multiple files. See below
for more information about 'path'
=item record_separator
The separator between lines in the file. This gets stored in $/ before calling
getline() to read data. The default record_separator is "\n".
=item delimiter
The separator between columns in the file. It is used to construct a regex
with qr() to split() a line into a list of values. The default delimiter
is '\s*,\s*', meaning that the file is separated by commas. Another common
value would be "\t" for tabs.
=item columns
A listref of column names in the file. Just as SQL tables have columns,
Filesystem files also have named columns so the system knows how to read
the file data into object properties. A Filesystem data source does
not need to specify named columns if the 'columns_from_header' property
is true.
Classes that use the Filesystem data source attach their properties to the
data source's columns via the 'column_name' metadata. Besides the columns
directly named in the 'columns' list, two additional column-like tokens may
be used as a column_name: '__FILE__' and '$.'. __FILE__ means the object's
property will hold the name of the file the data was read from. $. means the
value will be the input line number from the file. These are useful when
iterating over the contents of a file. Since these two fake columns are
always considered "sorted", it makes reading from the file faster in some
cases. See the 'sorted_columns' discussion below for more information.
=item sorted_columns
A listref of column names that the file is sorted by, in the order of the
sorting. If a column is sorted in descending order, put a minus (-) in front
of the name. If the file is sorted by multiple columns, say first by last_name
and then by first_name, then include them both:
sorted_columns => ['last_name','first_name']
The system uses this information to know when to stop reading if a query is
done on a sorted column. It's also used to determine whether a query done
on the data source matches the sort order of the file. If not, then the
data must be gathered in two passes. The first pass finds records in the
file that match the filter. After that, the matching records are sorted
in the same way the query is requesting before returning the data to the
Context.
The Context expects incoming data to always be sorted by at least the
class' ID properties. If the file is unsorted and the caller wants to be
able to iterate over the data, then it is common to have the class' ID
properties specified like this:
id_by => [
file => { is => 'String', column_name => '__FILE__' },
line => { is => 'Integer', column_name => '$.' },
]
Otherwise, it will need to read in the whole file and sort the contents
before returning the first row of data from its iterator.
=item columns_from_header
If true, the system will read the first line of the file to determine what the
column names are.
=item header_lines
The number of lines at the top of the file that do not contain entity data.
When the file is opened, this number of lines are skipped before reading
data. If the columns_from_header flag is true, the header_lines value should
be at least 1.
=item handle_class
Which class to use for reading and writing to the file. The default is
IO::File. Any other value must refer to a class that has the same interface
as IO::File, in particular: new, input_line_number, getline, tell, seek and
print.
=back
=head2 Path specification
Besides refering to just one file on the filesystem, the path spec is a
recipe for finding files in a directory tree. If a class using a Filesystem
data source does not have 'table_name' metadata, then the path specification
must resolve to file names. Alternatively, classes may specify their
'table_name' which is interpreted as a file within the directory indicated
by the path specification.
Three kinds of special tokens can also appear in a file spec:
=over 4
=item $property
When querying, the system will extract the value (or values, for an in-clause)
of $property from the BoolExpr when constructing the pathname. If the
BoolExpr does not have a value for that property, then the system will do a
shell glob to find the possible values. For example, given this path spec
and query:
path => '/var/people/$state/$city/people.txt'
my @people = MyProgram::People->get(city => 'Springfield', 'age >' => 40);
it would find the data files using the glob expression
/var/people/*/Springfield/people.txt
It also knows that any objects coming from the file
/var/people/CA/Springfield/people.txt
must have the value 'CA' for their 'state' property, even though that
information is not in the contents of the file.
When committing changes back to the file, the object property values are
used to determine which file it should be saved to.
The property name can also be wrapped in braces:
/var/people/${state}_US/city_${city}/people.txt
=item &method
The replacement value is resolved by calling the named method on the subject
class of the query. The method is called like this:
$replacement = $subject_class->$method( $boolexpr_or_object);
During a query, the method is passed a BoolExpr; during a commit, the method
is passed an object. It must return a string.
The method name can also be wrapped in braces:
/&{resolve_prefix}.dir/people.txt
=item *, ?
Literal shell glob wildcards are honored when finding files, but their values
are not used to supply values to objects.
=back
=head2 Environment Variables
If the environment variable $UR_DBI_MONITOR_SQL is true, then the Filesystem
data source will print information about the queries it runs.
=head1 INHERITANCE
UR::DataSource
=head1 SEE ALSO
UR, UR::DataSource
=cut
Meta.pm 100664 023532 023421 13703 12544604516 16233 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/DataSource package UR::DataSource::Meta;
# The datasource for metadata describing the tables, columns and foreign
# keys in the target datasource
use strict;
use warnings;
use version;
use DBD::SQLite;
use UR;
our $VERSION = "0.44"; # UR $VERSION;
UR::Object::Type->define(
class_name => 'UR::DataSource::Meta',
is => ['UR::DataSource::SQLite'],
has_constant => [
owner => { value => 'main' },
],
);
sub _resolve_class_name_for_table_name_fixups {
my $self = shift->_singleton_object;
if ($_[0] =~ m/Dd/) {
$_[0] = "DataSource::RDBMS::";
}
return @_;
}
# Do a DB dump at commit time
sub dump_on_commit { 1; }
# This is the template for the schema:
our $METADATA_DB_SQL =<__meta__->module_path();
my $meta_datasource_name = $namespace_name . '::DataSource::Meta';
my $meta_datasource = UR::Object::Type->define(
class_name => $meta_datasource_name,
is => 'UR::DataSource::Meta',
is_abstract => 0,
);
my $meta_datasource_src = $meta_datasource->resolve_module_header_source();
my $meta_datasource_filename = $meta_datasource->module_base_name();
my $meta_datasource_filepath = $namespace_path;
return unless defined($meta_datasource_filepath); # This namespace could be fabricated at runtime
$meta_datasource_filepath =~ s/.pm//;
$meta_datasource_filepath .= '/DataSource';
mkdir($meta_datasource_filepath);
unless (-d $meta_datasource_filepath) {
die "Failed to create directory $meta_datasource_filepath: $!";
}
$meta_datasource_filepath .= '/Meta.pm';
# Write the Meta DB datasource Module
if (-e $meta_datasource_filepath) {
Carp::croak("Can't create new MetaDB datasource Module $meta_datasource_filepath: File already exists");
}
my $fh = IO::File->new("> $meta_datasource_filepath");
unless ($fh) {
Carp::croak("Can't create MetaDB datasource Module $meta_datasource_filepath: $!");
}
$fh->printf($module_template, $meta_datasource_name, $meta_datasource_src);
# Write the skeleton SQLite file
my $meta_db_file = $meta_datasource->class_name->_data_dump_path;
IO::File->new(">$meta_db_file")->print($UR::DataSource::Meta::METADATA_DB_SQL);
return ($meta_datasource, $meta_db_file);
}
sub _dbi_connect_args {
my $self = shift;
my @connection = $self->SUPER::_dbi_connect_args(@_);
if(version->parse($DBD::SQLite::VERSION) >= version->parse('1.38_01')) {
my $connect_attr = $connection[3] ||= {};
$connect_attr->{sqlite_use_immediate_transaction} = 0;
}
return @connection;
}
1;
=pod
=head1 NAME
UR::DataSource::Meta - Data source for the MetaDB
=head1 SYNOPSIS
my $meta_table = UR::DataSource::RDBMS::Table->get(
table_name => 'DD_TABLE'
namespace => 'UR',
);
my @myapp_tables = UR::DataSource::RDBMS::Table->get(
namespace => 'MyApp',
);
=head1 DESCRIPTION
UR::DataSource::Meta a datasource that contains all table/column meta
data for the UR namespace itself. Essentially the schema schema.
=head1 INHERITANCE
UR::DataSource::Meta is a subclass of L
=head1 get() required parameters
C or C are required parameters when calling C
on any MetaDB-sourced object types.
=cut
Meta.sqlite3-dump 100664 023532 023421 30261 12544604516 20144 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/DataSource BEGIN TRANSACTION;
CREATE TABLE dd_table (
data_source varchar NOT NULL,
owner varchar,
table_name varchar NOT NULL,
table_type varchar NOT NULL,
er_type varchar NOT NULL,
last_ddl_time timestamp,
last_object_revision timestamp NOT NULL,
remarks varchar,
PRIMARY KEY(data_source, table_name)
);
INSERT INTO "dd_table" VALUES('UR::DataSource::Meta','main','dd_table_column','TABLE','entity',NULL,'2007-04-16 19:35:06',NULL);
INSERT INTO "dd_table" VALUES('UR::DataSource::Meta','main','dd_bitmap_index','TABLE','entity',NULL,'2007-04-16 19:35:06',NULL);
INSERT INTO "dd_table" VALUES('UR::DataSource::Meta','main','dd_pk_constraint_column','TABLE','entity',NULL,'2007-04-16 19:35:07',NULL);
INSERT INTO "dd_table" VALUES('UR::DataSource::Meta','main','dd_fk_constraint','TABLE','entity',NULL,'2007-04-16 19:35:07',NULL);
INSERT INTO "dd_table" VALUES('UR::DataSource::Meta','main','dd_fk_constraint_column','TABLE','entity',NULL,'2007-04-16 19:35:07',NULL);
INSERT INTO "dd_table" VALUES('UR::DataSource::Meta','main','dd_table','TABLE','entity',NULL,'2007-04-16 19:35:07',NULL);
INSERT INTO "dd_table" VALUES('UR::DataSource::Meta','main','dd_unique_constraint_column','TABLE','entity',NULL,'2007-04-16 19:35:06',NULL);
CREATE TABLE dd_bitmap_index (
data_source varchar NOT NULL,
owner varchar,
table_name varchar NOT NULL,
bitmap_index_name varchar NOT NULL,
PRIMARY KEY (data_source, table_name, bitmap_index_name)
);
CREATE TABLE dd_table_column (
data_source varchar NOT NULL,
owner varchar,
table_name varchar NOT NULL,
column_name varchar NOT NULL,
data_type varchar NOT NULL,
data_length varchar,
nullable varchar NOT NULL,
last_object_revision timestamp NOT NULL,
remarks varchar,
PRIMARY KEY(data_source, table_name, column_name)
);
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_table','last_object_revision','timestamp',NULL,'N','2007-04-16 19:35:07','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_bitmap_index','table_name','varchar',NULL,'N','2007-04-16 19:35:06','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_bitmap_index','data_source','varchar',NULL,'N','2007-04-16 19:35:06','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_pk_constraint_column','owner','varchar',NULL,'Y','2007-04-16 19:35:07','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_pk_constraint_column','rank','integer',NULL,'N','2007-04-16 19:35:07','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_fk_constraint_column','owner','varchar',NULL,'N','2007-04-16 19:35:07','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_table','er_type','varchar',NULL,'N','2007-04-16 19:35:07','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_unique_constraint_column','constraint_name','varchar',NULL,'N','2007-04-16 19:35:06','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_table_column','data_length','varchar',NULL,'Y','2007-04-16 19:35:06','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_unique_constraint_column','column_name','varchar',NULL,'N','2007-04-16 19:35:06','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_pk_constraint_column','table_name','varchar',NULL,'N','2007-04-16 19:35:07','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_table_column','last_object_revision','timestamp',NULL,'N','2007-04-16 19:35:06','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_bitmap_index','bitmap_index_name','varchar',NULL,'N','2007-04-16 19:35:06','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_fk_constraint_column','table_name','varchar',NULL,'N','2007-04-16 19:35:07','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_table','last_ddl_time','timestamp',NULL,'Y','2007-04-16 19:35:07','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_fk_constraint','fk_constraint_name','varchar',NULL,'N','2007-04-16 19:35:07','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_table_column','nullable','varchar',NULL,'N','2007-04-16 19:35:06','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_fk_constraint','data_source','varchar',NULL,'N','2007-04-16 19:35:07','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_table_column','data_type','varchar',NULL,'N','2007-04-16 19:35:06','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_table_column','table_name','varchar',NULL,'N','2007-04-16 19:35:06','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_bitmap_index','owner','varchar',NULL,'Y','2007-04-16 19:35:06','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_table','owner','varchar',NULL,'Y','2007-04-16 19:35:07','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_fk_constraint_column','data_source','varchar',NULL,'N','2007-04-16 19:35:07','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_fk_constraint','r_table_name','varchar',NULL,'N','2007-04-16 19:35:07','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_table_column','remarks','varchar',NULL,'Y','2007-04-16 19:35:06','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_pk_constraint_column','data_source','varchar',NULL,'N','2007-04-16 19:35:07','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_table_column','column_name','varchar',NULL,'N','2007-04-16 19:35:06','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_table','table_name','varchar',NULL,'N','2007-04-16 19:35:07','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_table','table_type','varchar',NULL,'N','2007-04-16 19:35:07','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_table','remarks','varchar',NULL,'Y','2007-04-16 19:35:07','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_fk_constraint_column','r_table_name','varchar',NULL,'N','2007-04-16 19:35:07','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_unique_constraint_column','owner','varchar',NULL,'Y','2007-04-16 19:35:06','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_table_column','data_source','varchar',NULL,'N','2007-04-16 19:35:06','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_fk_constraint','r_owner','varchar',NULL,'Y','2007-04-16 19:35:07','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_unique_constraint_column','table_name','varchar',NULL,'N','2007-04-16 19:35:06','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_table','data_source','varchar',NULL,'N','2007-04-16 19:35:07','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_fk_constraint_column','r_column_name','varchar',NULL,'N','2007-04-16 19:35:07','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_pk_constraint_column','column_name','varchar',NULL,'N','2007-04-16 19:35:07','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_fk_constraint_column','fk_constraint_name','varchar',NULL,'N','2007-04-16 19:35:07','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_fk_constraint_column','column_name','varchar',NULL,'N','2007-04-16 19:35:07','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_fk_constraint','owner','varchar',NULL,'Y','2007-04-16 19:35:07','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_unique_constraint_column','data_source','varchar',NULL,'N','2007-04-16 19:35:06','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_table_column','owner','varchar',NULL,'Y','2007-04-16 19:35:06','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_fk_constraint','last_object_revision','timestamp',NULL,'N','2007-04-16 19:35:07','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_fk_constraint','table_name','varchar',NULL,'N','2007-04-16 19:35:07','');
CREATE TABLE dd_pk_constraint_column (
data_source varchar NOT NULL,
owner varchar,
table_name varchar NOT NULL,
column_name varchar NOT NULL,
rank integer NOT NULL,
PRIMARY KEY (data_source,table_name,column_name,rank)
);
INSERT INTO "dd_pk_constraint_column" VALUES('UR::DataSource::Meta','main','dd_unique_constraint_column','column_name',4);
INSERT INTO "dd_pk_constraint_column" VALUES('UR::DataSource::Meta','main','dd_fk_constraint_column','data_source',1);
INSERT INTO "dd_pk_constraint_column" VALUES('UR::DataSource::Meta','main','dd_table_column','table_name',2);
INSERT INTO "dd_pk_constraint_column" VALUES('UR::DataSource::Meta','main','dd_fk_constraint','table_name',2);
INSERT INTO "dd_pk_constraint_column" VALUES('UR::DataSource::Meta','main','dd_pk_constraint_column','table_name',2);
INSERT INTO "dd_pk_constraint_column" VALUES('UR::DataSource::Meta','main','dd_bitmap_index','table_name',2);
INSERT INTO "dd_pk_constraint_column" VALUES('UR::DataSource::Meta','main','dd_fk_constraint_column','column_name',4);
INSERT INTO "dd_pk_constraint_column" VALUES('UR::DataSource::Meta','main','dd_pk_constraint_column','rank',4);
INSERT INTO "dd_pk_constraint_column" VALUES('UR::DataSource::Meta','main','dd_pk_constraint_column','data_source',1);
INSERT INTO "dd_pk_constraint_column" VALUES('UR::DataSource::Meta','main','dd_table_column','column_name',3);
INSERT INTO "dd_pk_constraint_column" VALUES('UR::DataSource::Meta','main','dd_fk_constraint','data_source',1);
INSERT INTO "dd_pk_constraint_column" VALUES('UR::DataSource::Meta','main','dd_unique_constraint_column','data_source',1);
INSERT INTO "dd_pk_constraint_column" VALUES('UR::DataSource::Meta','main','dd_unique_constraint_column','constraint_name',3);
INSERT INTO "dd_pk_constraint_column" VALUES('UR::DataSource::Meta','main','dd_fk_constraint','fk_constraint_name',4);
INSERT INTO "dd_pk_constraint_column" VALUES('UR::DataSource::Meta','main','dd_fk_constraint_column','fk_constraint_name',3);
INSERT INTO "dd_pk_constraint_column" VALUES('UR::DataSource::Meta','main','dd_unique_constraint_column','table_name',2);
INSERT INTO "dd_pk_constraint_column" VALUES('UR::DataSource::Meta','main','dd_pk_constraint_column','column_name',3);
INSERT INTO "dd_pk_constraint_column" VALUES('UR::DataSource::Meta','main','dd_bitmap_index','data_source',1);
INSERT INTO "dd_pk_constraint_column" VALUES('UR::DataSource::Meta','main','dd_table','data_source',1);
INSERT INTO "dd_pk_constraint_column" VALUES('UR::DataSource::Meta','main','dd_bitmap_index','bitmap_index_name',3);
INSERT INTO "dd_pk_constraint_column" VALUES('UR::DataSource::Meta','main','dd_table','table_name',2);
INSERT INTO "dd_pk_constraint_column" VALUES('UR::DataSource::Meta','main','dd_table_column','data_source',1);
INSERT INTO "dd_pk_constraint_column" VALUES('UR::DataSource::Meta','main','dd_fk_constraint','r_table_name',3);
INSERT INTO "dd_pk_constraint_column" VALUES('UR::DataSource::Meta','main','dd_fk_constraint_column','table_name',2);
CREATE TABLE dd_unique_constraint_column (
data_source varchar NOT NULL,
owner varchar,
table_name varchar NOT NULL,
constraint_name varchar NOT NULL,
column_name varchar NOT NULL,
PRIMARY KEY (data_source,table_name,constraint_name,column_name)
);
CREATE TABLE dd_fk_constraint (
data_source varchar NOT NULL,
owner varchar,
r_owner varchar,
table_name varchar NOT NULL,
r_table_name varchar NOT NULL,
fk_constraint_name varchar NOT NULL,
last_object_revision timestamp NOT NULL,
PRIMARY KEY(data_source, table_name, r_table_name, fk_constraint_name)
);
CREATE TABLE dd_fk_constraint_column (
fk_constraint_name varchar NOT NULL,
data_source varchar NOT NULL,
owner varchar,
table_name varchar NOT NULL,
r_table_name varchar NOT NULL,
column_name varchar NOT NULL,
r_column_name varchar NOT NULL,
PRIMARY KEY(data_source, table_name, fk_constraint_name, column_name)
);
COMMIT;
Meta.sqlite3-dump-boostrap 100664 023532 023421 32112 12544604516 21770 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/DataSource BEGIN TRANSACTION;
CREATE TABLE dd_table (
data_source varchar NOT NULL,
owner varchar,
table_name varchar NOT NULL,
table_type varchar NOT NULL,
er_type varchar NOT NULL,
last_ddl_time timestamp,
last_object_revision timestamp NOT NULL,
remarks varchar,
PRIMARY KEY(data_source, owner, table_name)
);
INSERT INTO "dd_table" VALUES('UR::DataSource::Meta','main','dd_table_column','TABLE','entity',NULL,'2007-04-16 19:35:06',NULL);
INSERT INTO "dd_table" VALUES('UR::DataSource::Meta','main','dd_bitmap_index','TABLE','entity',NULL,'2007-04-16 19:35:06',NULL);
INSERT INTO "dd_table" VALUES('UR::DataSource::Meta','main','dd_pk_constraint_column','TABLE','entity',NULL,'2007-04-16 19:35:07',NULL);
INSERT INTO "dd_table" VALUES('UR::DataSource::Meta','main','dd_fk_constraint','TABLE','entity',NULL,'2007-04-16 19:35:07',NULL);
INSERT INTO "dd_table" VALUES('UR::DataSource::Meta','main','dd_fk_constraint_column','TABLE','entity',NULL,'2007-04-16 19:35:07',NULL);
INSERT INTO "dd_table" VALUES('UR::DataSource::Meta','main','dd_table','TABLE','entity',NULL,'2007-04-16 19:35:07',NULL);
INSERT INTO "dd_table" VALUES('UR::DataSource::Meta','main','dd_unique_constraint_column','TABLE','entity',NULL,'2007-04-16 19:35:06',NULL);
CREATE TABLE dd_bitmap_index (
data_source varchar NOT NULL,
owner varchar,
table_name varchar NOT NULL,
bitmap_index_name varchar NOT NULL,
PRIMARY KEY (data_source, owner, table_name, bitmap_index_name)
);
CREATE TABLE dd_table_column (
data_source varchar NOT NULL,
owner varchar,
table_name varchar NOT NULL,
column_name varchar NOT NULL,
data_type varchar NOT NULL,
data_length varchar,
nullable varchar NOT NULL,
last_object_revision timestamp NOT NULL,
remarks varchar,
PRIMARY KEY(data_source, owner, table_name, column_name)
);
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_table','last_object_revision','timestamp',NULL,'N','2007-04-16 19:35:07','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_bitmap_index','table_name','varchar',NULL,'N','2007-04-16 19:35:06','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_bitmap_index','data_source','varchar',NULL,'N','2007-04-16 19:35:06','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_pk_constraint_column','owner','varchar',NULL,'Y','2007-04-16 19:35:07','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_pk_constraint_column','rank','integer',NULL,'N','2007-04-16 19:35:07','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_fk_constraint_column','owner','varchar',NULL,'N','2007-04-16 19:35:07','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_table','er_type','varchar',NULL,'N','2007-04-16 19:35:07','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_unique_constraint_column','constraint_name','varchar',NULL,'N','2007-04-16 19:35:06','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_table_column','data_length','varchar',NULL,'Y','2007-04-16 19:35:06','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_unique_constraint_column','column_name','varchar',NULL,'N','2007-04-16 19:35:06','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_pk_constraint_column','table_name','varchar',NULL,'N','2007-04-16 19:35:07','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_table_column','last_object_revision','timestamp',NULL,'N','2007-04-16 19:35:06','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_bitmap_index','bitmap_index_name','varchar',NULL,'N','2007-04-16 19:35:06','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_fk_constraint_column','table_name','varchar',NULL,'N','2007-04-16 19:35:07','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_table','last_ddl_time','timestamp',NULL,'Y','2007-04-16 19:35:07','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_fk_constraint','fk_constraint_name','varchar',NULL,'N','2007-04-16 19:35:07','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_table_column','nullable','varchar',NULL,'N','2007-04-16 19:35:06','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_fk_constraint','data_source','varchar',NULL,'N','2007-04-16 19:35:07','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_table_column','data_type','varchar',NULL,'N','2007-04-16 19:35:06','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_table_column','table_name','varchar',NULL,'N','2007-04-16 19:35:06','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_bitmap_index','owner','varchar',NULL,'Y','2007-04-16 19:35:06','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_table','owner','varchar',NULL,'Y','2007-04-16 19:35:07','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_fk_constraint_column','data_source','varchar',NULL,'N','2007-04-16 19:35:07','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_fk_constraint','r_table_name','varchar',NULL,'N','2007-04-16 19:35:07','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_table_column','remarks','varchar',NULL,'Y','2007-04-16 19:35:06','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_pk_constraint_column','data_source','varchar',NULL,'N','2007-04-16 19:35:07','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_table_column','column_name','varchar',NULL,'N','2007-04-16 19:35:06','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_table','table_name','varchar',NULL,'N','2007-04-16 19:35:07','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_table','table_type','varchar',NULL,'N','2007-04-16 19:35:07','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_table','remarks','varchar',NULL,'Y','2007-04-16 19:35:07','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_fk_constraint_column','r_table_name','varchar',NULL,'N','2007-04-16 19:35:07','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_unique_constraint_column','owner','varchar',NULL,'Y','2007-04-16 19:35:06','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_table_column','data_source','varchar',NULL,'N','2007-04-16 19:35:06','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_fk_constraint','r_owner','varchar',NULL,'Y','2007-04-16 19:35:07','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_unique_constraint_column','table_name','varchar',NULL,'N','2007-04-16 19:35:06','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_table','data_source','varchar',NULL,'N','2007-04-16 19:35:07','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_fk_constraint_column','r_column_name','varchar',NULL,'N','2007-04-16 19:35:07','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_pk_constraint_column','column_name','varchar',NULL,'N','2007-04-16 19:35:07','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_fk_constraint_column','fk_constraint_name','varchar',NULL,'N','2007-04-16 19:35:07','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_fk_constraint_column','column_name','varchar',NULL,'N','2007-04-16 19:35:07','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_fk_constraint','owner','varchar',NULL,'Y','2007-04-16 19:35:07','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_unique_constraint_column','data_source','varchar',NULL,'N','2007-04-16 19:35:06','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_table_column','owner','varchar',NULL,'Y','2007-04-16 19:35:06','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_fk_constraint','last_object_revision','timestamp',NULL,'N','2007-04-16 19:35:07','');
INSERT INTO "dd_table_column" VALUES('UR::DataSource::Meta','main','dd_fk_constraint','table_name','varchar',NULL,'N','2007-04-16 19:35:07','');
CREATE TABLE dd_pk_constraint_column (
data_source varchar NOT NULL,
owner varchar,
table_name varchar NOT NULL,
column_name varchar NOT NULL,
rank integer NOT NULL,
PRIMARY KEY (data_source,owner,table_name,column_name,rank)
);
INSERT INTO "dd_pk_constraint_column" VALUES('UR::DataSource::Meta','main','dd_unique_constraint_column','column_name',5);
INSERT INTO "dd_pk_constraint_column" VALUES('UR::DataSource::Meta','main','dd_fk_constraint_column','data_source',1);
INSERT INTO "dd_pk_constraint_column" VALUES('UR::DataSource::Meta','main','dd_table_column','table_name',3);
INSERT INTO "dd_pk_constraint_column" VALUES('UR::DataSource::Meta','main','dd_pk_constraint_column','owner',2);
INSERT INTO "dd_pk_constraint_column" VALUES('UR::DataSource::Meta','main','dd_fk_constraint','table_name',4);
INSERT INTO "dd_pk_constraint_column" VALUES('UR::DataSource::Meta','main','dd_pk_constraint_column','table_name',3);
INSERT INTO "dd_pk_constraint_column" VALUES('UR::DataSource::Meta','main','dd_fk_constraint','r_owner',3);
INSERT INTO "dd_pk_constraint_column" VALUES('UR::DataSource::Meta','main','dd_bitmap_index','table_name',3);
INSERT INTO "dd_pk_constraint_column" VALUES('UR::DataSource::Meta','main','dd_fk_constraint_column','column_name',5);
INSERT INTO "dd_pk_constraint_column" VALUES('UR::DataSource::Meta','main','dd_pk_constraint_column','rank',5);
INSERT INTO "dd_pk_constraint_column" VALUES('UR::DataSource::Meta','main','dd_fk_constraint_column','owner',2);
INSERT INTO "dd_pk_constraint_column" VALUES('UR::DataSource::Meta','main','dd_pk_constraint_column','data_source',1);
INSERT INTO "dd_pk_constraint_column" VALUES('UR::DataSource::Meta','main','dd_table_column','column_name',4);
INSERT INTO "dd_pk_constraint_column" VALUES('UR::DataSource::Meta','main','dd_fk_constraint','data_source',1);
INSERT INTO "dd_pk_constraint_column" VALUES('UR::DataSource::Meta','main','dd_fk_constraint','owner',2);
INSERT INTO "dd_pk_constraint_column" VALUES('UR::DataSource::Meta','main','dd_bitmap_index','owner',2);
INSERT INTO "dd_pk_constraint_column" VALUES('UR::DataSource::Meta','main','dd_unique_constraint_column','data_source',1);
INSERT INTO "dd_pk_constraint_column" VALUES('UR::DataSource::Meta','main','dd_unique_constraint_column','constraint_name',4);
INSERT INTO "dd_pk_constraint_column" VALUES('UR::DataSource::Meta','main','dd_fk_constraint','fk_constraint_name',6);
INSERT INTO "dd_pk_constraint_column" VALUES('UR::DataSource::Meta','main','dd_fk_constraint_column','fk_constraint_name',4);
INSERT INTO "dd_pk_constraint_column" VALUES('UR::DataSource::Meta','main','dd_unique_constraint_column','table_name',3);
INSERT INTO "dd_pk_constraint_column" VALUES('UR::DataSource::Meta','main','dd_unique_constraint_column','owner',2);
INSERT INTO "dd_pk_constraint_column" VALUES('UR::DataSource::Meta','main','dd_pk_constraint_column','column_name',4);
INSERT INTO "dd_pk_constraint_column" VALUES('UR::DataSource::Meta','main','dd_table_column','owner',2);
INSERT INTO "dd_pk_constraint_column" VALUES('UR::DataSource::Meta','main','dd_bitmap_index','data_source',1);
INSERT INTO "dd_pk_constraint_column" VALUES('UR::DataSource::Meta','main','dd_table','data_source',1);
INSERT INTO "dd_pk_constraint_column" VALUES('UR::DataSource::Meta','main','dd_bitmap_index','bitmap_index_name',4);
INSERT INTO "dd_pk_constraint_column" VALUES('UR::DataSource::Meta','main','dd_table','table_name',3);
INSERT INTO "dd_pk_constraint_column" VALUES('UR::DataSource::Meta','main','dd_table_column','data_source',1);
INSERT INTO "dd_pk_constraint_column" VALUES('UR::DataSource::Meta','main','dd_table','owner',2);
INSERT INTO "dd_pk_constraint_column" VALUES('UR::DataSource::Meta','main','dd_fk_constraint','r_table_name',5);
INSERT INTO "dd_pk_constraint_column" VALUES('UR::DataSource::Meta','main','dd_fk_constraint_column','table_name',3);
CREATE TABLE dd_unique_constraint_column (
data_source varchar NOT NULL,
owner varchar,
table_name varchar NOT NULL,
constraint_name varchar NOT NULL,
column_name varchar NOT NULL,
PRIMARY KEY (data_source,owner,table_name,constraint_name,column_name)
);
CREATE TABLE dd_fk_constraint (
data_source varchar NOT NULL,
owner varchar,
r_owner varchar,
table_name varchar NOT NULL,
r_table_name varchar NOT NULL,
fk_constraint_name varchar NOT NULL,
last_object_revision timestamp NOT NULL,
PRIMARY KEY(data_source, owner, r_owner, table_name, r_table_name, fk_constraint_name)
);
CREATE TABLE dd_fk_constraint_column (
fk_constraint_name varchar NOT NULL,
data_source varchar NOT NULL,
owner varchar,
table_name varchar NOT NULL,
r_table_name varchar NOT NULL,
column_name varchar NOT NULL,
r_column_name varchar NOT NULL,
PRIMARY KEY(data_source, owner, table_name, fk_constraint_name, column_name)
);
COMMIT;
Meta.sqlite3-schema 100664 023532 023421 4340 12544604516 20416 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/DataSource CREATE TABLE IF NOT EXISTS dd_bitmap_index (
data_source varchar NOT NULL,
owner varchar,
table_name varchar NOT NULL,
bitmap_index_name varchar NOT NULL,
PRIMARY KEY (data_source, owner, table_name, bitmap_index_name)
);
CREATE TABLE IF NOT EXISTS dd_fk_constraint (
data_source varchar NOT NULL,
owner varchar,
r_owner varchar,
table_name varchar NOT NULL,
r_table_name varchar NOT NULL,
fk_constraint_name varchar NOT NULL,
last_object_revision timestamp NOT NULL,
PRIMARY KEY(data_source, owner, r_owner, table_name, r_table_name, fk_constraint_name)
);
CREATE TABLE IF NOT EXISTS dd_fk_constraint_column (
fk_constraint_name varchar NOT NULL,
data_source varchar NOT NULL,
owner varchar,
table_name varchar NOT NULL,
r_table_name varchar NOT NULL,
column_name varchar NOT NULL,
r_column_name varchar NOT NULL,
PRIMARY KEY(data_source, owner, table_name, fk_constraint_name, column_name)
);
CREATE TABLE IF NOT EXISTS dd_pk_constraint_column (
data_source varchar NOT NULL,
owner varchar,
table_name varchar NOT NULL,
column_name varchar NOT NULL,
rank integer NOT NULL,
PRIMARY KEY (data_source,owner,table_name,column_name,rank)
);
CREATE TABLE IF NOT EXISTS dd_table (
data_source varchar NOT NULL,
owner varchar,
table_name varchar NOT NULL,
table_type varchar NOT NULL,
er_type varchar NOT NULL,
last_ddl_time timestamp,
last_object_revision timestamp NOT NULL,
remarks varchar,
PRIMARY KEY(data_source, owner, table_name)
);
CREATE TABLE IF NOT EXISTS dd_table_column (
data_source varchar NOT NULL,
owner varchar,
table_name varchar NOT NULL,
column_name varchar NOT NULL,
data_type varchar NOT NULL,
data_length varchar,
nullable varchar NOT NULL,
last_object_revision timestamp NOT NULL,
remarks varchar,
PRIMARY KEY(data_source, owner, table_name, column_name)
);
CREATE TABLE IF NOT EXISTS dd_unique_constraint_column (
data_source varchar NOT NULL,
owner varchar,
table_name varchar NOT NULL,
constraint_name varchar NOT NULL,
column_name varchar NOT NULL,
PRIMARY KEY (data_source,owner,table_name,constraint_name,column_name)
);
MySQL.pm 100664 023532 023421 14361 12544604516 16313 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/DataSource package UR::DataSource::MySQL;
use strict;
use warnings;
require UR;
our $VERSION = "0.44"; # UR $VERSION;
UR::Object::Type->define(
class_name => 'UR::DataSource::MySQL',
is => ['UR::DataSource::RDBMS'],
is_abstract => 1,
);
# RDBMS API
sub driver { "mysql" }
#sub server {
# my $self = shift->_singleton_object();
# $self->_init_database;
# return $self->_database_file_path;
#}
sub owner { shift->_singleton_object->login }
#sub login {
# undef
#}
#
#sub auth {
# undef
#}
sub _default_sql_like_escape_string { undef }; # can't do an 'escape' clause with the 'like' operator
sub can_savepoint { 1;}
*_init_created_dbh = \&init_created_handle;
sub init_created_handle
{
my ($self, $dbh) = @_;
return unless defined $dbh;
$dbh->{LongTruncOk} = 0;
return $dbh;
}
sub _ignore_table {
my $self = shift;
my $table_name = shift;
return 1 if $table_name =~ /^(pg_|sql_|URMETA)/;
}
#
# for concurrency's sake we need to use dummy tables in place of sequence generators here, too
#
sub _get_sequence_name_for_table_and_column {
my $self = shift->_singleton_object;
my ($table_name,$column_name) = @_;
my $dbh = $self->get_default_handle();
# See if the sequence generator "table" is already there
my $seq_table = sprintf('URMETA_%s_%s_SEQ', $table_name, $column_name);
#$DB::single = 1;
unless ($self->{'_has_sequence_generator'}->{$seq_table} or
grep {$_ eq $seq_table} $self->get_table_names() ) {
unless ($dbh->do("CREATE TABLE IF NOT EXISTS $seq_table (next_value integer PRIMARY KEY AUTO_INCREMENT)")) {
die "Failed to create sequence generator $seq_table: ".$dbh->errstr();
}
}
$self->{'_has_sequence_generator'}->{$seq_table} = 1;
return $seq_table;
}
sub _get_next_value_from_sequence {
my($self,$sequence_name) = @_;
my $dbh = $self->get_default_handle();
# FIXME can we use a statement handle with a wildcard as the table name here?
unless ($dbh->do("INSERT into $sequence_name values(null)")) {
die "Failed to INSERT into $sequence_name during id autogeneration: " . $dbh->errstr;
}
my $new_id = $dbh->last_insert_id(undef,undef,$sequence_name,'next_value');
unless (defined $new_id) {
die "last_insert_id() returned undef during id autogeneration after insert into $sequence_name: " . $dbh->errstr;
}
unless($dbh->do("DELETE from $sequence_name where next_value = $new_id")) {
die "DELETE from $sequence_name for next_value $new_id failed during id autogeneration";
}
return $new_id;
}
sub get_bitmap_index_details_from_data_dictionary {
# Mysql dosen't have bitmap indexes.
return [];
}
sub set_savepoint {
my($self,$sp_name) = @_;
my $dbh = $self->get_default_handle;
my $sp = $dbh->quote($sp_name);
$dbh->do("savepoint $sp_name");
}
sub rollback_to_savepoint {
my($self,$sp_name) = @_;
my $dbh = $self->get_default_handle;
my $sp = $dbh->quote($sp_name);
$dbh->do("rollback to savepoint $sp_name");
}
sub _resolve_order_by_clause_for_column {
my($self, $column_name, $query_plan, $property_meta) = @_;
my $is_optional = $property_meta->is_optional;
my $column_clause = $column_name; # default, usual case
if ($is_optional) {
if ($query_plan->order_by_column_is_descending($column_name)) {
$column_clause = "CASE WHEN $column_name ISNULL THEN 0 ELSE 1 END, $column_name DESC";
} else {
$column_clause = "CASE WHEN $column_name ISNULL THEN 1 ELSE 0 END, $column_name";
}
} elsif ($query_plan->order_by_column_is_descending($column_name)) {
$column_clause = $column_name . ' DESC';
}
return $column_clause;
}
# FIXME This works on Mysql 4.x (and later?). Mysql5 has a database called
# IMFORMATION_SCHEMA that may be more useful for these kinds of queries
sub get_unique_index_details_from_data_dictionary {
my($self, $owner_name, $table_name) = @_;
my $dbh = $self->get_default_handle();
return undef unless $dbh;
#$table_name = $dbh->quote($table_name);
my $sql = qq(SHOW INDEX FROM $table_name FROM $owner_name);
my $sth = $dbh->prepare($sql);
return undef unless $sth;
$sth->execute();
my $ret;
while (my $data = $sth->fetchrow_hashref()) {
next if ($data->{'Non_unique'});
$ret->{$data->{'Key_name'}} ||= [];
push @{ $ret->{ $data->{'Key_name'} } }, $data->{'Column_name'};
}
return $ret;
}
sub get_column_details_from_data_dictionary {
my $self = shift;
# Mysql seems wierd about the distinction between catalog/database and schema/owner
# For 'ur update classes', it works if we just pass in undef for catalog
# The passed-in args are: $self,$catalog,$schema,$table,$column
my $catalog = shift;
return $self->SUPER::get_column_details_from_data_dictionary(undef, @_);
}
sub get_foreign_key_details_from_data_dictionary {
my $self = shift;
# Mysql requires undef in some fields instead of an empty string
my @new_params = map { length($_) ? $_ : undef } @_;
return $self->SUPER::get_foreign_key_details_from_data_dictionary(@new_params);
}
my %ur_data_type_for_vendor_data_type = (
# DB type UR Type
'TINYINT' => ['Integer', undef],
'SMALLINT' => ['Integer', undef],
'MEDIUMINT' => ['Integer', undef],
'BIGINT' => ['Integer', undef],
'BINARY' => ['Text', undef],
'VARBINARY' => ['Text', undef],
'TINYTEXT' => ['Text', undef],
'MEDIUMTEXT' => ['Text', undef],
'LONGTEXT' => ['Text', undef],
'TINYBLOB' => ['Blob', undef],
'MEDIUMBLOB' => ['Blob', undef],
'LONGBLOB' => ['Blob', undef],
);
sub ur_data_type_for_data_source_data_type {
my($class,$type) = @_;
$type = $class->normalize_vendor_type($type);
my $urtype = $ur_data_type_for_vendor_data_type{$type};
unless (defined $urtype) {
$urtype = $class->SUPER::ur_data_type_for_data_source_data_type($type);
}
return $urtype;
}
1;
=pod
=head1 NAME
UR::DataSource::MySQL - MySQL specific subclass of UR::DataSource::RDBMS
=head1 DESCRIPTION
This module provides the MySQL-specific methods necessary for interacting with
MySQL databases
=head1 SEE ALSO
L, L
=cut
Oracle.pm 100664 023532 023421 53047 12544604516 16557 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/DataSource package UR::DataSource::Oracle;
use strict;
use warnings;
require UR;
our $VERSION = "0.44"; # UR $VERSION;
UR::Object::Type->define(
class_name => 'UR::DataSource::Oracle',
is => ['UR::DataSource::RDBMS'],
is_abstract => 1,
);
sub driver { "Oracle" }
sub owner { shift->_singleton_object->login }
sub can_savepoint { 1 } # Oracle supports savepoints inside transactions
sub does_support_recursive_queries { 'connect by' };
sub set_savepoint {
my($self,$sp_name) = @_;
my $dbh = $self->get_default_handle;
my $sp = $dbh->quote($sp_name);
$dbh->do("savepoint $sp_name");
}
sub rollback_to_savepoint {
my($self,$sp_name) = @_;
my $dbh = $self->get_default_handle;
my $sp = $dbh->quote($sp_name);
$dbh->do("rollback to $sp_name");
}
my $DATE_FORMAT = 'YYYY-MM-DD HH24:MI:SS';
my $TIMESTAMP_FORMAT = 'YYYY-MM-DD HH24:MI:SSXFF';
sub _set_date_format {
my $self = shift;
foreach my $sql ("alter session set NLS_DATE_FORMAT = '$DATE_FORMAT'",
"alter session set NLS_TIMESTAMP_FORMAT = '$TIMESTAMP_FORMAT'"
) {
$self->do_sql($sql);
}
}
*_init_created_dbh = \&init_created_handle;
sub init_created_handle {
my ($self, $dbh) = @_;
return unless defined $dbh;
$dbh->{LongTruncOk} = 0;
$self->_set_date_format();
return $dbh;
}
sub _dbi_connect_args {
my @args = shift->SUPER::_dbi_connect_args(@_);
$args[3]{ora_module_name} = (UR::Context::Process->get_current->prog_name || $0);
return @args;
}
sub _prepare_for_lob {
{ ora_auto_lob => 0 }
}
sub _post_process_lob_values {
my ($self, $dbh, $lob_id_arrayref) = @_;
return
map {
if (defined($_)) {
my $length = $dbh->ora_lob_length($_);
my $data = $dbh->ora_lob_read($_, 1, $length);
# TODO: bind to a file for items of a certain size to save RAM.
# Special work with tying a scalar to the file?
$data;
}
else {
undef;
}
} @$lob_id_arrayref;
}
sub _ignore_table {
my $self = shift;
my $table_name = shift;
return 1 if $table_name =~ /\$/;
}
sub get_table_last_ddl_times_by_table_name {
my $self = shift;
my $sql = qq|
select object_name table_name, last_ddl_time
from all_objects o
where o.owner = ?
and (o.object_type = 'TABLE' or o.object_type = 'VIEW')
|;
my $data = $self->get_default_handle->selectall_arrayref(
$sql,
undef,
$self->owner
);
return { map { @$_ } @$data };
};
sub _get_next_value_from_sequence {
my($self,$sequence_name) = @_;
# we may need to change how this db handle is gotten
my $dbh = $self->get_default_handle;
my $new_id = $dbh->selectrow_array("SELECT " . $sequence_name . ".nextval from DUAL");
if ($dbh->err) {
die "Failed to prepare SQL to generate a column id from sequence: $sequence_name.\n" . $dbh->errstr . "\n";
return;
}
return $new_id;
}
sub get_bitmap_index_details_from_data_dictionary {
my($self, $table_name) = @_;
my $sql = qq(
select c.table_name,c.column_name,c.index_name
from all_indexes i join all_ind_columns c on i.index_name = c.index_name
where i.index_type = 'BITMAP'
);
my @select_params;
if ($table_name) {
@select_params = $self->_resolve_owner_and_table_from_table_name($table_name);
$sql .= " and i.table_owner = ? and i.table_name = ?";
}
my $dbh = $self->get_default_handle;
my $rows = $dbh->selectall_arrayref($sql, undef, @select_params);
return undef unless $rows;
my @ret = map { { table_name => $_->[0], column_name => $_->[1], index_name => $_->[2] } } @$rows;
return \@ret;
}
sub get_unique_index_details_from_data_dictionary {
my ($self, $owner_name, $table_name) = @_;
my $sql = qq(
select cc.constraint_name, cc.column_name
from all_cons_columns cc
join all_constraints c
on c.constraint_name = cc.constraint_name
and c.owner = cc.owner
and c.constraint_type = 'U'
where cc.table_name = ?
and cc.owner = ?
union
select ai.index_name, aic.column_name
from all_indexes ai
join all_ind_columns aic
on aic.index_name = ai.index_name
and aic.index_owner = ai.owner
where ai.uniqueness = 'UNIQUE'
and aic.table_name = ?
and aic.index_owner = ?
);
my $dbh = $self->get_default_handle();
return undef unless $dbh;
my $sth = $dbh->prepare($sql);
return undef unless $sth;
$sth->execute($table_name, $owner_name, $table_name, $owner_name);
my $ret;
while (my $data = $sth->fetchrow_hashref()) {
$ret->{$data->{'CONSTRAINT_NAME'}} ||= [];
push @{ $ret->{ $data->{CONSTRAINT_NAME} } }, $data->{COLUMN_NAME};
}
return $ret;
}
sub set_userenv {
# there are two places to set these oracle variables-
# 1. this method in UR::DataSource::Oracle is a class method
# that can be called to change the values later
# 2. the method in YourSubclass::DataSource::Oracle is called in
# init_created_handle which is called while the datasource
# is still being set up- it operates directly on the db handle
my ($self, %p) = @_;
my $dbh = $p{'dbh'} || $self->get_default_handle();
# module is application name
my $module = $p{'module'} || $0;
# storing username in 'action' oracle variable
my $action = $p{'action'};
if (! defined($action)) {
$action = getpwuid($>); # real UID
}
my $sql = q{BEGIN dbms_application_info.set_module(?, ?); END;};
my $sth = $dbh->prepare($sql);
if (!$sth) {
warn "Couldnt prepare query to set module/action in Oracle";
return undef;
}
$sth->execute($module, $action) || warn "Couldnt set module/action in Oracle";
}
sub get_userenv {
# there are two ways to set these values but this is
# the only way to retrieve the values after they are set
my ($self, $dbh) = @_;
if (!$dbh) {
$dbh = $self->get_default_handle();
}
if (!$dbh) {
warn "No dbh";
return undef;
}
my $sql = q{
SELECT sys_context('USERENV','MODULE') as module,
sys_context('USERENV','ACTION') as action
FROM dual
};
my $sth = $dbh->prepare($sql);
return undef unless $sth;
$sth->execute() || die "execute failed: $!";
my $r = $sth->fetchrow_hashref();
return $r;
}
my %ur_data_type_for_vendor_data_type = (
'VARCHAR2' => ['Text', undef],
'BLOB' => ['XmlBlob', undef],
);
sub ur_data_type_for_data_source_data_type {
my($class,$type) = @_;
$type = $class->normalize_vendor_type($type);
my $urtype = $ur_data_type_for_vendor_data_type{$type};
unless (defined $urtype) {
$urtype = $class->SUPER::ur_data_type_for_data_source_data_type($type);
}
return $urtype;
}
sub _alter_sth_for_selecting_blob_columns {
my($self, $sth, $column_objects) = @_;
for (my $n = 0; $n < @$column_objects; $n++) {
next unless defined ($column_objects->[$n]); # No metaDB info for this one
if ($column_objects->[$n]->data_type eq 'BLOB') {
$sth->bind_param($n+1, undef, { ora_type => 23 });
}
}
}
sub get_connection_debug_info {
my $self = shift;
my @debug_info = $self->SUPER::get_connection_debug_info(@_);
push @debug_info, (
"DBD::Oracle Version: ", $DBD::Oracle::VERSION, "\n",
"TNS_ADMIN: ", $ENV{TNS_ADMIN}, "\n",
"ORACLE_HOME: ", $ENV{ORACLE_HOME}, "\n",
);
return @debug_info;
}
# This is a near cut-and-paste from DBD::Oracle, with the exception that
# the query hint is removed, since it performs poorly on Oracle 11
sub get_table_details_from_data_dictionary {
my $self = shift;
my $version = $self->_get_oracle_major_server_version();
if ($version < '11') {
return $self->SUPER::get_table_details_from_data_dictionary(@_);
}
my($CatVal, $SchVal, $TblVal, $TypVal) = @_;
my $dbh = $self->get_default_handle();
# XXX add knowledge of temp tables, etc
# SQL/CLI (ISO/IEC JTC 1/SC 32 N 0595), 6.63 Tables
if (ref $CatVal eq 'HASH') {
($CatVal, $SchVal, $TblVal, $TypVal) =
@$CatVal{'TABLE_CAT','TABLE_SCHEM','TABLE_NAME','TABLE_TYPE'};
}
my @Where = ();
my $SQL;
if ( defined $CatVal && $CatVal eq '%' && (!defined $SchVal || $SchVal eq '') && (!defined $TblVal || $TblVal eq '')) { # Rule 19a
$SQL = <<'SQL';
SELECT NULL TABLE_CAT
, NULL TABLE_SCHEM
, NULL TABLE_NAME
, NULL TABLE_TYPE
, NULL REMARKS
FROM DUAL
SQL
}
elsif ( defined $SchVal && $SchVal eq '%' && (!defined $CatVal || $CatVal eq '') && (!defined $TblVal || $TblVal eq '')) { # Rule 19b
$SQL = <<'SQL';
SELECT NULL TABLE_CAT
, s TABLE_SCHEM
, NULL TABLE_NAME
, NULL TABLE_TYPE
, NULL REMARKS
FROM
(
SELECT USERNAME s FROM ALL_USERS
UNION
SELECT 'PUBLIC' s FROM DUAL
)
ORDER BY TABLE_SCHEM
SQL
}
elsif ( defined $TypVal && $TypVal eq '%' && (!defined $CatVal || $CatVal eq '') && (!defined $SchVal || $SchVal eq '') && (!defined $TblVal || $TblVal eq '')) { # Rule 19c
$SQL = <<'SQL';
SELECT NULL TABLE_CAT
, NULL TABLE_SCHEM
, NULL TABLE_NAME
, t.tt TABLE_TYPE
, NULL REMARKS
FROM
(
SELECT 'TABLE' tt FROM DUAL
UNION
SELECT 'VIEW' tt FROM DUAL
UNION
SELECT 'SYNONYM' tt FROM DUAL
UNION
SELECT 'SEQUENCE' tt FROM DUAL
) t
ORDER BY TABLE_TYPE
SQL
}
else {
$SQL = <<'SQL';
SELECT *
FROM
(
SELECT
NULL TABLE_CAT
, t.OWNER TABLE_SCHEM
, t.TABLE_NAME TABLE_NAME
, decode(t.OWNER
, 'SYS' , 'SYSTEM '
, 'SYSTEM' , 'SYSTEM '
, '' ) || t.TABLE_TYPE TABLE_TYPE
, c.COMMENTS REMARKS
FROM ALL_TAB_COMMENTS c
, ALL_CATALOG t
WHERE c.OWNER (+) = t.OWNER
AND c.TABLE_NAME (+) = t.TABLE_NAME
AND c.TABLE_TYPE (+) = t.TABLE_TYPE
)
SQL
if ( defined $SchVal ) {
push @Where, "TABLE_SCHEM LIKE '$SchVal' ESCAPE '\\'";
}
if ( defined $TblVal ) {
push @Where, "TABLE_NAME LIKE '$TblVal' ESCAPE '\\'";
}
if ( defined $TypVal ) {
my $table_type_list;
$TypVal =~ s/^\s+//;
$TypVal =~ s/\s+$//;
my @ttype_list = split (/\s*,\s*/, $TypVal);
foreach my $table_type (@ttype_list) {
if ($table_type !~ /^'.*'$/) {
$table_type = "'" . $table_type . "'";
}
$table_type_list = join(", ", @ttype_list);
}
push @Where, "TABLE_TYPE IN ($table_type_list)";
}
$SQL .= ' WHERE ' . join("\n AND ", @Where ) . "\n" if @Where;
$SQL .= " ORDER BY TABLE_TYPE, TABLE_SCHEM, TABLE_NAME\n";
}
my $sth = $dbh->prepare($SQL) or return undef;
$sth->execute or return undef;
$sth;
}
sub get_column_details_from_data_dictionary {
my $self = shift;
my $version = $self->_get_oracle_major_server_version();
if ($version < '11') {
return $self->SUPER::get_column_details_from_data_dictionary(@_);
}
my $dbh = $self->get_default_handle();
my $attr = ( ref $_[0] eq 'HASH') ? $_[0] : {
'TABLE_SCHEM' => $_[1],'TABLE_NAME' => $_[2],'COLUMN_NAME' => $_[3] };
my($typecase,$typecaseend) = ('','');
my $v = DBD::Oracle::db::ora_server_version($dbh);
if (!defined($v) or $v->[0] >= 8) {
$typecase = <<'SQL';
CASE WHEN tc.DATA_TYPE LIKE 'TIMESTAMP% WITH% TIME ZONE' THEN 95
WHEN tc.DATA_TYPE LIKE 'TIMESTAMP%' THEN 93
WHEN tc.DATA_TYPE LIKE 'INTERVAL DAY% TO SECOND%' THEN 110
WHEN tc.DATA_TYPE LIKE 'INTERVAL YEAR% TO MONTH' THEN 107
ELSE
SQL
$typecaseend = 'END';
}
my $SQL = <<"SQL";
SELECT *
FROM
(
SELECT
to_char( NULL ) TABLE_CAT
, tc.OWNER TABLE_SCHEM
, tc.TABLE_NAME TABLE_NAME
, tc.COLUMN_NAME COLUMN_NAME
, $typecase decode( tc.DATA_TYPE
, 'MLSLABEL' , -9106
, 'ROWID' , -9104
, 'UROWID' , -9104
, 'BFILE' , -4 -- 31?
, 'LONG RAW' , -4
, 'RAW' , -3
, 'LONG' , -1
, 'UNDEFINED', 0
, 'CHAR' , 1
, 'NCHAR' , 1
, 'NUMBER' , decode( tc.DATA_SCALE, NULL, 8, 3 )
, 'FLOAT' , 8
, 'VARCHAR2' , 12
, 'NVARCHAR2', 12
, 'BLOB' , 30
, 'CLOB' , 40
, 'NCLOB' , 40
, 'DATE' , 93
, NULL
) $typecaseend DATA_TYPE -- ...
, tc.DATA_TYPE TYPE_NAME -- std.?
, decode( tc.DATA_TYPE
, 'LONG RAW' , 2147483647
, 'LONG' , 2147483647
, 'CLOB' , 2147483647
, 'NCLOB' , 2147483647
, 'BLOB' , 2147483647
, 'BFILE' , 2147483647
, 'NUMBER' , decode( tc.DATA_SCALE
, NULL, 126
, nvl( tc.DATA_PRECISION, 38 )
)
, 'FLOAT' , tc.DATA_PRECISION
, 'DATE' , 19
, tc.DATA_LENGTH
) COLUMN_SIZE
, decode( tc.DATA_TYPE
, 'LONG RAW' , 2147483647
, 'LONG' , 2147483647
, 'CLOB' , 2147483647
, 'NCLOB' , 2147483647
, 'BLOB' , 2147483647
, 'BFILE' , 2147483647
, 'NUMBER' , nvl( tc.DATA_PRECISION, 38 ) + 2
, 'FLOAT' , 8 -- ?
, 'DATE' , 16
, tc.DATA_LENGTH
) BUFFER_LENGTH
, decode( tc.DATA_TYPE
, 'DATE' , 0
, tc.DATA_SCALE
) DECIMAL_DIGITS -- ...
, decode( tc.DATA_TYPE
, 'FLOAT' , 2
, 'NUMBER' , decode( tc.DATA_SCALE, NULL, 2, 10 )
, NULL
) NUM_PREC_RADIX
, decode( tc.NULLABLE
, 'Y' , 1
, 'N' , 0
, NULL
) NULLABLE
, cc.COMMENTS REMARKS
, tc.DATA_DEFAULT COLUMN_DEF -- Column is LONG!
, decode( tc.DATA_TYPE
, 'MLSLABEL' , -9106
, 'ROWID' , -9104
, 'UROWID' , -9104
, 'BFILE' , -4 -- 31?
, 'LONG RAW' , -4
, 'RAW' , -3
, 'LONG' , -1
, 'UNDEFINED', 0
, 'CHAR' , 1
, 'NCHAR' , 1
, 'NUMBER' , decode( tc.DATA_SCALE, NULL, 8, 3 )
, 'FLOAT' , 8
, 'VARCHAR2' , 12
, 'NVARCHAR2', 12
, 'BLOB' , 30
, 'CLOB' , 40
, 'NCLOB' , 40
, 'DATE' , 9 -- not 93!
, NULL
) SQL_DATA_TYPE -- ...
, decode( tc.DATA_TYPE
, 'DATE' , 3
, NULL
) SQL_DATETIME_SUB -- ...
, to_number( NULL ) CHAR_OCTET_LENGTH -- TODO
, tc.COLUMN_ID ORDINAL_POSITION
, decode( tc.NULLABLE
, 'Y' , 'YES'
, 'N' , 'NO'
, NULL
) IS_NULLABLE
FROM ALL_TAB_COLUMNS tc
, ALL_COL_COMMENTS cc
WHERE tc.OWNER = cc.OWNER
AND tc.TABLE_NAME = cc.TABLE_NAME
AND tc.COLUMN_NAME = cc.COLUMN_NAME
)
WHERE 1 = 1
SQL
my @BindVals = ();
while ( my ( $k, $v ) = each %$attr ) {
if ( $v ) {
$SQL .= " AND $k LIKE ? ESCAPE '\\'\n";
push @BindVals, $v;
}
}
$SQL .= " ORDER BY TABLE_SCHEM, TABLE_NAME, ORDINAL_POSITION\n";
my $sth = $dbh->prepare( $SQL ) or return undef;
$sth->execute( @BindVals ) or return undef;
$sth;
}
sub get_primary_key_details_from_data_dictionary {
my $self = shift;
my $version = $self->_get_oracle_major_server_version();
if ($version < '11') {
return $self->SUPER::get_primary_key_details_from_data_dictionary(@_);
}
my $dbh = $self->get_default_handle();
my($catalog, $schema, $table) = @_;
if (ref $catalog eq 'HASH') {
($schema, $table) = @$catalog{'TABLE_SCHEM','TABLE_NAME'};
$catalog = undef;
}
my $SQL = <<'SQL';
SELECT *
FROM
(
SELECT
NULL TABLE_CAT
, c.OWNER TABLE_SCHEM
, c.TABLE_NAME TABLE_NAME
, c.COLUMN_NAME COLUMN_NAME
, c.POSITION KEY_SEQ
, c.CONSTRAINT_NAME PK_NAME
FROM ALL_CONSTRAINTS p
, ALL_CONS_COLUMNS c
WHERE p.OWNER = c.OWNER
AND p.TABLE_NAME = c.TABLE_NAME
AND p.CONSTRAINT_NAME = c.CONSTRAINT_NAME
AND p.CONSTRAINT_TYPE = 'P'
)
WHERE TABLE_SCHEM = ?
AND TABLE_NAME = ?
ORDER BY TABLE_SCHEM, TABLE_NAME, KEY_SEQ
SQL
#warn "@_\n$Sql ($schema, $table)";
my $sth = $dbh->prepare($SQL) or return undef;
$sth->execute($schema, $table) or return undef;
$sth;
}
sub get_foreign_key_details_from_data_dictionary {
my $self = shift;
my $version = $self->_get_oracle_major_server_version();
if ($version < '11') {
return $self->SUPER::get_foreign_key_details_from_data_dictionary(@_);
}
my $dbh = $self->get_default_handle();
my $attr = ( ref $_[0] eq 'HASH') ? $_[0] : {
'UK_TABLE_SCHEM' => $_[1],'UK_TABLE_NAME ' => $_[2]
,'FK_TABLE_SCHEM' => $_[4],'FK_TABLE_NAME ' => $_[5] };
my $SQL = <<'SQL'; # XXX: DEFERABILITY
SELECT *
FROM
(
SELECT
to_char( NULL ) UK_TABLE_CAT
, uk.OWNER UK_TABLE_SCHEM
, uk.TABLE_NAME UK_TABLE_NAME
, uc.COLUMN_NAME UK_COLUMN_NAME
, to_char( NULL ) FK_TABLE_CAT
, fk.OWNER FK_TABLE_SCHEM
, fk.TABLE_NAME FK_TABLE_NAME
, fc.COLUMN_NAME FK_COLUMN_NAME
, uc.POSITION ORDINAL_POSITION
, 3 UPDATE_RULE
, decode( fk.DELETE_RULE, 'CASCADE', 0, 'RESTRICT', 1, 'SET NULL', 2, 'NO ACTION', 3, 'SET DEFAULT', 4 )
DELETE_RULE
, fk.CONSTRAINT_NAME FK_NAME
, uk.CONSTRAINT_NAME UK_NAME
, to_char( NULL ) DEFERABILITY
, decode( uk.CONSTRAINT_TYPE, 'P', 'PRIMARY', 'U', 'UNIQUE')
UNIQUE_OR_PRIMARY
FROM ALL_CONSTRAINTS uk
, ALL_CONS_COLUMNS uc
, ALL_CONSTRAINTS fk
, ALL_CONS_COLUMNS fc
WHERE uk.OWNER = uc.OWNER
AND uk.CONSTRAINT_NAME = uc.CONSTRAINT_NAME
AND fk.OWNER = fc.OWNER
AND fk.CONSTRAINT_NAME = fc.CONSTRAINT_NAME
AND uk.CONSTRAINT_TYPE IN ('P','U')
AND fk.CONSTRAINT_TYPE = 'R'
AND uk.CONSTRAINT_NAME = fk.R_CONSTRAINT_NAME
AND uk.OWNER = fk.R_OWNER
AND uc.POSITION = fc.POSITION
)
WHERE 1 = 1
SQL
my @BindVals = ();
while ( my ( $k, $v ) = each %$attr ) {
if ( $v ) {
$SQL .= " AND $k = ?\n";
push @BindVals, $v;
}
}
$SQL .= " ORDER BY UK_TABLE_SCHEM, UK_TABLE_NAME, FK_TABLE_SCHEM, FK_TABLE_NAME, ORDINAL_POSITION\n";
my $sth = $dbh->prepare( $SQL ) or return undef;
$sth->execute( @BindVals ) or return undef;
$sth;
}
sub _get_oracle_major_server_version {
my $self = shift;
unless (exists $self->{'__ora_major_server_version'}) {
my $dbh = $self->get_default_handle();
my @data = $dbh->selectrow_arrayref('select version from v$instance');
$self->{'__ora_major_server_version'} = (split(/\./, $data[0]->[0]))[0];
}
return $self->{'__ora_major_server_version'};
}
sub cast_for_data_conversion {
my($class, $left_type, $right_type, $operator, $sql_clause) = @_;
my @retval = ('%s','%s');
# compatible types
if ($left_type->isa($right_type)
or
$right_type->isa($left_type)
) {
return @retval;
}
if (! $left_type->isa('UR::Value::Text')
and
! $right_type->isa('UR::Value::Text')
) {
# We only support cases where one is a string, for now
# hopefully the DB can sort it out
return @retval;
}
# Oracle can auto-convert strings into numbers and dates in the 'where'
# clause, but has issues in joins
if ($sql_clause eq 'where') {
return @retval;
}
# Figure out which one is the non-string
my($data_type, $i) = $left_type->isa('UR::Value::Text')
? ( $right_type, 1)
: ( $left_type, 0);
if ($data_type->isa('UR::Value::Number')) {
$retval[$i] = q{to_char(%s)};
} elsif ($data_type->isa('UR::Value::Timestamp')) {
# These time formats shoule match what's given in init_created_handle
$retval[$i] = qq{to_char(%s, '$TIMESTAMP_FORMAT')};
} elsif ($data_type->isa('UR::Value::DateTime')) {
$retval[$i] = qq{to_char(%s, '$DATE_FORMAT')};
} else {
@retval = $class->SUPER::cast_for_data_conversion($left_type, $right_type);
}
return @retval;
}
sub _vendor_data_type_for_ur_data_type {
return ( TEXT => 'VARCHAR2',
STRING => 'VARCHAR2',
BOOLEAN => 'INTEGER',
__default__ => 'VARCHAR2',
shift->SUPER::_vendor_data_type_for_ur_data_type(),
);
};
1;
=pod
=head1 NAME
UR::DataSource::Oracle - Oracle specific subclass of UR::DataSource::RDBMS
=head1 DESCRIPTION
This module provides the Oracle-specific methods necessary for interacting with
Oracle databases
=head1 SEE ALSO
L, L
=cut
Pg.pm 100664 023532 023421 15721 12544604516 15715 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/DataSource package UR::DataSource::Pg;
use strict;
use warnings;
require UR;
our $VERSION = "0.44"; # UR $VERSION;
UR::Object::Type->define(
class_name => 'UR::DataSource::Pg',
is => ['UR::DataSource::RDBMS'],
is_abstract => 1,
);
# RDBMS API
sub driver { "Pg" }
#sub server {
# my $self = shift->_singleton_object();
# $self->_init_database;
# return $self->_database_file_path;
#}
sub owner { shift->_singleton_object->login }
#sub login {
# undef
#}
#
#sub auth {
# undef
#}
sub _default_sql_like_escape_string { return '\\\\' };
sub _format_sql_like_escape_string {
my $class = shift;
my $escape = shift;
return "E'$escape'";
}
sub can_savepoint { 1;}
sub set_savepoint {
my($self,$sp_name) = @_;
my $dbh = $self->get_default_handle;
$dbh->pg_savepoint($sp_name);
}
sub rollback_to_savepoint {
my($self,$sp_name) = @_;
my $dbh = $self->get_default_handle;
$dbh->pg_rollback_to($sp_name);
}
*_init_created_dbh = \&init_created_handle;
sub init_created_handle
{
my ($self, $dbh) = @_;
return unless defined $dbh;
$dbh->{LongTruncOk} = 0;
return $dbh;
}
sub _ignore_table {
my $self = shift;
my $table_name = shift;
return 1 if $table_name =~ /^(pg_|sql_)/;
}
sub _get_next_value_from_sequence {
my($self,$sequence_name) = @_;
# we may need to change how this db handle is gotten
my $dbh = $self->get_default_handle;
my($new_id) = $dbh->selectrow_array("SELECT nextval('$sequence_name')");
if ($dbh->err) {
die "Failed to prepare SQL to generate a column id from sequence: $sequence_name.\n" . $dbh->errstr . "\n";
return;
}
return $new_id;
}
# The default for PostgreSQL's serial datatype is to create a sequence called
# tablename_columnname_seq
sub _get_sequence_name_for_table_and_column {
my($self,$table_name, $column_name) = @_;
return sprintf("%s_%s_seq",$table_name, $column_name);
}
sub get_bitmap_index_details_from_data_dictionary {
# FIXME Postgres has bitmap indexes, but we don't support them yet. See the Oracle
# datasource module for details about how to get it working
return [];
}
sub get_unique_index_details_from_data_dictionary {
my($self, $owner_name, $table_name) = @_;
my $sql = qq(
SELECT c_index.relname, a.attname
FROM pg_catalog.pg_class c_table
JOIN pg_catalog.pg_index i ON i.indrelid = c_table.oid
JOIN pg_catalog.pg_class c_index ON c_index.oid = i.indexrelid
JOIN pg_catalog.pg_attribute a ON a.attrelid = c_index.oid
JOIN pg_catalog.pg_namespace n ON c_table.relnamespace = n.oid
WHERE c_table.relname = ? AND n.nspname = ?
and (i.indisunique = 't' or i.indisprimary = 't')
and i.indisvalid = 't'
);
my $dbh = $self->get_default_handle();
return undef unless $dbh;
my $sth = $dbh->prepare($sql);
return undef unless $sth;
#my $db_owner = $self->owner(); # We should probably do something with the owner/schema
$sth->execute($table_name, $owner_name);
my $ret;
while (my $data = $sth->fetchrow_hashref()) {
$ret->{$data->{'relname'}} ||= [];
push @{ $ret->{ $data->{'relname'} } }, $data->{'attname'};
}
return $ret;
}
my %ur_data_type_for_vendor_data_type = (
# DB type UR Type
'SMALLINT' => ['Integer', undef],
'BIGINT' => ['Integer', undef],
'SERIAL' => ['Integer', undef],
'TEXT' => ['Text', undef],
'BYTEA' => ['Blob', undef],
'CHARACTER VARYING' => ['Text', undef],
'TIMESTAMP WITHOUT TIME ZONE' => ['DateTime', undef],
'NUMERIC' => ['Number', undef],
'DOUBLE PRECISION' => ['Number', undef],
);
sub ur_data_type_for_data_source_data_type {
my($class,$type) = @_;
$type = $class->normalize_vendor_type($type);
my $urtype = $ur_data_type_for_vendor_data_type{$type};
unless (defined $urtype) {
$urtype = $class->SUPER::ur_data_type_for_data_source_data_type($type);
}
return $urtype;
}
sub _vendor_data_type_for_ur_data_type {
return ( BOOLEAN => 'BOOLEAN',
XML => 'XML',
shift->SUPER::_vendor_data_type_for_ur_data_type(),
);
}
sub _alter_sth_for_selecting_blob_columns {
my($self, $sth, $column_objects) = @_;
for (my $n = 0; $n < @$column_objects; $n++) {
next unless defined ($column_objects->[$n]); # No metaDB info for this one
if (uc($column_objects->[$n]->data_type) eq 'BLOB') {
require DBD::Pg;
$sth->bind_param($n+1, undef, { pg_type => DBD::Pg::PG_BYTEA() });
}
}
}
my $DATE_FORMAT = 'YYYY-MM-DD HH24:MI:SS';
my $TIMESTAMP_FORMAT = 'YYYY-MM-DD HH24:MI:SS.US';
sub cast_for_data_conversion {
my($class, $left_type, $right_type, $operator, $sql_clause) = @_;
my @retval = ('%s','%s');
# compatible types
if ($left_type->isa($right_type)
or
$right_type->isa($left_type)
) {
return @retval;
}
# So far, the only casting is to support using 'like' and one or both are strings
if ($operator ne 'like'
or
( ! $left_type->isa('UR::Value::Text') and ! $right_type->isa('UR::Value::Text') )
) {
return @retval;
}
# Figure out which one is the non-string
my($data_type, $i) = $left_type->isa('UR::Value::Text')
? ( $right_type, 1)
: ( $left_type, 0);
if ($data_type->isa('UR::Value::Timestamp')) {
$retval[$i] = qq{to_char(%s, '$TIMESTAMP_FORMAT')};
} elsif ($data_type->isa('UR::Value::DateTime')) {
$retval[$i] = qq{to_char(%s, '$DATE_FORMAT')};
} else {
@retval = $class->SUPER::cast_for_data_conversion($left_type, $right_type, $operator);
}
return @retval;
}
sub _resolve_order_by_clause_for_column {
my($self, $column_name, $query_plan, $property_meta) = @_;
my $column_clause = $self->SUPER::_resolve_order_by_clause_for_column($column_name, $query_plan);
my $is_text_type = $property_meta->is_text;
if ($is_text_type) {
# Tell the DB to sort the same order as Perl's cmp
$column_clause .= q( COLLATE "C");
}
return $column_clause;
}
sub _assure_schema_exists_for_table {
my($self, $table_name, $dbh) = @_;
$dbh ||= $self->get_default_handle;
my ($schema_name, undef) = $self->_extract_schema_and_table_name($table_name);
if ($schema_name) {
my $exists = $dbh->selectrow_array("SELECT schema_name FROM information_schema.schemata WHERE schema_name = ?;",
undef, $schema_name);
unless ($exists) {
$dbh->do("CREATE SCHEMA $schema_name")
or Carp::croak("Could not create schema $schema_name: " . $dbh->errstr);
}
}
}
1;
=pod
=head1 NAME
UR::DataSource::Pg - PostgreSQL specific subclass of UR::DataSource::RDBMS
=head1 DESCRIPTION
This module provides the PostgreSQL-specific methods necessary for interacting with
PostgreSQL databases
=head1 SEE ALSO
L, L
=cut
False.pm 100664 023532 023421 411 12544604516 20470 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/DataSource/Pg/Operator use strict;
use warnings;
package UR::DataSource::Pg::Operator::False;
sub generate_sql_for {
my($class, $expr_sql, $val, $escape) = @_;
my $sql = qq(( $expr_sql IS NULL or ${expr_sql}::text = '0' or ${expr_sql}::text = '' ));
return ($sql);
}
1;
True.pm 100664 023532 023421 420 12544604516 20355 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/DataSource/Pg/Operator use strict;
use warnings;
package UR::DataSource::Pg::Operator::True;
sub generate_sql_for {
my($class, $expr_sql, $val, $escape) = @_;
my $sql = qq(( $expr_sql IS NOT NULL and ${expr_sql}::text != '0' and ${expr_sql}::text != '' ));
return ($sql);
}
1;
QueryPlan.pm 100664 023532 023421 320137 12544604516 17307 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/DataSource package UR::DataSource::QueryPlan;
use strict;
use warnings;
use UR;
our $VERSION = "0.44"; # UR $VERSION;
# this class is an evolving attempt to formalize
# the blob of cached value used for query construction
class UR::DataSource::QueryPlan {
is => 'UR::Value',
id_by => [
rule_template => { is => 'UR::BoolExpr::Template', id_by => ['subject_class_name','logic_type','logic_detail','constant_values_id'] },
data_source => { is => 'UR::DataSource', id_by => 'data_source_id' },
],
has_transient => [
_is_initialized => { is => 'Boolean' },
needs_further_boolexpr_evaluation_after_loading => { is => 'Boolean' },
# data tracked for the whole query by property,alias,join_id
_delegation_chain_data => { is => 'HASH' },
_alias_data => { is => 'HASH' },
_join_data => { is => 'HASH' },
# the old $alias_num
_alias_count => { is => 'Number' },
# the old @sql_joins
_db_joins => { is => 'ARRAY' },
# the new @obj_joins
_obj_joins => { is => 'ARRAY' },
# the old all_table_properties, which has a small array of loading info
_db_column_data => { is => 'ARRAY' },
# the old hashes by the same names
_group_by_property_names => { is => 'HASH' },
_order_by_property_names => { is => 'HASH' },
_sql_filters => { is => 'ARRAY' },
_sql_params => { is => 'ARRAY' },
lob_column_names => {},
lob_column_positions => {},
query_config => {},
post_process_results_callback => {},
select_clause => {},
select_hint => {},
from_clause => {},
where_clause => {},
connect_by_clause => {},
group_by_clause => {},
order_by_columns => {},
order_by_non_column_data => {}, # flag that's true if asked to order_by something not in the data source
sql_params => {},
filter_specs => {},
property_names_in_resultset_order => {},
rule_template_id => {},
rule_template_id_without_recursion_desc => {},
rule_template_without_recursion_desc => {},
joins => {},
recursion_desc => {},
recurse_property_on_this_row => {},
recurse_property_referencing_other_rows => {},
recurse_resolution_by_iteration => {}, # For data sources that don't support recursive queries
joins_across_data_sources => {}, # context _resolve_query_plan_for_ds_and_bxt
loading_templates => {},
class_name => {},
rule_matches_all => {},
rule_template_is_id_only => {},
sub_typing_property => {},
class_table_name => {},
rule_template_specifies_value_for_subtype => {},
sub_classification_meta_class_name => {},
]
};
sub _load {
my $class = shift;
my $rule = shift;
# See if the requested object is loaded.
my @loaded = $UR::Context::current->get_objects_for_class_and_rule($class,$rule,0);
return $class->context_return(@loaded) if @loaded;
# Auto generate the object on the fly.
my $id = $rule->value_for_id;
unless (defined $id) {
#$DB::single = 1;
Carp::croak "No id specified for loading members of an infinite set ($class)!"
}
my $class_meta = $class->__meta__;
my @p = (id => $id);
if (my $alt_ids = $class_meta->{id_by}) {
if (@$alt_ids == 1) {
push @p, $alt_ids->[0] => $id;
}
else {
my ($rule, %extra) = UR::BoolExpr->resolve_normalized($class, $rule);
push @p, $rule->params_list;
}
}
my $obj = $UR::Context::current->_construct_object($class, @p);
if (my $method_name = $class_meta->sub_classification_method_name) {
my($rule, %extra) = UR::BoolExpr->resolve_normalized($class, $rule);
my $sub_class_name = $obj->$method_name;
if ($sub_class_name ne $class) {
# delegate to the sub-class to create the object
$UR::Context::current->_abandon_object($obj);
$obj = $UR::Context::current->_construct_object($sub_class_name,$rule);
$obj->__signal_change__("load");
return $obj;
}
# fall through if the class names match
}
$obj->__signal_change__("load");
return $obj;
}
# these hash keys are probably removable
# because they are not above, they will be deleted if _init sets them
# this exists primarily as a cleanup target list
my @extra = qw(
id_properties
direct_table_properties
all_table_properties
sub_classification_method_name
subclassify_by
properties_meta_in_resultset_order
all_properties
rule_specifies_id
all_id_property_names
id_property_sorter
properties_for_params
first_table_name
base_joins
parent_class_objects
);
sub _init {
my $self = shift;
Carp::confess("already initialized???") if $self->_is_initialized;
# We could have this sub-classify by data source type, but right
# now it's conditional logic because we'll likely remove the distinctions.
# This will work because we'll separate out the ds-specific portion
# and call methods on the DS to get that part.
my $ds = $self->data_source;
if ($ds->isa("UR::DataSource::RDBMS")) {
$self->_init_light();
$self->_init_rdbms();
}
elsif ($ds->isa('UR::DataSource::Filesystem')) {
$self->_init_core();
$self->_init_filesystem();
}
else {
# Once all callers are using the API for this we won't need "_init".
$self->_init_core();
$self->_init_default() if $ds->isa("UR::DataSource::Default");
#$self->_init_remote_cache() if $ds->isa("UR::DataSource::RemoteCache");
}
# This object is currently still used as a hashref, but the properties
# are a declaration of the part of the hashref data we are still dependent upon.
# This removes the other properties to ensure this is the case.
# Next steps are to clean up the code below to not produce the data,
# then this loop can throw an exception if extra untracked data is found.
for my $key (keys %$self) {
next if $self->can($key);
delete $self->{$key};
}
$self->_is_initialized(1);
return $self;
}
sub _determine_complete_order_by_list {
my($self, $rule_template, $class_data, $db_property_data) = @_;
my $class_meta = $rule_template->subject_class_name->__meta__;
my $order_by_columns = $class_data->{order_by_columns} || [];
my $order_by = $rule_template->order_by;
my $ds = $self->data_source;
my %order_by_property_names;
my $order_by_non_column_data;
if ($order_by) {
my %db_property_data_map = map { $_->[1]->property_name => $_ } @$db_property_data;
# we only pull back columns we're ordering by if there is ordering happening
my %is_descending;
my @column_data;
for my $name (@$order_by) {
my $order_by_prop = $name;
if ($order_by_prop =~ m/^(-|\+)(.*)$/) {
$order_by_prop = $2;
$is_descending{$order_by_prop} = $1 eq '-';
}
my($order_by_prop_meta) = $class_meta->_concrete_property_meta_for_class_and_name($order_by_prop);
unless ($order_by_prop_meta) {
Carp::croak("Cannot order by '$name': Class "
. $class_meta->class_name
. " has no property named '$order_by_prop'");
}
$name = ( $is_descending{$order_by_prop} ? '-' : '' ) . $order_by_prop_meta->property_name;
if ($order_by_property_names{$name} = $db_property_data_map{$order_by_prop_meta->property_name}) { # yes, single =
push @column_data, $order_by_property_names{$name};
my $table_column_names = $ds->_select_clause_columns_for_table_property_data($column_data[-1]);
$is_descending{$table_column_names->[0]} = $is_descending{$order_by_prop}; # copy for table.column designation
$order_by_property_names{$table_column_names->[0]} = $order_by_property_names{$name};
} else {
$order_by_non_column_data = 1;
}
}
if (@column_data) {
my $additional_order_by_columns = $ds->_select_clause_columns_for_table_property_data(@column_data);
# Strip out columns named in the original $order_by_columns list that now appear in the
# additional order by list so we don't duplicate columns names, and the additional columns
# appear earlier in the list
my %additional_order_by_columns = map { $_ => 1 } @$additional_order_by_columns;
my @existing_order_by_columns = grep { ! $additional_order_by_columns{$_} } @$order_by_columns;
$order_by_columns = [ map { $is_descending{$_} ? '-'. $_ : $_ } ( @$additional_order_by_columns, @existing_order_by_columns ) ];
}
}
$self->_order_by_property_names(\%order_by_property_names);
return ($order_by_columns, $order_by_non_column_data);
}
sub _init_rdbms {
my $self = shift;
my $rule_template = $self->rule_template;
my $ds = $self->data_source;
# class-based values
my $class_name = $rule_template->subject_class_name;
my $class_meta = $class_name->__meta__;
my $class_data = $ds->_get_class_data_for_loading($class_meta);
my @parent_class_objects = @{ $class_data->{parent_class_objects} };
my @all_id_property_names = @{ $class_data->{all_id_property_names} };
my @id_properties = @{ $class_data->{id_properties} };
#my $first_table_name = $class_data->{first_table_name};
#my $id_property_sorter = $class_data->{id_property_sorter};
#my @lob_column_names = @{ $class_data->{lob_column_names} };
my @lob_column_positions = @{ $class_data->{lob_column_positions} };
#my $query_config = $class_data->{query_config};
#my $post_process_results_callback = $class_data->{post_process_results_callback};
#my $class_table_name = $class_data->{class_table_name};
# individual template based
my $hints = $rule_template->hints;
my %hints = map { $_ => 1 } @$hints;
my $order_by = $rule_template->order_by;
my $group_by = $rule_template->group_by;
my $limit = $rule_template->limit;
my $aggregate = $rule_template->aggregate;
my $recursion_desc = $rule_template->recursion_desc;
my ($first_table_name, @db_joins) = _resolve_db_joins_for_inheritance($class_meta);
$self->_db_joins(\@db_joins);
$self->_obj_joins([]);
# an array of arrays, containing $table_name, $column_name, $alias, $object_num
# as joins are done we extend this, and then condense it into object fabricators
my @db_property_data = @{ $class_data->{all_table_properties} };
my %group_by_property_names;
if ($group_by) {
# we only pull back columns we're grouping by or aggregating if there is grouping happening
for my $name (@$group_by) {
unless ($class_name->can($name)) {
Carp::croak("Cannot group by '$name': Class $class_name has no property/method by that name");
}
$group_by_property_names{$name} = 1;
}
for my $data (@db_property_data) {
my $name = $data->[1]->property_name;
if ($group_by_property_names{$name}) {
$group_by_property_names{$name} = $data;
}
}
@db_property_data = grep { ref($_) } values %group_by_property_names;
}
my($order_by_columns, $order_by_non_column_data)
= $self->_determine_complete_order_by_list($rule_template, $class_data,\@db_property_data);
$self->_db_column_data(\@db_property_data);
$self->_group_by_property_names(\%group_by_property_names);
# Find out what delegated properties we'll be dealing with
my @sql_filters;
my @delegated_properties;
do {
my %filters =
map { $_ => $rule_template->operator_for($_) }
grep { substr($_,0,1) ne '-' }
$rule_template->_property_names;
unless (@all_id_property_names == 1 && $all_id_property_names[0] eq "id") {
delete $filters{'id'};
}
# Remove the flag for descending/ascending sort
my @order_by_properties = $order_by ? @$order_by : ();
s/^-|\+// foreach @order_by_properties;
my %properties_involved = map { $_ => 1 }
keys(%filters),
($hints ? @$hints : ()),
@order_by_properties,
($group_by ? @$group_by : ());
my @properties_involved = sort keys(%properties_involved);
my @errors;
while (my $property_name = shift @properties_involved) {
if (index($property_name,'.') != -1) {
push @delegated_properties, $property_name;
next;
}
my (@pmeta) = $class_meta->property_meta_for_name($property_name);
unless (@pmeta) {
if ($class_name->can($property_name)) {
# method, not property
next;
}
else {
push @errors, "Class ".$class_meta->id." has no property or method named '$property_name'";
next;
}
}
# For each property in this list, go up the inheritance and find the right property
# to query on. Give priority to properties that actually have columns
FIND_PROPERTY_WITH_COLUMN:
foreach my $pmeta ( @pmeta ) {
foreach my $candidate_class ( $class_meta->all_class_metas ) {
my $candidate_prop_meta = UR::Object::Property->get(class_name => $candidate_class->class_name,
property_name => $property_name);
next unless $candidate_prop_meta;
if ($candidate_prop_meta->column_name) {
$pmeta = $candidate_prop_meta;
next FIND_PROPERTY_WITH_COLUMN;
}
}
}
my $property = $pmeta[0];
my $table_name = $property->class_meta->first_table_name;
my $operator = $rule_template->operator_for($property_name);
my $value_position = $rule_template->value_position_for_property_name($property_name);
if ($property->can("expr_sql")) {
unless ($table_name) {
$ds->warning_message("Property '$property_name' of class '$class_name' can 'expr_sql' but has no table!");
next;
}
my $expr_sql = $property->expr_sql;
if (exists $filters{$property_name}) {
my @coercion = $self->data_source->cast_for_data_conversion(
$property->_data_type_as_class_name,
'UR::Value::String', # We can't know here what the type should be
$operator,
'where');
push @sql_filters,
$table_name => {
# cheap hack of prefixing with a whitespace differentiates
# from a regular column below
" " . $expr_sql => {
operator => $operator,
value_position => $value_position,
left_coercion => $coercion[0],
right_coercion => $coercion[1],
}
};
}
next;
}
# If the property is calculate and has a calculate_from list, add the
# calculate_from things to the internal hints list, but not the template
if ($property->is_calculated and $property->calculate_from) {
my $calculate_from = $property->calculate_from;
push @properties_involved, @$calculate_from;
push @$hints, @$calculate_from;
$hints{$_} = 1 foreach @$calculate_from;
}
if (exists($filters{$property_name}) and $filters{$property_name} eq 'isa') {
# RDBMS databases can't do 'isa'
$self->needs_further_boolexpr_evaluation_after_loading(1);
next;
}
elsif (my $column_name = $property->column_name) {
# normal column: filter on it
unless ($table_name) {
$ds->warning_message("Property '$property_name' of class '$class_name' has column '$column_name' but has no table!");
next;
}
if (exists $filters{$property_name}) {
my @coercion = $self->data_source->cast_for_data_conversion(
$property->_data_type_as_class_name,
'UR::Value::String', # We can't know here what the type should be
$operator,
'where');
push @sql_filters,
$table_name => {
$column_name => {
operator => $operator,
value_position => $value_position,
left_coercion => $coercion[0],
right_coercion => $coercion[1],
}
};
}
}
elsif ($property->is_delegated) {
push @delegated_properties, $property->property_name;
}
elsif ( ! exists($hints{$property_name}) or exists($filters{$property_name}) ) {
$self->needs_further_boolexpr_evaluation_after_loading(1);
}
else {
next;
}
} # end of properties in the expression which control the query content
if (@errors) {
my $class_name = $class_meta->class_name;
$ds->error_message("ERRORS PROCESSING PARAMTERS: (" . join("\n", @errors) . ") used to generate SQL for $class_name!");
#print Data::Dumper::Dumper($rule_template);
Carp::croak("Can't continue");
}
};
my $object_num = 0;
$self->_alias_count(0);
my %hints_included;
my @select_hint;
# FIXME - this needs to be broken out into delegated-property-join-resolver
# and inheritance-join-resolver methods that can be called recursively.
# It would better encapsulate what's going on and avoid bugs with complicated
# get()s
# one iteration per target value involved in the query,
# including values needed for filtering, ordering, grouping, and hints (selecting more)
# these "properties" may be a single property name or an ad-hoc "chain"
DELEGATED_PROPERTY:
for my $delegated_property (sort @delegated_properties) {
my $property_name = $delegated_property;
my $delegation_chain_data = $self->_delegation_chain_data || $self->_delegation_chain_data({});
$delegation_chain_data->{"__all__"}{table_alias} = {};
$delegation_chain_data->{"__all__"}{class_alias} = { $first_table_name => $class_meta };
my ($final_accessor, $is_optional, @joins) = _resolve_object_join_data_for_property_chain($rule_template,$property_name,$property_name);
# when there is no "final_accessor" it often means we have an object-accessor in a hint
# we want that to go through the join process, and only be left out at filter construction time
#unless ($final_accessor) {
#$self->needs_further_boolexpr_evaluation_after_loading(1);
#next;
#}
# this is gathered here and used below, but previously was gathered internally to the methods which take it
# since it is no longer needed directly in this method it might be refactored into the places which use it
my %ds_for_class;
for my $join (@joins) {
my $source_class_object = $join->{'source_class'}->__meta__;
my ($source_data_source) = UR::Context->resolve_data_sources_for_class_meta_and_rule($source_class_object, $rule_template);
$ds_for_class{$join->{'source_class'}} = $source_data_source;
my $foreign_class_object = $join->{'foreign_class'}->__meta__;
my ($foreign_data_source) = UR::Context->resolve_data_sources_for_class_meta_and_rule($foreign_class_object, $rule_template);
$ds_for_class{$join->{'foreign_class'}} = $foreign_data_source;
}
# Splice out joins that go through a UR::Value class and back out to the DB, since UR::Value-types
# don't get stored in the DB
# TODO: move this into the join creation logic
for (my $i = 0; $i < @joins; $i++) {
if (
$i < $#joins
and
(
# db -> UR::Value -> db : shortcut
$joins[$i]->{'foreign_class'}->isa('UR::Value')
and $joins[$i+1]->{'source_class'}->isa('UR::Value')
#and $joins[$i]->{'foreign_class'}->isa($joins[$i+1]->{'source_class'}) ## remove this?
)
) {
my $fixed_join = UR::Object::Join->_get_or_define(
source_class => $joins[$i]->{'source_class'},
source_property_names => $joins[$i]->{'source_property_names'},
foreign_class => $joins[$i+1]->{'foreign_class'},
foreign_property_names => $joins[$i+1]->{'foreign_property_names'},
is_optional => $joins[$i]->{'is_optional'},
id => $joins[$i]->{id} . "->" . $joins[$i+1]->{id});
if ($joins[$i+1]->{where}) {
# If there's a where involved, it will always be on the second thing,
# where the foreign_class is NOT a UR::Value
$fixed_join->{where} = $joins[$i+1]->{where};
}
splice(@joins, $i, 2, $fixed_join);
}
}
if (@joins and $joins[-1]{foreign_class}->isa("UR::Value")) {
# the final join in a chain is often the link between a primitive value
# and the UR::Value subclass into which it falls ...irrelevent for db joins
$final_accessor = $joins[-1]->source_property_names->[0];
pop @joins;
next DELEGATED_PROPERTY unless @joins;
}
my $last_class_object_excluding_inherited_joins;
my $alias_for_property_value;
# one iteration per table between the start table and target
while (my $object_join = shift @joins) {
$object_num++;
my @joins_for_object = ($object_join);
# one iteration per layer of inheritance for this object
# or per case of a join having additional filtering
my $current_inheritance_depth_for_this_target_join = 0;
while (my $join = shift @joins_for_object) {
my $where = $join->{where};
$current_inheritance_depth_for_this_target_join++;
my $foreign_class_name = $join->{foreign_class};
my $foreign_class_object = $join->{'foreign_class_meta'} || $foreign_class_name->__meta__;
if ($foreign_class_object->join_hint and !($hints_included{$foreign_class_name}++)) {
push @select_hint, $foreign_class_object->join_hint;
}
if (not exists $ds_for_class{$foreign_class_name}) {
# error: we should have at least a key with an empty value if we tried to find the ds
die "no data source key for $foreign_class_name when adding a join?"
}
my $ds = $ds_for_class{$foreign_class_name};
if (not $ds) {
# no ds for the next piece of data: we will have to resolve this on the client side
# this is where things may get slow if the query is insufficiently filtered
$self->needs_further_boolexpr_evaluation_after_loading(1);
next DELEGATED_PROPERTY;
}
my $alias = $self->_add_join(
$delegated_property,
$join,
$object_num,
$is_optional,
$final_accessor,
$ds_for_class{$foreign_class_name},
);
if (not $alias) {
# unable to add a join for another reason
# TODO: is the above the only valid case of a join being impossible?
# Can we remove this?
$self->needs_further_boolexpr_evaluation_after_loading(1);
next DELEGATED_PROPERTY;
}
# set these for after all of the joins are done
my $last_class_name = $foreign_class_name;
my $last_class_object = $foreign_class_object;
# on the first iteration, we figure out the remaining inherited iterations
# if there is inheritance to do, unshift those onto the stack ahead of other things
if ($current_inheritance_depth_for_this_target_join == 1) {
if ($final_accessor and $last_class_object->property_meta_for_name($final_accessor)) {
$last_class_object_excluding_inherited_joins = $last_class_object;
}
my @parents = grep { $_->table_name } $foreign_class_object->ancestry_class_metas;
if (@parents) {
my @last_id_property_names = $foreign_class_object->id_property_names;
for my $parent (@parents) {
my @parent_id_property_names = $parent->id_property_names;
die if @parent_id_property_names > 1;
my $parent_join_foreign_class_name = $parent->class_name;
my $inheritance_join = UR::Object::Join->_get_or_define(
source_class => $last_class_name,
source_property_names => [@last_id_property_names], # we change content below
foreign_class => $parent_join_foreign_class_name,
foreign_property_names => \@parent_id_property_names,
is_optional => $is_optional,
id => "${last_class_name}::" . join(',',@last_id_property_names),
);
unshift @joins_for_object, $inheritance_join;
@last_id_property_names = @parent_id_property_names;
$last_class_name = $foreign_class_name;
my $foreign_class_object = $parent_join_foreign_class_name->__meta__;
my ($foreign_data_source) = UR::Context->resolve_data_sources_for_class_meta_and_rule($foreign_class_object, $rule_template);
$ds_for_class{$parent_join_foreign_class_name} = $foreign_data_source;
}
next;
}
}
if (!@joins and not $alias_for_property_value) {
# we are out of joins for this delegated property
# setting $alias_for_property_value helps map to exactly where we do real filter/order/etc.
my $foreign_class_loading_data = $ds->_get_class_data_for_loading($foreign_class_object);
if ($final_accessor and
grep { $_->[1]->property_name eq $final_accessor } @{ $foreign_class_loading_data->{direct_table_properties} }
) {
$alias_for_property_value = $alias;
#print "found alias for $property_name on $foreign_class_name: $alias\n";
}
else {
# The thing we're joining to isn't a database-backed column (maybe calculated?)
$self->needs_further_boolexpr_evaluation_after_loading(1);
next DELEGATED_PROPERTY;
}
}
} # next join in the inheritance for this object
} # next join across objects from the query subject to the delegated property target
# done adding any new joins for this delegated property/property-chain
# now see if anything in the where-clause needs to filter on the item joined-to
my $value_position = $rule_template->value_position_for_property_name($property_name);
if (defined $value_position) {
# this property _is_ used to filter results
if (not $final_accessor) {
# on the client side :(
$self->needs_further_boolexpr_evaluation_after_loading(1);
next;
}
else {
# at the database level :)
my $final_accessor_property_meta = $last_class_object_excluding_inherited_joins->property_meta_for_name($final_accessor);
unless ($final_accessor_property_meta) {
Carp::croak("No property metadata for property named '$final_accessor' in class "
. $last_class_object_excluding_inherited_joins->class_name
. " while resolving joins for property '" . $delegated_property->property_name . "' in class "
. $delegated_property->class_name);
}
my $sql_lvalue;
if ($final_accessor_property_meta->is_calculated) {
$sql_lvalue = $final_accessor_property_meta->calculate_sql;
unless (defined($sql_lvalue)) {
$self->needs_further_boolexpr_evaluation_after_loading(1);
next;
}
}
else {
$sql_lvalue = $final_accessor_property_meta->column_name;
unless (defined($sql_lvalue)) {
Carp::confess("No column name set for non-delegated/calculated property $property_name of $class_name");
}
}
my $operator = $rule_template->operator_for($property_name);
unless ($alias_for_property_value) {
die "No alias found for $property_name?!";
}
my @coercion = $self->data_source->cast_for_data_conversion(
$final_accessor_property_meta->_data_type_as_class_name,
'UR::Value::String', # We can't know here what the type should be
$operator,
'where');
push @sql_filters,
$alias_for_property_value => {
$sql_lvalue => {
operator => $operator,
value_position => $value_position,
left_coercion => $coercion[0],
right_coercion => $coercion[1],
}
};
}
}
} # next delegated property
# the columns to query
my $db_property_data = $self->_db_column_data;
# the following two sets of variables hold the net result of the logic
my $select_clause;
my $from_clause;
my $connect_by_clause;
my $group_by_clause;
# Build the SELECT clause explicitly.
$select_clause = $ds->_select_clause_for_table_property_data(@$db_property_data);
# Oracle places group_by in a comment in the select
unshift(@select_hint, $class_meta->select_hint) if $class_meta->select_hint;
# Build the FROM clause base.
# Add joins to the from clause as necessary, then
$from_clause = (defined $first_table_name ? "$first_table_name" : '');
my $cnt = 0;
my @sql_params;
my @sql_joins = @{ $self->_db_joins };
while (@sql_joins) {
my $table_name = shift (@sql_joins);
my $condition = shift (@sql_joins);
my ($table_alias) = ($table_name =~ /(\S+)\s*$/s);
my $join_type;
if ($condition->{-is_required}) {
$join_type = 'INNER';
}
else {
$join_type = 'LEFT';
}
$from_clause .= "\n$join_type join " . $table_name . " on ";
# Restart the counter on each join for the from clause,
# but for the where clause keep counting w/o reset.
$cnt = 0;
for my $column_name (keys %$condition) {
next if substr($column_name,0,1) eq '-';
my $linkage_data = $condition->{$column_name};
my $expr_sql = (substr($column_name,0,1) eq " " ? $column_name : "${table_alias}.${column_name}");
my ($operator, $value_position, $value, $link_table_name, $link_column_name, $left_coercion, $right_coercion)
= @$linkage_data{qw/operator value_position value link_table_name link_column_name left_coercion right_coercion/};
$expr_sql = sprintf($right_coercion, $expr_sql) if ($right_coercion);
$from_clause .= "\n and " if ($cnt++);
if ($link_table_name and $link_column_name) {
# the linkage data is a join specifier
my $link_sql = "${link_table_name}.${link_column_name}";
$link_sql = sprintf($left_coercion, $link_sql) if ($left_coercion);
$from_clause .= "$link_sql = $expr_sql";
}
elsif (defined $value_position) {
Carp::croak("Joins cannot use variable values currently!");
}
else {
my ($more_sql, @more_params) = $ds->_extend_sql_for_column_operator_and_value($expr_sql, $operator, $value);
if ($more_sql) {
$from_clause .= $more_sql;
push @sql_params, @more_params;
}
else {
# error
return;
}
}
} # next column
} # next db join
# build the WHERE clause by making a data structure which will be parsed outside of this module
# special handling of different size lists, and NULLs, make a completely reusable SQL template very hard.
my @filter_specs;
while (@sql_filters) {
my $table_name = shift (@sql_filters);
my $condition = shift (@sql_filters);
my ($table_alias) = ($table_name =~ /(\S+)\s*$/s);
for my $column_name (keys %$condition) {
my $linkage_data = $condition->{$column_name};
my $expr_sql = (substr($column_name,0,1) eq " " ? $column_name : "${table_alias}.${column_name}");
my ($operator, $value_position, $value, $link_table_name, $link_column_name, $left_coercion, $right_coercion)
= @$linkage_data{qw/operator value_position value link_table_name
link_column_name left_coercion right_coercion/};
if ($link_table_name and $link_column_name) {
# the linkage data is a join specifier
Carp::confess("explicit column linkage in where clause?");
#$sql .= "${link_table_name}.${link_column_name} = $expr_sql";
}
else {
# the linkage data is a value position from the @values list
unless (defined $value_position) {
Carp::confess("No value position for $column_name in query!");
}
$expr_sql = sprintf($left_coercion, $expr_sql);
push @filter_specs, [$expr_sql, $operator, $value_position];
}
} # next column
} # next db filter
$connect_by_clause = '';
my $recurse_resolution_by_iteration = 0;
if ($recursion_desc) {
unless (ref($recursion_desc) eq 'ARRAY') {
Carp::croak("Recursion description must be an arrayref with exactly 2 items");
}
if (@$recursion_desc != 2) {
Carp::croak("Recursion description must contain exactly 2 items; got ".scalar(@$recursion_desc)
. ': ' . join(', ',@$recursion_desc));
}
# Oracle supports "connect by" queries.
if ($ds->does_support_recursive_queries eq 'connect by') {
my ($this,$prior) = @{ $recursion_desc };
my $this_property_meta = $class_meta->property_meta_for_name($this);
unless ($this_property_meta) {
Carp::croak("Class ".$class_meta->class_name." has no property named '$this', named in the recursion description");
}
my $prior_property_meta = $class_meta->property_meta_for_name($prior);
unless ($prior_property_meta) {
Carp::croak("Class ".$class_meta->class_name." has no property named '$prior', named in the recursion description");
}
my $this_class_meta = $this_property_meta->class_meta;
my $prior_class_meta = $prior_property_meta->class_meta;
my $this_table_name = $this_class_meta->table_name;
unless ($this_table_name) {
Carp::croak("Cannot resolve table name from class ".$class_meta->class_name." and property '$this', named in the recursion description");
}
my $prior_table_name = $prior_class_meta->table_name;
unless ($prior_table_name) {
Carp::croak("Cannot resolve table name from class ".$class_meta->class_name." and property '$prior', named in the recursion description");
}
my $this_column_name = $this_property_meta->column_name || $this;
my $prior_column_name = $prior_property_meta->column_name || $prior;
$connect_by_clause = "connect by $this_table_name.$this_column_name = prior $prior_table_name.$prior_column_name\n";
} else {
$recurse_resolution_by_iteration = 1;
}
}
my @property_names_in_resultset_order;
for my $property_meta_array (@$db_property_data) {
push @property_names_in_resultset_order, $property_meta_array->[1]->property_name;
}
# this is only used when making a real instance object instead of a "set"
my $per_object_in_resultset_loading_detail;
unless ($group_by) {
$per_object_in_resultset_loading_detail = $ds->_generate_loading_templates_arrayref(\@$db_property_data, $self->_obj_joins);
}
if ($group_by) {
# when grouping, we're making set objects instead of regular objects
# this means that we re-constitute the select clause and add a group_by clause
$group_by_clause = 'group by ' . $select_clause if (scalar(@$group_by));
# Q: - does it even make sense for the user to specify an order_by in the
# get() request for Set objects? If so, then we need to concatonate these order_by_columns
# with the ones that already exist in $order_by_columns from the class data
# A: - yes, because group by means "return a list of subsets", and this lets you sort the subsets
$order_by_columns = $ds->_select_clause_columns_for_table_property_data(@$db_property_data);
$select_clause .= ', ' if $select_clause;
$select_clause .= 'count(*) count';
for my $ag (@$aggregate) {
next if $ag eq 'count';
# TODO: translate property names to column names, and skip non-column properties
$select_clause .= ', ' . $ag;
}
unless (@$group_by == @$db_property_data) {
print "mismatch table properties vs group by!\n";
}
}
%$self = (
%$self,
# custom for RDBMS
select_clause => $select_clause,
select_hint => scalar(@select_hint) ? \@select_hint : undef,
from_clause => $from_clause,
connect_by_clause => $connect_by_clause,
group_by_clause => $group_by_clause,
order_by_columns => $order_by_columns,
order_by_non_column_data => $order_by_non_column_data,
filter_specs => \@filter_specs,
sql_params => \@sql_params,
recurse_resolution_by_iteration => $recurse_resolution_by_iteration,
# override defaults in the regular datasource $parent_template_data
property_names_in_resultset_order => \@property_names_in_resultset_order,
properties_meta_in_resultset_order => $db_property_data, # duplicate?!
loading_templates => $per_object_in_resultset_loading_detail,
);
my $template_data = $rule_template->{loading_data_cache} = $self;
return $self;
}
sub _init_filesystem {
my $self = shift;
my $rule_template = $self->rule_template;
my $ds = $self->data_source;
# class-based values
my $class_name = $rule_template->subject_class_name;
my $class_meta = $class_name->__meta__;
my $class_data = $ds->_get_class_data_for_loading($class_meta);
my @db_property_data = @{ $class_data->{all_table_properties} };
my($order_by_columns, $order_by_non_column_data)
= $self->_determine_complete_order_by_list($rule_template, $class_data, \@db_property_data);
%$self = (
%$self,
order_by_columns => $order_by_columns,
order_by_non_column_data => $order_by_non_column_data,
);
my $template_data = $rule_template->{loading_data_cache} = $self;
return $self;
}
sub _add_join {
my ($self,
$property_name,
$join,
$object_num,
$is_optional,
$final_accessor,
$foreign_data_source,
) = @_;
my $delegation_chain_data = $self->_delegation_chain_data || $self->_delegation_chain_data({});
my $table_alias = $delegation_chain_data->{"__all__"}{table_alias} ||= {};
my $source_table_and_column_names = $delegation_chain_data->{$property_name}{latest_source_table_and_column_names} ||= [];
my $source_class_name = $join->{source_class};
my $source_class_object = $join->{'source_class_meta'} || $source_class_name->__meta__;
my $class_alias = $delegation_chain_data->{"__all__"}{class_alias} ||= {};
if (! %$class_alias and $source_class_object->table_name) {
$class_alias->{$source_class_object->table_name} = $source_class_object;
}
my $foreign_class_name = $join->{foreign_class};
my $foreign_class_object = $join->{'foreign_class_meta'} || $foreign_class_name->__meta__;
my $rule_template = $self->rule_template;
my $ds = $self->data_source;
my $group_by = $rule_template->group_by;
#my($foreign_data_source) = UR::Context->resolve_data_sources_for_class_meta_and_rule($foreign_class_object, $rule_template);
if (!$foreign_data_source or ($foreign_data_source ne $ds)) {
# FIXME - do something smarter in the future where it can do a join-y thing in memory
$self->needs_further_boolexpr_evaluation_after_loading(1);
return;
}
my $foreign_class_loading_data = $ds->_get_class_data_for_loading($foreign_class_object);
# This will get filled in during the first pass, and every time after we've successfully
# performed a join - ie. that the delegated property points directly to a class/property
# that is a real table/column, and not a tableless class or another delegated property
my @source_property_names;
unless (@$source_table_and_column_names) {
@source_property_names = @{ $join->{source_property_names} };
@$source_table_and_column_names =
map {
if (my($view, $alias) = $ds->parse_view_and_alias_from_inline_view($_->[0])) {
# This "table_name" was actually a bit of SQL with an inline view and an alias
$_->[0] = $view;
$_->[2] = $alias;
}
$_;
}
map {
my($p) = $source_class_object->_concrete_property_meta_for_class_and_name($_);
unless ($p) {
Carp::croak("No property $_ for class ".$source_class_object->class_name);
}
my($table_name,$column_name) = $p->table_and_column_name_for_property();
if ($table_name && $column_name) {
[$table_name, $column_name];
} else {
#Carp::confess("Can't determine table and column for property $_ in class " .
# $source_class_object->class_name);
();
}
}
@source_property_names;
}
return unless @$source_table_and_column_names;
#my @source_property_names = @{ $join->{source_property_names} };
#my ($source_table_name, $fcols, $fprops) = $self->_resolve_table_and_column_data($source_class_object, @source_property_names);
#my @source_column_names = @$fcols;
#my @source_property_meta = @$fprops;
my @foreign_property_names = @{ $join->{foreign_property_names} };
my ($foreign_table_name, $fcols, $fprops) = $self->_resolve_table_and_column_data($foreign_class_object, @foreign_property_names);
my @foreign_column_names = @$fcols;
my @foreign_property_meta = @$fprops;
unless (@foreign_column_names) {
# all calculated properties: don't try to join any further
return;
}
unless ($foreign_table_name) {
# If we can't make the join because there is no datasource representation
# for this class, we're done following the joins for this property
# and will NOT try to filter on it at the datasource level
$self->needs_further_boolexpr_evaluation_after_loading(1);
return;
}
unless (@foreign_column_names == @foreign_property_meta) {
# some calculated properties, be sure to re-check for a match after loading the object
$self->needs_further_boolexpr_evaluation_after_loading(1);
}
my $alias = $self->_get_join_alias($join, $property_name);
unless ($alias) {
my $alias_num = $self->_alias_count($self->_alias_count+1);
my $alias_name = $join->sub_group_label || $property_name;
if (substr($alias_name,-1) eq '?') {
chop($alias_name) if substr($alias_name,-1) eq '?';
}
my $alias_length = length($alias_name)+length($alias_num)+1;
my $alias_max_length = 29;
if ($alias_length > $alias_max_length) {
$alias = substr($alias_name,0,$alias_max_length-length($alias_num)-1);
}
else {
$alias = $alias_name;
}
$alias =~ s/\./_/g;
$alias .= '_' . $alias_num;
$self->_set_join_alias($join, $property_name, $alias);
if ($foreign_class_object->table_name) {
my @extra_db_filters;
my @extra_obj_filters;
# TODO: when "flatten" correctly feeds the "ON" clause we can remove this
# This will crash if the "where" happens to use indirect things
my $where = $join->{where};
if ($where) {
for (my $n = 0; $n < @$where; $n += 2) {
my $key =$where->[$n];
my ($name,$op) = ($key =~ /^(\S+)\s*(.*)/);
if(index($name, '-') == 0) {
#skip '-order_by', '-hint' and the like for joins
next;
}
#my $meta = $foreign_class_object->property_meta_for_name($name);
#my $column = $meta->is_calculated ? (defined($meta->calculate_sql) ? ($meta->calculate_sql) : () ) : ($meta->column_name);
my ($table_name, $column_names, $property_metas) = $self->_resolve_table_and_column_data($foreign_class_object, $name);
my $column = $column_names->[0];
if (not $column) {
Carp::confess("No column for $foreign_class_object->{id} $name? Indirect property flattening must be enabled to use indirect filters in where with via/to.");
}
my $value = $where->[$n+1];
push @extra_db_filters, $column => { value => $value, ($op ? (operator => $op) : ()) };
push @extra_obj_filters, $name => { value => $value, ($op ? (operator => $op) : ()) };
}
}
my @db_join_data;
for (my $n = 0; $n < @foreign_column_names; $n++) {
my $link_table_name = $table_alias->{$source_table_and_column_names->[$n][0]}
|| $source_table_and_column_names->[$n][2]
|| $source_table_and_column_names->[$n][0];
my $link_column_name = $source_table_and_column_names->[$n][1];
my $foreign_column_name = $foreign_column_names[$n];
my $link_class_meta = $class_alias->{$link_table_name} || $source_class_object;
my $link_property_name = $link_class_meta->property_for_column($link_column_name);
# _concrete_property_meta_for_class_and_name returns a list :(
# since we're inspecting the joins by their "real" names and not the generic
# "id", it will only ever return a 1-element list
my($link_prop) = $link_class_meta->_concrete_property_meta_for_class_and_name($link_property_name);
my $left_type = $link_prop->_data_type_as_class_name;
my $right_type = $foreign_property_meta[$n]->_data_type_as_class_name;
my @coercion = $self->data_source->cast_for_data_conversion($left_type, $right_type, '=', 'join');
push @db_join_data,
$foreign_column_name => {
link_table_name => $link_table_name,
link_column_name => $link_column_name,
left_coercion => $coercion[0],
right_coercion => $coercion[1],
};
}
$self->_add_db_join(
"$foreign_table_name $alias" => {
@db_join_data,
@extra_db_filters,
}
);
$self->_add_obj_join(
"$alias" => {
(
map {
$foreign_property_names[$_] => {
link_class_name => $source_class_name,
link_alias => $table_alias->{$source_table_and_column_names->[$_][0]} # join alias
|| $source_table_and_column_names->[$_][2] # SQL inline view alias
|| $source_table_and_column_names->[$_][0], # table_name
link_property_name => $source_property_names[$_]
}
}
(0..$#foreign_property_names)
),
@extra_obj_filters,
}
);
# Add all of the columns in the join table to the return list
# Note that we increment the object numbers.
# Note: we add grouping columns individually instead of in chunks
unless ($group_by) {
$self->_add_columns(
map {
my $new = [@$_];
$new->[2] = $alias;
$new->[3] = $object_num;
$new
}
@{ $foreign_class_loading_data->{direct_table_properties} }
);
}
}
if ($group_by) {
if ($self->_groups_by_property($property_name)) {
my ($p) =
map {
my $new = [@$_];
$new->[2] = $alias;
$new->[3] = 0;
$new
}
grep { $_->[1]->property_name eq $final_accessor }
@{ $foreign_class_loading_data->{direct_table_properties} };
$self->_add_columns($p);
}
}
if ($self->_orders_by_property($property_name)) {
my ($p) =
map {
my $new = [@$_];
$new->[2] = $alias;
$new->[3] = 0;
$new
}
grep { $_->[1]->property_name eq $final_accessor }
@{ $foreign_class_loading_data->{direct_table_properties} };
# ??? what do we do here now with $p?
}
unless ($is_optional) {
# if _any_ part requires this, mark it required
$self->_set_alias_required($alias);
}
} # done adding a new join alias for a join which has not yet been done
if ($foreign_class_object->table_name) {
$table_alias->{$foreign_table_name} = $alias;
$class_alias->{$alias} = $foreign_class_object;
@$source_table_and_column_names = (); # Flag that we need to re-derive this at the top of the loop
}
return $alias;
}
sub _resolve_table_and_column_data {
my ($class, $class_meta, @property_names) = @_;
my @property_meta =
map { $class_meta->_concrete_property_meta_for_class_and_name($_) }
@property_names;
my $table_name;
my @column_names =
map {
# TODO: encapsulate
if ($_->is_calculated) {
if ($_->calculate_sql) {
$_->calculate_sql;
} else {
();
}
} else {
my $column_name;
($table_name, $column_name) = $_->table_and_column_name_for_property();
$column_name;
}
}
@property_meta;
if ($table_name and $table_name =~ /^(.*)\s+(\w+)\s*$/s) {
$table_name = $1;
}
return ($table_name, \@column_names, \@property_meta);
}
sub _set_join_alias {
my ($self, $join, $property_name, $alias) = @_;
$self->_join_data->{$join->id}{$property_name}{alias} = $alias;
$self->_alias_data({}) unless $self->_alias_data();
$self->_alias_data->{$alias}{join_id} = $join->id;
}
sub _get_join_alias {
my ($self,$join,$property_name) = @_;
$self->_join_data({}) unless $self->_join_data();
return $self->_join_data->{$join->id}{$property_name}{alias};
}
sub _get_alias_join {
my ($self,$alias) = @_;
my $alias_data = $self->_alias_data;
return if (! $alias_data or ! exists($alias_data->{$alias}));
my $join_id = $self->_alias_data->{$alias}{join_id};
UR::Object::Join->get($join_id);
}
sub _add_db_join {
my ($self, $key, $data) = @_;
my ($alias) = ($key =~/\w+$/);
my $alias_data = $self->_alias_data || $self->_alias_data({});
$alias_data->{$alias}{db_join} = $data;
my $db_joins = $self->_db_joins || $self->_db_joins([]);
push @$db_joins, $key, $data;
}
sub _add_obj_join {
my ($self, $key, $data) = @_;
Carp::confess() unless ref $data;
my $alias_data = $self->_alias_data || $self->_alias_data({});
$alias_data->{$key}{obj_join} = $data; # the key is the alias here
my $obj_joins = $self->_obj_joins || $self->_obj_joins([]);
push @$obj_joins, $key, $data;
}
sub _set_alias_required {
my ($self, $alias) = @_;
my $alias_data = $self->_alias_data || $self->_alias_data({});
$alias_data->{$alias}{is_required} = 1;
$alias_data->{$alias}{db_join}{-is_required} = 1;
$alias_data->{$alias}{obj_join}{-is_required} = 1;
}
sub _add_columns {
my $self = shift;
my @new = @_;
my $old = $self->_db_column_data;
my $pos = @$old;
my $lob_column_positions = $self->{lob_column_positions};
my $lob_column_names = $self->{lob_column_names};
for my $class_property (@new) {
my ($sql_class,$sql_property,$sql_table_name) = @$class_property;
my $data_type = $sql_property->data_type || '';
if ($data_type =~ /LOB$/) {
push @$lob_column_names, $sql_property->column_name;
push @$lob_column_positions, $pos;
}
$pos++;
}
push @$old, @new;
}
# Used by the object fabricator to find out which resultset column a
# property's data is stored
sub column_index_for_class_property_and_object_num {
my($self, $class_name, $property_name, $object_num) = @_;
$object_num ||= 0;
my $db_column_data = $self->_db_column_data;
for (my $resultset_col = 0; $resultset_col < @$db_column_data; $resultset_col++) {
if ($db_column_data->[$resultset_col]->[1]->class_name eq $class_name
and $db_column_data->[$resultset_col]->[1]->property_name eq $property_name
and $db_column_data->[$resultset_col]->[3] == $object_num
) {
return $resultset_col;
}
}
return undef;
}
# used by the object fabricator to determine the resultset column
# the source property of a join is stored.
sub column_index_for_class_and_property_before_object_num {
my($self, $class_name, $property_name, $object_num) = @_;
return unless $object_num;
my $db_column_data = $self->_db_column_data;
my $index;
for (my $resultset_col = 0; $resultset_col < @$db_column_data; $resultset_col++) {
last if ($db_column_data->[$resultset_col]->[3] >= $object_num);
if ($db_column_data->[$resultset_col]->[1]->class_name eq $class_name
and
$db_column_data->[$resultset_col]->[1]->property_name eq $property_name
) {
$index = $resultset_col;
}
}
return $index;
}
sub _groups_by_property {
my ($self, $property_name) = @_;
return $self->_group_by_property_names->{$property_name};
}
sub _orders_by_property {
my ($self, $property_name) = @_;
return $self->_order_by_property_names->{$property_name};
}
sub _resolve_db_joins_for_inheritance {
my $class_meta = $_[0];
my $first_table_name;
my @sql_joins;
my $prev_table_name;
my $prev_id_column_name;
my $prev_property_meta;
my @parent_class_objects = $class_meta->ancestry_class_metas;
my %seen;
for my $co ( $class_meta, @parent_class_objects ) {
my $class_name = $co->class_name;
next if $seen{$class_name}++;
my @id_property_objects = $co->direct_id_property_metas;
my %id_properties = map { $_->property_name => 1 } @id_property_objects;
my @id_column_names =
map { $_->column_name }
@id_property_objects;
my $table_name = $co->table_name;
if ($table_name) {
$first_table_name ||= $table_name;
if ($prev_table_name) {
die "Database-level inheritance cannot be used with multi-value-id classes ($class_name)!" if @id_property_objects > 1;
my $prev_table_alias;
if ($prev_table_name =~ /.*\s+(\w+)\s*$/) {
$prev_table_alias = $1;
}
else {
$prev_table_alias = $prev_table_name;
}
my @coercion = $co->data_source->cast_for_data_conversion(
$prev_property_meta->_data_type_as_class_name,
$id_property_objects[0]->_data_type_as_class_name,
'=',
'join');
push @sql_joins,
$table_name =>
{
$id_property_objects[0]->column_name => {
link_table_name => $prev_table_alias,
link_column_name => $prev_id_column_name,
left_coercion => $coercion[0],
right_coercion => $coercion[1],
},
-is_required => 1,
};
}
$prev_table_name = $table_name;
$prev_id_column_name = $id_property_objects[0]->column_name;
$prev_property_meta = $id_property_objects[0];
}
}
return ($first_table_name, @sql_joins);
}
sub _resolve_object_join_data_for_property_chain {
my ($rule_template, $property_name) = @_;
my $class_meta = $rule_template->subject_class_name->__meta__;
my @joins;
my $is_optional;
my $final_accessor;
my @pmeta = $class_meta->_concrete_property_meta_for_class_and_name($property_name);
my $last_class_meta = $class_meta;
for my $meta (@pmeta) {
if (!$meta) {
Carp::croak "Can't resolve joins for ".$rule_template->subject_class_name . " property '$property_name': No property metadata found for that class and property_name";
}
#id is a special property that we want to look up, but isn't necessarily on a table
#so if it aliases another property, we look at that instead
if($meta->property_name eq 'id' and $meta->class_name eq 'UR::Object') {
my @id_properties = grep {$_->class_name ne 'UR::Object'} $last_class_meta->id_properties;
if(@id_properties == 1) {
$meta = $id_properties[0];
$last_class_meta = $meta->class_name->__meta__;
next;
}
elsif (@id_properties > 1) {
Carp::confess "can't join to class " . $last_class_meta->class_name . " with multiple id properties: @id_properties";
}
}
if($meta->data_type and $meta->data_type =~ /::/) {
$last_class_meta = UR::Object::Type->get($meta->data_type);
} else {
$last_class_meta = UR::Object::Type->get($meta->class_name);
}
last unless $last_class_meta;
}
# we can't actually get this from the joins because
# a bunch of optional things can be chained together to form
# something non-optional
$is_optional = 0;
for my $pmeta (@pmeta) {
push @joins, $pmeta->_resolve_join_chain();
$is_optional = 1 if $pmeta->is_optional or $pmeta->is_many;
}
return unless @joins;
return ($joins[-1]->{source_name_for_foreign}, $is_optional, @joins)
};
sub _init_light {
my $self = shift;
my $rule_template = $self->rule_template;
my $ds = $self->data_source;
my $class_name = $rule_template->subject_class_name;
my $class_meta = $class_name->__meta__;
my $class_data = $ds->_get_class_data_for_loading($class_meta);
my @parent_class_objects = @{ $class_data->{parent_class_objects} };
my @all_properties = @{ $class_data->{all_properties} };
my $sub_classification_meta_class_name = $class_data->{sub_classification_meta_class_name};
my $subclassify_by = $class_data->{subclassify_by};
my @all_id_property_names = @{ $class_data->{all_id_property_names} };
my @id_properties = @{ $class_data->{id_properties} };
my $id_property_sorter = $class_data->{id_property_sorter};
my $sub_typing_property = $class_data->{sub_typing_property};
my $class_table_name = $class_data->{class_table_name};
my $recursion_desc = $rule_template->recursion_desc;
my $recurse_property_on_this_row;
my $recurse_property_referencing_other_rows;
my $recurse_resolution_by_iteration;
if ($recursion_desc) {
($recurse_property_on_this_row,$recurse_property_referencing_other_rows) = @$recursion_desc;
$recurse_resolution_by_iteration = ! $ds->does_support_recursive_queries;
}
my $needs_further_boolexpr_evaluation_after_loading;
my $is_join_across_data_source;
my @sql_params;
my @filter_specs;
my @property_names_in_resultset_order;
my $object_num = 0; # 0-based, usually zero unless there are joins
my @filters = $rule_template->_property_names;
my %filters =
map { $_ => 0 }
grep { substr($_,0,1) ne '-' }
@filters;
unless (@all_id_property_names == 1 && $all_id_property_names[0] eq "id") {
delete $filters{'id'};
}
my (
@sql_joins,
@sql_filters,
$prev_table_name,
$prev_id_column_name,
$eav_class,
@eav_properties,
$eav_cnt,
%pcnt,
$pk_used,
@delegated_properties,
%outer_joins,
%chain_delegates,
);
for my $key (keys %filters) {
if (index($key,'.') != -1) {
$chain_delegates{$key} = delete $filters{$key};
}
}
for my $co ( $class_meta, @parent_class_objects ) {
my $class_name = $co->class_name;
last if ( ($class_name eq 'UR::Object') or (not $class_name->isa("UR::Object")) );
my @id_property_objects = $co->direct_id_property_metas;
if (@id_property_objects == 0) {
@id_property_objects = $co->property_meta_for_name("id");
if (@id_property_objects == 0) {
Carp::confess("Couldn't determine ID properties for $class_name\n");
}
}
my %id_properties = map { $_->property_name => 1 } @id_property_objects;
my @id_column_names =
map { $_->column_name }
@id_property_objects;
for my $property_name (sort keys %filters) {
my $property = UR::Object::Property->get(class_name => $class_name, property_name => $property_name);
next unless $property;
my $operator = $rule_template->operator_for($property_name);
my $value_position = $rule_template->value_position_for_property_name($property_name);
delete $filters{$property_name};
$pk_used = 1 if $id_properties{ $property_name };
if ($property->is_legacy_eav) {
die "Old GSC EAV can be handled with a via/to/where/is_mutable=1";
}
elsif ($property->is_delegated) {
push @delegated_properties, $property;
}
elsif ($property->is_calculated || $property->is_transient) {
$needs_further_boolexpr_evaluation_after_loading = 1;
}
else {
push @sql_filters,
$class_name =>
{
$property_name => { operator => $operator, value_position => $value_position }
};
}
}
$prev_id_column_name = $id_property_objects[0]->column_name;
} # end of inheritance loop
if ( my @errors = keys(%filters) ) {
my $class_name = $class_meta->class_name;
$ds->error_message('Unknown param(s) (' . join(',',@errors) . ") used to generate SQL for $class_name!");
Carp::confess();
}
my $last_class_name = $class_name;
my $last_class_object = $class_meta;
my $alias_num = 1;
my %joins_done;
my $joins_across_data_sources;
DELEGATED_PROPERTY:
for my $delegated_property (@delegated_properties) {
my $last_alias_for_this_chain;
my $property_name = $delegated_property->property_name;
my @joins = $delegated_property->_resolve_join_chain($property_name);
my $relationship_name = $delegated_property->via;
unless ($relationship_name) {
$relationship_name = $property_name;
$needs_further_boolexpr_evaluation_after_loading = 1;
}
my $delegate_class_meta = $delegated_property->class_meta;
my($via_accessor_meta) = $delegate_class_meta->_concrete_property_meta_for_class_and_name($relationship_name);
next unless $via_accessor_meta;
my $final_accessor = $delegated_property->to;
my $data_type = $via_accessor_meta->data_type;
unless ($data_type) {
Carp::croak "Can't resolve delegation for $property_name on class $class_name: via property $relationship_name has no data type";
}
my $data_type_meta = UR::Object::Type->get($via_accessor_meta->data_type);
unless ($data_type_meta) {
Carp::croak "No class meta data for " . $via_accessor_meta->data_type .
" while resolving property $property_name on class $class_name";
}
my($final_accessor_meta) = $data_type_meta->_concrete_property_meta_for_class_and_name(
$final_accessor
);
unless ($final_accessor_meta) {
Carp::croak("No property '$final_accessor' on class " . $via_accessor_meta->data_type .
" while resolving property $property_name on class $class_name");
}
# Follow the chain of via/to delegation down to where the data ultimately lives
while($final_accessor_meta->is_delegated) {
# May have been 'to' an id_by/id_class_by property. Stop chaining and do two queries
# If we had access to the value at this point, we could continue joining through that
# value's class and id
next DELEGATED_PROPERTY if ($final_accessor_meta->id_by or $final_accessor_meta->id_class_by);
my $prev_accessor_meta = $final_accessor_meta;
$final_accessor_meta = $final_accessor_meta->to_property_meta();
unless ($final_accessor_meta) {
Carp::croak("Can't resolve property '$final_accessor' of class " . $via_accessor_meta->data_type
. ": Resolution involved property '" . $prev_accessor_meta->property_name . "' of class "
. $prev_accessor_meta->class_name
. " which is delegated, but its via/to metadata does not resolve to a known class and property");
}
}
$final_accessor = $final_accessor_meta->property_name;
for my $join (@joins) {
my $source_class_name = $join->{source_class};
my $source_class_object = $join->{'source_class_meta'} || $source_class_name->__meta__;
my $foreign_class_name = $join->{foreign_class};
next DELEGATED_PROPERTY if ($foreign_class_name->isa('UR::Value'));
my $foreign_class_object = $join->{'foreign_class_meta'} || $foreign_class_name->__meta__;
my($foreign_data_source) = $UR::Context::current->resolve_data_sources_for_class_meta_and_rule($foreign_class_object, $rule_template);
if (! $foreign_data_source) {
$needs_further_boolexpr_evaluation_after_loading = 1;
next DELEGATED_PROPERTY;
} elsif ($foreign_data_source ne $ds or
! $ds->does_support_joins or
! $foreign_data_source->does_support_joins
)
{
push(@{$joins_across_data_sources->{$foreign_data_source->id}}, $delegated_property);
next DELEGATED_PROPERTY;
}
my @source_property_names = @{ $join->{source_property_names} };
my @source_table_and_column_names =
map {
my($p) = $source_class_object->_concrete_property_meta_for_class_and_name($_);
unless ($p) {
Carp::confess("No property $_ for class $source_class_object->{class_name}\n");
}
unless ($p->class_name->__meta__) {
Carp::croak("Can't get class metadata for " . $p->class_name);
}
[$p->class_name->__meta__->class_name, $p->property_name];
}
@source_property_names;
my $foreign_table_name = $foreign_class_name;
unless ($foreign_table_name) {
# If we can't make the join because there is no datasource representation
# for this class, we're done following the joins for this property
# and will NOT try to filter on it at the datasource level
$needs_further_boolexpr_evaluation_after_loading = 1;
next DELEGATED_PROPERTY;
}
my @foreign_property_names = @{ $join->{foreign_property_names} };
my @foreign_property_meta =
map {
$foreign_class_object->_concrete_property_meta_for_class_and_name($_)
}
@foreign_property_names;
my @foreign_column_names =
map {
# TODO: encapsulate
$_->is_calculated ? (defined($_->calculate_sql) ? ($_->calculate_sql) : () ) : ($_->property_name)
}
@foreign_property_meta;
unless (@foreign_column_names) {
# all calculated properties: don't try to join any further
last;
}
unless (@foreign_column_names == @foreign_property_meta) {
# some calculated properties, be sure to re-check for a match after loading the object
$needs_further_boolexpr_evaluation_after_loading = 1;
}
my $alias = $joins_done{$join->{id}};
unless ($alias) {
$alias = "${relationship_name}_${alias_num}";
$alias_num++;
$object_num++;
push @sql_joins,
"$foreign_table_name $alias" =>
{
map {
$foreign_property_names[$_] => {
link_table_name => $last_alias_for_this_chain || $source_table_and_column_names[$_][0],
link_column_name => $source_table_and_column_names[$_][1]
}
}
(0..$#foreign_property_names)
};
# Add all of the columns in the join table to the return list.
push @all_properties,
map { [$foreign_class_object, $_, $alias, $object_num] }
map { $_->[1] } # These three lines are to get around a bug in perl
sort { $a->[0] cmp $b->[0] } # 5.8's sort involving method calls within the sort
map { [ $_->property_name, $_ ] } # sub that do sorts of their own
grep { defined($_->column_name) && $_->column_name ne '' }
UR::Object::Property->get( class_name => $foreign_class_name );
$joins_done{$join->{id}} = $alias;
}
# Set these for after all of the joins are done
$last_class_name = $foreign_class_name;
$last_class_object = $foreign_class_object;
$last_alias_for_this_chain = $alias;
} # next join
unless ($delegated_property->via) {
next;
}
my($final_accessor_property_meta) = $last_class_object->_concrete_property_meta_for_class_and_name($final_accessor);
unless ($final_accessor_property_meta) {
Carp::croak("No property metadata for property named '$final_accessor' in class " . $last_class_object->class_name
. " while resolving joins for property '" .$delegated_property->property_name . "' in class "
. $delegated_property->class_name);
}
my $sql_lvalue;
if ($final_accessor_property_meta->is_calculated) {
$sql_lvalue = $final_accessor_property_meta->calculate_sql;
unless (defined($sql_lvalue)) {
$needs_further_boolexpr_evaluation_after_loading = 1;
next;
}
}
else {
$sql_lvalue = $final_accessor_property_meta->column_name;
unless (defined($sql_lvalue)) {
Carp::confess("No column name set for non-delegated/calculated property $property_name of $class_name");
}
}
my $operator = $rule_template->operator_for($property_name);
my $value_position = $rule_template->value_position_for_property_name($property_name);
} # next delegated property
for my $property_meta_array (@all_properties) {
push @property_names_in_resultset_order, $property_meta_array->[1]->property_name;
}
my $rule_template_without_recursion_desc = ($recursion_desc ? $rule_template->remove_filter('-recurse') : $rule_template);
my $rule_template_specifies_value_for_subtype;
if ($sub_typing_property) {
$rule_template_specifies_value_for_subtype = $rule_template->specifies_value_for($sub_typing_property)
}
#my $per_object_in_resultset_loading_detail = $ds->_generate_loading_templates_arrayref(\@all_properties);
%$self = (
%$self,
%$class_data,
properties_for_params => \@all_properties,
property_names_in_resultset_order => \@property_names_in_resultset_order,
joins => \@sql_joins,
rule_template_id => $rule_template->id,
rule_template_without_recursion_desc => $rule_template_without_recursion_desc,
rule_template_id_without_recursion_desc => $rule_template_without_recursion_desc->id,
rule_matches_all => $rule_template->matches_all,
rule_specifies_id => ($rule_template->specifies_value_for('id') || undef),
rule_template_is_id_only => $rule_template->is_id_only,
rule_template_specifies_value_for_subtype => $rule_template_specifies_value_for_subtype,
recursion_desc => $rule_template->recursion_desc,
recurse_property_on_this_row => $recurse_property_on_this_row,
recurse_property_referencing_other_rows => $recurse_property_referencing_other_rows,
recurse_resolution_by_iteration => $recurse_resolution_by_iteration,
#loading_templates => $per_object_in_resultset_loading_detail,
joins_across_data_sources => $joins_across_data_sources,
);
return $self;
}
sub _init_core {
my $self = shift;
my $rule_template = $self->rule_template;
my $ds = $self->data_source;
# TODO: most of this only applies to the RDBMS subclass,
# but some applies to any datasource. It doesn't hurt to have the RDBMS stuff
# here and ignored, but it's not placed correctly.
# class-based values
my $class_name = $rule_template->subject_class_name;
my $class_meta = $class_name->__meta__;
my $class_data = $ds->_get_class_data_for_loading($class_meta);
my @parent_class_objects = @{ $class_data->{parent_class_objects} };
my @all_properties = @{ $class_data->{all_properties} };
# my $first_table_name = $class_data->{first_table_name};
my $sub_classification_meta_class_name = $class_data->{sub_classification_meta_class_name};
my $subclassify_by = $class_data->{subclassify_by};
my @all_id_property_names = @{ $class_data->{all_id_property_names} };
my @id_properties = @{ $class_data->{id_properties} };
my $id_property_sorter = $class_data->{id_property_sorter};
# my $order_by_clause = $class_data->{order_by_clause};
# my @lob_column_names = @{ $class_data->{lob_column_names} };
# my @lob_column_positions = @{ $class_data->{lob_column_positions} };
# my $query_config = $class_data->{query_config};
# my $post_process_results_callback = $class_data->{post_process_results_callback};
my $sub_typing_property = $class_data->{sub_typing_property};
my $class_table_name = $class_data->{class_table_name};
# individual query/boolexpr based
my $recursion_desc = $rule_template->recursion_desc;
my $recurse_property_on_this_row;
my $recurse_property_referencing_other_rows;
if ($recursion_desc) {
($recurse_property_on_this_row,$recurse_property_referencing_other_rows) = @$recursion_desc;
}
# _usually_ items freshly loaded from the DB don't need to be evaluated through the rule
# because the SQL gets constructed in such a way that all the items returned would pass anyway.
# But in certain cases (a delegated property trying to match a non-object value (which is a bug
# in the caller's code from one point of view) or with calculated non-sql properties, then the
# sql will return a superset of the items we're actually asking for, and the loader needs to
# validate them through the rule
my $needs_further_boolexpr_evaluation_after_loading;
# Does fulfilling this request involve querying more than one data source?
my $is_join_across_data_source;
my @sql_params;
my @filter_specs;
my @property_names_in_resultset_order;
my $object_num = 0; # 0-based, usually zero unless there are joins
my @filters = $rule_template->_property_names;
my %filters =
map { $_ => 0 }
grep { substr($_,0,1) ne '-' }
@filters;
unless (@all_id_property_names == 1 && $all_id_property_names[0] eq "id") {
delete $filters{'id'};
}
my (
@sql_joins,
@sql_filters,
$prev_table_name,
$prev_id_column_name,
$eav_class,
@eav_properties,
$eav_cnt,
%pcnt,
$pk_used,
@delegated_properties,
%outer_joins,
%chain_delegates,
);
for my $key (keys %filters) {
if (index($key,'.') != -1) {
$chain_delegates{$key} = delete $filters{$key};
}
}
for my $co ( $class_meta, @parent_class_objects ) {
# my $table_name = $co->table_name;
# next unless $table_name;
# $first_table_name ||= $table_name;
my $class_name = $co->class_name;
last if ( ($class_name eq 'UR::Object') or (not $class_name->isa("UR::Object")) );
my @id_property_objects = $co->direct_id_property_metas;
if (@id_property_objects == 0) {
@id_property_objects = $co->property_meta_for_name("id");
if (@id_property_objects == 0) {
Carp::confess("Couldn't determine ID properties for $class_name\n");
}
}
my %id_properties = map { $_->property_name => 1 } @id_property_objects;
my @id_column_names =
map { $_->column_name }
@id_property_objects;
# if ($prev_table_name)
# {
# # die "Database-level inheritance cannot be used with multi-value-id classes ($class_name)!" if @id_property_objects > 1;
# Carp::confess("No table for class $co->{class_name}") unless $table_name;
# push @sql_joins,
# $table_name =>
# {
# $id_property_objects[0]->column_name => {
# link_table_name => $prev_table_name,
# link_column_name => $prev_id_column_name
# }
# };
# delete $filters{ $id_property_objects[0]->property_name } if $pk_used;
# }
for my $property_name (sort keys %filters)
{
my $property = UR::Object::Property->get(class_name => $class_name, property_name => $property_name);
next unless $property;
my $operator = $rule_template->operator_for($property_name);
my $value_position = $rule_template->value_position_for_property_name($property_name);
delete $filters{$property_name};
$pk_used = 1 if $id_properties{ $property_name };
# if ($property->can("expr_sql")) {
# my $expr_sql = $property->expr_sql;
# push @sql_filters,
# $table_name =>
# {
# # cheap hack of putting a whitespace differentiates
# # from a regular column below
# " " . $expr_sql => { operator => $operator, value_position => $value_position }
# };
# next;
# }
if ($property->is_legacy_eav) {
die "Old GSC EAV can be handled with a via/to/where/is_mutable=1";
}
elsif ($property->is_transient) {
die "Query by transient property $property_name on $class_name cannot be done!";
}
elsif ($property->is_delegated) {
push @delegated_properties, $property;
}
elsif ($property->is_calculated) {
$needs_further_boolexpr_evaluation_after_loading = 1;
}
else {
# normal column: filter on it
push @sql_filters,
$class_name =>
{
$property_name => { operator => $operator, value_position => $value_position }
};
}
}
# $prev_table_name = $table_name;
$prev_id_column_name = $id_property_objects[0]->column_name;
} # end of inheritance loop
if ( my @errors = keys(%filters) ) {
my $class_name = $class_meta->class_name;
$ds->error_message('Unknown param(s) (' . join(',',@errors) . ") used to generate SQL for $class_name!");
Carp::confess();
}
my $last_class_name = $class_name;
my $last_class_object = $class_meta;
my $alias_num = 1;
my %joins_done;
my $joins_across_data_sources;
DELEGATED_PROPERTY:
for my $delegated_property (@delegated_properties) {
my $last_alias_for_this_chain;
my $property_name = $delegated_property->property_name;
my @joins = $delegated_property->_resolve_join_chain($property_name);
#pop @joins if $joins[-1]->{foreign_class}->isa("UR::Value");
my $relationship_name = $delegated_property->via;
unless ($relationship_name) {
$relationship_name = $property_name;
$needs_further_boolexpr_evaluation_after_loading = 1;
}
my $delegate_class_meta = $delegated_property->class_meta;
my($via_accessor_meta) = $delegate_class_meta->_concrete_property_meta_for_class_and_name($relationship_name);
my $final_accessor = $delegated_property->to;
my($final_accessor_meta) = $via_accessor_meta->data_type->__meta__->_concrete_property_meta_for_class_and_name(
$final_accessor
);
unless ($final_accessor_meta) {
Carp::croak("No property '$final_accessor' on class " . $via_accessor_meta->data_type .
" while resolving property $property_name on class $class_name");
}
while($final_accessor_meta->is_delegated) {
$final_accessor_meta = $final_accessor_meta->to_property_meta();
unless ($final_accessor_meta) {
Carp::croak("No property '$final_accessor' on class " . $via_accessor_meta->data_type .
" while resolving property $property_name on class $class_name");
}
}
$final_accessor = $final_accessor_meta->property_name;
for my $join (@joins) {
my $source_class_name = $join->{source_class};
my $source_class_object = $join->{'source_class_meta'} || $source_class_name->__meta__;
my $foreign_class_name = $join->{foreign_class};
my $foreign_class_object = $join->{'foreign_class_meta'} || $foreign_class_name->__meta__;
my($foreign_data_source) = $UR::Context::current->resolve_data_sources_for_class_meta_and_rule($foreign_class_object, $rule_template);
if (! $foreign_data_source) {
$needs_further_boolexpr_evaluation_after_loading = 1;
next DELEGATED_PROPERTY;
} elsif ($foreign_data_source ne $ds or
! $ds->does_support_joins or
! $foreign_data_source->does_support_joins
)
{
push(@{$joins_across_data_sources->{$foreign_data_source->id}}, $delegated_property);
next DELEGATED_PROPERTY;
}
my @source_property_names = @{ $join->{source_property_names} };
my @source_table_and_column_names =
map {
my($p) = $source_class_object->_concrete_property_meta_for_class_and_name($_);
unless ($p) {
Carp::confess("No property $_ for class $source_class_object->{class_name}\n");
}
[$p->class_name->__meta__->class_name, $p->property_name];
}
@source_property_names;
my $foreign_table_name = $foreign_class_name;
unless ($foreign_table_name) {
# If we can't make the join because there is no datasource representation
# for this class, we're done following the joins for this property
# and will NOT try to filter on it at the datasource level
$needs_further_boolexpr_evaluation_after_loading = 1;
next DELEGATED_PROPERTY;
}
my @foreign_property_names = @{ $join->{foreign_property_names} };
my @foreign_property_meta =
map {
$foreign_class_object->_concrete_property_meta_for_class_and_name($_);
}
@foreign_property_names;
my @foreign_column_names =
map {
# TODO: encapsulate
$_->is_calculated ? (defined($_->calculate_sql) ? ($_->calculate_sql) : () ) : ($_->property_name)
}
@foreign_property_meta;
unless (@foreign_column_names) {
# all calculated properties: don't try to join any further
last;
}
unless (@foreign_column_names == @foreign_property_meta) {
# some calculated properties, be sure to re-check for a match after loading the object
$needs_further_boolexpr_evaluation_after_loading = 1;
}
my $alias = $joins_done{$join->{id}};
unless ($alias) {
$alias = "${relationship_name}_${alias_num}";
$alias_num++;
$object_num++;
my @source_property_meta = map { $source_class_object->_concrete_property_meta_for_class_and_name($_) }
@source_property_names;
push @sql_joins,
"$foreign_table_name $alias" =>
{
map {
my @coercion = $ds->cast_for_data_conversion(
$source_property_meta[$_]->_data_type_as_class_name,
$foreign_property_meta[$_]->_data_type_as_class_name,
'=',
'join');
$foreign_property_names[$_] => {
link_table_name => $last_alias_for_this_chain || $source_table_and_column_names[$_][0],
link_column_name => $source_table_and_column_names[$_][1],
left_coercion => $coercion[0],
right_coercion => $coercion[1],
}
}
(0..$#foreign_property_names)
};
# Add all of the columns in the join table to the return list.
push @all_properties,
map { [$foreign_class_object, $_, $alias, $object_num] }
map { $_->[1] } # These three lines are to get around a bug in perl
sort { $a->[0] cmp $b->[0] } # 5.8's sort involving method calls within the sort
map { [ $_->property_name, $_ ] } # sub that do sorts of their own
grep { defined($_->column_name) && $_->column_name ne '' }
UR::Object::Property->get( class_name => $foreign_class_name );
$joins_done{$join->{id}} = $alias;
}
# Set these for after all of the joins are done
$last_class_name = $foreign_class_name;
$last_class_object = $foreign_class_object;
$last_alias_for_this_chain = $alias;
} # next join
unless ($delegated_property->via) {
next;
}
my($final_accessor_property_meta) = $last_class_object->_concrete_property_meta_for_class_and_name($id_properties[0]);
unless ($final_accessor_property_meta) {
Carp::croak("No property metadata for property named '$final_accessor' in class " . $last_class_object->class_name
. " while resolving joins for property '" .$delegated_property->property_name . "' in class "
. $delegated_property->class_name);
}
my $sql_lvalue;
if ($final_accessor_property_meta->is_calculated) {
$sql_lvalue = $final_accessor_property_meta->calculate_sql;
unless (defined($sql_lvalue)) {
$needs_further_boolexpr_evaluation_after_loading = 1;
next;
}
}
else {
$sql_lvalue = $final_accessor_property_meta->column_name;
unless (defined($sql_lvalue)) {
Carp::confess("No column name set for non-delegated/calculated property $property_name of $class_name");
}
}
my $operator = $rule_template->operator_for($property_name);
my $value_position = $rule_template->value_position_for_property_name($property_name);
#push @sql_filters,
# $final_table_name_with_alias => {
# $sql_lvalue => { operator => $operator, value_position => $value_position }
# };
} # next delegated property
for my $property_meta_array (@all_properties) {
push @property_names_in_resultset_order, $property_meta_array->[1]->property_name;
}
my $rule_template_without_recursion_desc = ($recursion_desc ? $rule_template->remove_filter('-recurse') : $rule_template);
my $rule_template_specifies_value_for_subtype;
if ($sub_typing_property) {
$rule_template_specifies_value_for_subtype = $rule_template->specifies_value_for($sub_typing_property)
}
my @this_ds_properties = grep { ! $_->[1]->is_delegated
and (! $_->[1]->is_calculated or $_->[1]->calculate_sql)
}
@all_properties;
my $per_object_in_resultset_loading_detail = $ds->_generate_loading_templates_arrayref(\@this_ds_properties);
%$self = (
%$self,
%$class_data,
properties_for_params => \@all_properties,
property_names_in_resultset_order => \@property_names_in_resultset_order,
joins => \@sql_joins,
rule_template_id => $rule_template->id,
rule_template_without_recursion_desc => $rule_template_without_recursion_desc,
rule_template_id_without_recursion_desc => $rule_template_without_recursion_desc->id,
rule_matches_all => $rule_template->matches_all,
rule_specifies_id => ($rule_template->specifies_value_for('id') || undef),
rule_template_is_id_only => $rule_template->is_id_only,
rule_template_specifies_value_for_subtype => $rule_template_specifies_value_for_subtype,
recursion_desc => $rule_template->recursion_desc,
recurse_property_on_this_row => $recurse_property_on_this_row,
recurse_property_referencing_other_rows => $recurse_property_referencing_other_rows,
loading_templates => $per_object_in_resultset_loading_detail,
joins_across_data_sources => $joins_across_data_sources,
);
return $self;
}
sub _init_default {
my $self = shift;
my $bx_template = $self->rule_template;
$self->{needs_further_boolexpr_evaluation_after_loading} = 1;
my $all_possible_headers = $self->{loading_templates}[0]{property_names};
my $expected_headers;
my $class_meta = $bx_template->subject_class_name->__meta__;
for my $pname (@$all_possible_headers) {
my $pmeta = $class_meta->property($pname);
if ($pmeta->is_delegated) {
next;
}
push @$expected_headers, $pname;
}
$self->{loading_templates}[0]{property_names} = $expected_headers;
if ($bx_template->subject_class_name->isa('UR::Value')) {
# Hack so the objects get blessed into the proper subclass in the Object Fabricator.
# This is necessary so every possible UR::Value subclass doesn't need its
# own "id" property defined. Without it, the data shows that these objects get
# loaded as the base UR::Value class (since its "id" is defined on UR:Value)
# and then would get automagically subclassed.
$self->{'loading_templates'}->[0]->{'final_class_name'} = $bx_template->subject_class_name
}
return $self;
}
sub _init_remote_cache {
my $self = shift;
my $rule_template = $self->rule_template;
my $ds = $self->data_source;
my $class_name = $rule_template->subject_class_name;
my $class_meta = $class_name->__meta__;
my $class_data = $ds->_get_class_data_for_loading($class_meta);
my $recursion_desc = $rule_template->recursion_desc;
my $rule_template_without_recursion_desc = ($recursion_desc ? $rule_template->remove_filter('-recurse') : $rule_template);
my $rule_template_specifies_value_for_subtype;
my $sub_typing_property = $class_data->{'sub_typing_property'};
if ($sub_typing_property) {
$rule_template_specifies_value_for_subtype = $rule_template->specifies_value_for($sub_typing_property)
}
my @property_names = $class_name->__meta__->all_property_names;
%$self = (
%$self,
select_clause => '',
select_hint => undef,
from_clause => '',
where_clause => '',
connect_by_clause => '',
order_by_clause => '',
needs_further_boolexpr_evaluation_after_loading => undef,
loading_templates => [],
sql_params => [],
filter_specs => [],
property_names_in_resultset_order => \@property_names,
properties_for_params => [],
rule_template_id => $rule_template->id,
rule_template_without_recursion_desc => $rule_template_without_recursion_desc,
rule_template_id_without_recursion_desc => $rule_template_without_recursion_desc->id,
rule_matches_all => $rule_template->matches_all,
rule_specifies_id => ($rule_template->specifies_value_for('id') || undef),
rule_template_is_id_only => $rule_template->is_id_only,
rule_template_specifies_value_for_subtype => $rule_template_specifies_value_for_subtype,
recursion_desc => undef,
recurse_property_on_this_row => undef,
recurse_property_referencing_other_rows => undef,
%$class_data,
);
return $self;
}
sub order_by_column_list {
my $self = shift;
$self->_resolve_order_by_and_descending_data();
return $self->{_order_by_column_list};
}
sub _resolve_order_by_and_descending_data {
my $self = shift;
unless ($self->{_order_by_column_list}) {
my %is_descending;
my @order_by_columns =
map {
m/^-(.*)/
? $is_descending{$1} = $1
: $_;
}
@{ $self->order_by_columns || [] };
$self->{_order_by_column_list} = \@order_by_columns;
$self->{_order_by_column_is_descending} = \%is_descending;
}
}
sub order_by_column_is_descending {
my($self, $column_name) = @_;
$self->_resolve_order_by_and_descending_data();
return $self->{_order_by_column_is_descending}->{$column_name};
}
sub property_meta_for_column {
my($self, $table_and_column_name) = @_;
$table_and_column_name = lc($table_and_column_name);
my $data_source = $self->data_source();
my ($table_name, $column_name) = $data_source->_resolve_table_and_column_from_column_name($table_and_column_name);
if (my $join = $self->_get_alias_join($table_name)) {
# The given $table_name was actually a join alias
my $foreign_class_meta = $join->foreign_class->__meta__;
my $prop_name = $foreign_class_meta->property_for_column($column_name);
return $prop_name
? $foreign_class_meta->property_meta_for_name($prop_name)
: undef;
} else {
my $class_meta = $self->class_name->__meta__;
my $prop_name = $class_meta->property_for_column($table_and_column_name);
return $class_meta->property_meta_for_name($prop_name);
}
}
1;
RDBMS.pm 100664 023532 023421 425235 12544604516 16243 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/DataSource package UR::DataSource::RDBMS;
# NOTE:: UR::DataSource::QueryPlan has conditional logic
# for this class/subclasses currently
use strict;
use warnings;
use Scalar::Util;
use List::MoreUtils;
use File::Basename;
require UR;
our $VERSION = "0.44"; # UR $VERSION;
UR::Object::Type->define(
class_name => 'UR::DataSource::RDBMS',
is => ['UR::DataSource','UR::Singleton'],
is_abstract => 1,
has => [
server => { is => 'Text', doc => 'the "server" part of the DBI connect string' },
login => { is => 'Text', doc => 'user name to connect as', is_optional => 1 },
auth => { is => 'Text', doc => 'authentication for the given user', is_optional => 1 },
owner => { is => 'Text', doc => 'Schema/owner name to connect to', is_optional => 1 },
],
has_optional => [
alternate_db_dsn => {
is => 'Text',
default_value => 0,
doc => 'Set to a DBI dsn to copy all data queried from this datasource to an alternate database',
},
camel_case_table_names => {
is => 'Boolean',
default_value => 0,
doc => 'When true, dynamically calculating class names from table names will expect camel case in table names.',
},
camel_case_column_names => {
is => 'Boolean',
default_value => 0,
doc => 'When true, dynamically calculating property names from column names will expect camel case in column names.',
},
_all_dbh_hashref => { is => 'HASH', len => undef, is_transient => 1 },
_last_savepoint => { is => 'Text', len => undef, is_transient => 1 },
],
valid_signals => ['query', 'query_failed', 'commit_failed', 'do_failed', 'connect_failed', 'sequence_nextval', 'sequence_nextval_failed'],
doc => 'A logical DBI-based database, independent of prod/dev/testing considerations or login details.',
);
# A record of objects saved to the database. It's filled in by _sync_database()
# and used by the alternate DB saving code. Objects noted in this hash don't get
# saved to the alternate DB
my %objects_in_database_saved_by_this_process;
sub database_exists {
my $self = shift;
warn $self->class . " failed to implement the database_exists() method. Testing connection as a surrogate. FIXME here!\n";
eval {
my $c = $self->create_default_handle();
};
if ($@) {
return;
}
return 1;
}
sub create_database {
my $self = shift;
die $self->class . " failed to implement the create_database() method!"
. " Unable to initialize a new database for this data source "
. $self->__display_name__ . " FIXME here.\n";
}
sub _resolve_ddl_for_table {
my ($self,$table, %opts) = @_;
my $all = delete $opts{all};
if (%opts) {
Carp::confess("odd arguments to _resolve_ddl_for_table: " . UR::Util::d(\%opts));
}
my $table_name = $table->table_name;
my @ddl;
if ($table->{db_committed} and not $all) {
my @columns = $table->columns;
for my $column (@columns) {
next unless $all or $column->last_object_revision eq '-';
my $column_name = $column->column_name;
my $ddl = "alter table $table_name add column ";
$ddl .= "\t$column_name " . $column->data_type;
if ($column->data_length) {
$ddl .= '(' . $column->data_length . ')';
}
push(@ddl, $ddl) if $ddl;
}
}
else {
my $ddl;
my @columns = $table->columns;
for my $column (@columns) {
next unless $all or $column->last_object_revision eq '-';
my $column_name = $column->column_name;
$ddl = 'create table ' . $table_name . "(\n" unless defined $ddl;
$ddl .= "\t$column_name " . $column->data_type;
if ($column->data_length) {
$ddl .= '(' . $column->data_length . ')';
}
$ddl .= ",\n" unless $column eq $columns[-1];
}
$ddl .= "\n)" if defined $ddl;
push(@ddl, $ddl) if $ddl;
}
return @ddl;
}
sub generate_schema_for_class_meta {
my ($self, $class_meta, $temp) = @_;
# We now support on-the-fly database introspection
# this gets called with the temp flag when _sync_database realizes
# it knows nothing about the table in question.
# We basically presume the schema is the one we would have generated
# given the current class definitions
# TODO: We still need to presume foreign keys are constrained.
my $method = ($temp ? '__define__' : 'create');
my @defined;
my $table_name = $class_meta->table_name;
my @fks_to_generate;
for my $p ($class_meta->parent_class_metas) {
next if ($p->class_name eq 'UR::Object' or $p->class_name eq 'UR::Entity');
next unless $p->class_name->isa("UR::Object");
my @new = $self->generate_schema_for_class_meta($p,$temp);
push @defined, @new;
my $parent_table;
if (($parent_table) = grep { $_->isa("UR::DataSource::RDBMS::Table") } @new) {
my @id_by = $class_meta->id_property_names;
my @column_names = map { $class_meta->property($_)->column_name } @id_by;
my $r_table_name = $parent_table->table_name;
##$DB::single = 1; # get pk columns
my @r_id_by = $p->id_property_names;
my @r_column_names = map { $class_meta->property($_)->column_name } @r_id_by;
push @fks_to_generate, [$class_meta->class_name, $table_name, $r_table_name, \@column_names, \@r_column_names];
}
}
my %properties_with_expected_columns =
map { $_->column_name => $_ }
grep { $_->column_name }
$class_meta->direct_property_metas;
#my %expected_constraints =
# map { $_->column_name => $_ }
# grep { $_->class_meta eq $class_meta }
# map { $class_meta->property_meta_for_name($_) }
# map { @{ $_->id_by } }
# grep { $_->id_by }
# $class_meta->all_property_metas;
#print Data::Dumper::Dumper(\%expected_constraints);
unless ($table_name) {
if (my @column_names = keys %properties_with_expected_columns) {
Carp::confess("class " . $class_meta->__display_name__ . " has no table_name specified for columns @column_names!");
}
else {
# no table, but no storable columns. all ok.
return;
}
}
## print "handling table $table_name\n";
if ($table_name =~ /[^\w\.]/) {
# pass back anything from parent classes, but do nothing for special "view" tables
#$DB::single = 1;
return @defined;
}
my $t = '-';
my $table = $self->refresh_database_metadata_for_table_name($table_name, $method);
my %existing_columns;
if ($table) {
## print "found table $table_name\n";
%existing_columns =
map { $_->column_name => $_ }
grep { $_->column_name }
$table->columns;
push @defined, ($table,$table->columns);
}
else {
## print "adding table $table_name\n";
$table = UR::DataSource::RDBMS::Table->$method(
table_name => $table_name,
data_source => $self->_my_data_source_id,
remarks => $class_meta->doc,
er_type => 'entity',
last_object_revision => $t,
table_type => ($table_name =~ /\s/ ? 'view' : 'table'),
);
Carp::confess("Failed to create metadata or table $table_name") unless $table;
push @defined, $table;
}
my ($update,$add,$extra) = UR::Util::intersect_lists([keys %properties_with_expected_columns],[keys %existing_columns]);
for my $column_name (@$extra) {
my $column = $existing_columns{$column_name};
$column->last_object_revision('?');
}
for my $column_name (@$add) {
my $property = $properties_with_expected_columns{$column_name};
#print "adding column $column_name\n";
my $column = UR::DataSource::RDBMS::TableColumn->$method(
column_name => $column_name,
table_name => $table->table_name,
data_source => $table->data_source,
namespace => $table->namespace,
data_type => $self->object_to_db_type($property->data_type) || 'Text',
data_length => $property->data_length,
nullable => $property->is_optional,
remarks => $property->doc,
last_object_revision => $t,
);
push @defined, $column;
}
for my $column_name (@$update) {
my $property = $properties_with_expected_columns{$column_name};
my $column = $existing_columns{$column_name};
##print "updating column $column_name with data from property " . $property->property_name . "\n";
if ($column->data_type) {
$column->data_type($self->object_to_db_type($property->data_type)) if $property->data_type;
}
else {
$column->data_type($self->object_to_db_type($property->data_type) || 'Text');
}
$column->data_length($property->data_length);
$column->nullable($property->is_optional);
$column->remarks($property->doc);
}
for my $property ( $class_meta->direct_id_property_metas ) {
unless (UR::DataSource::RDBMS::PkConstraintColumn->get(table_name => $table->table_name, column_name => $property->column_name, data_source => $table->data_source)) {
UR::DataSource::RDBMS::PkConstraintColumn->$method(
column_name => $property->column_name,
data_source => $table->data_source,
rank => $property->is_id,
table_name => $table->table_name );
}
}
# this "property_metas" method filers out things which have an id_by.
# it used to call ->properties, which used that method internally ...but seems like it never could have done anything?
for my $property ($class_meta->property_metas) {
my $id_by = $property->id_by;
next unless $id_by;
my $r_class_name = $property->data_type;
my $r_class_meta = $r_class_name->__meta__;
my $r_table_name = $r_class_meta->table_name;
next unless $r_table_name;
my @column_names = map { $class_meta->property($_)->column_name } @$id_by;
my @r_column_names = map { $r_class_meta->property($_)->column_name } @{ $r_class_meta->id_property_names };
push @fks_to_generate, [$property->id, $table_name, $r_table_name, \@column_names, \@r_column_names ];
}
for my $fk_to_generate (@fks_to_generate) {
my ($fk_id, $table_name, $r_table_name, $column_names, $r_column_names) = @$fk_to_generate;
my $fk = UR::DataSource::RDBMS::FkConstraint->$method(
fk_constraint_name => $fk_id,
table_name => $table_name,
r_table_name => $r_table_name,
data_source => $self->_my_data_source_id,
last_object_revision => '-',
);
unless ($fk) {
die "failed to generate an implied foreign key constraint for $table_name => $r_table_name!"
. UR::DataSource::RDBMS::FkConstraint->error_message;
}
push @defined, $fk;
for (my $n = 0; $n < @$column_names; $n++) {
my $column_name = $column_names->[$n];
my $r_column_name = $r_column_names->[$n];
my %fkcol_params = ( fk_constraint_name => $fk_id,
table_name => $table_name,
column_name => $column_name,
r_table_name => $r_table_name,
r_column_name => $r_column_name,
data_source => $self->_my_data_source_id,
);
my $fkcol = UR::DataSource::RDBMS::FkConstraintColumn->get(%fkcol_params);
unless ($fkcol) {
$fkcol = UR::DataSource::RDBMS::FkConstraintColumn->$method(%fkcol_params);
}
unless ($fkcol) {
die "failed to generate an implied foreign key constraint for $table_name => $r_table_name!"
. UR::DataSource::RDBMS::FkConstraint->error_message;
}
push @defined, $fkcol;
}
}
# handle missing meta datasource on the fly...
if (@defined) {
my $ns = $class_meta->namespace;
my $exists = UR::Object::Type->get($ns . "::DataSource::Meta");
unless ($exists) {
UR::DataSource::Meta->generate_for_namespace($ns);
}
}
unless ($temp) {
my @ddl = $self->_resolve_ddl_for_table($table);
$t = $UR::Context::current->now;
if (@ddl) {
my $dbh = $table->data_source->get_default_handle;
for my $ddl (@ddl) {
$dbh->do($ddl) or Carp::confess("Failed to modify the database schema!: $ddl\n" . $dbh->errstr);
for my $o ($table, $table->columns) {
$o->last_object_revision($t);
}
}
}
}
return @defined;
}
# override in architecture-oriented subclasses
sub object_to_db_type {
my ($self, $object_type) = @_;
my $db_type = $object_type;
# ...
return $db_type;
}
# override in architecture-oriented subclasses
sub db_to_object_type {
my ($self, $db_type) = @_;
my $object_type = $db_type;
# ...
return $object_type;
}
# FIXME - shouldn't this be a property of the class instead of a method?
sub does_support_joins { 1 }
sub get_class_meta_for_table {
my $self = shift;
my $table = shift;
my $table_name = $table->table_name;
return $self->get_class_meta_for_table_name($table_name);
}
sub get_class_meta_for_table_name {
my($self,$table_name) = @_;
# There is an unique constraint on classes, but only those which use
# tables in an RDBMS, which dicates that there can be only two for
# a given table in a given data source: one for the ghost and one
# for the regular entity. We can't just fix this with a unique constraint
# since classes with a null data source would be lost in some queries.
my @class_meta =
grep { not $_->class_name->isa("UR::Object::Ghost") }
UR::Object::Type->get(
table_name => $table_name,
data_source => $self->class,
);
unless (@class_meta) {
# This will load every class in the namespace on the first execution :(
##$DB::single = 1;
@class_meta =
grep { not $_->class_name->isa("UR::Object::Ghost") }
UR::Object::Type->get(
table_name => $table_name,
data_source => $self->class,
);
}
$self->context_return(@class_meta);
}
sub dbi_data_source_name {
my $self = shift->_singleton_object;
my $driver = $self->driver;
my $server = $self->server;
unless ($driver) {
Carp::confess("Cannot resolve a dbi_data_source_name with an undefined driver()");
}
unless ($server) {
Carp::confess("Cannot resolve a dbi_data_source_name with an undefined server()");
}
return 'dbi:' . $driver . ':' . $server;
}
*get_default_dbh = \&get_default_handle;
sub get_default_handle {
my $self = shift->_singleton_object;
my $dbh = $self->SUPER::get_default_handle;
unless ($dbh && $dbh->{Active}) {
$self->__invalidate_get_default_handle__;
$dbh = $self->create_default_handle();
}
return $dbh;
}
sub get_for_dbh {
my $class = shift;
my $dbh = shift;
my $ds_name = $dbh->{"private_UR::DataSource::RDBMS_name"};
return unless($ds_name);
my $ds = UR::DataSource->get($ds_name);
return $ds;
}
sub has_changes_in_base_context {
shift->has_default_handle;
# TODO: actually check, as this is fairly conservative
# If used for switching contexts, we'd need to safely rollback any transactions first.
}
sub _dbi_connect_args {
my $self = shift;
my @connection;
$connection[0] = $self->dbi_data_source_name;
$connection[1] = $self->login;
$connection[2] = $self->auth;
$connection[3] = { AutoCommit => 0, RaiseError => 0 };
return @connection;
}
sub get_connection_debug_info {
my $self = shift;
my $handle_class = $self->default_handle_class;
my @debug_info = (
"DBI Data Source Name: ", $self->dbi_data_source_name, "\n",
"DBI Login: ", $self->login || '' , "\n",
"DBI Version: ", $DBI::VERSION, "\n",
"DBI Error: ", $handle_class->errstr || '(no error)', "\n",
);
return @debug_info;
}
sub default_handle_class { 'UR::DBI' };
sub create_dbh { shift->create_default_handle_wrapper }
sub create_default_handle {
my $self = shift;
if (! ref($self) and $self->isa('UR::Singleton')) {
$self = $self->_singleton_object;
}
# get connection information
my @connection = $self->_dbi_connect_args();
# connect
my $handle_class = $self->default_handle_class;
my $dbh = $handle_class->connect(@connection);
unless ($dbh) {
my $errstr;
{ no strict 'refs';
$errstr = ${"${handle_class}::errstr"};
};
my @confession = (
"Failed to connect to the database: $errstr\n",
$self->get_connection_debug_info(),
);
$self->__signal_observers__('connect_failed', 'connect', \@connection, $errstr);
Carp::confess(@confession);
}
# used for reverse lookups
$dbh->{'private_UR::DataSource::RDBMS_name'} = $self->class;
# store the handle in a hash, since it's not a UR::Object
my $all_dbh_hashref = $self->_all_dbh_hashref;
unless ($all_dbh_hashref) {
$all_dbh_hashref = {};
$self->_all_dbh_hashref($all_dbh_hashref);
}
$all_dbh_hashref->{$dbh} = $dbh;
Scalar::Util::weaken($all_dbh_hashref->{$dbh});
$self->is_connected(1);
return $dbh;
}
# The default is to ignore no tables, but derived classes
# will probably override this
sub _ignore_table {
0;
}
sub _table_name_to_use_for_metadata_objects {
my($self, $schema, $table_name) = @_;
return $self->owner
? $table_name
: join('.', $schema, $table_name);
}
sub _get_table_names_from_data_dictionary {
my $self = shift->_singleton_object;
if (@_) {
Carp::confess("get_tables does not currently take filters! FIXME.");
}
my $dbh = $self->get_default_handle;
my $owner = $self->owner || '%';
# FIXME This will fix the immediate problem of getting classes to be created out of
# views. We still need to somehow mark the resulting class as read-only
my $sth = $self->get_table_details_from_data_dictionary('%', $owner, '%', 'TABLE,VIEW');
my @names;
while (my $row = $sth->fetchrow_hashref) {
my $table_name = $self->_table_name_to_use_for_metadata_objects(@$row{'TABLE_SCHEM','TABLE_NAME'});
$table_name =~ s/"|'//g; # Postgres puts quotes around entities that look like keywords
next if $self->_ignore_table($table_name);
push @names, $table_name;
}
return @names;
}
# A wrapper for DBI's table_info() since the DBD implementations of them
# aren't always exactly what we need in other places in the system. Other
# subclasses can override it to get custom behavior
sub get_table_details_from_data_dictionary {
return shift->_get_whatever_details_from_data_dictionary('table_info',@_);
}
sub _get_whatever_details_from_data_dictionary {
my $self = shift;
my $method = shift;
my $dbh = $self->get_default_handle();
return unless $dbh;
return $dbh->$method(@_);
}
sub get_column_details_from_data_dictionary {
return shift->_get_whatever_details_from_data_dictionary('column_info',@_);
}
sub get_foreign_key_details_from_data_dictionary {
return shift->_get_whatever_details_from_data_dictionary('foreign_key_info',@_);
}
sub get_primary_key_details_from_data_dictionary {
return shift->_get_whatever_details_from_data_dictionary('primary_key_info',@_);
}
sub get_table_names {
map { $_->table_name } shift->get_tables(@_);
}
sub get_tables {
my $self = shift;
#my $class = shift->_singleton_class_name;
#return UR::DataSource::RDBMS::Table->get(data_source_id => $class);
my $ds_id;
if (ref $self) {
if ($self->can('id')) {
$ds_id = $self->id;
} else {
$ds_id = ref $self;
}
} else {
$ds_id = $self;
}
return UR::DataSource::RDBMS::Table->get(data_source => $ds_id);
}
sub get_nullable_foreign_key_columns_for_table {
my $self = shift;
my $table = shift;
my @nullable_fk_columns;
my @fk = $table->fk_constraints;
for my $fk (@fk){
my @fk_columns = UR::DataSource::RDBMS::FkConstraintColumn->get(
fk_constraint_name => $fk->fk_constraint_name,
data_source => $self->_my_data_source_id);
for my $fk_col (@fk_columns){
my $column_obj = UR::DataSource::RDBMS::TableColumn->get(data_source => $self->_my_data_source_id,
table_name => $fk_col->table_name,
column_name=> $fk_col->column_name);
unless ($column_obj) {
Carp::croak("Can't find TableColumn metadata object for table name ".$fk_col->table_name." column ".$fk_col->column_name." while processing foreign key constraint named ".$fk->fk_constraint_name);
}
if ($column_obj->nullable and $column_obj->nullable ne 'N'){
my $col = $column_obj->column_name;
push @nullable_fk_columns, $col;
}
}
}
return @nullable_fk_columns;
}
sub get_non_primary_key_nullable_foreign_key_columns_for_table {
my $self = shift;
my $table = shift;
my @nullable_fk_columns = $self->get_nullable_foreign_key_columns_for_table($table);
my %pk_columns = map { $_->column_name => 1} $table->primary_key_constraint_columns;
my @non_pk_nullable_fk_columns;
for my $fk_column (@nullable_fk_columns){
push @non_pk_nullable_fk_columns, $fk_column unless grep { $fk_column eq $_} keys %pk_columns;
}
return @non_pk_nullable_fk_columns;
}
# TODO: make "env" an optional characteristic of a class attribute
# for all of the places we do this crap...
sub access_level {
my $self = shift;
my $env = $self->_method2env("access_level");
if (@_) {
if ($self->has_default_handle) {
Carp::confess("Cannot change the db access level for $self while connected!");
}
$ENV{$env} = lc(shift);
}
else {
$ENV{$env} ||= "ro";
}
return $ENV{$env};
}
sub _method2env {
my $class = shift;
my $method = shift;
unless ($method =~ /^(.*)::([^\:]+)$/) {
$class = ref($class) if ref($class);
$method = $class . "::" . $method;
}
$method =~ s/::/__/g;
return $method;
}
sub resolve_class_name_for_table_name {
my $self = shift->_singleton_object;
my $qualified_table_name = shift;
my $relation_type = shift; # Should be 'TABLE' or 'VIEW'
my(undef, $table_name) = $self->_resolve_owner_and_table_from_table_name($qualified_table_name);
# When a table_name conflicts with a reserved word, it ends in an underscore.
$table_name =~ s/_$//;
if ($self->camel_case_table_names) {
$table_name = UR::Value::Text->get($table_name)->to_lemac("_");
}
my $namespace = $self->get_namespace;
my $vocabulary = $namespace->get_vocabulary;
my @words;
$vocabulary = 'UR::Vocabulary' unless eval { $vocabulary->__meta__ };
if ($vocabulary) {
@words =
map { $vocabulary->convert_to_title_case($_) }
map { $vocabulary->plural_to_singular($_) }
map { lc($_) }
split("_",$table_name);
} else {
@words =
map { ucfirst(lc($_)) }
split("_",$table_name);
}
if ($self->can('_resolve_class_name_for_table_name_fixups')) {
@words = $self->_resolve_class_name_for_table_name_fixups(@words);
}
my $class_name;
my $addl;
if ($relation_type && $relation_type =~ m/view/i) {
$addl = 'View::';
} else {
# Should just be for tables, temp tables, etc
$addl = '';
}
$class_name = $namespace . "::" . $addl . join("",@words);
if (substr($class_name, -6) eq '::Type') {
# Don't overwrite class metadata objects for a table called 'type'
$class_name .= 'Table';
$self->warning_message("Class for table $table_name will be $class_name");
}
return $class_name;
}
sub resolve_type_name_for_table_name {
my $self = shift->_singleton_object;
my $table_name = shift;
if ($self->camel_case_table_names) {
$table_name = UR::Value::Text->get($table_name)->to_lemac("_");
}
my $namespace = $self->get_namespace;
my $vocabulary = $namespace->get_vocabulary;
$vocabulary = 'UR::Vocabulary' unless eval { $vocabulary->__meta__ };
my $vocab_obj = eval { $vocabulary->__meta__ };
my @words =
(
(
map { $vocabulary->plural_to_singular($_) }
map { lc($_) }
split("_",$table_name)
)
);
my $type_name = join(" ",@words);
return $type_name;
}
sub resolve_property_name_for_column_name {
my $self = shift->_singleton_object;
my $column_name = shift;
if ($self->camel_case_column_names) {
$column_name = UR::Value::Text->get($column_name)->to_lemac("_");
}
my @words =
map { lc($_) }
split("_",$column_name);
my $type_name = join("_",@words);
return $type_name;
}
sub _get_or_create_table_meta {
my $self = shift;
my ($data_source,
$qualified_table_name,
$db_table_name,
$creation_method,
$table_data,
$revision_time) = @_;
my $data_source_id = $self->_my_data_source_id;
my $table_object = UR::DataSource::RDBMS::Table->get(data_source => $data_source_id,
table_name => $qualified_table_name);
if ($table_object) {
# Already exists, update the existing entry
# Instead of deleting and recreating the table object (the old way),
# modify its attributes in-place. The name can't change but all the other
# stuff might.
$table_object->table_type($table_data->{TABLE_TYPE});
$table_object->data_source($data_source->class);
$table_object->remarks($table_data->{REMARKS});
$table_object->last_object_revision($revision_time) if ($table_object->__changes__());
} else {
# Create a brand new one from scratch
$table_object = UR::DataSource::RDBMS::Table->$creation_method(
table_name => $qualified_table_name,
table_type => $table_data->{TABLE_TYPE},
data_source => $data_source_id,
remarks => $table_data->{REMARKS},
last_object_revision => $revision_time,
);
unless ($table_object) {
Carp::confess("Failed to $creation_method table object for $db_table_name");
}
}
return $table_object;
}
sub refresh_database_metadata_for_table_name {
my ($self,$qualified_table_name, $creation_method) = @_;
$creation_method ||= 'create';
# this must be on or before the actual data dictionary queries
my $revision_time = $UR::Context::current->now();
# The class definition can specify a table name as . to override the
# data source's default schema/owner.
my($ds_owner,$db_table_name) = $self->_resolve_owner_and_table_from_table_name($qualified_table_name);
my $data_source_id = $self->_my_data_source_id;
my $table_object = $self->_get_or_create_table_metadata_for_refresh($ds_owner, $db_table_name, $qualified_table_name, $creation_method, $revision_time);
return unless $table_object;
# We'll count a table object as changed even if any of the columns,
# FKs, etc # were changed
my $data_was_changed_for_this_table = $self->_update_column_metadata_for_refresh($ds_owner, $db_table_name, $qualified_table_name, $creation_method, $revision_time, $table_object);
if ($self->_update_foreign_key_metadata_for_refresh($ds_owner, $db_table_name, $qualified_table_name, $creation_method, $revision_time, $table_object)) {
$data_was_changed_for_this_table = 1;
}
if ($self->_update_primary_key_metadata_for_refresh($ds_owner, $db_table_name, $qualified_table_name, $creation_method, $revision_time, $table_object)) {
$data_was_changed_for_this_table = 1;
}
if ($self->_update_unique_constraint_metadata_for_refresh($ds_owner, $db_table_name, $qualified_table_name, $creation_method, $revision_time, $table_object)) {
$data_was_changed_for_this_table = 1;
}
$table_object->last_object_revision($revision_time) if ($data_was_changed_for_this_table);
# Determine the ER type.
# We have 'validation item', 'entity', and 'bridge'
my $column_count = scalar($table_object->column_names) || 0;
my $pk_column_count = scalar($table_object->primary_key_constraint_column_names) || 0;
my $constraint_count = scalar($table_object->fk_constraint_names) || 0;
if ($column_count == 1 and $pk_column_count == 1) {
$table_object->er_type('validation item');
}
else {
if ($constraint_count == $column_count) {
$table_object->er_type('bridge');
}
else {
$table_object->er_type('entity');
}
}
return $table_object;
}
sub _get_or_create_table_metadata_for_refresh {
my($self, $ds_owner, $db_table_name, $qualified_table_name, $creation_method, $revision_time) = @_;
my $table_sth = $self->get_table_details_from_data_dictionary('%', $ds_owner, $db_table_name, "TABLE,VIEW");
my $table_data = $table_sth->fetchrow_hashref();
unless ($table_data && %$table_data) {
#$self->error_message("No data for table $table_name in data source $self.");
return;
}
my $table_object = $self->_get_or_create_table_meta(
$self,
$qualified_table_name,
$db_table_name,
$creation_method,
$table_data,
$revision_time);
return $table_object;
}
sub _update_column_metadata_for_refresh {
my($self, $ds_owner, $db_table_name, $qualified_table_name, $creation_method, $revision_time, $table_object) = @_;
my $data_was_changed_for_this_table = 0;
my $data_source_id = $self->_my_data_source_id;
# mysql databases seem to require you to actually put in the database name in the first arg
my $db_name = ($self->can('db_name')) ? $self->db_name : '%';
my $column_sth = $self->get_column_details_from_data_dictionary($db_name, $ds_owner, $db_table_name, '%');
unless ($column_sth) {
$self->error_message("Error getting column data for table $db_table_name in data source $self.");
return;
}
my $all_column_data = $column_sth->fetchall_arrayref({});
unless (@$all_column_data) {
$self->error_message("No column data for table $db_table_name in data source $data_source_id");
return;
}
my %columns_to_delete = map {$_->column_name, $_}
UR::DataSource::RDBMS::TableColumn->get(
table_name => $qualified_table_name,
data_source => $data_source_id);
for my $column_data (@$all_column_data) {
#my $id = $table_name . '.' . $column_data->{COLUMN_NAME}
$column_data->{'COLUMN_NAME'} =~ s/"|'//g; # Postgres puts quotes around things that look like keywords
delete $columns_to_delete{$column_data->{'COLUMN_NAME'}};
my $column_obj = UR::DataSource::RDBMS::TableColumn->get(table_name => $qualified_table_name,
data_source => $data_source_id,
column_name => $column_data->{'COLUMN_NAME'});
if ($column_obj) {
# Already exists, change the attributes
$column_obj->data_source($table_object->{data_source});
$column_obj->data_type($column_data->{TYPE_NAME});
$column_obj->nullable(substr($column_data->{IS_NULLABLE}, 0, 1));
$column_obj->data_length($column_data->{COLUMN_SIZE});
$column_obj->remarks($column_data->{REMARKS});
if ($column_obj->__changes__()) {
$column_obj->last_object_revision($revision_time);
$data_was_changed_for_this_table = 1;
}
} else {
# It's new, create it from scratch
$column_obj = UR::DataSource::RDBMS::TableColumn->$creation_method(
column_name => $column_data->{COLUMN_NAME},
table_name => $qualified_table_name,
data_source => $table_object->{data_source},
data_type => $column_data->{TYPE_NAME},
nullable => substr($column_data->{IS_NULLABLE}, 0, 1),
data_length => $column_data->{COLUMN_SIZE},
remarks => $column_data->{REMARKS},
last_object_revision => $revision_time,
);
$data_was_changed_for_this_table = 1;
}
unless ($column_obj) {
Carp::confess("Failed to create a column ".$column_data->{'COLUMN_NAME'}." for table $db_table_name");
}
}
for my $to_delete (values %columns_to_delete) {
#$self->status_message("Detected column " . $to_delete->column_name . " has gone away.");
$to_delete->delete;
$data_was_changed_for_this_table = 1;
}
return $data_was_changed_for_this_table;
}
sub _update_foreign_key_metadata_for_refresh {
my($self, $ds_owner, $db_table_name, $qualified_table_name, $creation_method, $revision_time, $table_object) = @_;
my $data_was_changed_for_this_table = 0;
my $data_source_id = $self->_my_data_source_id;
# Make a note of what FKs exist in the Meta DB involving this table
my @fks_in_meta_db = UR::DataSource::RDBMS::FkConstraint->get(data_source => $data_source_id,
table_name => $qualified_table_name);
push @fks_in_meta_db, UR::DataSource::RDBMS::FkConstraint->get(data_source => $data_source_id,
r_table_name => $qualified_table_name);
my %fks_in_meta_db_by_fingerprint;
foreach my $fk ( @fks_in_meta_db ) {
my $fingerprint = $self->_make_foreign_key_fingerprint($fk);
$fks_in_meta_db_by_fingerprint{$fingerprint} = $fk;
}
# constraints on this table against columns in other tables
my $fk_sth = $self->get_foreign_key_details_from_data_dictionary('', $ds_owner, $db_table_name, '', '', '');
my %fk; # hold the fk constraints that this invocation of foreign_key_info created
my @constraints;
my %fks_in_real_db;
if ($fk_sth) {
while (my $data = $fk_sth->fetchrow_hashref()) {
foreach ( qw( FK_NAME FK_TABLE_NAME FKTABLE_NAME UK_TABLE_NAME PKTABLE_NAME FK_COLUMN_NAME FKCOLUMN_NAME UK_COLUMN_NAME PKCOLUMN_NAME ) ) {
next unless defined($data->{$_});
# Postgres puts quotes around things that look like keywords
$data->{$_} =~ s/"|'//g;
}
my $constraint_name = $data->{'FK_NAME'};
my $fk_table_name = $self->_table_name_to_use_for_metadata_objects(
$data->{FK_TABLE_SCHEM} || $data->{FKTABLE_SCHEM},
$data->{'FK_TABLE_NAME'} || $data->{'FKTABLE_NAME'});
my $r_table_name = $self->_table_name_to_use_for_metadata_objects(
$data->{UK_TABLE_SCHEM} || $data->{PKTABLE_SCHEM},
$data->{'UK_TABLE_NAME'} || $data->{'PKTABLE_NAME'});
my $fk_column_name = $data->{'FK_COLUMN_NAME'}
|| $data->{'FKCOLUMN_NAME'};
my $r_column_name = $data->{'UK_COLUMN_NAME'}
|| $data->{'PKCOLUMN_NAME'};
# MySQL returns primary key info with foreign_key_info()!?
# They show up here with no $r_table_name or $r_column_name
next unless ($r_table_name and $r_column_name);
my $fk = UR::DataSource::RDBMS::FkConstraint->get(fk_constraint_name => $constraint_name,
table_name => $fk_table_name,
data_source => $data_source_id,
r_table_name => $r_table_name
);
unless ($fk) {
$fk = UR::DataSource::RDBMS::FkConstraint->$creation_method(
fk_constraint_name => $constraint_name,
table_name => $fk_table_name,
r_table_name => $r_table_name,
data_source => $table_object->{data_source},
last_object_revision => $revision_time,
);
$fk{$fk->id} = $fk;
$data_was_changed_for_this_table = 1;
}
if ($fk{$fk->id}) {
my %fkcol_params = ( fk_constraint_name => $constraint_name,
table_name => $fk_table_name,
column_name => $fk_column_name,
r_table_name => $r_table_name,
r_column_name => $r_column_name,
data_source => $table_object->{data_source},
);
my $fkcol = UR::DataSource::RDBMS::FkConstraintColumn->get(%fkcol_params);
unless ($fkcol) {
$fkcol = UR::DataSource::RDBMS::FkConstraintColumn->$creation_method(%fkcol_params);
}
}
my $fingerprint = $self->_make_foreign_key_fingerprint($fk);
$fks_in_real_db{$fingerprint} = $fk;
push @constraints, $fk;
}
}
# get foreign_key_info the other way
# constraints on other tables against columns in this table
my $fk_reverse_sth = $self->get_foreign_key_details_from_data_dictionary('', '', '', '', $ds_owner, $db_table_name);
%fk = (); # resetting this prevents data_source referencing
# tables from fouling up their fk objects
if ($fk_reverse_sth) {
while (my $data = $fk_reverse_sth->fetchrow_hashref()) {
foreach ( qw( FK_NAME FK_TABLE_NAME FKTABLE_NAME UK_TABLE_NAME PKTABLE_NAME FK_COLUMN_NAME FKCOLUMN_NAME UK_COLUMN_NAME PKCOLUMN_NAME PKTABLE_SCHEM FKTABLE_SCHEM UK_TABLE_SCHEM FK_TABLE_SCHEM) ) {
next unless defined($data->{$_});
# Postgres puts quotes around things that look like keywords
$data->{$_} =~ s/"|'//g;
}
my $constraint_name = $data->{'FK_NAME'} || '';
my $fk_table_name = $self->_table_name_to_use_for_metadata_objects(
$data->{FK_TABLE_SCHEM} || $data->{FKTABLE_SCHEM},
$data->{'FK_TABLE_NAME'} || $data->{'FKTABLE_NAME'});
my $r_table_name = $self->_table_name_to_use_for_metadata_objects(
$data->{UK_TABLE_SCHEM} || $data->{PKTABLE_SCHEM},
$data->{'UK_TABLE_NAME'} || $data->{'PKTABLE_NAME'});
my $fk_column_name = $data->{'FK_COLUMN_NAME'}
|| $data->{'FKCOLUMN_NAME'};
my $r_column_name = $data->{'UK_COLUMN_NAME'}
|| $data->{'PKCOLUMN_NAME'};
# MySQL returns primary key info with foreign_key_info()?!
# They show up here with no $r_table_name or $r_column_name
next unless ($r_table_name and $r_column_name);
my $fk = UR::DataSource::RDBMS::FkConstraint->get(fk_constraint_name => $constraint_name,
table_name => $fk_table_name,
r_table_name => $r_table_name,
data_source => $table_object->{'data_source'},
);
unless ($fk) {
$fk = UR::DataSource::RDBMS::FkConstraint->$creation_method(
fk_constraint_name => $constraint_name,
table_name => $fk_table_name,
r_table_name => $r_table_name,
data_source => $table_object->{data_source},
last_object_revision => $revision_time,
);
unless ($fk) {
##$DB::single = 1;
1;
}
$fk{$fk->fk_constraint_name} = $fk;
$data_was_changed_for_this_table = 1;
}
if ($fk{$fk->fk_constraint_name}) {
my %fkcol_params = ( fk_constraint_name => $constraint_name,
table_name => $fk_table_name,
column_name => $fk_column_name,
r_table_name => $r_table_name,
r_column_name => $r_column_name,
data_source => $table_object->{data_source},
);
unless ( UR::DataSource::RDBMS::FkConstraintColumn->get(%fkcol_params) ) {
UR::DataSource::RDBMS::FkConstraintColumn->$creation_method(%fkcol_params);
}
}
my $fingerprint = $self->_make_foreign_key_fingerprint($fk);
$fks_in_real_db{$fingerprint} = $fk;
push @constraints, $fk;
}
}
# Find FKs still in the Meta db that don't exist in the real database anymore
foreach my $fingerprint ( keys %fks_in_meta_db_by_fingerprint ) {
unless ($fks_in_real_db{$fingerprint}) {
my $fk = $fks_in_meta_db_by_fingerprint{$fingerprint};
my @fk_cols = $fk->get_related_column_objects();
$_->delete foreach @fk_cols;
$fk->delete;
}
}
return $data_was_changed_for_this_table;
}
sub _update_primary_key_metadata_for_refresh {
my($self, $ds_owner, $db_table_name, $qualified_table_name, $creation_method, $revision_time, $table_object) = @_;
my $data_was_changed_for_this_table = 0;
my $data_source_id = $self->_my_data_source_id;
my $pk_sth = $self->get_primary_key_details_from_data_dictionary(undef, $ds_owner, $db_table_name);
if ($pk_sth) {
my @new_pk;
while (my $data = $pk_sth->fetchrow_hashref()) {
$data->{'COLUMN_NAME'} =~ s/"|'//g; # Postgres puts quotes around things that look like keywords
my $pk = UR::DataSource::RDBMS::PkConstraintColumn->get(
table_name => $qualified_table_name,
data_source => $data_source_id,
column_name => $data->{'COLUMN_NAME'},
);
if ($pk) {
# Since the rank/order is pretty much all that might change, we
# just delete and re-create these.
# It's a no-op at save time if there are no changes.
$pk->delete;
}
push @new_pk, [
table_name => $qualified_table_name,
data_source => $data_source_id,
column_name => $data->{'COLUMN_NAME'},
rank => $data->{'KEY_SEQ'} || $data->{'ORDINAL_POSITION'},
];
}
for my $data (@new_pk) {
my $pk = UR::DataSource::RDBMS::PkConstraintColumn->$creation_method(@$data);
unless ($pk) {
$self->error_message("Failed to create primary key @$data");
return;
}
}
}
return $data_was_changed_for_this_table;
}
sub _update_unique_constraint_metadata_for_refresh {
my($self, $ds_owner, $db_table_name, $qualified_table_name, $creation_method, $revision_time, $table_object) = @_;
my $data_was_changed_for_this_table = 0;
my $data_source_id = $self->_my_data_source_id;
if (my $uc = $self->get_unique_index_details_from_data_dictionary($ds_owner, $db_table_name)) {
my %uc = %$uc; # make a copy we can manipulate in case $uc is shared or read-only
# check for redundant unique constraints
# there may be both an index and a constraint
for my $uc_name_1 ( keys %uc ) {
my $uc_columns_1 = $uc{$uc_name_1}
or next;
my $uc_columns_1_serial = join ',', sort @$uc_columns_1;
for my $uc_name_2 ( keys %uc ) {
next if ( $uc_name_2 eq $uc_name_1 );
my $uc_columns_2 = $uc{$uc_name_2}
or next;
my $uc_columns_2_serial = join ',', sort @$uc_columns_2;
if ( $uc_columns_2_serial eq $uc_columns_1_serial ) {
delete $uc{$uc_name_1};
}
}
}
# compare primary key constraints to unique constraints
my $pk_columns_serial =
join(',',
sort map { $_->column_name }
UR::DataSource::RDBMS::PkConstraintColumn->get(
data_source => $data_source_id,
table_name => $qualified_table_name,
)
);
for my $uc_name ( keys %uc ) {
# see if primary key constraint has the same name as
# any unique constraints
# FIXME - disabling this for now, the Meta DB dosen't track PK constraint names
# Isn't it just as goot to check the involved columns?
#if ( $table_object->primary_key_constraint_name eq $uc_name ) {
# delete $uc{$uc_name};
# next;
#}
# see if any unique constraints cover the exact same column(s) as
# the primary key column(s)
my $uc_columns_serial = join ',', sort @{ $uc{$uc_name} };
if ( $pk_columns_serial eq $uc_columns_serial ) {
delete $uc{$uc_name};
}
}
# Create new UniqueConstraintColumn objects for the columns that don't exist, and delete the
# objects if they don't apply anymore
foreach my $uc_name ( keys %uc ) {
my %constraint_objs =
map { $_->column_name => $_ }
UR::DataSource::RDBMS::UniqueConstraintColumn->get(
data_source => $data_source_id,
table_name => $qualified_table_name,
constraint_name => $uc_name,
);
foreach my $col_name ( @{$uc{$uc_name}} ) {
if ($constraint_objs{$col_name} ) {
delete $constraint_objs{$col_name};
} else {
my $uc = UR::DataSource::RDBMS::UniqueConstraintColumn->$creation_method(
data_source => $data_source_id,
table_name => $qualified_table_name,
constraint_name => $uc_name,
column_name => $col_name,
);
1;
}
}
foreach my $obj ( values %constraint_objs ) {
$obj->delete();
}
}
}
return $data_was_changed_for_this_table;
}
sub _make_foreign_key_fingerprint {
my($self,$fk) = @_;
my @column_objects_with_name = map { [ $_->column_name, $_ ] }
$fk->get_related_column_objects();
my @fk_cols = map { $_->[1] }
sort {$a->[0] cmp $b->[0]}
@column_objects_with_name;
my $fingerprint =
join(':',
$fk->table_name,
$fk->r_table_name,
map { $_->column_name, $_->r_column_name } @fk_cols
);
return $fingerprint;
}
sub _resolve_owner_and_table_from_table_name {
my($self, $table_name) = @_;
return (undef, undef) unless $table_name;
if ($table_name =~ m/(\w+)\.(\w+)/) {
return($1,$2);
}
else {
return($self->owner, $table_name);
}
}
sub _resolve_table_and_column_from_column_name {
my($self, $column_name) = @_;
if ($column_name =~ m/(\w+)\.(\w+)$/) {
return ($1, $2);
} else {
return (undef, $column_name);
}
}
# Derived classes should define a method to return a ref to an array of hash refs
# describing all the bitmap indicies in the DB. Each hash ref should contain
# these keys: table_name, column_name, index_name
# If the DB dosen't support bitmap indicies, it should return an empty listref
# This is used by the part that writes class defs based on the DB schema, and
# possibly by sync_database()
# Implemented methods should take one optional argument: a table name
#
# FIXME The API for bitmap_index and unique_index methods here aren't the same as
# the other data_dictionary methods. These two return hashrefs of massaged
# data while the others return DBI statement handles.
sub get_bitmap_index_details_from_data_dictionary {
my $class = shift;
Carp::confess("Class $class didn't define its own bitmap_index_info() method");
}
# Derived classes should define a method to return a ref to a hash keyed by constraint
# names. Each value holds a listref of hashrefs containing these keys:
# CONSTRAINT_NAME and COLUMN_NAME
sub get_unique_index_details_from_data_dictionary {
my $class = shift;
Carp::confess("Class $class didn't define its own unique_index_info() method");
}
sub _resolve_table_name_for_class_name {
my($self, $class_name) = @_;
for my $parent_class_name ($class_name, $class_name->inheritance) {
my $parent_class = $parent_class_name->__meta__; # UR::Object::Type->get(class_name => $parent_class_name);
next unless $parent_class;
if (my $table_name = $parent_class->table_name) {
return $table_name;
}
}
return;
}
# For when there's no metaDB info for a class' table, it walks up the
# ancestry of the class, and uses the ID properties to get the column
# names, and assummes they must be the table primary keys.
#
# From there, it guesses the sequence name
sub _resolve_sequence_name_from_class_id_properties {
my($self, $class_name) = @_;
my $class_meta = $class_name->__meta__;
for my $meta ($class_meta, $class_meta->ancestry_class_metas) {
next unless $meta->table_name;
my @primary_keys = grep { $_ } # Only interested in the properties with columns defined
map { $_->column_name }
$meta->direct_id_property_metas;
if (@primary_keys > 1) {
Carp::croak("Tables with multiple primary keys (i.e. " .
$meta->table_name . ": " .
join(',',@primary_keys) .
") cannot have a surrogate key created from a sequence.");
}
elsif (@primary_keys == 1) {
my $sequence = $self->_get_sequence_name_for_table_and_column($meta->table_name, $primary_keys[0]);
return $sequence if $sequence;
}
}
}
sub _resolve_sequence_name_for_class_name {
my($self, $class_name) = @_;
my $table_name = $self->_resolve_table_name_for_class_name($class_name);
unless ($table_name) {
Carp::croak("Could not determine a table name for class $class_name");
}
my $table_meta = UR::DataSource::RDBMS::Table->get(
table_name => $table_name,
data_source => $self->_my_data_source_id);
my $sequence;
if ($table_meta) {
my @primary_keys = $table_meta->primary_key_constraint_column_names;
if (@primary_keys == 0) {
Carp::croak("No primary keys found for table " . $table_name . "\n");
}
$sequence = $self->_get_sequence_name_for_table_and_column($table_name, $primary_keys[0]);
} else {
# No metaDB info... try and make a guess based on the class' ID properties
$sequence = $self->_resolve_sequence_name_from_class_id_properties($class_name);
}
return $sequence;
}
our %sequence_for_class_name;
sub autogenerate_new_object_id_for_class_name_and_rule {
# The sequences in the database are named by a naming convention which allows us to connect them to the table
# whose surrogate keys they fill. Look up the sequence and get a unique value from it for the object.
# If and when we save, we should not get any integrity constraint violation errors.
my $self = shift;
my $class_name = shift;
my $rule = shift; # Not used for the moment...
if ($self->use_dummy_autogenerated_ids) {
return $self->next_dummy_autogenerated_id;
}
my $sequence = $sequence_for_class_name{$class_name} || $class_name->__meta__->id_generator;
my $new_id = eval {
# FIXME Child classes really should use the same sequence generator as its parent
# if it doesn't specify its own.
# It'll be hard to distinguish the case of a class meta not explicitly mentioning its
# sequence name, but there's a sequence generator in the schema for it (the current
# mechanism), and when we should defer to the parent's sequence...
unless ($sequence) {
$sequence = $self->_resolve_sequence_name_for_class_name($class_name);
if (!$sequence) {
Carp::croak("No identity generator found for class " . $class_name . "\n");
}
$sequence_for_class_name{$class_name} = $sequence;
}
$self->__signal_observers__('sequence_nextval', $sequence);
$self->_get_next_value_from_sequence($sequence);
};
unless (defined $new_id) {
my $dbh = $self->get_default_handle;
$self->__signal_observers__('sequence_nextval_failed', '', $sequence, $dbh->errstr);
no warnings 'uninitialized';
Carp::croak("Can't get next value for sequence $sequence. Exception: $@. DBI error: ".$dbh->errstr);
}
return $new_id;
}
sub _get_sequence_name_for_table_and_column {
my($self,$table_name,$column_name) = @_;
# The default is to take the column name (should be a primary key from a table) and
# change the _ID at the end of the column name with _SEQ
# if column_name is all uppercase, make the sequence name end in upper case _SEQ
my $replacement = $column_name eq uc($column_name) ? '_SEQ' : '_seq';
$column_name =~ s/_ID/$replacement/i;
return $column_name;
}
sub resolve_order_by_clause {
my($self, $query_plan) = @_;
my $order_by_columns = $query_plan->order_by_column_list;
return '' unless (@$order_by_columns);
my $query_class_meta = $query_plan->class_name->__meta__;
my @order_by_parts = map {
my $order_by_property_meta = $query_plan->property_meta_for_column($_);
unless ($order_by_property_meta) {
Carp::croak("Cannot resolve property metadata for order-by column '$_' of class "
. $query_class_meta->class_name);
}
$self->_resolve_order_by_clause_for_column($_, $query_plan, $order_by_property_meta);
}
@$order_by_columns;
return 'order by ' . join(', ',@order_by_parts);
}
sub _resolve_order_by_clause_for_column {
my($self, $column_name, $query_plan) = @_;
return $query_plan->order_by_column_is_descending($column_name)
? $column_name . ' DESC'
: $column_name;
}
sub do_sql {
my $self = shift;
my $sql = shift;
my $dbh = $self->get_default_handle;
my $rv = $dbh->do($sql);
unless ($rv) {
$self->__signal_observers__('do_failed', 'do', $sql, $dbh->errstr);
Carp::croak("DBI do() failed: ".$dbh->errstr);
}
return $rv;
}
sub create_iterator_closure_for_rule {
my ($self, $rule) = @_;
my ($rule_template, @values) = $rule->template_and_values();
my $query_plan = $self->_resolve_query_plan($rule_template);
#
# the template has general class data
#
my $class_name = $query_plan->{class_name};
my @lob_column_names = @{ $query_plan->{lob_column_names} };
my @lob_column_positions = @{ $query_plan->{lob_column_positions} };
my $query_config = $query_plan->{query_config};
my $post_process_results_callback = $query_plan->{post_process_results_callback};
#
# the template has explicit template data
#
my $select_clause = $query_plan->{select_clause};
my $select_hint = $query_plan->{select_hint};
my $from_clause = $query_plan->{from_clause};
my $where_clause = $query_plan->{where_clause};
my $connect_by_clause = $query_plan->{connect_by_clause};
my $group_by_clause = $query_plan->{group_by_clause};
my $sql_params = $query_plan->{sql_params};
my $filter_specs = $query_plan->{filter_specs};
my @property_names_in_resultset_order = @{ $query_plan->{property_names_in_resultset_order} };
# TODO: we get 90% of the way to a full where clause in the template, but
# actually have to build it here since ther is no way to say "in (?)" and pass an arrayref :(
# It _is_ possible, however, to process all of the filter specs with a constant number of params.
# This would optimize the common case.
my @all_sql_params = @$sql_params;
for my $filter_spec (@$filter_specs) {
my ($expr_sql, $operator, $value_position) = @$filter_spec;
my $value = $values[$value_position];
my ($more_sql, @more_params) =
$self->_extend_sql_for_column_operator_and_value($expr_sql, $operator, $value);
$where_clause .= ($where_clause ? "\nand " : ($connect_by_clause ? "start with " : "where "));
if ($more_sql) {
$where_clause .= $more_sql;
push @all_sql_params, @more_params;
}
else {
# error
return;
}
}
# The full SQL statement for the template, besides the filter logic, is built here.
my $order_by_clause = $self->resolve_order_by_clause($query_plan);
my $sql = "\nselect ";
if ($select_hint) {
my $hint = '';
foreach (@$select_hint) {
$hint .= ' ' . $_;
}
$hint =~ s/\/\*\s?|\s?\*\///g; # remove embedded comment marks
$sql .= "/*$hint */ ";
}
$sql .= $select_clause;
$sql .= "\nfrom $from_clause";
$sql .= "\n$where_clause" if defined($where_clause) and length($where_clause);
$sql .= "\n$connect_by_clause" if $connect_by_clause;
$sql .= "\n$group_by_clause" if $group_by_clause;
$sql .= "\n$order_by_clause" if $order_by_clause;
$self->__signal_change__('query',$sql);
my $dbh = $self->get_default_handle;
my $sth = $dbh->prepare($sql,$query_plan->{query_config});
unless ($sth) {
$self->__signal_observers__('query_failed', 'prepare', $sql, $dbh->errstr);
$self->error_message("Failed to prepare SQL $sql\n" . $dbh->errstr . "\n");
Carp::confess($self->error_message);
}
unless ($sth->execute(@all_sql_params)) {
$self->__signal_observers__('query_failed', 'execute', $sql, $dbh->errstr);
$self->error_message("Failed to execute SQL $sql\n" . $sth->errstr . "\n" . Data::Dumper::Dumper(\@all_sql_params) . "\n");
Carp::confess($self->error_message);
}
die unless $sth; # FIXME - this has no effect, right?
# buffers for the iterator
my $next_db_row;
my $pending_db_object_data;
my $ur_test_fill_db = $self->alternate_db_dsn
&&
$self->_create_sub_for_copying_to_alternate_db(
$self->alternate_db_dsn,
$query_plan->{loading_templates}
);
my $iterator = sub {
unless ($sth) {
##$DB::single = 1;
return;
}
$next_db_row = $sth->fetchrow_arrayref;
#$self->__signal_change__('fetch',$next_db_row); # FIXME: commented out because it may make fetches too slow
unless ($next_db_row) {
$sth->finish;
$sth = undef;
return;
}
# this handles things like BLOBS, which have a special interface to get the 'real' data
if ($post_process_results_callback) {
$next_db_row = $post_process_results_callback->($next_db_row);
}
# this is used for automated re-testing against a private database
$ur_test_fill_db && $ur_test_fill_db->($next_db_row);
return $next_db_row;
}; # end of iterator closure
Sub::Name::subname('UR::DataSource::RDBMS::__datasource_iterator(closure)__', $iterator);
return $iterator;
}
sub _create_sub_for_copying_to_alternate_db {
my($self, $connect_string, $loading_templates) = @_;
my $ds_type = $self->ur_datasource_class_for_dbi_connect_string($connect_string);
my $dbh = $ds_type->_create_dbh_for_alternate_db($connect_string)
|| do {
Carp::carp("Cannot connect to alternate DB for copying: $DBI::errstr");
return sub {}
};
my @saving_templates = $self->_resolve_loading_templates_for_alternate_db($loading_templates);
foreach my $tmpl ( @saving_templates ) {
my $class_meta = $tmpl->{data_class_name}->__meta__;
$ds_type->mk_table_for_class_meta($class_meta, $dbh);
}
my @inserter_for_each_table = map { $self->_make_insert_closures_for_loading_template_for_alternate_db($_, $dbh) }
@saving_templates;
# Iterate through all the inserters, prerequisites first, for each row
# returned from the database. Each inserter may return false, which means
# it did not save anything to the alternate DB, for example if it
# is asked to save an object with a dummy ID (< 0). In that case, no
# subsequent inserters will be processed for that row
return Sub::Name::subname '__altdb_inserter' => sub {
foreach my $inserter ( @inserter_for_each_table ) {
last unless &$inserter;
}
};
}
sub _make_insert_closures_for_loading_template_for_alternate_db {
my($self, $template, $dbh) = @_;
my %seen_ids; # don't insert the same object more than once
my $class_name = $template->{data_class_name};
my $class_meta = $class_name->__meta__;
my $table_name = $class_meta->table_name;
my $columns_string = join(', ',
map { $class_meta->column_for_property($_) }
@{ $template->{property_names} } );
my $insert_sql = "insert into $table_name ($columns_string) values ("
. join(',',
map { '?' } @{ $template->{property_names} } )
. ')';
my $insert_sth = $dbh->prepare($insert_sql)
|| Carp::croak("Prepare for insert on alternate DB table $table_name failed: ".$dbh->errstr);
my $check_id_exists_sql = "select count(*) from $table_name where "
. join(' and ',
map { "$_ = ?" }
map { $class_meta->column_for_property($_) }
@{ $template->{id_property_names} });
my $check_id_exists_sth = $dbh->prepare($check_id_exists_sql)
|| Carp::croak("Prepare for check ID select on alternate DB table $table_name failed: ".$dbh->errstr);
my @id_column_positions = @{$template->{id_column_positions}};
my @column_positions = @{$template->{column_positions}};
my $id_resolver = $template->{id_resolver};
my $check_id_is_not_null = _create_sub_to_check_if_id_is_not_null(@id_column_positions);
my @prerequisites = $self->_make_insert_closures_for_prerequisite_tables($class_meta, $template);
my $object_num = $template->{object_num};
my $inserter = Sub::Name::subname "__altdb_inserter_obj${object_num}_${class_name}" => sub {
my($next_db_row) = @_;
my $id = $id_resolver->(@$next_db_row[@id_column_positions]);
return if _object_was_saved_to_database_by_this_process($class_name, $id);
if ($check_id_is_not_null->($next_db_row) and ! $seen_ids{$id}++) {
$check_id_exists_sth->execute( @$next_db_row[@id_column_positions]);
my($count) = @{ $check_id_exists_sth->fetchrow_arrayref() };
unless ($count) {
my @column_values = @$next_db_row[@column_positions];
$insert_sth->execute(@column_values)
|| Carp::croak("Inserting to alternate DB for $class_name failed");
}
}
return 1;
};
return (@prerequisites, $inserter);
}
# not a method
sub _create_sub_to_check_if_id_is_not_null {
my(@id_columns) = @_;
return sub {
my $next_db_row = $_[0];
foreach my $col ( @id_columns ) {
return 1 if defined $next_db_row->[$col];
}
return 0;
};
}
my %cached_fk_data_for_table;
sub _make_insert_closures_for_prerequisite_tables {
my($self, $class_meta, $loading_template) = @_;
$cached_fk_data_for_table{$class_meta->table_name} ||= $self->_load_fk_data_for_class_meta($class_meta);
my %column_idx_for_column_name;
for (my $i = 0; $i < @{ $loading_template->{property_names} }; $i++) {
my $column_name = $class_meta->column_for_property( $loading_template->{property_names}->[$i] );
$column_idx_for_column_name{ $column_name }
= $loading_template->{column_positions}->[$i];
}
my $class_name = $class_meta->class_name;
return map { $self->_make_prerequisite_insert_closure_for_fk($class_name, \%column_idx_for_column_name, $_) }
@{ $cached_fk_data_for_table{ $class_meta->table_name } };
}
sub _load_fk_data_for_class_meta {
my($self, $class_meta) = @_;
my ($db_owner, $table_name_without_owner) = $self->_resolve_owner_and_table_from_table_name($class_meta->table_name);
my @fk_data;
my $fk_sth = $self->get_foreign_key_details_from_data_dictionary('','','','', $db_owner, $table_name_without_owner);
my %seen_fk_names;
while( $fk_sth and my $row = $fk_sth->fetchrow_hashref ) {
foreach my $key (qw(UK_TABLE_CAT UK_TABLE_SCHEM UK_TABLE_NAME UK_COLUMN_NAME FK_TABLE_CAT FK_TABLE_SCHEM FK_TABLE_NAME FK_COLUMN_NAME)) {
no warnings 'uninitialized';
$row->{$key} =~ s/"|'//g; # Postgres puts quotes around entities that look like keywords
}
if (!@fk_data or $row->{ORDINAL_POSITION} == 1
or ( $row->{FK_NAME} and !$seen_fk_names{ $row->{FK_NAME} }++)
) {
# part of a new FK
push @fk_data, [];
}
push @{ $fk_data[-1] }, { %$row };
}
return \@fk_data;
}
# return true if this list of FK columns exists for inheritance:
# this table's FKs matches the given class' ID properties, and the FK points
# to every ID property of the parent class
sub _fk_represents_inheritance {
my($load_class_name, $fk_column_list) = @_;
my $load_class_meta = $load_class_name->__meta__;
my %is_pk_column_for_class = map { $_ => 1 }
grep { $_ }
map { $load_class_meta->column_for_property($_) }
$load_class_name->__meta__->id_property_names;
if (scalar(@$fk_column_list) != scalar(values %is_pk_column_for_class)) {
# differing number of columns vs ID properties
return '';
}
foreach my $fk ( @$fk_column_list ) {
return '' unless $is_pk_column_for_class{ $fk->{FK_COLUMN_NAME} };
}
my %checked;
foreach my $parent_class_name ( $load_class_meta->inheritance ) {
next if ($checked{$parent_class_name}++);
my $parent_class_meta = eval { $parent_class_name->__meta__ };
next unless $parent_class_meta; # for non-ur classes
my @pk_columns_for_parent = grep { $_ }
map { $parent_class_meta->column_for_property($_) }
$parent_class_meta->id_property_names;
next if (scalar(@$fk_column_list) != scalar(@pk_columns_for_parent));
foreach my $parent_pk_column ( @pk_columns_for_parent ) {
return '' unless $is_pk_column_for_class{ $parent_pk_column };
}
}
return 1;
}
sub _make_prerequisite_insert_closure_for_fk {
my($self, $load_class_name, $column_idx_for_column_name, $fk_column_list) = @_;
my $pk_class_name = $self->_lookup_fk_target_class_name($fk_column_list);
# fks for inheritance are handled inside _resolve_loading_templates_for_alternate_db
return () if _fk_represents_inheritance($load_class_name, $fk_column_list);
my $pk_class_meta = $pk_class_name->__meta__;
my %pk_to_fk_column_name_map = map { @$_{'UK_COLUMN_NAME','FK_COLUMN_NAME'} }
@$fk_column_list;
my @fk_columns = map { $column_idx_for_column_name->{$_} }
map { $pk_to_fk_column_name_map{$_} }
$pk_class_meta->id_property_names;
if (grep { !defined } @fk_columns
or
!@fk_columns
) {
Carp::croak(sprintf(q(Couldn't determine column order for inserting prerequisites of %s with foreign key "%s" refering to table %s with columns (%s)),
$load_class_name,
$fk_column_list->[0]->{FK_NAME},
$fk_column_list->[0]->{UK_TABLE_NAME},
join(', ', map { $_->{UK_COLUMN_NAME} } @$fk_column_list)
));
}
my $id_resolver = $pk_class_meta->get_composite_id_resolver();
my $check_id_is_not_null = _create_sub_to_check_if_id_is_not_null(@fk_columns);
return Sub::Name::subname "__altdb_prereq_inserter_${pk_class_name}" => sub {
my($next_db_row) = @_;
if ($check_id_is_not_null->($next_db_row)) {
my $id = $id_resolver->(@$next_db_row[@fk_columns]);
return if _object_was_saved_to_database_by_this_process($pk_class_name, $id);
# here we _do_ want to recurse back in. That way if these prerequisites
# have prerequisites of their own, they'll be loaded in the recursive call.
$pk_class_name->get($id);
}
return 1;
}
}
# not a method
sub _object_was_saved_to_database_by_this_process {
my($class_name, $id) = @_;
# Fast common case
return 1 if exists ($objects_in_database_saved_by_this_process{$class_name})
&&
exists($objects_in_database_saved_by_this_process{$class_name}->{$id});
foreach my $saved_class ( keys %objects_in_database_saved_by_this_process ) {
next unless ($class_name->isa($saved_class) || $saved_class->isa($class_name));
return 1 if exists($objects_in_database_saved_by_this_process{$saved_class}->{$id});
}
return;
}
# given a UR::DataSource::RDBMS::FkConstraint, find the table this fk refers to
# (the table with the pk_columns), then find which class goes with that table.
sub _lookup_fk_target_class_name {
my($self, $fk_column_list) = @_;
my $pk_owner = $fk_column_list->[0]->{UK_TABLE_SCHEM};
my $pk_table_name = $fk_column_list->[0]->{UK_TABLE_NAME};
my $pk_table_name_with_owner = $pk_owner ? join('.', $pk_owner, $pk_table_name) : $pk_table_name;
my $pk_class_name = $self->_lookup_class_for_table_name( $pk_table_name_with_owner )
|| $self->_lookup_class_for_table_name( $pk_table_name );
unless ($pk_class_name) {
# didn't find it. Maybe the target class isn't loaded yet
# try looking up the class on the other side of the FK
# and determine which property matches this FK
my $fk_owner = $fk_column_list->[0]->{FK_TABLE_SCHEM};
my $fk_table_name = $fk_column_list->[0]->{FK_TABLE_NAME};
my $fk_table_name_with_owner = $fk_owner ? join('.', $fk_owner, $fk_table_name) : $fk_table_name;
my $fk_class_name = $self->_lookup_class_for_table_name( $fk_table_name_with_owner )
|| $self->_lookup_class_for_table_name( $fk_table_name );
if ($fk_class_name) {
# get all the relation property target classes loaded
my @relation_property_metas = grep { $_->id_by and $_->data_type }
$fk_class_name->__meta__->properties();
foreach my $prop_meta ( @relation_property_metas ) {
eval { $prop_meta->data_type->__meta__ };
}
# try looking up again
$pk_class_name = $self->_lookup_class_for_table_name( $pk_table_name_with_owner )
|| $self->_lookup_class_for_table_name( $pk_table_name );
}
}
unless ($pk_class_name) {
Carp::croak(
sprintf(q(Couldn't determine class with table %s involved in foreign key "%s" from table %s with columns (%s)),
$pk_table_name,
$fk_column_list->[0]->{FK_NAME},
$fk_column_list->[0]->{FK_TABLE_NAME},
join(', ', map { $_->{FK_COLUMN_NAME} } @$fk_column_list),
));
}
return $pk_class_name;
}
# Given a query plan's loading templates, return a new list of look-alike
# loading templates. This new list may look different from the original
# list in the case of table inheritance: it separates out each class' table
# and the columns that goes with it.
sub _resolve_loading_templates_for_alternate_db {
my($self, $original_loading_templates) = @_;
my @loading_templates;
foreach my $loading_template ( @$original_loading_templates ) {
my $load_class_name = $loading_template->{data_class_name};
my %column_for_property_name;
for (my $i = 0; $i < @{ $loading_template->{property_names} }; $i++) {
$column_for_property_name{ $loading_template->{property_names}->[$i] }
= $loading_template->{column_positions}->[$i];
}
my @involved_class_metas = reverse
grep { $_->table_name }
$load_class_name->__meta__->all_class_metas;
foreach my $class_meta ( @involved_class_metas ) {
my @id_property_names = map { $_->property_name }
grep { $_->column_name }
$class_meta->direct_id_property_metas;
my @id_column_positions = map { $column_for_property_name{$_} } @id_property_names;
my @property_names = map { $_->property_name }
grep { $_->column_name }
$class_meta->direct_property_metas;
my @column_positions = map { $column_for_property_name{$_} } @property_names;
my $this_template = {
id_property_names => \@id_property_names,
id_column_positions => \@id_column_positions,
property_names => \@property_names,
column_positions => \@column_positions,
table_alias => $class_meta->table_name,
data_class_name => $class_meta->class_name,
final_class_name => $loading_template->{final_class_name},
object_num => $loading_template->{object_num},
id_resolver => $class_meta->get_composite_id_resolver,
};
push @loading_templates, $this_template
}
}
return @loading_templates;
}
sub _create_dbh_for_alternate_db {
my($self, $connect_string) = @_;
# Support an extension of the connect string to allow user and password.
# URI::DB supports these kinds of things, too.
$connect_string =~ s/user=(\w+);?//;
my $user = $1;
$connect_string =~ s/password=(\w+);?//;
my $password = $1;
# Don't use $self->default_handle_class here
# Generally, it'll be UR::DBI, which respects the setting for UR_DBI_NO_COMMIT.
# Tests are usually run with no-commit on, and we still want to fill the
# test db in that case
my $handle_class = 'DBI';
$handle_class->connect($connect_string, $user || '', $password || '', { AutoCommit => 1, PrintWarn => 0 });
}
# Create the table behind this class in the specified database.
# used by the functionality behind the UR_TEST_FILLDB env var
sub mk_table_for_class_meta {
my($self, $class_meta, $dbh) = @_;
return 1 unless $class_meta->has_table;
$dbh ||= $self->get_default_handle;
my $table_name = $class_meta->table_name();
$self->_assure_schema_exists_for_table($table_name, $dbh);
# we only care about properties backed up by a real column
my @props = grep { $_->column_name } $class_meta->direct_property_metas();
my $sql = "create table IF NOT EXISTS $table_name (";
my @cols;
foreach my $prop ( @props ) {
my $col = $prop->column_name;
my $type = $self->data_source_type_for_ur_data_type($prop->data_type);
my $len = $prop->data_length;
my $nullable = $prop->is_optional;
my $string = "$col" . " " . $type;
$string .= " NOT NULL" unless $nullable;
push @cols, $string;
}
$sql .= join(',',@cols);
my @id_cols = $class_meta->direct_id_column_names();
$sql .= ", PRIMARY KEY (" . join(',',@id_cols) . ")" if (@id_cols);
# Should we also check for the unique properties?
$sql .= ")";
unless ($dbh->do($sql) ) {
$self->error_message("Can't create table $table_name: ".$DBI::errstr."\nSQL: $sql");
return undef;
}
1;
}
sub _assure_schema_exists_for_table {
my($self, $table_name, $dbh) = @_;
$dbh ||= $self->get_default_handle;
my($schema_name, undef) = $self->_extract_schema_and_table_name($table_name);
if ($schema_name) {
$dbh->do("CREATE SCHEMA IF NOT EXISTS $schema_name")
|| Carp::croak("Could not create schema $schema_name: ".$dbh->errstr);
}
}
sub _extract_schema_and_table_name {
my($self, $string) = @_;
my($schema_name, $table_name) = $string =~ m/(.*)\.(\w+)$/;
return ($schema_name, $table_name);
}
sub _default_sql_like_escape_string {
return '\\'; # Most RDBMSs support an 'escape' as part of a 'like' operator, except mysql
}
sub _format_sql_like_escape_string {
my $class = shift;
my $escape = shift;
return "'$escape'";
}
# This method is used when generating SQL for a rule template, in the joins
# and also on a per-query basis to turn specific values into a where clause
sub _extend_sql_for_column_operator_and_value {
my($self, $expr_sql, $op, $val, $escape) = @_;
my $class = $self->_sql_generation_class_for_operator($op);
$escape ||= $self->_default_sql_like_escape_string;
$escape = $self->_format_sql_like_escape_string($escape);
return $class->generate_sql_for($expr_sql, $val, $escape);
}
sub _sql_generation_class_for_operator {
my($self, $op) = @_;
my $suffix = UR::Util::class_suffix_for_operator($op);
my @classes = $self->inheritance;
foreach my $class ( @classes ) {
my $op_class_name = join('::', $class, 'Operator', $suffix);
return $op_class_name if UR::Util::use_package_optimistically($op_class_name);
}
Carp::croak("Can't load SQL generation class for operator $op: $@");
}
sub _value_is_null {
my ($class, $value) = @_;
return 1 if not defined $value;
return 1 if $value eq '';
return 1 if (ref($value) eq 'HASH' and $value->{operator} eq '=' and (!defied($value->{value}) or $value->{value} eq ''));
return 0;
}
sub _resolve_ids_from_class_name_and_sql {
my $self = shift;
my $class_name = shift;
my $sql = shift;
my $query;
my @params;
if (ref($sql) eq "ARRAY") {
($query, @params) = @{$sql};
} else {
$query = $sql;
}
my $class_meta = $class_name->__meta__;
my @id_columns = map
{ $class_meta->property_meta_for_name($_)->column_name }
$class_meta->id_property_names;
# query for the ids
my $dbh = $self->get_default_handle();
my $sth = $dbh->prepare($query);
unless ($sth) {
Carp::croak("Could not prepare query $query: $DBI::errstr");
}
unless ($sth->{NUM_OF_PARAMS} == scalar(@params)) {
Carp::croak('The number of params supplied ('
. scalar(@params)
. ') does not match the number of placeholders (' . $sth->{NUM_OF_PARAMS}
. ") in the supplied sql: $query");
}
$sth->execute(@params);
# After execute, we can see if the SQL contained all the required primary keys
my @id_column_idx = map { $sth->{NAME_lc_hash}->{$_} }
map { lc }
@id_columns;
if (grep { ! defined } @id_column_idx) {
@id_columns = sort @id_columns;
my @missing_ids = sort grep { ! defined($sth->{NAME_lc_hash}->{lc($_)}) } @id_columns;
Carp::croak("The SQL supplied is missing one or more ID columns.\n\tExpected: "
. join(', ', @id_columns)
. ' but some were missing: '
. join(', ', @missing_ids)
. " for query: $query");
}
my $id_resolver = $class_name->__meta__->get_composite_id_resolver();
my $id_values = $sth->fetchall_arrayref(\@id_column_idx);
return [ map { $id_resolver->(@$_) } @$id_values ];
}
sub _sync_database {
my $self = shift;
my %params = @_;
unless (ref($self)) {
if ($self->isa("UR::Singleton")) {
$self = $self->_singleton_object;
}
else {
die "Called as a class-method on a non-singleton datasource!";
}
}
my $changed_objects = delete $params{changed_objects};
my %objects_by_class_name;
for my $obj (@$changed_objects) {
my $class_name = ref($obj);
$objects_by_class_name{$class_name} ||= [];
push @{ $objects_by_class_name{$class_name} }, $obj;
if ($self->alternate_db_dsn) {
$objects_in_database_saved_by_this_process{$class_name}->{$obj->id} = 1;
}
}
my $dbh = $self->get_default_handle;
#
# Determine what commands need to be executed on the database
# to sync those changes, and categorize them by type and table.
#
# As we iterate through changes, keep track of all of the involved tables.
my %all_tables; # $all_tables{$table_name} = $number_of_commands;
# Make a hash for each type of command keyed by table name.
my %insert; # $insert{$table_name} = [ $change1, $change2, ...];
my %update; # $update{$table_name} = [ $change1, $change2, ...];
my %delete; # $delete{$table_name} = [ $change1, $change2, ...];
# Make a master hash referencing each of the above.
# $explicit_commands_by_type_and_table{'insert'}{$table} = [ $change1, $change2 ...]
my %explicit_commands_by_type_and_table = (
'insert' => \%insert,
'update' => \%update,
'delete' => \%delete
);
# Build the above data structures.
{
no warnings;
for my $class_name (sort keys %objects_by_class_name) {
for my $obj (@{ $objects_by_class_name{$class_name} }) {
my @commands = $self->_default_save_sql_for_object($obj);
next unless @commands;
for my $change (@commands)
{
#$commands{$change} = $change;
# Example change:
# { type => 'update', table_name => $table_name,
# column_names => \@changed_cols, sql => $sql,
# params => \@values, class => $table_class, id => $id };
# There are often multiple changes per object, espeically
# when the object is spread across multiple tables because of
# inheritance. We classify each change by the table and
# the class immediately associated with the table, even if
# the class in an abstract parent class on the object.
my $table_name = $change->{table_name};
my $id = $change->{id};
$all_tables{$table_name}++;
if ($change->{type} eq 'insert')
{
push @{ $insert{$table_name} }, $change;
}
elsif ($change->{type} eq 'update')
{
push @{ $update{$table_name} }, $change;
}
elsif ($change->{type} eq 'delete')
{
push @{ $delete{$table_name} }, $change;
}
else
{
print "UNKNOWN COMMAND TYPE $change->{type} $change->{sql}\n";
}
}
}
}
}
# Determine which tables require a lock;
my %tables_requiring_lock;
for my $table_name (keys %all_tables) {
my $table_object = $self->_get_table_object($table_name);
unless ($table_object) {
warn "looking up schema for RDBMS table $table_name...\n";
$table_object = $self->refresh_database_metadata_for_table_name($table_name);
unless ($table_object) {
die "Failed to generate table data for $table_name!";
}
}
if (my @bitmap_index_names = $table_object->bitmap_index_names) {
my $changes;
if ($changes = $insert{$table_name} or $changes = $delete{$table_name}) {
$tables_requiring_lock{$table_name} = 1;
}
elsif (not $tables_requiring_lock{$table_name}) {
$changes = $update{$table_name};
my @column_names = sort map { @{ $_->{column_names} } } @$changes;
my $last_column_name = "";
for my $column_name (@column_names) {
next if $column_name eq $last_column_name;
my $column_obj = UR::DataSource::RDBMS::TableColumn->get(
data_source => $table_object->data_source,
table_name => $table_name,
column_name => $column_name,
);
if ($column_obj->bitmap_index_names) {
$tables_requiring_lock{$table_name} = 1;
last;
}
$last_column_name = $column_name;
}
}
}
}
#
# Make a mapping of prerequisites for each command,
# and a reverse mapping of dependants for each command.
#
my %all_table_commands;
my %prerequisites;
my %dependants;
for my $table_name (keys %all_tables) {
my $table = $self->_get_table_object($table_name);
my @fk = $table->fk_constraints;
my $matched_table_name;
if ($insert{$table_name})
{
$matched_table_name = 1;
$all_table_commands{"insert $table_name"} = 1;
}
if ($update{$table_name})
{
$matched_table_name = 1;
$all_table_commands{"update $table_name"} = 1;
}
if ($delete{$table_name})
{
$matched_table_name = 1;
$all_table_commands{"delete $table_name"} = 1;
}
unless ($matched_table_name) {
Carp::carp("Possible metadata inconsistency: A change on table $table_name was not an insert, update or delete!");
}
my $tmparray;
# handle multiple differnt ops on the same table
if ($insert{$table_name} and $update{$table_name}) {
# insert before update
$tmparray = $prerequisites{"update $table_name"}{"insert $table_name"} ||= [];
$tmparray = $dependants{"insert $table_name"}{"update $table_name"} ||= [];
}
if ($delete{$table_name} and $update{$table_name}) {
# update before delete
$tmparray = $prerequisites{"delete $table_name"}{"update $table_name"} ||= [];
$tmparray = $dependants{"update $table_name"}{"delete $table_name"} ||= [];
}
if ($delete{$table_name} and $insert{$table_name} and not $update{$table_name}) {
# delete before insert
$tmparray = $prerequisites{"insert $table_name"}{"delete $table_name"} ||= [];
$tmparray = $dependants{"delete $table_name"}{"insert $table_name"} ||= [];
}
# Go through the constraints.
for my $fk (@fk)
{
my $r_table_name = $fk->r_table_name;
# RULES:
# insert r_table_name before insert table_name
# insert r_table_name before update table_name
# delete table_name before delete r_table_name
# update table_name before delete r_table_name
if ($insert{$table_name} and $insert{$r_table_name})
{
$tmparray = $prerequisites{"insert $table_name"}{"insert $r_table_name"} ||= [];
push @$tmparray, $fk;
$tmparray = $dependants{"insert $r_table_name"}{"insert $table_name"} ||= [];
push @$tmparray, $fk;
}
if ($update{$table_name} and $insert{$r_table_name})
{
$tmparray = $prerequisites{"update $table_name"}{"insert $r_table_name"} ||= [];
push @$tmparray, $fk;
$tmparray = $dependants{"insert $r_table_name"}{"update $table_name"} ||= [];
push @$tmparray, $fk;
}
if ($delete{$r_table_name} and $delete{$table_name})
{
$tmparray = $prerequisites{"delete $r_table_name"}{"delete $table_name"} ||= [];
push @$tmparray, $fk;
$tmparray = $dependants{"delete $table_name"}{"delete $r_table_name"} ||= [];
push @$tmparray, $fk;
}
if ($delete{$r_table_name} and $update{$table_name})
{
$tmparray = $prerequisites{"delete $r_table_name"}{"update $table_name"} ||= [];
push @$tmparray, $fk;
$tmparray = $dependants{"update $table_name"}{"delete $r_table_name"} ||= [];
push @$tmparray, $fk;
}
}
}
#
# Use the above mapping to build an ordered list of general commands.
# Note that the general command is something like "insert EMPLOYEES",
# while the explicit command is an exact insert statement with params.
#
my @general_commands_in_order;
my %self_referencing_table_commands;
my %all_unresolved = %all_table_commands;
my $unresolved_count;
my $last_unresolved_count = 0;
my @ready_to_add = ();
while ($unresolved_count = scalar(keys(%all_unresolved)))
{
if ($unresolved_count == $last_unresolved_count)
{
# We accomplished nothing on the last iteration.
# We are in an infinite loop unless something is done.
# Rather than die with an error, issue a warning and attempt to
# brute-force the sync.
# Process something with minimal deps as a work-around.
my @ordered_by_least_number_of_prerequisites =
sort{ scalar(keys(%{$prerequisites{$a}})) <=> scalar(keys(%{$prerequisites{$b}})) }
grep { $prerequisites{$_} }
keys %all_unresolved;
@ready_to_add = ($ordered_by_least_number_of_prerequisites[0]);
warn "Circular dependency! Pushing @ready_to_add to brute-force the save.\n";
#print STDERR Data::Dumper::Dumper(\%objects_by_class_name, \%prerequisites, \%dependants ) . "\n";
}
else
{
# This is the normal case. It is either the first iteration,
# or we are on additional iterations with some progress made
# in the last iteration.
# Find commands which have no unresolved prerequisites.
@ready_to_add =
grep { not $prerequisites{$_} }
keys %all_unresolved;
# If there are none of the above, find commands
# with only self-referencing prerequisites.
unless (@ready_to_add)
{
# Find commands with only circular dependancies.
@ready_to_add =
# The circular prerequisite must be the only prerequisite on the table.
grep { scalar(keys(%{$prerequisites{$_}})) == 1 }
# The prerequisite must be the same as the the table itself.
grep { $prerequisites{$_}{$_} }
# There must be prerequisites for the given table,
grep { $prerequisites{$_} }
# Look at all of the unresolved table commands.
keys %all_unresolved;
# Note this for below.
# It records the $fk object which is circular.
for my $table_command (@ready_to_add)
{
$self_referencing_table_commands{$table_command} = $prerequisites{$table_command}{$table_command};
}
}
}
# Record our current unresolved count for comparison on the next iteration.
$last_unresolved_count = $unresolved_count;
for my $db_command (@ready_to_add)
{
# Put it in the list.
push @general_commands_in_order, $db_command;
# Delete it from the main hash of command/table pairs
# for which dependencies are not resolved.
delete $all_unresolved{$db_command};
# Find anything which depended on this command occurring first
# and remove this command from that command's prerequisite list.
for my $dependant (keys %{ $dependants{$db_command} })
{
# Tell it to take us out of its list of prerequisites.
delete $prerequisites{$dependant}{$db_command} if $prerequisites{$dependant};
# Get rid of the prereq entry if it is empty;
delete $prerequisites{$dependant} if (keys(%{ $prerequisites{$dependant} }) == 0);
}
# Note that nothing depends on this command any more since it has been queued.
delete $dependants{$db_command};
}
}
# Go through the ordered list of general commands (ie "insert TABLE_NAME")
# and build the list of explicit commands.
my @explicit_commands_in_order;
for my $general_command (@general_commands_in_order)
{
my ($dml_type,$table_name) = split(/\s+/,$general_command);
if (my $circular_fk_list = $self_referencing_table_commands{$general_command})
{
# A circular foreign key requires that the
# items be inserted in a specific order.
my (@rcol_sets) =
map { [ $_->column_names ] }
@$circular_fk_list;
# Get the IDs and objects which need to be saved.
my @cmds = @{ $explicit_commands_by_type_and_table{$dml_type}{$table_name} };
my @ids = map { $_->{id} } @cmds;
# my @objs = $cmds[0]->{class}->is_loaded(\@ids);
my $is_loaded_class =
($dml_type eq 'delete')
? $cmds[0]->{class}->ghost_class
: $cmds[0]->{class};
my @objs = $is_loaded_class->is_loaded(\@ids);
my %objs = map { $_->id => $_ } @objs;
# Produce the explicit command list in dep order.
my %unsorted_cmds = map { $_->{id} => $_ } @cmds;
my $add;
my @local_explicit_commands;
my %adding;
$add = sub {
my ($cmd) = @_;
if ($adding{$cmd}) {
##$DB::single = 1;
Carp::confess("Circular foreign key!") unless $main::skip_croak;
}
$adding{$cmd} = 1;
my $obj = $objs{$cmd->{id}};
my $class_meta = $obj->class->__meta__;
for my $rcol_set (@rcol_sets) {
my @ordered_values = map { $obj->$_ }
map { $class_meta->property_for_column($_) }
@$rcol_set;
my $pid = $obj->class->__meta__->resolve_composite_id_from_ordered_values(@ordered_values);
if (defined $pid) { # This recursive foreign key dep may have been optional
my $pcmd = delete $unsorted_cmds{$pid};
$add->($pcmd) if $pcmd;
}
}
delete $adding{$cmd};
push @local_explicit_commands, $cmd;
};
for my $cmd (@cmds) {
next unless $unsorted_cmds{$cmd->{id}};
$add->(delete $unsorted_cmds{$cmd->{id}});
}
if ($dml_type eq 'delete') {
@local_explicit_commands = reverse @local_explicit_commands;
}
push @explicit_commands_in_order, @local_explicit_commands;
}
else
{
# Order is irrelevant on non-self-referencing tables.
push @explicit_commands_in_order, @{ $explicit_commands_by_type_and_table{$dml_type}{$table_name} };
}
}
my %table_objects_by_class_name;
my %column_objects_by_class_and_column_name;
# Make statement handles.
my %sth;
for my $cmd (@explicit_commands_in_order)
{
my $sql = $cmd->{sql};
unless ($sth{$sql})
{
my $class_name = $cmd->{class};
# get the db handle to use for this class
my $dbh = $cmd->{dbh};
my $sth = $dbh->prepare($sql);
$sth{$sql} = $sth;
unless ($sth)
{
$self->__signal_observers__('commit_failed', 'prepare', $sql, $dbh->errstr);
$self->error_message("Error preparing SQL:\n$sql\n" . $dbh->errstr . "\n");
return;
}
my $tables = $table_objects_by_class_name{$class_name};
my $class_object = $class_name->__meta__;
unless ($tables) {
my $tables;
my @all_table_names = $class_object->all_table_names;
for my $table_name (@all_table_names) {
my $table = $self->_get_table_object($table_name);
push @$tables, $table;
$column_objects_by_class_and_column_name{$class_name} ||= {};
my $columns = $column_objects_by_class_and_column_name{$class_name};
unless (%$columns) {
for my $column ($table->columns) {
$columns->{$column->column_name} = $column;
}
}
}
$table_objects_by_class_name{$class_name} = $tables;
}
my @column_objects;
foreach my $column_name ( @{ $cmd->{column_names} } ) {
my $column = $column_objects_by_class_and_column_name{$class_name}->{$column_name};
unless ($column) {
FIND_IN_ANCESTRY:
for my $ancestor_class_name ($class_object->ancestry_class_names) {
$column = $column_objects_by_class_and_column_name{$ancestor_class_name}->{$column_name};
if ($column) {
$column_objects_by_class_and_column_name{$class_name}->{$column_name} = $column;
last FIND_IN_ANCESTRY;
}
}
}
# If we didn't find a column object, then $column will be undef
# and we'll have to guess what it looks like
push @column_objects, $column;
}
# print "Column Types: @column_types\n";
$self->_alter_sth_for_selecting_blob_columns($sth,\@column_objects);
}
}
# DBI docs say that if AutoCommit is on, then starting a transaction will temporarily
# turn it off. When the handle gets commit() or rollback(), it will get turned back
# on automatically by DBI
if ($dbh->{AutoCommit}
and
! eval { $dbh->begin_work; 1 }
) {
Carp::croak(sprintf('Cannot begin transaction on data source %s: %s',
$self->id, $dbh->errstr));
}
# Set a savepoint if possible.
my $savepoint;
if ($self->can_savepoint) {
$savepoint = $self->_last_savepoint;
if ($savepoint) {
$savepoint++;
}
else {
$savepoint=1;
}
my $sp_name = "sp".$savepoint;
unless ($self->set_savepoint($sp_name)) {
$self->error_message("Failed to set a savepoint on "
. $self->class
. ": "
. $dbh->errstr
);
return;
}
$self->_last_savepoint($savepoint);
}
# Do any explicit table locking necessary.
if (my @tables_requiring_lock = sort keys %tables_requiring_lock) {
$self->debug_message("Locking tables: @tables_requiring_lock.");
my $max_failed_attempts = 10;
for my $table_name (@tables_requiring_lock) {
my $table = $self->_get_table_object($table_name);
my $dbh = $table->dbh;
my $sth = $dbh->prepare("lock table $table_name in exclusive mode");
my $failed_attempts = 0;
my @err;
for (1) {
unless ($sth->execute) {
$failed_attempts++;
$self->warning_message(
"Failed to lock $table_name (attempt # $failed_attempts): "
. $sth->errstr
);
push @err, $sth->errstr;
unless ($failed_attempts >= $max_failed_attempts) {
redo;
}
}
}
if ($failed_attempts > 1) {
my $err = join("\n",@err);
if ($failed_attempts >= $max_failed_attempts) {
$self->error_message(
"Could not obtain an exclusive table lock on table "
. $table_name . " after $failed_attempts attempts"
);
$self->rollback_to_savepoint($savepoint);
return;
}
}
}
}
# Execute the commands in the correct order.
my @failures;
my $last_failure_count = 0;
my @previous_failure_sets;
# If there are failures, we fall-back to brute force and send
# a message to support to debug the inefficiency.
my $skip_fault_tolerance_check = 1;
for (1) {
@failures = ();
for my $cmd (@explicit_commands_in_order) {
unless ($sth{$cmd->{sql}}->execute(@{$cmd->{params}}))
{
my $dbh = $cmd->{dbh};
# my $dbh = UR::Context->resolve_data_source_for_object($cmd->{class})->get_default_handle;
$self->__signal_observers__('commit_failed', 'execute', $cmd->{sql}, $dbh->errstr);
push @failures, {cmd => $cmd, error_message => $sth{$cmd->{sql}}->errstr};
last if $skip_fault_tolerance_check;
}
$sth{$cmd->{sql}}->finish();
}
if (@failures) {
# There have been some failures. In case the error has to do with
# a failure to correctly determine dependencies in the code above,
# we will retry the set of failed commands. This repeats as long
# as some progress is made on each iteration.
if ( (@failures == $last_failure_count) or $skip_fault_tolerance_check) {
# We've tried this exact set of comands before and failed.
# This is a real error. Stop retrying and report.
for my $error (@failures)
{
$self->error_message($self->id . ": Error executing SQL:\n$error->{cmd}{sql}\n" .
"PARAMS: " . join(', ',map { defined($_) ? "'$_'" : '(undef)' } @{$error->{cmd}{params}}) . "\n" .
$error->{error_message} . "\n");
}
last;
}
else {
# We've failed, but we haven't retried this exact set of commands
# and found the exact same failures. This is either the first failure,
# or we had failures before and had success on the last brute-force
# approach to sorting commands. Try again.
push @previous_failure_sets, \@failures;
@explicit_commands_in_order = map { $_->{cmd} } @failures;
$last_failure_count = scalar(@failures);
$self->warning_message("RETRYING SAVE");
redo;
}
}
}
# Rollback to savepoint if there are errors.
if (@failures) {
if (!$savepoint or $savepoint eq "NONE") {
# A failure on a database which does not support savepoints.
# We must rollback the entire transacation.
# This is only a problem for a mixed raw-sql and UR::Object environment.
$dbh->rollback;
}
else {
$self->_reverse_sync_database();
}
# Return false, indicating failure.
return;
}
unless ($self->_set_specified_objects_saved_uncommitted($changed_objects)) {
Carp::confess("Error setting objects to a saved state after sync_database. Exiting.");
return;
}
if (exists $params{'commit_on_success'} and ($params{'commit_on_success'} eq '1')) {
# Commit the current transaction.
# The handles will automatically update their objects to
# a committed state from the one set above.
# It will throw an exception on failure.
$dbh->commit;
}
# Though we succeeded, see if we had to use the fault-tolerance code to
# do so, and warn software support. This should never occur.
if (@previous_failure_sets) {
my $msg = "Dependency failure saving: " . Dumper(\@explicit_commands_in_order)
. "\n\nThe following error sets were produced:\n"
. Dumper(\@previous_failure_sets) . "\n\n" . Carp::cluck() . "\n\n";
$self->warning_message($msg);
$UR::Context::current->send_email(
To => UR::Context::Process->support_email,
Subject => 'sync_database dependency sort failure',
Message => $msg
) or $self->warning_message("Failed to send error email!");
}
return 1;
}
# this is necessary for overriding data source names when looking up table metadata with
# bifurcated oracle/postgres syncs in testing.
sub _my_data_source_id {
my $self = shift;
return ref($self) ? $self->id : $self;
}
sub _get_table_object {
my($self, $ds_table) = @_;
my $data_source_id = $self->_my_data_source_id;
my $table = UR::DataSource::RDBMS::Table->get(
table_name => $ds_table,
data_source => $data_source_id)
||
UR::DataSource::RDBMS::Table->get(
table_name => $ds_table,
data_source => 'UR::DataSource::Meta');
return $table;
}
sub _alter_sth_for_selecting_blob_columns {
my($self, $sth, $column_objects) = @_;
return;
}
sub _reverse_sync_database {
my $self = shift;
unless ($self->can_savepoint) {
# This will not respect manual DML
# Developers must not use this back door on non-savepoint databases.
$self->get_default_handle->rollback;
return "NONE";
}
my $savepoint = $self->_last_savepoint;
unless ($savepoint) {
Carp::confess("No savepoint set!");
}
my $sp_name = "sp".$savepoint;
unless ($self->rollback_to_savepoint($sp_name)) {
$self->error_message("Error removing savepoint $savepoint " . $self->get_default_handle->errstr);
return 1;
}
$self->_last_savepoint(undef);
return $savepoint;
}
# Given a table object and a list of primary key values, return
# a where clause to match a row. Some values may be undef (NULL)
# and it properly writes "column IS NULL". As a side effect, the
# @$values list is altered to remove the undef value
sub _matching_where_clause {
my($self,$table_obj,$values) = @_;
unless ($table_obj) {
Carp::confess("No table passed to _matching_where_clause for $self!");
}
my @pks = $table_obj->primary_key_constraint_column_names;
my @where;
# in @$values, the updated data values always seem to be before the where clause
# values but still in the right order, so start at the right place
my $skip = scalar(@$values) - scalar(@pks);
for (my($pk_idx,$values_idx) = (0,$skip); $pk_idx < @pks;) {
if (defined $values->[$values_idx]) {
push(@where, $pks[$pk_idx] . ' = ?');
$pk_idx++;
$values_idx++;
} else {
push(@where, $pks[$pk_idx] . ' IS NULL');
splice(@$values, $values_idx, 1);
$pk_idx++;
}
}
return join(' and ', @where);
}
sub _id_values_for_primary_key {
my ($self,$table_obj,$object_to_save) = @_;
unless ($table_obj && $object_to_save) {
Carp::confess("Both table and object_to_save should be passed for $self!");
}
my $class_obj; # = $object_to_save->__meta__;
foreach my $possible_class_obj ($object_to_save->__meta__->all_class_metas) {
next unless ($possible_class_obj->table_name);
if ( $possible_class_obj->table_name eq $table_obj->table_name ) {
$class_obj = $possible_class_obj;
last;
}
}
unless (defined $class_obj) {
Carp::croak("Can't find class object with table " . $table_obj->table_name . " while searching inheritance for object of class ".$self->class);
}
my @pk_cols = $table_obj->primary_key_constraint_column_names;
my %pk_cols = map { $_ => 1 } @pk_cols;
# this previously went to $object_to_save->__meta__, which is nearly the same thing but not quite
my @values = $class_obj->resolve_ordered_values_from_composite_id($object_to_save->id);
my @columns = $class_obj->direct_id_column_names;
foreach my $col_in_class ( @columns ) {
unless ($pk_cols{$col_in_class}) {
my $table_name = $table_obj->table_name;
my $class_name = $class_obj->class_name;
Carp::croak("While committing, metadata for table $table_name does not match class $class_name.\n Table primary key columns are " .
join(', ',@pk_cols) .
"\n class ID property columns " .
join(', ', @columns));
}
}
my $i=0;
my %column_index = map { $_ => $i++ } @columns;
my @bad_pk_cols = grep { ! exists($column_index{$_}) } @pk_cols;
if (@bad_pk_cols) {
my $table_name = $table_obj->table_name;
Carp::croak("Metadata for table $table_name is inconsistent with class ".$class_obj->class_name.".\n"
. "Column(s) named " . join(',',@bad_pk_cols) . " appear as primary key constraint columns, "
. "but do not appear as ID column names. Check the dd_pk_constraint_columns data in the "
. "MetaDB and the ID properties of the class definition");
}
my @id_values_in_pk_order = @values[@column_index{@pk_cols}];
return @id_values_in_pk_order;
}
sub _lookup_class_for_table_name {
my $self = shift;
my $table_name = shift;
my @table_class_obj = grep { $_->class_name !~ /::Ghost$/ } UR::Object::Type->is_loaded(data_source_id => $self->id, table_name => $table_name);
# Like _get_table_object, we need to look in the data source and if the
# object wasn't found then in 'UR::DataSource::Meta' in order to mimic
# behavior elsewhere.
unless (@table_class_obj) {
@table_class_obj = grep { $_->class_name !~ /::Ghost$/ } UR::Object::Type->is_loaded(data_source_id => 'UR::DataSource::Meta', table_name => $table_name);
}
my $table_class;
my $table_class_obj;
if (@table_class_obj == 1) {
$table_class_obj = $table_class_obj[0];
return $table_class_obj->class_name;
} elsif (@table_class_obj > 1) {
Carp::confess("Got more than one class object for $table_name, this should not happen: @table_class_obj");
}
}
sub _default_save_sql_for_object {
my $self = shift;
my $object_to_save = shift;
my %params = @_;
my ($class,$id) = ($object_to_save->class, $object_to_save->id);
my $class_object = $object_to_save->__meta__;
# This object may have uncommitted changes already saved.
# If so, work from the last saved data.
# Normally, we go with the last committed data.
my $compare_version = ($object_to_save->{'db_saved_uncommitted'} ? 'db_saved_uncommitted' : 'db_committed');
# Determine what the overall save action for the object is,
# and get a specific change summary if we're doing an update.
my ($action,$change_summary);
if ($object_to_save->isa('UR::Object::Ghost'))
{
$action = 'delete';
}
elsif ($object_to_save->{$compare_version})
{
$action = 'update';
$change_summary = $object_to_save->property_diff($object_to_save->{$compare_version});
}
else
{
$action = 'insert';
}
# Handle each table. There is usually only one, unless,
# there is inheritance within the schema.
my @save_table_names =
grep { not /[^\w\.]/ } # remove any views from the list
List::MoreUtils::uniq($class_object->all_table_names);
@save_table_names = reverse @save_table_names unless ($object_to_save->isa('UR::Entity::Ghost'));
my @commands;
for my $table_name (@save_table_names)
{
# Get general info on the table we're working-with.
my $dsn = ref($self) ? $self->_my_data_source_id: $self; # The data source name
my $table = $self->_get_table_object($table_name);
unless ($table) {
$self->generate_schema_for_class_meta($class_object,1);
# try again...
$table = $self->_get_table_object($table_name);
unless ($table) {
Carp::croak("No table $table_name found for data source $dsn");
}
}
my $table_class = $self->_lookup_class_for_table_name($table_name);
if (!$table_class) {
Carp::croak("NO CLASS FOR $table_name\n");
}
my $data_source = $UR::Context::current->resolve_data_source_for_object($object_to_save);
unless ($data_source) {
Carp::croak("Couldn't resolve data source for object ".$object_to_save->__display_name__.":\n"
. Data::Dumper::Dumper($object_to_save));
}
# The "action" now can vary on a per-table basis.
my $table_action = $action;
# Handle re-classification of objects.
# We skip deletion and turn insert into update in these cases.
if ( ($table_class ne $class) and ( ($table_class . "::Ghost") ne $class) ) {
if ($action eq 'delete') {
# see if the object we're deleting actually exists reclassified
my $replacement = $table_class->is_loaded($id);
if ($replacement) {
next;
}
}
elsif ($action eq 'insert') {
# see if the object we're inserting is actually a reclassification
# of a pre-existing object
my $replacing = $table_class->ghost_class->is_loaded($id);
if ($replacing) {
$table_action = 'update';
$change_summary = $object_to_save->property_diff(%$replacing);
}
}
}
# Determine the $sql and @values needed to save this object.
if ($table_action eq 'delete')
{
# A row loaded from the database with its object deleted.
# Delete the row in the database.
#grab fk_constraints so we can undef non primary-key nullable fks before delete
my @non_pk_nullable_fk_columns = $self->get_non_primary_key_nullable_foreign_key_columns_for_table($table);
my @values = $self->_id_values_for_primary_key($table,$object_to_save);
my $where = $self->_matching_where_clause($table, \@values);
if (@non_pk_nullable_fk_columns) {
#generate an update statement to set nullable fk columns to null pre delete
my $update_sql = "UPDATE ";
$update_sql .= "$table_name SET ";
$update_sql .= join(", ", map { "$_=?"} @non_pk_nullable_fk_columns);
$update_sql .= " WHERE $where";
my @update_values = @values;
for (@non_pk_nullable_fk_columns){
unshift @update_values, undef;
}
my $update_command = { type => 'update',
table_name => $table_name,
column_names => \@non_pk_nullable_fk_columns,
sql => $update_sql,
params => \@update_values,
class => $table_class,
id => $id,
dbh => $data_source->get_default_handle
};
push @commands, $update_command;
}
my $sql = " DELETE FROM ";
$sql .= "$table_name WHERE $where";
push @commands, { type => 'delete',
table_name => $table_name,
column_names => undef,
sql => $sql,
params => \@values,
class => $table_class,
id => $id,
dbh => $data_source->get_default_handle
};
#print Data::Dumper::Dumper \@commands;
}
elsif ($table_action eq 'update')
{
# Pre-existing row.
# Update in the database if there are columns which have changed.
my $changes_for_this_table;
if (@save_table_names > 1)
{
my @changes =
map { $_ => $change_summary->{$_} }
grep { $class_object->table_for_property($_) eq $table_name }
keys %$change_summary;
$changes_for_this_table = {@changes};
}
else
{
# Shortcut and use the overall changes summary when
# there is only one table.
$changes_for_this_table = $change_summary;
}
my(@changed_cols,@values);
for my $property (keys %$changes_for_this_table)
{
my $column_name = $class_object->column_for_property($property);
Carp::croak("No column in table $table_name for property $property?") unless $column_name;
push @changed_cols, $column_name;
push @values, $changes_for_this_table->{$property};
}
if (@changed_cols)
{
my @changed_values = map { defined ($_) && $object_to_save->can($_)
? $object_to_save->$_
: undef }
map { $class_object->property_for_column($_) || undef }
@changed_cols;
my @id_values = $self->_id_values_for_primary_key($table,$object_to_save);
if (scalar(@changed_cols) != scalar(@changed_values)) {
no warnings 'uninitialized';
my $mapping = join("\n", map { " $_ => ".$class_object->property_for_column($_) } @changed_cols);
Carp::croak("Column count mismatch while updating table $table_name. "
. "The table metadata expects to see ".scalar(@changed_cols)
. " columns, but ".scalar(@values)." were retrieved from the object of type "
. $object_to_save->class . ".\nCurrent column => property mapping:\n$mapping\n"
. "There is probably a mismatch between the database column metadata and the column_name "
. "property metadata");
}
my @all_values = ( @changed_values, @id_values );
my $where = $self->_matching_where_clause($table, \@all_values);
my $sql = " UPDATE ";
$sql .= "$table_name SET " . join(",", map { "$_ = ?" } @changed_cols) . " WHERE $where";
push @commands, { type => 'update',
table_name => $table_name,
column_names => \@changed_cols,
sql => $sql,
params => \@all_values,
class => $table_class,
id => $id,
dbh => $data_source->get_default_handle
};
}
}
elsif ($table_action eq 'insert')
{
# An object without a row in the database.
# Insert into the database.
my @changed_cols = reverse sort
map { $class_object->column_for_property($_->property_name) }
grep { ! $_->is_transient }
grep { ($class_object->table_for_property($_->property_name) || '') eq $table_name }
grep { $_->column_name }
List::MoreUtils::uniq($class_object->all_property_metas());
my $sql = " INSERT INTO ";
$sql .= "$table_name ("
. join(",", @changed_cols)
. ") VALUES ("
. join(',', split(//,'?' x scalar(@changed_cols))) . ")";
my @values = map {
# when there is a column but no property, use NULL as the value
defined($_) && $object_to_save->can($_)
? $object_to_save->$_
: undef
}
map { $class_object->property_for_column($_) || undef }
(@changed_cols);
if (scalar(@changed_cols) != scalar(@values)) {
no warnings 'uninitialized';
my $mapping = join("\n", map { " $_ => ".$class_object->property_for_column($_) } @changed_cols);
Carp::croak("Column count mismatch while inserting into table $table_name. "
. "The table metadata expects to see ".scalar(@changed_cols)
. " columns, but ".scalar(@values)." were retrieved from the object of type "
. $object_to_save->class . ".\nCurrent column => property mapping:\n$mapping\n"
. "There is probably a mismatch between the database column metadata and the column_name "
. "property metadata");
}
#grab fk_constraints so we can undef non primary-key nullable fks before delete
my %non_pk_nullable_fk_columns = map { $_ => 1 }
$self->get_non_primary_key_nullable_foreign_key_columns_for_table($table);
if (%non_pk_nullable_fk_columns){
my @insert_values;
my %update_values;
for (my $i = 0; $i < @changed_cols; $i++){
my $col = $changed_cols[$i];
if ($non_pk_nullable_fk_columns{$col}) {
push @insert_values, undef;
$update_values{$col} = $values[$i];
}else{
push @insert_values, $values[$i];
}
}
push @commands, { type => 'insert',
table_name => $table_name,
column_names => \@changed_cols,
sql => $sql,
params => \@insert_values,
class => $table_class,
id => $id,
dbh => $data_source->get_default_handle
};
##$DB::single = 1;
# %update_values can be empty if the Metadb is out of date, and has a fk constraint column
# that no longer exists in the class metadata
if (%update_values) {
my @pk_values = $self->_id_values_for_primary_key($table, $object_to_save);
my $where = $self->_matching_where_clause($table, \@pk_values);
my @update_cols = keys %update_values;
my @update_values = ((map {$update_values{$_}} @update_cols), @pk_values);
my $update_sql = " UPDATE ";
$update_sql .= "$table_name SET ". join(",", map { "$_ = ?" } @update_cols) . " WHERE $where";
push @commands, { type => 'update',
table_name => $table_name,
column_names => \@update_cols,
sql => $update_sql,
params => \@update_values,
class => $table_class,
id => $id,
dbh => $data_source->get_default_handle
};
}
}
else
{
push @commands, { type => 'insert',
table_name => $table_name,
column_names => \@changed_cols,
sql => $sql,
params => \@values,
class => $table_class,
id => $id,
dbh => $data_source->get_default_handle
};
}
}
else
{
die "Unknown action $table_action for $object_to_save" . Dumper($object_to_save) . "\n";
}
} # next table
return @commands;
}
sub _do_on_default_dbh {
my $self = shift;
my $method = shift;
return 1 unless $self->has_default_handle();
my $dbh = $self->get_default_handle;
unless ($dbh->$method(@_)) {
$self->error_message("DataSource ".$self->get_name." failed to $method: ".$dbh->errstr);
return undef;
}
return 1;
}
sub commit {
my $self = shift;
if ($self->has_default_handle) {
if (my $dbh = $self->get_default_handle) {
if ($dbh->{AutoCommit} ) {
$self->debug_message('Ignoring ineffective commit because AutoCommit is on');
return 1;
}
}
}
$self->_do_on_default_dbh('commit', @_);
}
sub rollback {
my $self = shift;
if ($self->has_default_handle) {
if (my $dbh = $self->get_default_handle) {
if ($dbh->{AutoCommit} ) {
$self->debug_message('Ignoring ineffective rollback because AutoCommit is on');
return 1;
}
}
}
$self->_do_on_default_dbh('rollback', @_);
}
sub disconnect {
my $self = shift;
if (! ref($self) and $self->isa('UR::Singleton')) {
$self = $self->_singleton_object;
}
my $rv = $self->_do_on_default_dbh('disconnect', @_);
$self->__invalidate_get_default_handle__;
$self->is_connected(0);
return $rv;
}
sub _generate_class_data_for_loading {
my ($self, $class_meta) = @_;
my $parent_class_data = $self->SUPER::_generate_class_data_for_loading($class_meta);
my @class_hierarchy = ($class_meta->class_name,$class_meta->ancestry_class_names);
my $order_by_columns;
do {
my @id_column_names;
for my $inheritance_class_name (@class_hierarchy) {
my $inheritance_class_object = UR::Object::Type->get($inheritance_class_name);
unless ($inheritance_class_object->table_name) {
next;
}
@id_column_names =
map {
my $t = $inheritance_class_object->table_name;
($t) = ($t =~ /(\S+)\s*$/);
$t . '.' . $_
}
grep { defined }
map {
my $p = $inheritance_class_object->property_meta_for_name($_);
Carp::croak("No property $_ found for " . $inheritance_class_object->class_name) unless $p;
$p->column_name;
}
map { $_->property_name }
grep { $_->column_name }
$inheritance_class_object->direct_id_property_metas;
last if (@id_column_names);
}
$order_by_columns = \@id_column_names;
};
my @all_table_properties;
my @direct_table_properties;
my $first_table_name = $class_meta->first_table_name;
my $sub_classification_method_name;
my ($sub_classification_meta_class_name, $subclassify_by);
my @base_joins;
my $prev_table_name;
my $prev_id_column_name;
my %seen;
for my $co ( $class_meta, @{ $parent_class_data->{parent_class_objects} } ) {
next if $seen{ $co->class_name }++;
my $table_name = $co->first_table_name;
next unless $table_name;
#$first_table_name ||= $co->table_name;
$sub_classification_method_name ||= $co->sub_classification_method_name;
$sub_classification_meta_class_name ||= $co->sub_classification_meta_class_name;
$subclassify_by ||= $co->subclassify_by;
my $sort_sub = sub ($$) { return $_[0]->property_name cmp $_[1]->property_name };
push @all_table_properties,
map { [$co, $_, $table_name, 0 ] }
sort $sort_sub
grep { (defined $_->column_name && $_->column_name ne '') or
(defined $_->calculate_sql && $_->calculate_sql ne '') }
UR::Object::Property->get( class_name => $co->class_name );
@direct_table_properties = @all_table_properties if $class_meta eq $co;
}
my @lob_column_names;
my @lob_column_positions;
my $pos = 0;
for my $class_property (@all_table_properties) {
my ($sql_class,$sql_property,$sql_table_name) = @$class_property;
my $data_type = $sql_property->data_type || '';
if ($data_type =~ /LOB$/i) {
push @lob_column_names, $sql_property->column_name;
push @lob_column_positions, $pos;
}
$pos++;
}
my $query_config;
my $post_process_results_callback;
if (@lob_column_names) {
$query_config = $self->_prepare_for_lob;
if ($query_config) {
my $results_row_arrayref;
my @lob_ids;
my @lob_values;
$post_process_results_callback = sub {
$results_row_arrayref = shift;
my $dbh = $self->get_default_handle;
@lob_ids = @$results_row_arrayref[@lob_column_positions];
@lob_values = $self->_post_process_lob_values($dbh,\@lob_ids);
@$results_row_arrayref[@lob_column_positions] = @lob_values;
$results_row_arrayref;
};
}
}
my $class_data = {
%$parent_class_data,
all_table_properties => \@all_table_properties,
direct_table_properties => \@direct_table_properties,
first_table_name => $first_table_name,
sub_classification_method_name => $sub_classification_method_name,
sub_classification_meta_class_name => $sub_classification_meta_class_name,
subclassify_by => $subclassify_by,
base_joins => \@base_joins,
order_by_columns => $order_by_columns,
lob_column_names => \@lob_column_names,
lob_column_positions => \@lob_column_positions,
query_config => $query_config,
post_process_results_callback => $post_process_results_callback,
};
return $class_data;
}
sub _select_clause_for_table_property_data {
my $self = shift;
my $column_data = $self->_select_clause_columns_for_table_property_data(@_);
my $select_clause = join(', ',@$column_data);
return $select_clause;
}
sub _select_clause_columns_for_table_property_data {
my $self = shift;
my @column_data;
for my $class_property (@_) {
my ($sql_class,$sql_property,$sql_table_name) = @$class_property;
$sql_table_name ||= $sql_class->table_name;
my ($select_table_name) = ($sql_table_name =~ /(\S+)\s*$/s);
# FIXME - maybe a better way would be for these sql-calculated properties, the column_name()
# or maybe some other related property name) is actually calculated, so this logic
# gets encapsulated in there?
if (my $sql_function = $sql_property->calculate_sql) {
my @calculate_from = ref($sql_property->calculate_from) eq 'ARRAY' ? @{$sql_property->calculate_from} : ( $sql_property->calculate_from );
foreach my $sql_column_name ( @calculate_from ) {
$sql_function =~ s/($sql_column_name)/$sql_table_name\.$1/g;
}
push(@column_data, $sql_function);
} else {
push(@column_data, $select_table_name . "." . $sql_property->column_name);
}
}
return \@column_data;
}
# These seem to be standard for most RDBMSs
my %ur_data_type_for_vendor_data_type = (
# DB type UR Type
'VARCHAR' => ['Text', undef],
'CHAR' => ['Text', 1],
'CHARACTER' => ['Text', 1],
'XML' => ['Text', undef],
'INTEGER' => ['Integer', undef],
'UNSIGNED INTEGER' => ['Integer', undef],
'SIGNED INTEGER' => ['Integer', undef],
'INT' => ['Integer', undef],
'LONG' => ['Integer', undef],
'BIGINT' => ['Integer', undef],
'SMALLINT' => ['Integer', undef],
'FLOAT' => ['Number', undef],
'NUMBER' => ['Number', undef],
'DOUBLE' => ['Number', undef],
'DECIMAL' => ['Number', undef],
'REAL' => ['Number', undef],
'BOOL' => ['Boolean', undef],
'BOOLEAN' => ['Boolean', undef],
'BIT' => ['Boolean', undef],
'DATE' => ['DateTime', undef],
'DATETIME' => ['DateTime', undef],
'TIMESTAMP' => ['DateTime', undef],
'TIME' => ['DateTime', undef],
);
sub normalize_vendor_type {
my ($class, $type) = @_;
$type = uc($type);
$type =~ s/\(\d+\)$//;
return $type;
}
sub ur_data_type_for_data_source_data_type {
my($class,$type) = @_;
$type = $class->normalize_vendor_type($type);
my $urtype = $ur_data_type_for_vendor_data_type{$type};
unless (defined $urtype) {
$urtype = $class->SUPER::ur_data_type_for_data_source_data_type($type);
}
return $urtype;
}
sub _vendor_data_type_for_ur_data_type {
return ( TEXT => 'VARCHAR',
STRING => 'VARCHAR',
INTEGER => 'INTEGER',
DECIMAL => 'INTEGER',
NUMBER => 'FLOAT',
BOOLEAN => 'INTEGER',
DATETIME => 'DATETIME',
TIMESTAMP => 'TIMESTAMP',
__default__ => 'VARCHAR',
);
}
sub data_source_type_for_ur_data_type {
my($class, $type) = @_;
if ($type and $type->isa('UR::Value')) {
($type) =~ m/UR::Value::(\w+)/;
}
my %types = $class->_vendor_data_type_for_ur_data_type();
return $type && $types{uc($type)}
? $types{uc($type)}
: $types{__default__};
}
# Given two properties with different 'is', return a 2-element list of
# SQL functions to apply to perform a comparison in the DB. 0th element
# gets applied to the left side, 1st element to the right. This implementation
# uses printf formats where the %s gets fed an SQL expression like
# "table.column"
#
# SQLite basically treats everything as strings, so needs no conversion.
# other DBs will have their own conversions
#
# $sql_clause will be one of "join", "where"
sub cast_for_data_conversion {
my($class, $left_type, $right_type, $operator, $sql_clause) = @_;
return ('%s', '%s');
}
sub do_after_fork_in_child {
my $self = shift->_singleton_object;
my $dbhs = $self->_all_dbh_hashref;
for my $k (keys %$dbhs) {
if ($dbhs->{$k}) {
$dbhs->{$k}->{InactiveDestroy} = 1;
delete $dbhs->{$k};
}
}
# reset our state back to being "disconnected"
$self->__invalidate_get_default_handle__;
$self->_all_dbh_hashref({});
$self->is_connected(0);
# now force a reconnect
$self->get_default_handle();
return 1;
}
sub parse_view_and_alias_from_inline_view {
my($self, $sql) = @_;
return ($sql and $sql =~ m/^(.*?)(?:\s+as)?\s+(\w+)\s*$/s)
? ($1, $2)
: ();
}
1;
=pod
=head1 NAME
UR::DataSource::RDBMS - Abstract base class for RDBMS-type data sources
=head1 DESCRIPTION
This class implements the interface UR uses to query RDBMS databases with
DBI. It encapsulates the system's knowledge of classes/properties relation
to tables/columns, and how to generate SQL to create, retrieve, update and
delete table rows that represent object instances.
=head1 SEE ALSO
UR::DataSource, UR::DataSource::Oracle, UR::DataSource::Pg, UR::DataSource::SQLite
UR::DataSource::MySQL
=cut
BitmapIndex.pm 100664 023532 023421 3141 12544604516 20373 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/DataSource/RDBMS use strict;
use warnings;
package UR::DataSource::RDBMS::BitmapIndex;
use UR;
our $VERSION = "0.44"; # UR $VERSION;
UR::Object::Type->define(
class_name => 'UR::DataSource::RDBMS::BitmapIndex',
is => ['UR::DataSource::RDBMS::Entity'],
dsmap => 'dd_bitmap_index',
er_role => '',
id_properties => [qw/data_source table_name bitmap_index_name/],
properties => [
bitmap_index_name => { type => 'varchar', len => undef, sql => 'bitmap_index_name' },
data_source => { type => 'varchar', len => undef, sql => 'data_source' },
data_source_obj => { type => 'UR::DataSource', id_by => 'data_source'},
namespace => { calculate_from => [ 'data_source'],
calculate => q( (split(/::/,$data_source))[0] ) },
owner => { type => 'varchar', len => undef, is_optional => 1, sql => 'owner' },
table_name => { type => 'varchar', len => undef, sql => 'table_name' },
],
data_source => 'UR::DataSource::Meta',
);
1;
=pod
=head1 NAME
UR::DataSource::RDBMS::BitmapIndex - metadata about a data source's bitmap indexes
=head1 DESCRIPTION
This class represents instances of bitmap indexes in a data source. They are
maintained by 'ur update classes' and stored in the namespace's MetaDB.
The existence of bitmap indexes in a datasource affects SQL generation during
a Context commit. Oracle's implementation requires a table covered by a
bitmap index to be locked while it is being updated.
=cut
Entity.pm 100664 023532 023421 1120 12544604516 17436 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/DataSource/RDBMS use strict;
use warnings;
package UR::DataSource::RDBMS::Entity;
use UR;
our $VERSION = "0.44"; # UR $VERSION;
UR::Object::Type->define(
class_name => 'UR::DataSource::RDBMS::Entity',
is => ['UR::Entity'],
is_abstract => 1,
data_source => 'UR::DataSource::Meta',
);
1;
=pod
=head1 NAME
UR::DataSource::Meta::RDBMS::Entity - Parent class for all MetaDB-sourced classes
=head1 DESCRIPTION
This class exists as a means for flagging MetaDB objects and handling them
specially by the infrastructure in certain circumstances, such as final
data source determination.
=cut
FkConstraint.pm 100664 023532 023421 13275 12544604516 20625 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/DataSource/RDBMS use strict;
use warnings;
package UR::DataSource::RDBMS::FkConstraint;
use UR;
our $VERSION = "0.44"; # UR $VERSION;
UR::Object::Type->define(
class_name => 'UR::DataSource::RDBMS::FkConstraint',
is => ['UR::DataSource::RDBMS::Entity'],
dsmap => 'dd_fk_constraint',
er_role => '',
id_properties => [qw/data_source table_name r_table_name fk_constraint_name/],
properties => [
data_source => { type => 'varchar', len => undef, sql => 'data_source' },
data_source_obj => { type => 'UR::DataSource', id_by => 'data_source'},
namespace => { calculate_from => [ 'data_source'],
calculate => q( (split(/::/,$data_source))[0] ) },
fk_constraint_name => { type => 'varchar', len => undef, sql => 'fk_constraint_name' },
owner => { type => 'varchar', len => undef, is_optional => 1, sql => 'owner' },
r_owner => { type => 'varchar', len => undef, is_optional => 1, sql => 'r_owner' },
r_table_name => { type => 'varchar', len => undef, sql => 'r_table_name' },
table_name => { type => 'varchar', len => undef, sql => 'table_name' },
last_object_revision => { type => 'timestamp', len => undef, sql => 'last_object_revision' },
],
data_source => 'UR::DataSource::Meta',
);
#UR::Object::Type->bootstrap_object(__PACKAGE__);
sub _fk_constraint_column_class {
if (shift->isa('UR::Object::Ghost')) {
return 'UR::DataSource::RDBMS::FkConstraintColumn::Ghost';
} else {
return 'UR::DataSource::RDBMS::FkConstraintColumn';
}
}
sub _table_classes {
if (shift->isa('UR::Object::Ghost')) {
return ('UR::DataSource::RDBMS::Table::Ghost', 'UR::DataSource::RDBMS::Table');
} else {
return ('UR::DataSource::RDBMS::Table', 'UR::DataSource::RDBMS::Table::Ghost');
}
}
sub get_with_special_params {
my($class,$rule,%args) = @_;
#$DB::single = 1;
my $column_name = delete $args{'column_name'};
my $r_column_name = delete $args{'r_column_name'};
my @fks = $class->get($rule);
return $class->context_return(@fks) unless ($column_name || $r_column_name);
my @objects;
foreach my $fk ( @fks ) {
my %fkc_args = ( data_source => $fk->data_source,
table_name => $fk->table_name,
r_table_name => $fk->r_table_name,
);
$fkc_args{'column_name'} = $column_name if $column_name;
$fkc_args{'r_column_name'} = $r_column_name if $r_column_name;
my @fkc = UR::DataSource::RDBMS::FkConstraintColumn->get(%fkc_args);
push @objects,$fk if @fkc;
}
return $class->context_return(@objects);
}
sub create {
my $class = shift;
my $params = { $class->define_boolexpr(@_)->normalize->params_list };
my $column_name = delete $params->{'column_name'};
my $r_column_name = delete $params->{'r_column_name'};
if ($column_name || $r_column_name) {
$column_name = [ $column_name ] unless (ref $column_name);
$r_column_name = [ $r_column_name ] unless (ref $r_column_name);
unless (scalar @$column_name == scalar @$r_column_name) {
Carp::confess('column_name list and r_column_name list must be the same length');
return undef;
}
}
my $self = $class->SUPER::create($params);
while ($column_name && @$column_name) {
my $col_name = shift @$column_name;
my $r_col_name = shift @$r_column_name;
my $col_class = $self->_fk_constraint_column_class;
$col_class->create(data_source => $self->data_source,
fk_constraint_name => $self->fk_constraint_name,
table_name => $self->table_name,
column_name => $col_name,
r_table_name => $self->r_table_name,
r_column_name => $r_col_name);
}
return $self;
}
sub get_related_column_objects {
my($self,$prop_name) = @_;
my @fkcs = UR::DataSource::RDBMS::FkConstraintColumn->get(
data_source => $self->data_source,
table_name => $self->table_name,
r_table_name => $self->r_table_name,
fk_constraint_name => $self->fk_constraint_name,
);
return @fkcs unless $prop_name;
return map { $_->$prop_name } @fkcs;
}
sub column_names {
return shift->get_related_column_objects('column_name');
}
sub r_column_names {
return shift->get_related_column_objects('r_column_name');
}
sub column_name_map {
my $self = shift;
my @fkcs = $self->get_related_column_objects();
return map { [ $_->column_name, $_->r_column_name ] } @fkcs;
}
sub _get_related_table {
my($self,$table_name) = @_;
foreach my $try_class ( $self->_table_classes ) {
my $table = $try_class->get(data_source => $self->data_source,
table_name => $table_name);
return $table if $table;
}
return undef;
}
sub get_table {
my $self = shift;
return $self->_get_related_table($self->table_name);
}
sub get_r_table {
my $self = shift;
return $self->_get_related_table($self->r_table_name);
}
1;
=pod
=head1 NAME
UR::DataSource::RDBMS::FkConstraint - metadata about a data source's foreign keys
=head1 DESCRIPTION
This class represents instances of foreign keys in a data source. They are
maintained by 'ur update classes' and stored in the namespace's MetaDB.
=cut
FkConstraintColumn.pm 100664 023532 023421 3403 12544604516 21753 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/DataSource/RDBMS use strict;
use warnings;
package UR::DataSource::RDBMS::FkConstraintColumn;
use UR;
our $VERSION = "0.44"; # UR $VERSION;
UR::Object::Type->define(
class_name => 'UR::DataSource::RDBMS::FkConstraintColumn',
is => ['UR::DataSource::RDBMS::Entity'],
dsmap => 'dd_fk_constraint_column',
er_role => 'bridge',
id_properties => [qw/data_source table_name fk_constraint_name column_name/],
properties => [
column_name => { type => 'varchar', len => undef, sql => 'column_name' },
data_source => { type => 'varchar', len => undef, sql => 'data_source' },
data_source_obj => { type => 'UR::DataSource', id_by => 'data_source'},
namespace => { calculate_from => [ 'data_source'],
calculate => q( (split(/::/,$data_source))[0] ) },
fk_constraint_name => { type => 'varchar', len => undef, sql => 'fk_constraint_name' },
table_name => { type => 'varchar', len => undef, sql => 'table_name' },
r_column_name => { type => 'varchar', len => undef, sql => 'r_column_name' },
r_table_name => { type => 'varchar', len => undef, sql => 'r_table_name' },
],
data_source => 'UR::DataSource::Meta',
);
1;
=pod
=head1 NAME
UR::DataSource::RDBMS::FkConstraintColumn - metadata about a data source's foreign keys
=head1 DESCRIPTION
This class represents the column linkages that make up a foreign key. Each
instance has a column_name (the source, where the foreign key points from)
and r_column_name (remote column name, where the fireign key points to),
as well as the source and remote table names.
=cut
Between.pm 100664 023532 023421 340 12544604516 21331 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/DataSource/RDBMS/Operator use strict;
use warnings;
package UR::DataSource::RDBMS::Operator::Between;
sub generate_sql_for {
my($class, $expr_sql, $val, $escape) = @_;
my $sql = "$expr_sql between ? and ?";
return ($sql, @$val);
}
1;
Equals.pm 100664 023532 023421 610 12544604516 21172 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/DataSource/RDBMS/Operator use strict;
use warnings;
package UR::DataSource::RDBMS::Operator::Equals;
sub generate_sql_for {
my($class, $expr_sql, $val, $escape) = @_;
my $sql;
my @sql_params;
if (UR::DataSource::RDBMS->_value_is_null($val)) {
$sql = "$expr_sql IS NULL";
} else {
$sql = "$expr_sql = ?";
@sql_params = ($val);
}
return ($sql, @sql_params);
}
1;
False.pm 100664 023532 023421 347 12544604516 21001 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/DataSource/RDBMS/Operator use strict;
use warnings;
package UR::DataSource::RDBMS::Operator::False;
sub generate_sql_for {
my($class, $expr_sql, $val, $escape) = @_;
my $sql = qq(( $expr_sql IS NULL or $expr_sql = 0 ));
return ($sql);
}
1;
GreaterOrEqual.pm 100664 023532 023421 333 12544604516 22624 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/DataSource/RDBMS/Operator use strict;
use warnings;
package UR::DataSource::RDBMS::Operator::GreaterOrEqual;
sub generate_sql_for {
my($class, $expr_sql, $val, $escape) = @_;
my $sql = "$expr_sql >= ?";
return ($sql, $val);
}
1;
GreaterThan.pm 100664 023532 023421 327 12544604516 22151 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/DataSource/RDBMS/Operator use strict;
use warnings;
package UR::DataSource::RDBMS::Operator::GreaterThan;
sub generate_sql_for {
my($class, $expr_sql, $val, $escape) = @_;
my $sql = "$expr_sql > ?";
return ($sql, $val);
}
1;
In.pm 100664 023532 023421 3166 12544604516 20337 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/DataSource/RDBMS/Operator use strict;
use warnings;
package UR::DataSource::RDBMS::Operator::In;
# This allows the size of an autogenerated IN-clause to be adjusted.
# The limit for Oracle is 1000, and a bug requires that, in some cases
# we drop to 250.
use constant IN_CLAUSE_SIZE_LIMIT => 250;
our @CARP_NOT = qw( UR::DataSource::RDBMS );
sub _negation_clause { '' }
sub generate_sql_for {
my($class, $expr_sql, $val, $escape) = @_;
unless (ref($val) eq 'ARRAY') {
$val = [$val];
}
unless (@$val) {
# an empty list was passed-in.
# since "in ()", like "where 1=0", is self-contradictory,
# there is no data to return, and no SQL required
Carp::carp("Null in-clause");
return;
}
my @list = do { no warnings 'uninitialized';
sort @$val; };
my $has_null = _list_contains_null(\@list);
my $wrap = ($has_null or @$val > IN_CLAUSE_SIZE_LIMIT ? 1 : 0);
my $cnt = 0;
my $sql = '';
$sql .= "\n(\n " if $wrap;
while (my @set = splice(@list,0,IN_CLAUSE_SIZE_LIMIT))
{
$sql .= "\n or " if $cnt++;
$sql .= $expr_sql
. $class->_negation_clause
. " in (" . join(",",map { UR::Util::sql_quote($_) } @set) . ")";
}
if ($has_null) {
$sql .= "\n or $expr_sql is "
. $class->_negation_clause
. ' null';
}
$sql .= "\n)\n" if $wrap;
return ($sql);
}
sub _list_contains_null {
my $list = shift;
foreach my $elt ( @$list ) {
if (! defined($elt)
or
length($elt) == 0
) {
return 1;
}
}
return '';
}
1;
LessOrEqual.pm 100664 023532 023421 330 12544604516 22136 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/DataSource/RDBMS/Operator use strict;
use warnings;
package UR::DataSource::RDBMS::Operator::LessOrEqual;
sub generate_sql_for {
my($class, $expr_sql, $val, $escape) = @_;
my $sql = "$expr_sql <= ?";
return ($sql, $val);
}
1;
LessThan.pm 100664 023532 023421 324 12544604516 21463 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/DataSource/RDBMS/Operator use strict;
use warnings;
package UR::DataSource::RDBMS::Operator::LessThan;
sub generate_sql_for {
my($class, $expr_sql, $val, $escape) = @_;
my $sql = "$expr_sql < ?";
return ($sql, $val);
}
1;
Like.pm 100664 023532 023421 417 12544604516 20631 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/DataSource/RDBMS/Operator use strict;
use warnings;
package UR::DataSource::RDBMS::Operator::Like;
sub generate_sql_for {
my($class, $expr_sql, $val, $escape) = @_;
my $sql = "$expr_sql like ?";
if ($escape) {
$sql .= " escape $escape";
}
return ($sql, $val);
}
1;
NotBetween.pm 100664 023532 023421 347 12544604516 22021 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/DataSource/RDBMS/Operator use strict;
use warnings;
package UR::DataSource::RDBMS::Operator::NotBetween;
sub generate_sql_for {
my($class, $expr_sql, $val, $escape) = @_;
my $sql = "$expr_sql not between ? and ?";
return ($sql, @$val);
}
1;
NotEquals.pm 100664 023532 023421 671 12544604516 21662 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/DataSource/RDBMS/Operator use strict;
use warnings;
package UR::DataSource::RDBMS::Operator::NotEquals;
sub generate_sql_for {
my($class, $expr_sql, $val, $escape) = @_;
my $sql;
my @sql_params;
if (UR::DataSource::RDBMS->_value_is_null($val)) {
$sql = "$expr_sql IS NOT NULL";
} else {
$sql = sprintf("( %s != ? or %s is null)", $expr_sql, $expr_sql);
@sql_params = ($val);
}
return ($sql, @sql_params);
}
1;
NotIn.pm 100664 023532 023421 274 12544604516 20775 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/DataSource/RDBMS/Operator use strict;
use warnings;
package UR::DataSource::RDBMS::Operator::NotIn;
use base 'UR::DataSource::RDBMS::Operator::In';
sub _negation_clause { ' not' }; # note the leading space
1;
NotLike.pm 100664 023532 023421 426 12544604516 21312 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/DataSource/RDBMS/Operator use strict;
use warnings;
package UR::DataSource::RDBMS::Operator::NotLike;
sub generate_sql_for {
my($class, $expr_sql, $val, $escape) = @_;
my $sql = "$expr_sql not like ?";
if ($escape) {
$sql .= " escape $escape";
}
return ($sql, $val);
}
1;
True.pm 100664 023532 023421 354 12544604516 20664 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/DataSource/RDBMS/Operator use strict;
use warnings;
package UR::DataSource::RDBMS::Operator::True;
sub generate_sql_for {
my($class, $expr_sql, $val, $escape) = @_;
my $sql = qq(( $expr_sql IS NOT NULL and $expr_sql != 0 ));
return ($sql);
}
1;
PkConstraintColumn.pm 100664 023532 023421 2774 12544604516 21777 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/DataSource/RDBMS use strict;
use warnings;
package UR::DataSource::RDBMS::PkConstraintColumn;
use UR;
our $VERSION = "0.44"; # UR $VERSION;
UR::Object::Type->define(
class_name => 'UR::DataSource::RDBMS::PkConstraintColumn',
is => ['UR::DataSource::RDBMS::Entity'],
dsmap => 'dd_pk_constraint_column',
er_role => '',
id_properties => [qw/data_source table_name column_name rank/],
properties => [
column_name => { type => 'varchar', len => undef, sql => 'column_name' },
data_source => { type => 'varchar', len => undef, sql => 'data_source' },
data_source_obj => { type => 'UR::DataSource', id_by => 'data_source'},
namespace => { calculate_from => [ 'data_source'],
calculate => q( (split(/::/,$data_source))[0] ) },
owner => { type => 'varchar', len => undef, is_optional => 1, sql => 'owner' },
rank => { type => 'integer', len => undef, sql => 'rank' },
table_name => { type => 'varchar', len => undef, sql => 'table_name' },
],
data_source => 'UR::DataSource::Meta',
);
1;
=pod
=head1 NAME
UR::DataSource::RDBMS::PkConstraintColumn - metadata about a data source's primary keys
=head1 DESCRIPTION
This class represents columns that make up a primary key. Tables with
multiple-column primary keys are ordered by their 'rank' property.
=cut
Table.pm 100664 023532 023421 15252 12544604516 17244 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/DataSource/RDBMS use strict;
use warnings;
package UR::DataSource::RDBMS::Table;
use UR;
our $VERSION = "0.44"; # UR $VERSION;
UR::Object::Type->define(
class_name => 'UR::DataSource::RDBMS::Table',
is => ['UR::DataSource::RDBMS::Entity'],
dsmap => 'dd_table',
id_properties => [qw/data_source table_name/],
properties => [
data_source => { type => 'varchar', len => undef, sql => 'data_source' },
data_source_obj => { type => 'UR::DataSource', id_by => 'data_source'},
namespace => { calculate_from => [ 'data_source'],
calculate => q( (split(/::/,$data_source))[0] ) },
owner => { type => 'varchar', len => undef, is_optional => 1, sql => 'owner' },
table_name => { type => 'varchar', len => undef, sql => 'table_name' },
er_type => { type => 'varchar', len => undef, sql => 'er_type', is_optional => 1 },
last_ddl_time => { type => 'timestamp', len => undef, sql => 'last_ddl_time', is_optional => 1 },
last_object_revision => { type => 'timestamp', len => undef, sql => 'last_object_revision' },
remarks => { type => 'varchar', len => undef, is_optional => 1, sql => 'remarks' },
table_type => { type => 'varchar', len => undef, sql => 'table_type' },
],
data_source => 'UR::DataSource::Meta',
);
sub _related_class_name {
my($self,$subject) = @_;
my $class = ref($self);
# FIXME This seems kinda braindead, but is probably faster than using s///
# Is it really the right thing?
my $pos = index($class, '::Table');
substr($class, $pos + 2, 5, $subject); # +2 to keep the "::"
return $class;
}
sub _fk_constraint_class {
return shift->_related_class_name('FkConstraint');
}
sub _pk_constraint_class {
return shift->_related_class_name('PkConstraintColumn');
}
sub _unique_constraint_class {
return shift->_related_class_name('UniqueConstraintColumn');
}
sub _table_column_class {
return shift->_related_class_name('TableColumn');
}
sub _bitmap_index_class {
return shift->_related_class_name('BitmapIndex');
}
sub columns {
my $self = shift;
my $col_class = $self->_table_column_class;
return $col_class->get(data_source => $self->data_source, table_name => $self->table_name);
}
sub column_names {
return map { $_->column_name } shift->columns;
}
sub primary_key_constraint_columns {
my $self = shift;
my $pk_class = $self->_pk_constraint_class;
my @pks = $pk_class->get(data_source => $self->data_source, table_name => $self->table_name);
my @pks_with_rank = map { [ $_->rank, $_ ] } @pks;
return map { $_->[1] }
sort { $a->[0] <=> $b->[0] }
@pks_with_rank;
}
sub primary_key_constraint_column_names {
return map { $_->column_name } shift->primary_key_constraint_columns;
}
sub fk_constraints {
my $self = shift;
my $fk_class = $self->_fk_constraint_class;
my @fks = $fk_class->get(data_source => $self->data_source, table_name => $self->table_name);
return @fks;
}
sub fk_constraint_names {
return map { $_->fk_constraint_name } shift->fk_constraints;
}
sub ref_fk_constraints {
my $self = shift;
my $fk_class = $self->_fk_constraint_class;
my @fks = $fk_class->get(data_source => $self->data_source, r_table_name => $self->table_name);
return @fks;
}
sub ref_fk_constraint_names {
return map { $_->fk_constraint_name } shift->ref_fk_constraints;
}
sub unique_constraint_column_names {
my($self,$constraint) = @_;
my @c;
if ($constraint) {
@c = $self->unique_constraints(constraint_name => $constraint);
} else {
@c = $self->unique_constraints();
}
my %names = map {$_->column_name => 1 } @c;
return keys %names;
}
sub unique_constraint_names {
my $self = shift;
my %names = map { $_->constraint_name => 1 } $self->unique_constraints;
return keys %names;
}
sub unique_constraints {
my $self = shift;
my $uc_class = $self->_unique_constraint_class;
my @c = $uc_class->get( data_source => $self->data_source, table_name => $self->table_name, @_);
return @c;
}
sub bitmap_indexes {
my $self = shift;
my $bi_class = $self->_bitmap_index_class;
my @bi = $bi_class->get(data_source => $self->data_source, table_name => $self->table_name);
return @bi;
}
sub bitmap_index_names {
return map { $_->bitmap_index_name } shift->bitmap_indexes;
}
# FIXME Due to a "bug" in getting class objects, you need to pass in namespace => 'name' as
# arguments to get this to work.
sub handler_class {
my $self = shift;
return UR::Object::Type->get(table_name => $self->table_name, @_);
}
sub handler_class_name {
my $self = shift;
return $self->handler_class(@_)->class_name;
}
sub delete {
my $self = shift;
my @deleteme = ( $self->fk_constraints,
$self->bitmap_indexes,
$self->primary_key_constraint_columns,
$self->columns,
);
for my $obj ( @deleteme ) {
$obj->delete;
unless ($obj->isa('UR::DeletedRef')) {
Carp::confess("Failed to delete $obj ".$obj->{'id'});
}
}
$self->SUPER::delete();
return $self;
}
1;
=pod
=head1 NAME
UR::DataSource::Meta::RDBMS::Table - Object-oriented class for RDBMS table objects.
=head1 SYNOPSIS
$t = UR::DataSource::Meta::RDBMS::Table->get(
data_source => 'Namespace::DataSource::Name',
table_name => 'MY_TABLE_NAME');
@c = $t->column_names;
@f = $t->fk_constraint_names;
=head1 DESCRIPTION
Objects of this class represent a table in a database. They are
primarily used by the class updating logic in the command line tool
C, but can be retrieved and used in any application.
Their instances come from from the MetaDB (L) which
is partitioned and has one physical database per Namespace.
=head2 Related Metadata Methods
=over 4
=item @col_objs = $t->columns();
=item @col_names = $t->column_names();
=item @fk_objs = $t->fk_constraints();
=item @fk_names = $t->fk_constraint_names();
=item @ref_fk_objs = $t->ref_fk_constraints();
=item @ref_fk_names = $t->ref_fk_constraint_names();
=item @pk_objs = $t->primary_key_constraint_columns();
=item @pk_col_names = $t->primary_key_constraint_column_names();
=item @bi_objs = $t->bitmap_indexes();
=item @bi_names = $t->bitmap_index_names();
Return related metadata objects (or names) for the given table object.
=back
=cut
Text.pm 100664 023532 023421 1161 12544604516 22440 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/DataSource/RDBMS/Table/View/Default package UR::DataSource::RDBMS::Table::View::Default::Text;
use strict;
use warnings;
require UR;
our $VERSION = "0.44"; # UR $VERSION;
UR::Object::Type->define(
class_name => __PACKAGE__,
is => 'UR::Object::View::Default::Text',
has_many => [
default_aspects => { is => 'ARRAY', is_constant => 1, value => ['table_name', 'data_source', 'column_names'] },
],
);
1;
=pod
=head1 NAME
UR::DataSource::RDBMS::Table::View::Default::Text - View class for RDBMS table objects
=head1 DESCRIPTION
This class defines a text-mode view for RDBMS table objects, and is used by
the 'ur info' command.
=cut
TableColumn.pm 100664 023532 023421 7254 12544604516 20405 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/DataSource/RDBMS use strict;
use warnings;
package UR::DataSource::RDBMS::TableColumn;
use UR;
our $VERSION = "0.44"; # UR $VERSION;
UR::Object::Type->define(
class_name => 'UR::DataSource::RDBMS::TableColumn',
is => ['UR::DataSource::RDBMS::Entity'],
dsmap => 'dd_table_column',
er_role => '',
id_properties => [qw/data_source table_name column_name/],
properties => [
column_name => { type => 'varchar', len => undef, sql => 'column_name' },
data_source => { type => 'varchar', len => undef, sql => 'data_source' },
data_source_obj => { type => 'UR::DataSource', id_by => 'data_source'},
namespace => { calculate_from => [ 'data_source'],
calculate => q( (split(/::/,$data_source))[0] ) },
owner => { type => 'varchar', len => undef, is_optional => 1, sql => 'owner' },
table_name => { type => 'varchar', len => undef, sql => 'table_name' },
data_length => { type => 'varchar', len => undef, is_optional => 1, sql => 'data_length' },
data_type => { type => 'varchar', len => undef, sql => 'data_type' },
last_object_revision => { type => 'timestamp', len => undef, sql => 'last_object_revision' },
nullable => { type => 'varchar', len => undef, sql => 'nullable' },
remarks => { type => 'varchar', len => undef, is_optional => 1, sql => 'remarks' },
],
data_source => 'UR::DataSource::Meta',
);
# Methods moved over from the old App::DB::TableColumn
sub _fk_constraint_class {
my $self = shift;
if (ref($self) =~ /::Ghost$/) {
return "UR::DataSource::RDBMS::FkConstraint::Ghost"
}
else {
return "UR::DataSource::RDBMS::FkConstraint"
}
}
sub get_table {
my $self = shift;
my $table_name = $self->table_name;
my $data_source = $self->data_source;
$data_source or Carp::confess("Can't determine data_source for table $table_name column ".$self->column_name );
my $table =
UR::DataSource::RDBMS::Table->get(table_name => $table_name, data_source => $data_source)
||
UR::DataSource::RDBMS::Table::Ghost->get(table_name => $table_name, data_source => $data_source);
return $table;
}
sub fk_constraint_names {
my @fks = shift->fk_constraints;
return map { $_->fk_constraint_name } @fks;
}
sub fk_constraints {
my $self = shift;
my $fk_class = $self->_fk_constraint_class();
my @fks = $fk_class->get(table_name => $self->table_name,
data_source => $self->data_source);
return @fks;
}
sub bitmap_index_names {
Carp::confess("not implemented yet?!");
}
# the update classes code uses this. If the data type of a column is a time-ish format, then
# the data_length reported by the schema is the number of bytes used internally by the DB.
# Since the UR-object will store the time in text format, it will always be longer than
# that. To keep $obj->__errors__ from complaining, don't even bother storing the length of
# time-ish data
sub is_time_data {
my $self = shift;
my $type = $self->data_type;
if ($type =~ m/TIMESTAMP|DATE|INTERVAL/i) {
return 1;
} else {
return;
}
}
1;
=pod
=head1 NAME
UR::DataSource::RDBMS::TableColumn - metadata about a data source's table's columns
=head1 DESCRIPTION
This class represents instances of columns in a data source's tables. They are
maintained by 'ur update classes' and stored in the namespace's MetaDB.
=cut
Text.pm 100664 023532 023421 1216 12544604516 23617 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/DataSource/RDBMS/TableColumn/View/Default package UR::DataSource::RDBMS::TableColumn::View::Default::Text;
use strict;
use warnings;
require UR;
our $VERSION = "0.44"; # UR $VERSION;
UR::Object::Type->define(
class_name => __PACKAGE__,
is => 'UR::Object::View::Default::Text',
has => [
default_aspects => { is => 'ARRAY', is_constant => 1, value => ['column_name', 'table_name', 'data_type', 'length', 'nullable'] },
],
);
1;
=pod
=head1 NAME
UR::DataSource::RDBMS::TableColumn::View::Default::Text - View class for RDBMS column objects
=head1 DESCRIPTION
This class defines a text-mode view for RDBMS column objects, and is used by
the 'ur info' command.
=cut
UniqueConstraintColumn.pm 100664 023532 023421 3261 12544604516 22663 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/DataSource/RDBMS use strict;
use warnings;
package UR::DataSource::RDBMS::UniqueConstraintColumn;
use UR;
our $VERSION = "0.44"; # UR $VERSION;
UR::Object::Type->define(
class_name => 'UR::DataSource::RDBMS::UniqueConstraintColumn',
is => ['UR::DataSource::RDBMS::Entity'],
dsmap => 'dd_unique_constraint_column',
id_properties => [qw/data_source table_name constraint_name column_name/],
properties => [
data_source => { type => 'varchar', len => undef, sql => 'data_source' },
data_source_obj => { type => 'UR::DataSource', id_by => 'data_source'},
namespace => { calculate_from => [ 'data_source'],
calculate => q( (split(/::/,$data_source))[0] ) },
owner => { type => 'varchar', len => undef, sql => 'owner', is_optional => 1 },
table_name => { type => 'varchar', len => undef, sql => 'table_name' },
constraint_name => { type => 'varchar', len => undef, sql => 'constraint_name' },
column_name => { type => 'varchar', len => undef, sql => 'column_name' },
],
data_source => 'UR::DataSource::Meta',
);
1;
=pod
=head1 NAME
UR::DataSource::RDBMS::UniqueConstraintColumn - metadata about a data source's unique constraints
=head1 DESCRIPTION
This class represents instances of unique constraints in a data source. They are
maintained by 'ur update classes' and stored in the namespace's MetaDB.
Multi-column unique constraints are represented by instances having the same
table_name and constraint_name, but different column_names.
=cut
RDBMSRetriableOperations.pm 100664 023532 023421 11374 12544604516 22114 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/DataSource package UR::DataSource::RDBMSRetriableOperations;
use strict;
use warnings;
use Time::HiRes;
# A mixin class that provides methods to retry queries and syncs
#
# Consumers should provide should_retry_operation_after_error().
# It's passed the SQL that generated the error and the DBI error string.
# It should return true if the operation generating that error should be
# retried.
class UR::DataSource::RDBMSRetriableOperations {
has_optional => [
retry_sleep_start_sec => { is => 'Integer', value => 1, doc => 'Initial inter-error sleep time' },
retry_sleep_max_sec => { is => 'Integer', value => 3600, doc => 'Maximum inter-error sleep time' },
],
valid_signals => ['retry']
};
# The guts of the thing. Consumers that want a base-datasource method to
# be retriable should override the method to call this instead, and pass
# a code ref to perform the retriable action
sub _retriable_operation {
my $self = UR::Util::object(shift);
my $code = shift;
$self->_make_retriable_operation_observer();
RETRY_LOOP:
for( my $db_retry_sec = $self->retry_sleep_start_sec;
$db_retry_sec < $self->retry_sleep_max_sec;
$db_retry_sec *= 2
) {
my @rv = eval { $code->(); };
if ($@) {
if ($@ =~ m/DB_RETRY/) {
$self->error_message("DB_RETRY");
$self->debug_message("Disconnecting and sleeping for $db_retry_sec seconds...\n");
$self->disconnect_default_handle;
Time::HiRes::sleep($db_retry_sec);
$self->__signal_observers__('retry', $db_retry_sec);
next RETRY_LOOP;
}
Carp::croak($@); # re-throw other exceptions
}
return $self->context_return(@rv);
}
die "Maximum database retries reached";
}
{
my %retry_observers;
sub _make_retriable_operation_observer {
my $self = shift;
unless ($retry_observers{$self->class}++) {
for (qw(query_failed commit_failed do_failed connect_failed sequence_nextval_failed)) {
$self->add_observer(
aspect => $_,
priority => 99999, # Super low priority to fire last
callback => \&_db_retry_observer,
);
}
}
}
}
# Default is to not retry
sub should_retry_operation_after_error {
my($self, $sql, $dbi_errstr) = @_;
return 0;
}
# The callback for the retry observer
sub _db_retry_observer {
my($self, $aspect, $db_operation, $sql, $dbi_errstr) = @_;
unless (defined $sql) {
$sql = '(no sql)';
}
$self->error_message("SQL failed during $db_operation\nerror: $dbi_errstr\nsql: $sql");
die "DB_RETRY" if $self->should_retry_operation_after_error($sql, $dbi_errstr);
# just fall off the end here...
# Code triggering the observer will throw an exception
}
# Searches the parentage of $self for a RDBMS datasource class
# and returns a ref to the named sub in that package
# This is necessary because we're using a mixin class and not
# a real role
my %cached_rdbms_datasource_method_for;
sub rdbms_datasource_method_for {
my $self = shift;
my $method = shift;
my $target_class_name = shift;
$target_class_name ||= $self->class;
if ($cached_rdbms_datasource_method_for{$target_class_name}) {
return $cached_rdbms_datasource_method_for{$target_class_name}->can($method);
}
foreach my $parent_class_name ( $target_class_name->__meta__->parent_class_names ) {
if ( $parent_class_name->isa('UR::DataSource::RDBMS') ) {
if ($parent_class_name->isa(__PACKAGE__) ) {
if (my $sub = $self->rdbms_datasource_method_for($method, $parent_class_name)) {
return $sub;
}
} else {
$cached_rdbms_datasource_method_for{$target_class_name} = $parent_class_name;
return $parent_class_name->can($method);
}
}
}
return;
}
# The retriable methods we want to wrap
foreach my $parent_method (qw(
create_iterator_closure_for_rule
create_default_handle
_sync_database
do_sql
autogenerate_new_object_id_for_class_name_and_rule
)) {
my $override = sub {
my $self = shift;
my @params = @_;
# Installing this as the $parent_method leads to infinte recursion if
# the parent does not directly inherit this class.
use warnings FATAL => qw( recursion );
my $parent_sub ||= $self->rdbms_datasource_method_for($parent_method);
$self->_retriable_operation(sub {
$self->$parent_sub(@params);
});
};
Sub::Install::install_sub({
into => __PACKAGE__,
as => $parent_method,
code => $override,
});
}
1;
SQLite.pm 100664 023532 023421 107123 12544604516 16526 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/DataSource package UR::DataSource::SQLite;
use strict;
use warnings;
use IO::Dir;
use File::Spec;
use File::Basename;
use version;
=pod
=head1 NAME
UR::DataSource::SQLite - base class for datasources using the SQLite3 RDBMS
=head1 SYNOPSIS
In the shell:
ur define datasource sqlite
Or write the singleton to represent the source directly:
class Acme::DataSource::MyDB1 {
is => 'UR::DataSource::SQLite',
has_constant => [
server => '/var/lib/acme-app/mydb1.sqlitedb'
]
};
You may also use a directory containing *.sqlite3 files. The primary database
must be named main.sqlite3. All the other *.sqlite3 files are attached when
the database is opened.
class Acme::DataSource::MyDB2 {
is => 'UR::DataSource::SQLite',
has_constant => [
server => '/path/to/directory/'
]
};
=cut
require UR;
our $VERSION = "0.44"; # UR $VERSION;
UR::Object::Type->define(
class_name => 'UR::DataSource::SQLite',
is => ['UR::DataSource::RDBMS'],
is_abstract => 1,
);
# RDBMS API
sub driver { "SQLite" }
sub default_owner {
return 'main';
}
sub owner { default_owner() }
sub login {
undef
}
sub auth {
undef
}
sub create_default_handle {
my $self = shift->_singleton_object();
$self->_init_database;
if ($self->_db_path_specifies_a_directory($self->server)) {
return $self->_create_default_handle_from_directory();
} else {
return $self->SUPER::create_default_handle(@_);
}
}
sub _create_default_handle_from_directory {
my $self = shift;
my $server_directory = $self->server;
my $ext = $self->_extension_for_db;
my $main_schema_file = File::Spec->catfile($server_directory, "main${ext}");
-f $main_schema_file
|| UR::Util::touch_file($main_schema_file)
|| die "Could not create main schema file $main_schema_file: $!";
my $server_sub_name = join('::', ref($self), 'server');
my $dbh = do {
no strict 'refs';
no warnings 'redefine';
local *$server_sub_name = sub { $main_schema_file };
$self->SUPER::create_default_handle();
};
$self->_attach_all_schema_files_in_directory($dbh, $server_directory);
return $dbh;
}
sub _attach_all_schema_files_in_directory {
my($self, $dbh, $server_directory) = @_;
my @schema_files = $self->_schema_files_in_directory($server_directory);
local $dbh->{AutoCommit} = 1;
my $main_db_file = join('', 'main', $self->_extension_for_db);
foreach my $file ( @schema_files ) {
next if $file eq $main_db_file;
my $schema = $self->_schema_from_schema_filename($file);
my $pathname = File::Spec->catfile($server_directory, $file);
$dbh->do("ATTACH DATABASE '$pathname' as $schema")
|| Carp::croak("Could not attach schema file $file: ".$dbh->errstr);
}
}
sub _schema_files_in_directory {
my($self, $dir) = @_;
my $dh = IO::Dir->new($dir);
my @files;
while (my $name = $dh->read) {
my $pathname = File::Spec->catfile($dir, $name);
next unless -f $pathname;
push(@files, $name) if $self->_schema_from_schema_filename($name);
}
return @files;
}
sub _schema_from_schema_filename {
my($self, $pathname) = @_;
my($schema, $dir, $ext) = File::Basename::fileparse($pathname, $self->_extension_for_db);
return $ext ? $schema : undef;
}
sub database_exists {
my $self = shift;
return 1 if -e $self->server;
return 1 if -e $self->_data_dump_path; # exists virtually, and will dynamicaly instantiate
return;
}
sub create_database {
my $self = shift;
die "Database exists!" if $self->database_exists;
my $path = $self->server;
return 1 if IO::File->new(">$path");
}
sub can_savepoint { 0;} # Dosen't support savepoints
# SQLite API
sub _schema_path {
return shift->_database_file_path() . '-schema';
}
sub _data_dump_path {
return shift->_database_file_path() . '-dump';
}
# FIXME is there a way to make this an object parameter instead of a method
sub server {
my $self = shift->_singleton_object();
my $path = $self->__meta__->module_path;
my $ext = $self->_extension_for_db;
$path =~ s/\.pm$/$ext/ or Carp::croak("Odd module path $path. Expected something endining in '.pm'");
my $dir = File::Basename::dirname($path);
return $path;
}
*_database_file_path = \&server;
sub _extension_for_db {
'.sqlite3';
}
sub _journal_file_path {
my $self = shift->_singleton_object();
return $self->server . "-journal";
}
sub _init_database {
my $self = shift->_singleton_object();
my $db_file = $self->server;
my $dump_file = $self->_data_dump_path;
my $schema_file = $self->_schema_path;
my $db_time = (stat($db_file))[9];
my $dump_time = (stat($dump_file))[9];
my $schema_time = (stat($schema_file))[9];
if ($schema_time && ((-e $db_file and $schema_time > $db_time) or (-e $dump_file and $schema_time > $dump_time))) {
$self->warning_message("Schema file is newer than the db file or the dump file. Replacing db_file $db_file.");
my $dbbak_file = $db_file . '-bak';
my $dumpbak_file = $dump_file . '-bak';
unlink $dbbak_file if -e $dbbak_file;
unlink $dumpbak_file if -e $dumpbak_file;
rename $db_file, $dbbak_file if -e $db_file;
rename $dump_file, $dumpbak_file if -e $dump_file;
if (-e $db_file) {
Carp::croak "Failed to move out-of-date file $db_file out of the way for reconstruction! $!";
}
if (-e $dump_file) {
Carp::croak "Failed to move out-of-date file $dump_file out of the way for reconstruction! $!";
}
}
if (-e $db_file) {
if ($dump_time && ($db_time < $dump_time)) {
my $bak_file = $db_file . '-bak';
$self->warning_message("Dump file is newer than the db file. Replacing db_file $db_file.");
unlink $bak_file if -e $bak_file;
rename $db_file, $bak_file;
if (-e $db_file) {
Carp::croak "Failed to move out-of-date file $db_file out of the way for reconstruction! $!";
}
}
}
# NOTE: don't make this an "else", since we might go into both branches because we delete the file above.
unless (-e $db_file) {
# initialize a new database from the one in the base class
# should this be moved to connect time?
# TODO: auto re-create things as needed based on timestamp
if (-e $dump_file) {
# create from dump
$self->warning_message("Re-creating $db_file from $dump_file.");
$self->_load_db_from_dump_internal($dump_file);
unless (-e $db_file) {
Carp::croak("Failed to import $dump_file into $db_file!");
}
}
elsif ( (not -e $db_file) and (-e $schema_file) ) {
# create from schema
$self->warning_message("Re-creating $db_file from $schema_file.");
$self->_load_db_from_dump_internal($schema_file);
unless (-e $db_file) {
Carp::croak("Failed to import $dump_file into $db_file!");
}
}
elsif ($self->class ne __PACKAGE__) {
# copy from the parent class (disabled)
Carp::croak("No schema or dump file found for $db_file.\n Tried schema path $schema_file\n and dump path $dump_file\nIf you still have *sqlite3n* SQLite database files please rename them to *sqlite3*, without the 'n'");
my $template_database_file = $self->SUPER::server();
unless (-e $template_database_file) {
Carp::croak("Missing template database file: $db_file! Cannot initialize database for " . $self->class);
}
unless(File::Copy::copy($template_database_file,$db_file)) {
Carp::croak("Error copying $db_file to $template_database_file to initialize database!");
}
unless(-e $db_file) {
Carp::croak("File $db_file not found after copy from $template_database_file. Cannot initialize database!");
}
}
else {
Carp::croak("No db file found, and no dump or schema file found from which to re-construct a db file!");
}
}
return 1;
}
*_init_created_dbh = \&init_created_handle;
sub init_created_handle
{
my ($self, $dbh) = @_;
return unless defined $dbh;
$dbh->{LongTruncOk} = 0;
# wait one minute busy timeout
$dbh->func(1800000,'busy_timeout');
return $dbh;
}
sub _ignore_table {
my $self = shift;
my $table_name = shift;
return 1 if $table_name =~ /^(sqlite|\$|URMETA)/;
}
sub _get_sequence_name_for_table_and_column {
my $self = shift->_singleton_object;
my ($table_name,$column_name) = @_;
my $dbh = $self->get_default_handle();
# See if the sequence generator "table" is already there
my $seq_table = sprintf('URMETA_%s_%s_seq', $table_name, $column_name);
unless ($self->{'_has_sequence_generator'}->{$seq_table} or
grep {$_ eq $seq_table} $self->get_table_names() ) {
unless ($dbh->do("CREATE TABLE IF NOT EXISTS $seq_table (next_value integer PRIMARY KEY AUTOINCREMENT)")) {
die "Failed to create sequence generator $seq_table: ".$dbh->errstr();
}
}
$self->{'_has_sequence_generator'}->{$seq_table} = 1;
return $seq_table;
}
sub _get_next_value_from_sequence {
my($self,$sequence_name) = @_;
my $dbh = $self->get_default_handle();
# FIXME can we use a statement handle with a wildcard as the table name here?
unless ($dbh->do("INSERT into $sequence_name values(null)")) {
die "Failed to INSERT into $sequence_name during id autogeneration: " . $dbh->errstr;
}
my $new_id = $dbh->last_insert_id(undef,undef,$sequence_name,'next_value');
unless (defined $new_id) {
die "last_insert_id() returned undef during id autogeneration after insert into $sequence_name: " . $dbh->errstr;
}
unless($dbh->do("DELETE from $sequence_name where next_value = $new_id")) {
die "DELETE from $sequence_name for next_value $new_id failed during id autogeneration";
}
return $new_id;
}
# Overriding this so we can force the schema to 'main' for older versions of SQLite
#
# NOTE: table_info (called by SUPER::get_table_details_from_data_dictionary) in older
# versions of DBD::SQLite does not return data for tables in other attached databases.
#
# This probably isn't an issue... Due to the limited number of people using older DBD::SQLite
# (of particular note is that OSX 10.5 and earlier use such an old version), interseted with
# the limited number of people using attached databases, it's probably not a problem.
# The commit_between_schemas test does do this. If it turns out it is a problem, we could
# appropriate the code from recent DBD::SQLite::table_info
sub get_table_details_from_data_dictionary {
my $self = shift;
my $sth = $self->SUPER::get_table_details_from_data_dictionary(@_);
my $sqlite_version = version->parse($DBD::SQLite::VERSION);
my $needed_version = version->parse("1.26_04");
if ($sqlite_version >= $needed_version || !$sth) {
return $sth;
}
my($catalog,$schema,$table_name) = @_;
my @tables;
my @returned_names;
while (my $info = $sth->fetchrow_hashref()) {
#@returned_names ||= (keys %$info);
unless (@returned_names) {
@returned_names = keys(%$info);
}
$info->{'TABLE_SCHEM'} ||= 'main';
push @tables, $info;
}
my $dbh = $self->get_default_handle();
my $sponge = DBI->connect("DBI:Sponge:", '','')
or return $dbh->DBI::set_err($DBI::err, "DBI::Sponge: $DBI::errstr");
unless (@returned_names) {
@returned_names = qw( TABLE_CAT TABLE_SCHEM TABLE_NAME TABLE_TYPE REMARKS );
}
my $returned_sth = $sponge->prepare("table_info $table_name", {
rows => [ map { [ @{$_}{@returned_names} ] } @tables ],
NUM_OF_FIELDS => scalar @returned_names,
NAME => \@returned_names,
}) or return $dbh->DBI::set_err($sponge->err(), $sponge->errstr());
return $returned_sth;
}
# DBD::SQLite doesn't implement column_info. This is the UR::DataSource version of the same thing
sub get_column_details_from_data_dictionary {
my($self,$catalog,$schema,$table,$column) = @_;
my $dbh = $self->get_default_handle();
# Convert the SQL wildcards to regex wildcards
$column = '' unless defined $column;
$column =~ s/%/.*/;
$column =~ s/_/./;
my $column_regex = qr(^$column$);
my $sth_tables = $dbh->table_info($catalog, $schema, $table, 'TABLE');
my @table_names = map { $_->{'TABLE_NAME'} } @{ $sth_tables->fetchall_arrayref({}) };
my $override_owner;
if ($DBD::SQLite::VERSION < 1.26_04) {
$override_owner = 'main';
}
my @columns;
foreach my $table_name ( @table_names ) {
my $sth = $dbh->prepare("PRAGMA table_info($table_name)")
or return $dbh->DBI::set_err($DBI::err, "DBI::Sponge: $DBI::errstr");
$sth->execute() or return $dbh->DBI::set_err($DBI::err, "DBI::Sponge: $DBI::errstr");
while (my $info = $sth->fetchrow_hashref()) {
next unless $info->{'name'} =~ m/$column_regex/;
# SQLite doesn't parse our that type varchar(255) actually means type varchar size 255
my $data_type = $info->{'type'};
my $column_size;
if ($data_type =~ m/(\S+)\s*\((\S+)\)/) {
$data_type = $1;
$column_size = $2;
}
my $node = {};
$node->{'TABLE_CAT'} = $catalog;
$node->{'TABLE_SCHEM'} = $schema || $override_owner;
$node->{'TABLE_NAME'} = $table_name;
$node->{'COLUMN_NAME'} = $info->{'name'};
$node->{'DATA_TYPE'} = $data_type;
$node->{'TYPE_NAME'} = $data_type;
$node->{'COLUMN_SIZE'} = $column_size;
$node->{'NULLABLE'} = ! $info->{'notnull'};
$node->{'IS_NULLABLE'} = ($node->{'NULLABLE'} ? 'YES' : 'NO');
$node->{'REMARKS'} = "";
$node->{'SQL_DATA_TYPE'} = ""; # FIXME shouldn't this be something related to DATA_TYPE
$node->{'SQL_DATETIME_SUB'} = "";
$node->{'CHAR_OCTET_LENGTH'} = undef; # FIXME this should be the same as column_size, right?
$node->{'ORDINAL_POSITION'} = $info->{'cid'};
$node->{'COLUMN_DEF'} = $info->{'dflt_value'};
# Remove starting and ending 's that appear erroneously with string default values
$node->{'COLUMN_DEF'} =~ s/^'|'$//g if defined ( $node->{'COLUMN_DEF'});
push @columns, $node;
}
}
my $sponge = DBI->connect("DBI:Sponge:", '','')
or return $dbh->DBI::set_err($DBI::err, "DBI::Sponge: $DBI::errstr");
my @returned_names = qw( TABLE_CAT TABLE_SCHEM TABLE_NAME COLUMN_NAME DATA_TYPE TYPE_NAME COLUMN_SIZE
BUFFER_LENGTH DECIMAL_DIGITS NUM_PREC_RADIX NULLABLE REMARKS COLUMN_DEF
SQL_DATA_TYPE SQL_DATETIME_SUB CHAR_OCTET_LENGTH ORDINAL_POSITION IS_NULLABLE );
my $returned_sth = $sponge->prepare("column_info $table", {
rows => [ map { [ @{$_}{@returned_names} ] } @columns ],
NUM_OF_FIELDS => scalar @returned_names,
NAME => \@returned_names,
}) or return $dbh->DBI::set_err($sponge->err(), $sponge->errstr());
return $returned_sth;
}
# SQLite doesn't store the name of a foreign key constraint in its metadata directly.
# We can guess at it from the SQL used in the table creation. These regexes are probably
# sloppy. We could replace them if there were a good SQL parser.
sub _resolve_fk_name {
my($self, $table_name, $column_list, $r_table_name, $r_column_list) = @_;
if (@$column_list != @$r_column_list) {
Carp::confess('There are '.scalar(@$column_list).' pk columns and '.scalar(@$r_column_list).' fk columns');
}
my($table_info) = $self->_get_info_from_sqlite_master($table_name, 'table');
return unless $table_info;
my $col_str = $table_info->{'sql'};
$col_str =~ s/^\s+|\s+$//g; # Remove leading and trailing whitespace
$col_str =~ s/\s{2,}/ /g; # Remove multiple spaces
if ($col_str =~ m/^CREATE TABLE (\w+)\s*?\((.*?)\)$/is) {
unless ($1 eq $table_name) {
Carp::croak("Table creation SQL for $table_name is inconsistent. Didn't find table name '$table_name' in string '$col_str'. Found $1 instead.");
}
$col_str = $2;
} else {
Carp::croak("Couldn't parse SQL for $table_name");
}
my $fk_name;
if (@$column_list > 1) {
# Multiple column FKs must be specified as a table-wide constraint, and has a well-known format
my $fk_list = '\s*' . join('\s*,\s*', @$column_list) . '\s*';
my $uk_list = '\s*' . join('\s*,\s*', @$r_column_list) . '\s*';
my $expected_to_find = sprintf('FOREIGN KEY\s*\(%s\) REFERENCES %s\s*\(%s\)',
$fk_list,
$r_table_name,
$uk_list);
my $regex = qr($expected_to_find)i;
if ($col_str =~ m/$regex/) {
($fk_name) = ($col_str =~ m/CONSTRAINT (\w+) FOREIGN KEY\s*\($fk_list\)/i);
} else {
# Didn't find anything...
return;
}
} else {
# single-column FK constraints can be specified a couple of ways...
# First, try as a table-wide constraint
my $col = $column_list->[0];
my $r_col = $r_column_list->[0];
if ($col_str =~ m/FOREIGN KEY\s*\($col\)\s*REFERENCES $r_table_name\s*\($r_col\)/i) {
($fk_name) = ($col_str =~ m/CONSTRAINT\s+(\w+)\s+FOREIGN KEY\s*\($col\)/i);
} else {
while ($col_str) {
# Try parsing each of the column definitions
# commas can't appear in here except to separate each column, right?
my $this_col;
if ($col_str =~ m/^(.*?)\s*,\s*(.*)/) {
$this_col = $1;
$col_str = $2;
} else {
$this_col = $col_str;
$col_str = '';
}
my($col_name, $col_type) = ($this_col =~ m/^(\w+) (\w+)/);
next unless ($col_name and
$col_name eq $col);
if ($this_col =~ m/REFERENCES $r_table_name\s*\($r_col\)/i) {
# It's the right column, and there's a FK constraint on it
# Did the FK get a name?
($fk_name) = ($this_col =~ m/CONSTRAINT (\w+) REFERENCES/i);
last;
} else {
# It's the right column, but there's no FK
return;
}
}
}
}
# The constraint didn't have a name. Make up something that'll likely be unique
$fk_name ||= join('_', $table_name, @$column_list, $r_table_name, @$r_column_list, 'fk');
return $fk_name;
}
# We'll only support specifying $fk_table or $pk_table but not both
# $fk_table refers to the table where the fk is attached
# $pk_table refers to the table the pk points to - where the primary key exists
sub get_foreign_key_details_from_data_dictionary {
my($self, $pk_catalog, $pk_schema, $pk_table, $fk_catalog, $fk_schema, $fk_table) = @_;
# first, build a data structure to collect columns of the same foreign key together
my @returned_fk_info;
if ($fk_table) {
@returned_fk_info = $self->_get_foreign_key_details_for_fk_table_name($fk_schema, $fk_table);
} elsif ($pk_table) {
# We'll have to loop through each table in the DB and find FKs that reference
# the named table
my @tables = $self->_get_info_from_sqlite_master(undef,'table');
TABLE:
foreach my $table_data ( @tables ) {
my $from_table = $table_data->{'table_name'};
push @returned_fk_info, $self->_get_foreign_key_details_for_fk_table_name($fk_schema, $from_table, sub { $_[0]->{table} eq $pk_table });
}
} else {
Carp::croak("Can't get_foreign_key_details_from_data_dictionary(): either pk_table ($pk_table) or fk_table ($fk_table) are required");
}
my $dbh = $self->get_default_handle;
my $sponge = DBI->connect("DBI:Sponge:", '','')
or return $dbh->DBI::set_err($DBI::err, "DBI::Sponge: $DBI::errstr");
my @returned_names = qw( UK_TABLE_CAT UK_TABLE_SCHEM UK_TABLE_NAME UK_COLUMN_NAME
FK_TABLE_CAT FK_TABLE_SCHEM FK_TABLE_NAME FK_COLUMN_NAME
ORDINAL_POSITION UPDATE_RULE DELETE_RULE FK_NAME UK_NAME DEFERABILITY );
my $table = $pk_table || $fk_table;
my $returned_sth = $sponge->prepare("foreign_key_info $table", {
rows => [ map { [ @{$_}{@returned_names} ] } @returned_fk_info ],
NUM_OF_FIELDS => scalar @returned_names,
NAME => \@returned_names,
}) or return $dbh->DBI::set_err($sponge->err(), $sponge->errstr());
return $returned_sth;
}
# used by _get_foreign_key_details_for_fk_table_name to convert the on_delete or on_update
# string into the number code commonly returnd by DBI
my %update_delete_action_to_numeric_code = (
CASCADE => 0,
RESTRICT => 1,
'SET NULL' => 2,
'NO ACTION' => 3,
'SET DEFAULT' => 4,
);
sub _get_foreign_key_details_for_fk_table_name {
my($self, $fk_schema_name, $fk_table_name, $accept_rows) = @_;
$accept_rows ||= sub { 1 }; # default is accept all
$fk_schema_name ||= 'main';
my $qualified_table_name = join('.', $fk_schema_name, $fk_table_name);
my $dbh = $self->get_default_handle;
my $fksth = $dbh->prepare("PRAGMA foreign_key_list($fk_table_name)")
or return $dbh->DBI::set_err($DBI::err, "DBI::Sponge: $DBI::errstr");
unless ($fksth->execute()) {
$self->error_message("foreign_key_list execute failed: $DBI::errstr");
return;
}
my @fk_rows_this_table;
my(@column_list, @r_column_list);
while (my $row = $fksth->fetchrow_hashref) {
next unless ($accept_rows->($row));
my %fk_info_row = ( FK_TABLE_NAME => $fk_table_name,
FK_TABLE_SCHEM => $fk_schema_name,
UK_TABLE_SCHEM => $fk_schema_name, # SQLite doesn't tell us what attached DB it's from, so we'll guess
UPDATE_RULE => $update_delete_action_to_numeric_code{$row->{on_update}},
DELETE_RULE => $update_delete_action_to_numeric_code{$row->{on_delete}},
ORDINAL_POSITION => $row->{seq} + 1,
);
@fk_info_row{'FK_COLUMN_NAME','UK_TABLE_NAME','UK_COLUMN_NAME'}
= @$row{'from','table','to'};
push @fk_rows_this_table, \%fk_info_row;
push @column_list, $row->{from};
push @r_column_list, $row->{to}
}
if (@fk_rows_this_table) {
my $fk_name = $self->_resolve_fk_name($fk_rows_this_table[0]->{FK_TABLE_NAME},
\@column_list,
$fk_rows_this_table[0]->{UK_TABLE_NAME}, # They'll all have the same table, right?
\@r_column_list);
foreach my $fk_info_row ( @fk_rows_this_table ) {
$fk_info_row->{FK_NAME} = $fk_name;
}
@fk_rows_this_table = sort { $a->{ORDINAL_POSITION} <=> $b->{ORDINAL_POSITION} } @fk_rows_this_table;
}
return @fk_rows_this_table;
}
sub get_bitmap_index_details_from_data_dictionary {
# SQLite dosen't support bitmap indicies, so there aren't any
return [];
}
sub get_unique_index_details_from_data_dictionary {
my($self, $owner_name, $table_name) = @_;
my $dbh = $self->get_default_handle();
return undef unless $dbh;
my($index_list_fcn, $index_info_fcn) = ('index_list','index_info');
if ($owner_name) {
$index_list_fcn = "${owner_name}.${index_list_fcn}";
$index_info_fcn = "${owner_name}.${index_info_fcn}";
}
my $idx_sth = $dbh->prepare(qq(PRAGMA ${index_list_fcn}($table_name)));
return undef unless $idx_sth;
$idx_sth->execute();
my $ret = {};
while(my $data = $idx_sth->fetchrow_hashref()) {
next unless ($data->{'unique'});
my $idx_name = $data->{'name'};
my $idx_item_sth = $dbh->prepare(qq(PRAGMA ${index_info_fcn}($idx_name)));
$idx_item_sth->execute();
while(my $index_item = $idx_item_sth->fetchrow_hashref()) {
$ret->{$idx_name} ||= [];
push( @{$ret->{$idx_name}}, $index_item->{'name'});
}
}
return $ret;
}
# By default, make a text dump of the database at commit time.
# This should really be a datasource property
sub dump_on_commit {
0;
}
# We're overriding commit from UR::DS::commit() to add the behavior that after
# the actual commit happens, we also make a dump of the database in text format
# so that can be version controlled
sub commit {
my $self = shift;
my $has_no_pending_trans = (!-f $self->_journal_file_path());
my $worked = $self->SUPER::commit(@_);
return unless $worked;
my $db_filename = $self->server();
my $dump_filename = $self->_data_dump_path();
return 1 if ($has_no_pending_trans);
return 1 unless $self->dump_on_commit or -e $dump_filename;
return $self->_dump_db_to_file_internal();
}
# Get info out of the sqlite_master table. Returns a hashref keyed by 'name'
# columns are:
# type - 'table' or 'index'
# name - Name of the object
# table_name - name of the table this object references. For tables, it's the same as name,
# for indexes, it's the name of the table it's indexing
# rootpage - Used internally by sqlite
# sql - The sql used to create the thing
sub _get_info_from_sqlite_master {
my($self, $name,$type) = @_;
my($schema, @where, @exec_values);
if ($name) {
($schema, $name) = $self->_resolve_owner_and_table_from_table_name($name);
push @where, 'name = ?';
push @exec_values, $name;
}
if ($type) {
push @where, 'type = ?';
push @exec_values, $type;
}
my $sqlite_master_table = $schema
? "${schema}.sqlite_master"
: 'sqlite_master';
my $sql = "select * from $sqlite_master_table";
if (@where) {
$sql .= ' where '.join(' and ', @where);
}
my $dbh = $self->get_default_handle();
my $sth = $dbh->prepare($sql);
unless ($sth) {
no warnings;
$self->error_message("Can't get table details for name $name and type $type: ".$dbh->errstr);
return;
}
unless ($sth->execute(@exec_values)) {
no warnings;
$self->error_message("Can't get table details for name $name and type $type: ".$dbh->errstr);
return;
}
my @rows;
while (my $row = $sth->fetchrow_arrayref()) {
my $item;
@$item{'type','name','table_name','rootpage','sql'} = @$row;
# Force all names to lower case so we can find them later
push @rows, $item;
}
return @rows;
}
# This is used if, for whatever reason, we can't sue the sqlite3 command-line
# program to load up the database. We'll make a good-faith effort to parse
# the SQL text, but it won't be fancy. This is intended to be used to initialize
# meta DB dumps, so we should have to worry about escaping quotes, multi-line
# statements, etc.
#
# The real DB file should be moved out of the way before this is called. The existing
# DB file will be removed.
sub _load_db_from_dump_internal {
my $self = shift;
my $file_name = shift;
my $fh = IO::File->new($file_name);
unless ($fh) {
Carp::croak("Can't open DB dump file $file_name: $!");
}
my $db_file = $self->server;
if (-f $db_file) {
unless(unlink($db_file)) {
Carp::croak("Can't remove DB file $db_file: $!");
}
}
my $dbh = DBI->connect("dbi:SQLite:dbname=$db_file",'','',{ AutoCommit => 0, RaiseError => 0 });
unless($dbh) {
Carp::croak("Can't create DB handle for file $db_file: $DBI::errstr");
}
my $dump_file_contents = do { local( $/ ) ; <$fh> };
my @sql = split(';',$dump_file_contents);
for (my $i = 0; $i < @sql; $i++) {
my $sql = $sql[$i];
next unless ($sql =~ m/\S/); # Skip blank lines
next if ($sql =~ m/BEGIN TRANSACTION|COMMIT/i); # We're probably already in a transaction
# Is it restoring the foreign_keys setting?
if ($sql =~ m/PRAGMA foreign_keys\s*=\s*(\w+)/) {
my $value = $1;
my $fk_setting = $self->_get_foreign_key_setting($dbh);
if (! defined($fk_setting)) {
# This version of SQLite cannot enforce foreign keys.
# Print a warning message if they're trying to turn it on.
# also, remember the setting so we can preserve its value
# in _dump_db_to_file_internal()
$self->_cache_foreign_key_setting_from_file($value);
if ($value ne 'OFF') {
$self->warning_message("Data source ".$self->id." does not support foreign key enforcement, but the dump file $db_file attempts to turn it on");
}
next;
}
}
unless ($dbh->do($sql)) {
Carp::croak("Error processing SQL statement $i from DB dump file:\n$sql\nDBI error was: $DBI::errstr\n");
}
}
$dbh->commit();
$dbh->disconnect();
return 1;
}
sub _cache_foreign_key_setting_from_file {
my $self = shift;
our %foreign_key_setting_from_file;
my $id = $self->id;
if (@_) {
$foreign_key_setting_from_file{$id} = shift;
}
return $foreign_key_setting_from_file{$id};
}
# Is foreign key enforcement on or off?
# returns undef if this version of SQLite cannot enforce foreign keys
sub _get_foreign_key_setting {
my $self = shift;
my $dbh = shift;
my $id = $self->id;
our %foreign_key_setting;
unless (exists $foreign_key_setting{$id}) {
$dbh ||= $self->get_default_handle;
my @row = $dbh->selectrow_array('PRAGMA foreign_keys');
$foreign_key_setting{$id} = $row[0];
}
return $foreign_key_setting{$id};
}
sub _resolve_order_by_clause_for_column {
my($self, $column_name, $query_plan, $property_meta) = @_;
my $is_optional = $property_meta->is_optional;
my $column_clause = $column_name; # default, usual case
if ($is_optional) {
if ($query_plan->order_by_column_is_descending($column_name)) {
$column_clause = "CASE WHEN $column_name ISNULL THEN 0 ELSE 1 END, $column_name DESC";
} else {
$column_clause = "CASE WHEN $column_name ISNULL THEN 1 ELSE 0 END, $column_name";
}
} elsif ($query_plan->order_by_column_is_descending($column_name)) {
$column_clause = $column_name . ' DESC';
}
return $column_clause;
}
sub _dump_db_to_file_internal {
my $self = shift;
my $fk_setting = $self->_get_foreign_key_setting();
my $file_name = $self->_data_dump_path();
unless (-w $file_name) {
# dump file isn't writable...
return 1;
}
my $fh = IO::File->new($file_name, '>');
unless ($fh) {
Carp::croak("Can't open DB dump file $file_name for writing: $!");
}
my $db_file = $self->server;
my $dbh = $self->get_default_handle;
unless ($dbh) {
Carp::croak("Can't create DB handle for file $db_file: $DBI::errstr");
}
if (defined $fk_setting) {
# Save the value of the foreign_keys setting, if it's supported
$fh->print('PRAGMA foreign_keys = ' . ( $fk_setting ? 'ON' : 'OFF' ) .";\n");
} else {
# If not supported, but if _load_db_from_dump_internal came across the value, preserve it
$fk_setting = $self->_cache_foreign_key_setting_from_file;
if (defined $fk_setting) {
$fh->print("PRAGMA foreign_keys = $fk_setting;\n");
}
}
$fh->print("BEGIN TRANSACTION;\n");
my @tables = $self->_get_table_names_from_data_dictionary();
foreach my $qualified_table ( @tables ) {
my(undef, $table) = $self->_resolve_owner_and_table_from_table_name($qualified_table);
my($item_info) = $self->_get_info_from_sqlite_master($table);
my $creation_sql = $item_info->{'sql'};
$creation_sql .= ";" unless(substr($creation_sql, -1, 1) eq ";");
$creation_sql .= "\n" unless(substr($creation_sql, -1, 1) eq "\n");
$fh->print($creation_sql);
if ($item_info->{'type'} eq 'table') {
my $sth = $dbh->prepare("select * from $table");
unless ($sth) {
Carp::croak("Can't retrieve data from table $table: $DBI::errstr");
}
unless($sth->execute()) {
Carp::croak("execute() failed while retrieving data for table $table: $DBI::errstr");
}
while(my @row = $sth->fetchrow_array) {
foreach my $col ( @row ) {
if (! defined $col) {
$col = 'null';
} elsif ($col =~ m/\D/ or length($col) == 0) {
$col = "'" . $col . "'"; # Put quotes around non-numeric stuff
}
}
$fh->printf("INSERT INTO %s VALUES(%s);\n",
$table,
join(',', @row));
}
}
}
$fh->print("COMMIT;\n");
$fh->close();
$dbh->disconnect();
return 1;
}
sub _create_dbh_for_alternate_db {
my($self, $connect_string) = @_;
my $match_dbname = qr{dbname=([^;]+)}i;
my($db_file) = $connect_string =~ m/$match_dbname/;
$db_file
|| Carp::croak("Cannot determine dbname for alternate DB from dbi connect string $connect_string");
if ($self->_db_path_specifies_a_directory($db_file)) {
mkdir $db_file;
my $main_schema_file = join('', 'main', $self->_extension_for_db);
$db_file = File::Spec->catfile($db_file, $main_schema_file);
$connect_string =~ s/$match_dbname/dbname=$db_file/;
}
my $dbh = $self->SUPER::_create_dbh_for_alternate_db($connect_string);
return $dbh;
}
sub _db_path_specifies_a_directory {
my($self, $pathname) = @_;
return (-d $pathname) || ($pathname =~ m{/$});
}
sub _assure_schema_exists_for_table {
my($self, $table_name, $dbh) = @_;
$dbh ||= $self->get_default_handle;
my($schema_name, undef) = $self->_extract_schema_and_table_name($table_name);
if ($schema_name
and
! $self->is_schema_attached($schema_name, $dbh)
) {
# pretend we have schemas
my($main_filename) = $dbh->{Name} =~ m/(?:dbname=)*(.*)/;
my $directory = File::Basename::dirname($main_filename);
my $schema_filename = File::Spec->catfile($directory, "${schema_name}.sqlite3");
unless (UR::Util::touch_file($schema_filename)) {
Carp::carp("touch_file $schema_filename failed: $!");
return;
}
unless ($dbh->do(qq(ATTACH DATABASE '$schema_filename' as $schema_name))) {
Carp::carp("Cannot attach file $schema_filename as $schema_name: ".$dbh->errstr);
return;
}
}
}
sub attached_schemas {
my($self, $dbh) = @_;
$dbh ||= $self->get_default_handle;
# Statement returns id, schema, filename
my $sth = $dbh->prepare('PRAGMA database_list') || Carp::croak("Cannot list attached databases: ".$dbh->errstr);
$sth->execute();
my %schemas = map { $_->[1] => $_->[2] }
@{ $sth->fetchall_arrayref };
return \%schemas;
}
sub is_schema_attached {
my($self, $schema, $dbh) = @_;
$dbh ||= $self->get_default_handle;
my $schemas = $self->attached_schemas($dbh);
return exists $schemas->{$schema};
}
1;
ValueDomain.pm 100664 023532 023421 1120 12544604516 17517 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/DataSource package UR::DataSource::ValueDomain;
use strict;
use warnings;
require UR;
our $VERSION = "0.44"; # UR $VERSION;
UR::Object::Type->define(
class_name => 'UR::DataSource::ValueDomain',
is => ['UR::DataSource'],
is_abstract => 1,
properties => [
],
doc => 'A logical DBI-based database, independent of prod/dev/testing considerations or login details.',
);
sub get_objects_for_rule {
my $class = shift;
my $rule = shift;
my $obj = $UR::Context::current->_construct_object($rule);
$obj->__signal_change__("define");
return $obj;
}
1;
Debug.pm 100664 023532 023421 522 12544604516 14274 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR package UR::Debug;
use strict;
use warnings;
require UR;
our $VERSION = "0.44"; # UR $VERSION;
our $verify_indexes = 0;
1;
=pod
=head1 NAME
UR::Debug - Controls for debugging behavior
=head1 DESCRIPTION
Flags which turn on debugging behavior are set here. Change them in the
debugger to activate debugging functionality.
=cut
DeletedRef.pm 100664 023532 023421 7152 12544604516 15277 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR package UR::DeletedRef;
use strict;
use warnings;
require UR;
BEGIN {
# this is to workaround a Perl bug where the overload magic flag is not updated
# for references with a different RV (which happens anytime you do "my $object"
# https://rt.perl.org/rt3/Public/Bug/Display.html?id=9472
if ($^V lt v5.8.9) {
eval "use overload fallback => 1";
};
};
our $VERSION = "0.44"; # UR $VERSION;
our $all_objects_deleted = {};
sub bury {
my $class = shift;
for my $object (@_) {
if ($ENV{'UR_DEBUG_OBJECT_RELEASE'}) {
print STDERR "MEM BURY object $object class ",$object->class," id ",$object->id,"\n";
}
my $original_class = ref($object);
my $original_id = $object->id;
%$object = (original_class => ref($object), original_data => {%$object});
bless $object, 'UR::DeletedRef';
$all_objects_deleted->{$original_class}->{$original_id} = $object;
Scalar::Util::weaken($all_objects_deleted->{$original_class}->{$original_id});
}
return 1;
}
sub resurrect {
shift unless (ref($_[0]));
foreach my $object (@_) {
my $original_class = $object->{'original_class'};
bless $object, $original_class;
%$object = (%{$object->{original_data}});
my $id = $object->id;
delete $all_objects_deleted->{$original_class}->{$id};
$object->resurrect_object if ($object->can('resurrect_object'));
}
return 1;
}
use Data::Dumper;
sub AUTOLOAD {
our $AUTOLOAD;
my $method = $AUTOLOAD;
$method =~ s/^.*:://g;
Carp::croak("Attempt to use a reference to an object which has been deleted. A call was made to method '$method'\nRessurrect it first.\n" . Dumper($_[0]));
}
sub __rollback__ {
return 1;
}
sub DESTROY {
if ($ENV{'UR_DEBUG_OBJECT_RELEASE'}) {
print STDERR "MEM DESTROY deletedref $_[0]\n";
}
delete $all_objects_deleted->{"$_[0]"};
}
1;
=pod
=head1 NAME
UR::DeletedRef - Represents an instance of a no-longer-existent object
=head1 SYNOPSIS
my $obj = Some::Class->get(123);
$obj->delete;
print ref($obj),"\n"; # prints 'UR::DeletedRef'
$obj->some_method(); # generates an exception through Carp::confess
$obj->resurrect;
print ref($obj),"\n"; # prints 'Some::Class'
=head1 DESCRIPTION
Object instances become UR::DeletedRefs when some part of the application
calls delete() or unload() on them, meaning that they no longer exist
in that Context. The extant object reference is turned into a UR::DeletedRef
so that if that same reference is used in any capacity later in the program,
it will generate an exception through its AUTOLOAD to prevent using it by
mistake.
Note that UR::DeletedRef instances are different than Ghost objects. When a
UR-based object is deleted through delete(), a new Ghost object reference is
created from the data in the old object, and the old object reference is
re-blessed as a UR::DeletedRef. Any variables still referencing the original
object now hold a reference to this UR::DeletedRef. The Ghost object can be
retrieved by issuing a get() against the Ghost class.
Objects unloaded from the Context using unload(), or indirectly by rolling-back
a transaction which triggers unload of objects loaded during the transaction,
are also turned into UR::DeletedRefs.
You aren't likely to encounter UR::DeletedRefs in normal use. What usually
happens is that an object will be deleted with delete() (or unload()), the
lexical variable pointing to the DeletedRef will soon go out of scope and
the DeletedRef will then be garbage-colelcted.
=head1 SEE ALSO
UR::Object, UR::Object::Ghost, UR::Context
=cut
Pod2Html.pm 100664 023532 023421 1016 12544604516 15423 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/Doc package UR::Doc::Pod2Html;
use strict;
use warnings;
our $VERSION = "0.44"; # UR $VERSION;
use Data::Dumper;
use parent 'Pod::Simple::HTML';
$Pod::Simple::HTML::Perldoc_URL_Prefix = '';
$Pod::Simple::HTML::Perldoc_URL_Postfix = '.html';
sub do_top_anchor {
my ($self, $value) = @_;
$self->{__do_top_anchor} = $value;
}
sub do_beginning {
return 1;
}
sub do_end {
return 1;
}
sub _add_top_anchor {
my $self = shift;
return $self->SUPER::_add_top_anchor(@_) if $self->{__do_top_anchor};
}
1;
Section.pm 100664 023532 023421 777 12544604516 15373 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/Doc package UR::Doc::Section;
use strict;
use warnings;
use UR;
our $VERSION = "0.44"; # UR $VERSION;
class UR::Doc::Section {
is => 'UR::Object',
has => [
title => {
is => 'Text',
is_optional => 1,
},
content => {
is => 'Text',
doc => 'pod content for this section',
},
format => {
is => 'Text',
default_value => 'pod',
valid_values => ['html','pod','txt'],
},
],
};
Writer.pm 100664 023532 023421 1334 12544604516 15251 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/Doc package UR::Doc::Writer;
use strict;
use warnings;
use UR;
our $VERSION = "0.44"; # UR $VERSION;
use Carp qw/croak/;
class UR::Doc::Writer {
is => 'UR::Object',
is_abstract => 1,
has => [
title => { is => 'Text', },
sections => {
is => 'UR::Doc::Section',
is_many => 1,
},
navigation => {
is => 'ARRAY',
is_optional => 1,
},
],
has_transient_optional => [
content => {
is => 'Text',
default_value => '',
},
]
};
sub _append {
my ($self, $data) = @_;
$self->content($self->content . $data);
}
sub generate_index {
my ($self, @command_trees) = @_;
return '';
}
Html.pm 100664 023532 023421 5612 12544604516 16160 0 ustar 00abrummet gsc 000000 000000 UR-0.44/lib/UR/Doc/Writer package UR::Doc::Writer::Html;
use strict;
use warnings;
use UR;
our $VERSION = "0.44"; # UR $VERSION;
use UR::Doc::Section;
use UR::Doc::Pod2Html;
use Carp qw/croak/;
class UR::Doc::Writer::Html {
is => 'UR::Doc::Writer',
};
sub render {
my $self = shift;
$self->content('');
$self->_render_header;
$self->_render_index;
my $i = 0;
for my $section ($self->sections) {
$self->_render_section($section, $i++);
}
$self->_render_footer;
}
sub _render_header {
my $self = shift;
if ($self->navigation) {
my @nav_html;
for my $item (@{$self->navigation}) {
my ($name, $uri) = @$item;
if ($uri) {
push(@nav_html, "$name");
} else {
push(@nav_html, $name);
}
}
$self->_append(join(" :: ", @nav_html) . "
\n");
}
my $translator = new UR::Doc::Pod2Html;
my $title;
$translator->output_string($title);
$translator->parse_string_document("=pod\n\n".$self->title."\n\n=cut\n\n");
$self->_append("$title
\n");
}
sub _render_index {
my $self = shift;
my @titles = grep { $_ and /./ } map { $_->title } $self->sections;
my $i = 0;
if (@titles) {
$self->_append("\n\n".
join("\n", map {"- $_
"} @titles)."
\n\n");
}
}
sub _render_section {
my ($self, $section, $idx) = @_;
if (my $title = $section->title) {
$self->_append("\n");
}
my $content = $section->content;
if ($section->format eq 'html') {
$self->_append($content);
} elsif ($section->format eq 'txt' or $section->format eq 'pod') {
$content = "\n\n=pod\n\n$content\n\n=cut\n\n";
my $new_content;
my $translator = new UR::Doc::Pod2Html;
$translator->output_string($new_content);
$translator->parse_string_document($content);
$self->_append($new_content);
} else {
croak "Unknown section type " . $section->type;
}
$self->_append("
\n");
}
sub _render_footer {
my $self = shift;
$self->_append("