UR-0.41 000755 023532 023421 0 12121654175 11544 5 ustar 00abrummet gsc 000000 000000 MANIFEST.SKIP 000444 023532 023421 204 12121654172 13471 0 ustar 00abrummet gsc 000000 000000 UR-0.41 ^MYMETA.yml$
^.git
^debian/
^ubuntu-lucid/
^alt/
^dist-maint/
^MANIFEST.bak$
^_build/
^Build$
\.tar\.gz$
^blib
^i
^MYMETA\.json$
^$
LICENSE 000444 023532 023421 121264 12121654173 12673 0 ustar 00abrummet gsc 000000 000000 UR-0.41 UR is licensed under the same terms as Perl itself, which means it is
dually-licensed under either the Artistic or GPL licenses.
Below are details of the Artistic License and, following it, the GPL.
The "Artistic License"
Preamble
The intent of this document is to state the conditions under which a
Package may be copied, such that the Copyright Holder maintains some
semblance of artistic control over the development of the package,
while giving the users of the package the right to use and distribute
the Package in a more-or-less customary fashion, plus the right to make
reasonable modifications.
Definitions:
"Package" refers to the collection of files distributed by the
Copyright Holder, and derivatives of that collection of files
created through textual modification.
"Standard Version" refers to such a Package if it has not been
modified, or has been modified in accordance with the wishes
of the Copyright Holder as specified below.
"Copyright Holder" is whoever is named in the copyright or
copyrights for the package.
"You" is you, if you're thinking about copying or distributing
this Package.
"Reasonable copying fee" is whatever you can justify on the
basis of media cost, duplication charges, time of people involved,
and so on. (You will not be required to justify it to the
Copyright Holder, but only to the computing community at large
as a market that must bear the fee.)
"Freely Available" means that no fee is charged for the item
itself, though there may be fees involved in handling the item.
It also means that recipients of the item may redistribute it
under the same conditions they received it.
1. You may make and give away verbatim copies of the source form of the
Standard Version of this Package without restriction, provided that you
duplicate all of the original copyright notices and associated disclaimers.
2. You may apply bug fixes, portability fixes and other modifications
derived from the Public Domain or from the Copyright Holder. A Package
modified in such a way shall still be considered the Standard Version.
3. You may otherwise modify your copy of this Package in any way, provided
that you insert a prominent notice in each changed file stating how and
when you changed that file, and provided that you do at least ONE of the
following:
a) place your modifications in the Public Domain or otherwise make them
Freely Available, such as by posting said modifications to Usenet or
an equivalent medium, or placing the modifications on a major archive
site such as uunet.uu.net, or by allowing the Copyright Holder to include
your modifications in the Standard Version of the Package.
b) use the modified Package only within your corporation or organization.
c) rename any non-standard executables so the names do not conflict
with standard executables, which must also be provided, and provide
a separate manual page for each non-standard executable that clearly
documents how it differs from the Standard Version.
d) make other distribution arrangements with the Copyright Holder.
4. You may distribute the programs of this Package in object code or
executable form, provided that you do at least ONE of the following:
a) distribute a Standard Version of the executables and library files,
together with instructions (in the manual page or equivalent) on where
to get the Standard Version.
b) accompany the distribution with the machine-readable source of
the Package with your modifications.
c) give non-standard executables non-standard names, and clearly
document the differences in manual pages (or equivalent), together
with instructions on where to get the Standard Version.
d) make other distribution arrangements with the Copyright Holder.
5. You may charge a reasonable copying fee for any distribution of this
Package. You may charge any fee you choose for support of this
Package. You may not charge a fee for this Package itself. However,
you may distribute this Package in aggregate with other (possibly
commercial) programs as part of a larger (possibly commercial) software
distribution provided that you do not advertise this Package as a
product of your own. You may embed this Package's interpreter within
an executable of yours (by linking); this shall be construed as a mere
form of aggregation, provided that the complete Standard Version of the
interpreter is so embedded.
6. The scripts and library files supplied as input to or produced as
output from the programs of this Package do not automatically fall
under the copyright of this Package, but belong to whoever generated
them, and may be sold commercially, and may be aggregated with this
Package. If such scripts or library files are aggregated with this
Package via the so-called "undump" or "unexec" methods of producing a
binary executable image, then distribution of such an image shall
neither be construed as a distribution of this Package nor shall it
fall under the restrictions of Paragraphs 3 and 4, provided that you do
not represent such an executable image as a Standard Version of this
Package.
7. C subroutines (or comparably compiled subroutines in other
languages) supplied by you and linked into this Package in order to
emulate subroutines and variables of the language defined by this
Package shall not be considered part of this Package, but are the
equivalent of input as in Paragraph 6, provided these subroutines do
not change the language in any way that would cause it to fail the
regression tests for the language.
8. Aggregation of this Package with a commercial distribution is always
permitted provided that the use of this Package is embedded; that is,
when no overt attempt is made to make this Package's interfaces visible
to the end user of the commercial distribution. Such use shall not be
construed as a distribution of this Package.
9. The name of the Copyright Holder may not be used to endorse or promote
products derived from this software without specific prior written permission.
10. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR
IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
The End
GNU GENERAL PUBLIC LICENSE
Version 3, 29 June 2007
Copyright (C) 2007 Free Software Foundation, Inc.
Everyone is permitted to copy and distribute verbatim copies
of this license document, but changing it is not allowed.
Preamble
The GNU General Public License is a free, copyleft license for
software and other kinds of works.
The licenses for most software and other practical works are designed
to take away your freedom to share and change the works. By contrast,
the GNU General Public License is intended to guarantee your freedom to
share and change all versions of a program--to make sure it remains free
software for all its users. We, the Free Software Foundation, use the
GNU General Public License for most of our software; it applies also to
any other work released this way by its authors. You can apply it to
your programs, too.
When we speak of free software, we are referring to freedom, not
price. Our General Public Licenses are designed to make sure that you
have the freedom to distribute copies of free software (and charge for
them if you wish), that you receive source code or can get it if you
want it, that you can change the software or use pieces of it in new
free programs, and that you know you can do these things.
To protect your rights, we need to prevent others from denying you
these rights or asking you to surrender the rights. Therefore, you have
certain responsibilities if you distribute copies of the software, or if
you modify it: responsibilities to respect the freedom of others.
For example, if you distribute copies of such a program, whether
gratis or for a fee, you must pass on to the recipients the same
freedoms that you received. You must make sure that they, too, receive
or can get the source code. And you must show them these terms so they
know their rights.
Developers that use the GNU GPL protect your rights with two steps:
(1) assert copyright on the software, and (2) offer you this License
giving you legal permission to copy, distribute and/or modify it.
For the developers' and authors' protection, the GPL clearly explains
that there is no warranty for this free software. For both users' and
authors' sake, the GPL requires that modified versions be marked as
changed, so that their problems will not be attributed erroneously to
authors of previous versions.
Some devices are designed to deny users access to install or run
modified versions of the software inside them, although the manufacturer
can do so. This is fundamentally incompatible with the aim of
protecting users' freedom to change the software. The systematic
pattern of such abuse occurs in the area of products for individuals to
use, which is precisely where it is most unacceptable. Therefore, we
have designed this version of the GPL to prohibit the practice for those
products. If such problems arise substantially in other domains, we
stand ready to extend this provision to those domains in future versions
of the GPL, as needed to protect the freedom of users.
Finally, every program is threatened constantly by software patents.
States should not allow patents to restrict development and use of
software on general-purpose computers, but in those that do, we wish to
avoid the special danger that patents applied to a free program could
make it effectively proprietary. To prevent this, the GPL assures that
patents cannot be used to render the program non-free.
The precise terms and conditions for copying, distribution and
modification follow.
TERMS AND CONDITIONS
0. Definitions.
"This License" refers to version 3 of the GNU General Public License.
"Copyright" also means copyright-like laws that apply to other kinds of
works, such as semiconductor masks.
"The Program" refers to any copyrightable work licensed under this
License. Each licensee is addressed as "you". "Licensees" and
"recipients" may be individuals or organizations.
To "modify" a work means to copy from or adapt all or part of the work
in a fashion requiring copyright permission, other than the making of an
exact copy. The resulting work is called a "modified version" of the
earlier work or a work "based on" the earlier work.
A "covered work" means either the unmodified Program or a work based
on the Program.
To "propagate" a work means to do anything with it that, without
permission, would make you directly or secondarily liable for
infringement under applicable copyright law, except executing it on a
computer or modifying a private copy. Propagation includes copying,
distribution (with or without modification), making available to the
public, and in some countries other activities as well.
To "convey" a work means any kind of propagation that enables other
parties to make or receive copies. Mere interaction with a user through
a computer network, with no transfer of a copy, is not conveying.
An interactive user interface displays "Appropriate Legal Notices"
to the extent that it includes a convenient and prominently visible
feature that (1) displays an appropriate copyright notice, and (2)
tells the user that there is no warranty for the work (except to the
extent that warranties are provided), that licensees may convey the
work under this License, and how to view a copy of this License. If
the interface presents a list of user commands or options, such as a
menu, a prominent item in the list meets this criterion.
1. Source Code.
The "source code" for a work means the preferred form of the work
for making modifications to it. "Object code" means any non-source
form of a work.
A "Standard Interface" means an interface that either is an official
standard defined by a recognized standards body, or, in the case of
interfaces specified for a particular programming language, one that
is widely used among developers working in that language.
The "System Libraries" of an executable work include anything, other
than the work as a whole, that (a) is included in the normal form of
packaging a Major Component, but which is not part of that Major
Component, and (b) serves only to enable use of the work with that
Major Component, or to implement a Standard Interface for which an
implementation is available to the public in source code form. A
"Major Component", in this context, means a major essential component
(kernel, window system, and so on) of the specific operating system
(if any) on which the executable work runs, or a compiler used to
produce the work, or an object code interpreter used to run it.
The "Corresponding Source" for a work in object code form means all
the source code needed to generate, install, and (for an executable
work) run the object code and to modify the work, including scripts to
control those activities. However, it does not include the work's
System Libraries, or general-purpose tools or generally available free
programs which are used unmodified in performing those activities but
which are not part of the work. For example, Corresponding Source
includes interface definition files associated with source files for
the work, and the source code for shared libraries and dynamically
linked subprograms that the work is specifically designed to require,
such as by intimate data communication or control flow between those
subprograms and other parts of the work.
The Corresponding Source need not include anything that users
can regenerate automatically from other parts of the Corresponding
Source.
The Corresponding Source for a work in source code form is that
same work.
2. Basic Permissions.
All rights granted under this License are granted for the term of
copyright on the Program, and are irrevocable provided the stated
conditions are met. This License explicitly affirms your unlimited
permission to run the unmodified Program. The output from running a
covered work is covered by this License only if the output, given its
content, constitutes a covered work. This License acknowledges your
rights of fair use or other equivalent, as provided by copyright law.
You may make, run and propagate covered works that you do not
convey, without conditions so long as your license otherwise remains
in force. You may convey covered works to others for the sole purpose
of having them make modifications exclusively for you, or provide you
with facilities for running those works, provided that you comply with
the terms of this License in conveying all material for which you do
not control copyright. Those thus making or running the covered works
for you must do so exclusively on your behalf, under your direction
and control, on terms that prohibit them from making any copies of
your copyrighted material outside their relationship with you.
Conveying under any other circumstances is permitted solely under
the conditions stated below. Sublicensing is not allowed; section 10
makes it unnecessary.
3. Protecting Users' Legal Rights From Anti-Circumvention Law.
No covered work shall be deemed part of an effective technological
measure under any applicable law fulfilling obligations under article
11 of the WIPO copyright treaty adopted on 20 December 1996, or
similar laws prohibiting or restricting circumvention of such
measures.
When you convey a covered work, you waive any legal power to forbid
circumvention of technological measures to the extent such circumvention
is effected by exercising rights under this License with respect to
the covered work, and you disclaim any intention to limit operation or
modification of the work as a means of enforcing, against the work's
users, your or third parties' legal rights to forbid circumvention of
technological measures.
4. Conveying Verbatim Copies.
You may convey verbatim copies of the Program's source code as you
receive it, in any medium, provided that you conspicuously and
appropriately publish on each copy an appropriate copyright notice;
keep intact all notices stating that this License and any
non-permissive terms added in accord with section 7 apply to the code;
keep intact all notices of the absence of any warranty; and give all
recipients a copy of this License along with the Program.
You may charge any price or no price for each copy that you convey,
and you may offer support or warranty protection for a fee.
5. Conveying Modified Source Versions.
You may convey a work based on the Program, or the modifications to
produce it from the Program, in the form of source code under the
terms of section 4, provided that you also meet all of these conditions:
a) The work must carry prominent notices stating that you modified
it, and giving a relevant date.
b) The work must carry prominent notices stating that it is
released under this License and any conditions added under section
7. This requirement modifies the requirement in section 4 to
"keep intact all notices".
c) You must license the entire work, as a whole, under this
License to anyone who comes into possession of a copy. This
License will therefore apply, along with any applicable section 7
additional terms, to the whole of the work, and all its parts,
regardless of how they are packaged. This License gives no
permission to license the work in any other way, but it does not
invalidate such permission if you have separately received it.
d) If the work has interactive user interfaces, each must display
Appropriate Legal Notices; however, if the Program has interactive
interfaces that do not display Appropriate Legal Notices, your
work need not make them do so.
A compilation of a covered work with other separate and independent
works, which are not by their nature extensions of the covered work,
and which are not combined with it such as to form a larger program,
in or on a volume of a storage or distribution medium, is called an
"aggregate" if the compilation and its resulting copyright are not
used to limit the access or legal rights of the compilation's users
beyond what the individual works permit. Inclusion of a covered work
in an aggregate does not cause this License to apply to the other
parts of the aggregate.
6. Conveying Non-Source Forms.
You may convey a covered work in object code form under the terms
of sections 4 and 5, provided that you also convey the
machine-readable Corresponding Source under the terms of this License,
in one of these ways:
a) Convey the object code in, or embodied in, a physical product
(including a physical distribution medium), accompanied by the
Corresponding Source fixed on a durable physical medium
customarily used for software interchange.
b) Convey the object code in, or embodied in, a physical product
(including a physical distribution medium), accompanied by a
written offer, valid for at least three years and valid for as
long as you offer spare parts or customer support for that product
model, to give anyone who possesses the object code either (1) a
copy of the Corresponding Source for all the software in the
product that is covered by this License, on a durable physical
medium customarily used for software interchange, for a price no
more than your reasonable cost of physically performing this
conveying of source, or (2) access to copy the
Corresponding Source from a network server at no charge.
c) Convey individual copies of the object code with a copy of the
written offer to provide the Corresponding Source. This
alternative is allowed only occasionally and noncommercially, and
only if you received the object code with such an offer, in accord
with subsection 6b.
d) Convey the object code by offering access from a designated
place (gratis or for a charge), and offer equivalent access to the
Corresponding Source in the same way through the same place at no
further charge. You need not require recipients to copy the
Corresponding Source along with the object code. If the place to
copy the object code is a network server, the Corresponding Source
may be on a different server (operated by you or a third party)
that supports equivalent copying facilities, provided you maintain
clear directions next to the object code saying where to find the
Corresponding Source. Regardless of what server hosts the
Corresponding Source, you remain obligated to ensure that it is
available for as long as needed to satisfy these requirements.
e) Convey the object code using peer-to-peer transmission, provided
you inform other peers where the object code and Corresponding
Source of the work are being offered to the general public at no
charge under subsection 6d.
A separable portion of the object code, whose source code is excluded
from the Corresponding Source as a System Library, need not be
included in conveying the object code work.
A "User Product" is either (1) a "consumer product", which means any
tangible personal property which is normally used for personal, family,
or household purposes, or (2) anything designed or sold for incorporation
into a dwelling. In determining whether a product is a consumer product,
doubtful cases shall be resolved in favor of coverage. For a particular
product received by a particular user, "normally used" refers to a
typical or common use of that class of product, regardless of the status
of the particular user or of the way in which the particular user
actually uses, or expects or is expected to use, the product. A product
is a consumer product regardless of whether the product has substantial
commercial, industrial or non-consumer uses, unless such uses represent
the only significant mode of use of the product.
"Installation Information" for a User Product means any methods,
procedures, authorization keys, or other information required to install
and execute modified versions of a covered work in that User Product from
a modified version of its Corresponding Source. The information must
suffice to ensure that the continued functioning of the modified object
code is in no case prevented or interfered with solely because
modification has been made.
If you convey an object code work under this section in, or with, or
specifically for use in, a User Product, and the conveying occurs as
part of a transaction in which the right of possession and use of the
User Product is transferred to the recipient in perpetuity or for a
fixed term (regardless of how the transaction is characterized), the
Corresponding Source conveyed under this section must be accompanied
by the Installation Information. But this requirement does not apply
if neither you nor any third party retains the ability to install
modified object code on the User Product (for example, the work has
been installed in ROM).
The requirement to provide Installation Information does not include a
requirement to continue to provide support service, warranty, or updates
for a work that has been modified or installed by the recipient, or for
the User Product in which it has been modified or installed. Access to a
network may be denied when the modification itself materially and
adversely affects the operation of the network or violates the rules and
protocols for communication across the network.
Corresponding Source conveyed, and Installation Information provided,
in accord with this section must be in a format that is publicly
documented (and with an implementation available to the public in
source code form), and must require no special password or key for
unpacking, reading or copying.
7. Additional Terms.
"Additional permissions" are terms that supplement the terms of this
License by making exceptions from one or more of its conditions.
Additional permissions that are applicable to the entire Program shall
be treated as though they were included in this License, to the extent
that they are valid under applicable law. If additional permissions
apply only to part of the Program, that part may be used separately
under those permissions, but the entire Program remains governed by
this License without regard to the additional permissions.
When you convey a copy of a covered work, you may at your option
remove any additional permissions from that copy, or from any part of
it. (Additional permissions may be written to require their own
removal in certain cases when you modify the work.) You may place
additional permissions on material, added by you to a covered work,
for which you have or can give appropriate copyright permission.
Notwithstanding any other provision of this License, for material you
add to a covered work, you may (if authorized by the copyright holders of
that material) supplement the terms of this License with terms:
a) Disclaiming warranty or limiting liability differently from the
terms of sections 15 and 16 of this License; or
b) Requiring preservation of specified reasonable legal notices or
author attributions in that material or in the Appropriate Legal
Notices displayed by works containing it; or
c) Prohibiting misrepresentation of the origin of that material, or
requiring that modified versions of such material be marked in
reasonable ways as different from the original version; or
d) Limiting the use for publicity purposes of names of licensors or
authors of the material; or
e) Declining to grant rights under trademark law for use of some
trade names, trademarks, or service marks; or
f) Requiring indemnification of licensors and authors of that
material by anyone who conveys the material (or modified versions of
it) with contractual assumptions of liability to the recipient, for
any liability that these contractual assumptions directly impose on
those licensors and authors.
All other non-permissive additional terms are considered "further
restrictions" within the meaning of section 10. If the Program as you
received it, or any part of it, contains a notice stating that it is
governed by this License along with a term that is a further
restriction, you may remove that term. If a license document contains
a further restriction but permits relicensing or conveying under this
License, you may add to a covered work material governed by the terms
of that license document, provided that the further restriction does
not survive such relicensing or conveying.
If you add terms to a covered work in accord with this section, you
must place, in the relevant source files, a statement of the
additional terms that apply to those files, or a notice indicating
where to find the applicable terms.
Additional terms, permissive or non-permissive, may be stated in the
form of a separately written license, or stated as exceptions;
the above requirements apply either way.
8. Termination.
You may not propagate or modify a covered work except as expressly
provided under this License. Any attempt otherwise to propagate or
modify it is void, and will automatically terminate your rights under
this License (including any patent licenses granted under the third
paragraph of section 11).
However, if you cease all violation of this License, then your
license from a particular copyright holder is reinstated (a)
provisionally, unless and until the copyright holder explicitly and
finally terminates your license, and (b) permanently, if the copyright
holder fails to notify you of the violation by some reasonable means
prior to 60 days after the cessation.
Moreover, your license from a particular copyright holder is
reinstated permanently if the copyright holder notifies you of the
violation by some reasonable means, this is the first time you have
received notice of violation of this License (for any work) from that
copyright holder, and you cure the violation prior to 30 days after
your receipt of the notice.
Termination of your rights under this section does not terminate the
licenses of parties who have received copies or rights from you under
this License. If your rights have been terminated and not permanently
reinstated, you do not qualify to receive new licenses for the same
material under section 10.
9. Acceptance Not Required for Having Copies.
You are not required to accept this License in order to receive or
run a copy of the Program. Ancillary propagation of a covered work
occurring solely as a consequence of using peer-to-peer transmission
to receive a copy likewise does not require acceptance. However,
nothing other than this License grants you permission to propagate or
modify any covered work. These actions infringe copyright if you do
not accept this License. Therefore, by modifying or propagating a
covered work, you indicate your acceptance of this License to do so.
10. Automatic Licensing of Downstream Recipients.
Each time you convey a covered work, the recipient automatically
receives a license from the original licensors, to run, modify and
propagate that work, subject to this License. You are not responsible
for enforcing compliance by third parties with this License.
An "entity transaction" is a transaction transferring control of an
organization, or substantially all assets of one, or subdividing an
organization, or merging organizations. If propagation of a covered
work results from an entity transaction, each party to that
transaction who receives a copy of the work also receives whatever
licenses to the work the party's predecessor in interest had or could
give under the previous paragraph, plus a right to possession of the
Corresponding Source of the work from the predecessor in interest, if
the predecessor has it or can get it with reasonable efforts.
You may not impose any further restrictions on the exercise of the
rights granted or affirmed under this License. For example, you may
not impose a license fee, royalty, or other charge for exercise of
rights granted under this License, and you may not initiate litigation
(including a cross-claim or counterclaim in a lawsuit) alleging that
any patent claim is infringed by making, using, selling, offering for
sale, or importing the Program or any portion of it.
11. Patents.
A "contributor" is a copyright holder who authorizes use under this
License of the Program or a work on which the Program is based. The
work thus licensed is called the contributor's "contributor version".
A contributor's "essential patent claims" are all patent claims
owned or controlled by the contributor, whether already acquired or
hereafter acquired, that would be infringed by some manner, permitted
by this License, of making, using, or selling its contributor version,
but do not include claims that would be infringed only as a
consequence of further modification of the contributor version. For
purposes of this definition, "control" includes the right to grant
patent sublicenses in a manner consistent with the requirements of
this License.
Each contributor grants you a non-exclusive, worldwide, royalty-free
patent license under the contributor's essential patent claims, to
make, use, sell, offer for sale, import and otherwise run, modify and
propagate the contents of its contributor version.
In the following three paragraphs, a "patent license" is any express
agreement or commitment, however denominated, not to enforce a patent
(such as an express permission to practice a patent or covenant not to
sue for patent infringement). To "grant" such a patent license to a
party means to make such an agreement or commitment not to enforce a
patent against the party.
If you convey a covered work, knowingly relying on a patent license,
and the Corresponding Source of the work is not available for anyone
to copy, free of charge and under the terms of this License, through a
publicly available network server or other readily accessible means,
then you must either (1) cause the Corresponding Source to be so
available, or (2) arrange to deprive yourself of the benefit of the
patent license for this particular work, or (3) arrange, in a manner
consistent with the requirements of this License, to extend the patent
license to downstream recipients. "Knowingly relying" means you have
actual knowledge that, but for the patent license, your conveying the
covered work in a country, or your recipient's use of the covered work
in a country, would infringe one or more identifiable patents in that
country that you have reason to believe are valid.
If, pursuant to or in connection with a single transaction or
arrangement, you convey, or propagate by procuring conveyance of, a
covered work, and grant a patent license to some of the parties
receiving the covered work authorizing them to use, propagate, modify
or convey a specific copy of the covered work, then the patent license
you grant is automatically extended to all recipients of the covered
work and works based on it.
A patent license is "discriminatory" if it does not include within
the scope of its coverage, prohibits the exercise of, or is
conditioned on the non-exercise of one or more of the rights that are
specifically granted under this License. You may not convey a covered
work if you are a party to an arrangement with a third party that is
in the business of distributing software, under which you make payment
to the third party based on the extent of your activity of conveying
the work, and under which the third party grants, to any of the
parties who would receive the covered work from you, a discriminatory
patent license (a) in connection with copies of the covered work
conveyed by you (or copies made from those copies), or (b) primarily
for and in connection with specific products or compilations that
contain the covered work, unless you entered into that arrangement,
or that patent license was granted, prior to 28 March 2007.
Nothing in this License shall be construed as excluding or limiting
any implied license or other defenses to infringement that may
otherwise be available to you under applicable patent law.
12. No Surrender of Others' Freedom.
If conditions are imposed on you (whether by court order, agreement or
otherwise) that contradict the conditions of this License, they do not
excuse you from the conditions of this License. If you cannot convey a
covered work so as to satisfy simultaneously your obligations under this
License and any other pertinent obligations, then as a consequence you may
not convey it at all. For example, if you agree to terms that obligate you
to collect a royalty for further conveying from those to whom you convey
the Program, the only way you could satisfy both those terms and this
License would be to refrain entirely from conveying the Program.
13. Use with the GNU Affero General Public License.
Notwithstanding any other provision of this License, you have
permission to link or combine any covered work with a work licensed
under version 3 of the GNU Affero General Public License into a single
combined work, and to convey the resulting work. The terms of this
License will continue to apply to the part which is the covered work,
but the special requirements of the GNU Affero General Public License,
section 13, concerning interaction through a network will apply to the
combination as such.
14. Revised Versions of this License.
The Free Software Foundation may publish revised and/or new versions of
the GNU General Public License from time to time. Such new versions will
be similar in spirit to the present version, but may differ in detail to
address new problems or concerns.
Each version is given a distinguishing version number. If the
Program specifies that a certain numbered version of the GNU General
Public License "or any later version" applies to it, you have the
option of following the terms and conditions either of that numbered
version or of any later version published by the Free Software
Foundation. If the Program does not specify a version number of the
GNU General Public License, you may choose any version ever published
by the Free Software Foundation.
If the Program specifies that a proxy can decide which future
versions of the GNU General Public License can be used, that proxy's
public statement of acceptance of a version permanently authorizes you
to choose that version for the Program.
Later license versions may give you additional or different
permissions. However, no additional obligations are imposed on any
author or copyright holder as a result of your choosing to follow a
later version.
15. Disclaimer of Warranty.
THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY
APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT
HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY
OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,
THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM
IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF
ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
16. Limitation of Liability.
IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS
THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY
GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE
USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF
DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD
PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),
EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
SUCH DAMAGES.
17. Interpretation of Sections 15 and 16.
If the disclaimer of warranty and limitation of liability provided
above cannot be given local legal effect according to their terms,
reviewing courts shall apply local law that most closely approximates
an absolute waiver of all civil liability in connection with the
Program, unless a warranty or assumption of liability accompanies a
copy of the Program in return for a fee.
END OF TERMS AND CONDITIONS
How to Apply These Terms to Your New Programs
If you develop a new program, and you want it to be of the greatest
possible use to the public, the best way to achieve this is to make it
free software which everyone can redistribute and change under these terms.
To do so, attach the following notices to the program. It is safest
to attach them to the start of each source file to most effectively
state the exclusion of warranty; and each file should have at least
the "copyright" line and a pointer to where the full notice is found.
Copyright (C)
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program. If not, see .
Also add information on how to contact you by electronic and paper mail.
If the program does terminal interaction, make it output a short
notice like this when it starts in an interactive mode:
Copyright (C)
This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
This is free software, and you are welcome to redistribute it
under certain conditions; type `show c' for details.
The hypothetical commands `show w' and `show c' should show the appropriate
parts of the General Public License. Of course, your program's commands
might be different; for a GUI interface, you would use an "about box".
You should also get your employer (if you work as a programmer) or school,
if any, to sign a "copyright disclaimer" for the program, if necessary.
For more information on this, and how to apply and follow the GNU GPL, see
.
The GNU General Public License does not permit incorporating your program
into proprietary programs. If your program is a subroutine library, you
may consider it more useful to permit linking proprietary applications with
the library. If this is what you want to do, use the GNU Lesser General
Public License instead of this License. But first, please read
.
Build.PL 000444 023532 023421 6406 12121654174 13123 0 ustar 00abrummet gsc 000000 000000 UR-0.41 #!/usr/bin/env perl
use warnings FATAL => 'all';
use strict;
use Module::Build;
my $subclass = Module::Build->subclass(
class_name => 'UR::ModuleBuildSelf',
code => q{
sub ACTION_docs {
# ensure docs get man pages and html
my $self = shift;
$self->depends_on('code');
$self->depends_on('manpages', 'html');
}
sub man1page_name {
# without this we have "man ur-init.pod" instead of "man ur-init"
my ($self, $file) = @_;
$file =~ s/.pod$//;
return $self->SUPER::man1page_name($file);
}
}
);
my $build = $subclass->new(
module_name => 'UR',
license => 'perl',
dist_author => [
'Anthony Brummett brummett@cpan.org',
'Scott Smith sakoht@cpan.org',
],
requires => {
# known bugs with Perl 5.6
perl => 'v5.8.7',
# pure Perl
'Class::Autouse' => '2.0',
'Class::AutoloadCAN' => '0.03',
'Clone::PP' => '1.02',
'Carp' => '',
'Sys::Hostname' => '1.11',
'File::Basename' => '2.73',
'File::Temp' => '',
'File::Path' => '',
'Lingua::EN::Inflect' => '1.88',
'Date::Format' => '',
'Data::Compare' => '0.13',
'Text::Diff' => '0.35',
'Path::Class' => '',
#'Class::Inspector' => '',
'Text::Glob' => '',
#'XML::Dumper' => '',
#'XML::Generator' => '',
#'XML::Simple' => '',
'version' => '',
'JSON' => '',
'Test::Fork' => '',
'Pod::Simple::Text' => '2.02',
'Pod::Simple::HTML' => '3.03',
'List::MoreUtils' => '',
'MRO::Compat' => '',
# C
'FreezeThaw' => '0.43',
'YAML' => '',
'DBI' => '1.601',
'DBD::SQLite' => '1.14',
'Sub::Name' => '0.04',
'Sub::Install' => '0.924',
'Data::UUID' => '0.148',
'Devel::GlobalDestruction' => '',
# possibly move to a web-specific
#'Net::HTTPServer' => '',
#'CGI::Application' => '',
#'URI::Escape' => '',
#'Getopt::Complete' => [
# we may migrate some of the Command logic here and really depend on it
# currently it is actually not _required_ to function
'Getopt::Complete' => '0.26',
#'XSLT' => [
# this stuff is hard to install and is only used by some views
#'XML::LibXML' => '',
#'XML::LibXSLT' => '',
},
cpan_client => 'cpanm',
script_files => [ 'bin/ur' ],
test_files => [qw|t/*.t t/*/*.t t/*/*/*.t t/*/*/*/*.t|],
bindoc_dirs => ['pod'],
tap_harness_args => {
'jobs' => 8,
'rules' => {
par => [
#{ seq => '../ext/DB_File/t/*' },
#{ seq => '../ext/IO_Compress_Zlib/t/*' },
#{ seq => '../lib/CPANPLUS/*' },
#{ seq => '../lib/ExtUtils/t/*' },
#'*'
{ seq => '../t/URT/t/42*' },
'*'
]
},
},
);
foreach my $metadb_type ( qw(sqlite3 sqlite3n sqlite3-dump sqlite3n-dump sqlite3-schema sqlite3n-schema) ) {
$build->add_build_element($metadb_type);
}
$build->create_build_script;
INSTALL 000444 023532 023421 71 12121654174 12610 0 ustar 00abrummet gsc 000000 000000 UR-0.41 perl Build.PL
./Build
./Build test
sudo ./Build install
MANIFEST 000444 023532 023421 53377 12121654174 13011 0 ustar 00abrummet gsc 000000 000000 UR-0.41 bin/ur
Build.PL
Changes
gmt-web/common.yml
gmt-web/content/documentation.html
gmt-web/content/index.html
gmt-web/content/install.md
gmt-web/content/res/images/icon_16.png
gmt-web/content/res/images/icon_48.png
INSTALL
lib/above.pm
lib/Command.pm
lib/Command/Dispatch/Shell.pm
lib/Command/DynamicSubCommands.pm
lib/Command/Shell.pm
lib/Command/SubCommandFactory.pm
lib/Command/Test.pm
lib/Command/Test/Echo.pm
lib/Command/Test/Tree1.pm
lib/Command/Test/Tree1/Echo1.pm
lib/Command/Test/Tree1/Echo2.pm
lib/Command/Tree.pm
lib/Command/V1.pm
lib/Command/V1.t
lib/Command/V2.pm
lib/Command/V2Deprecated.pm
lib/Command/View/DocMethods.pm
lib/Devel/callcount.pm
lib/UR.pm
lib/UR/All.pm
lib/UR/BoolExpr.pm
lib/UR/BoolExpr/BxParser.pm
lib/UR/BoolExpr/BxParser.yp
lib/UR/BoolExpr/Template.pm
lib/UR/BoolExpr/Template/And.pm
lib/UR/BoolExpr/Template/Composite.pm
lib/UR/BoolExpr/Template/Or.pm
lib/UR/BoolExpr/Template/PropertyComparison.pm
lib/UR/BoolExpr/Template/PropertyComparison/Between.pm
lib/UR/BoolExpr/Template/PropertyComparison/Equals.pm
lib/UR/BoolExpr/Template/PropertyComparison/False.pm
lib/UR/BoolExpr/Template/PropertyComparison/GreaterOrEqual.pm
lib/UR/BoolExpr/Template/PropertyComparison/GreaterThan.pm
lib/UR/BoolExpr/Template/PropertyComparison/In.pm
lib/UR/BoolExpr/Template/PropertyComparison/LessOrEqual.pm
lib/UR/BoolExpr/Template/PropertyComparison/LessThan.pm
lib/UR/BoolExpr/Template/PropertyComparison/Like.pm
lib/UR/BoolExpr/Template/PropertyComparison/Matches.pm
lib/UR/BoolExpr/Template/PropertyComparison/NotEqual.pm
lib/UR/BoolExpr/Template/PropertyComparison/NotIn.pm
lib/UR/BoolExpr/Template/PropertyComparison/NotLike.pm
lib/UR/BoolExpr/Template/PropertyComparison/True.pm
lib/UR/BoolExpr/Util.pm
lib/UR/Change.pm
lib/UR/Context.pm
lib/UR/Context/DefaultRoot.pm
lib/UR/Context/ImportIterator.pm
lib/UR/Context/LoadingIterator.pm
lib/UR/Context/ObjectFabricator.pm
lib/UR/Context/Process.pm
lib/UR/Context/Root.pm
lib/UR/Context/Transaction.pm
lib/UR/DataSource.pm
lib/UR/DataSource.pod
lib/UR/DataSource/Code.db
lib/UR/DataSource/Code.pm
lib/UR/DataSource/Code.schema
lib/UR/DataSource/CSV.pm
lib/UR/DataSource/Default.pm
lib/UR/DataSource/File.pm
lib/UR/DataSource/FileMux.pm
lib/UR/DataSource/Filesystem.pm
lib/UR/DataSource/Meta.pm
lib/UR/DataSource/Meta.sqlite3
lib/UR/DataSource/Meta.sqlite3-bak
lib/UR/DataSource/Meta.sqlite3-dump
lib/UR/DataSource/Meta.sqlite3-dump-boostrap
lib/UR/DataSource/Meta.sqlite3-schema
lib/UR/DataSource/MySQL.pm
lib/UR/DataSource/Oracle.pm
lib/UR/DataSource/Pg.pm
lib/UR/DataSource/QueryPlan.pm
lib/UR/DataSource/RDBMS.pm
lib/UR/DataSource/RDBMS/BitmapIndex.pm
lib/UR/DataSource/RDBMS/Entity.pm
lib/UR/DataSource/RDBMS/FkConstraint.pm
lib/UR/DataSource/RDBMS/FkConstraintColumn.pm
lib/UR/DataSource/RDBMS/PkConstraintColumn.pm
lib/UR/DataSource/RDBMS/Table.pm
lib/UR/DataSource/RDBMS/Table/View/Default/Text.pm
lib/UR/DataSource/RDBMS/TableColumn.pm
lib/UR/DataSource/RDBMS/TableColumn/View/Default/Text.pm
lib/UR/DataSource/RDBMS/UniqueConstraintColumn.pm
lib/UR/DataSource/SQLite.pm
lib/UR/DataSource/ValueDomain.pm
lib/UR/DBI.pm
lib/UR/DBI/Report.pm
lib/UR/Debug.pm
lib/UR/DeletedRef.pm
lib/UR/Doc/Pod2Html.pm
lib/UR/Doc/Section.pm
lib/UR/Doc/Writer.pm
lib/UR/Doc/Writer/Html.pm
lib/UR/Doc/Writer/Pod.pm
lib/UR/Env.pod
lib/UR/Env/UR_COMMAND_DUMP_STATUS_MESSAGES.pm
lib/UR/Env/UR_CONTEXT_BASE.pm
lib/UR/Env/UR_CONTEXT_CACHE_SIZE_HIGHWATER.pm
lib/UR/Env/UR_CONTEXT_CACHE_SIZE_LOWWATER.pm
lib/UR/Env/UR_CONTEXT_MONITOR_QUERY.pm
lib/UR/Env/UR_CONTEXT_ROOT.pm
lib/UR/Env/UR_DBI_DUMP_STACK_ON_CONNECT.pm
lib/UR/Env/UR_DBI_EXPLAIN_SQL_CALLSTACK.pm
lib/UR/Env/UR_DBI_EXPLAIN_SQL_IF.pm
lib/UR/Env/UR_DBI_EXPLAIN_SQL_MATCH.pm
lib/UR/Env/UR_DBI_EXPLAIN_SQL_SLOW.pm
lib/UR/Env/UR_DBI_MONITOR_DML.pm
lib/UR/Env/UR_DBI_MONITOR_EVERY_FETCH.pm
lib/UR/Env/UR_DBI_MONITOR_SQL.pm
lib/UR/Env/UR_DBI_NO_COMMIT.pm
lib/UR/Env/UR_DBI_SUMMARIZE_SQL.pm
lib/UR/Env/UR_DEBUG_OBJECT_PRUNING.pm
lib/UR/Env/UR_DEBUG_OBJECT_RELEASE.pm
lib/UR/Env/UR_IGNORE.pm
lib/UR/Env/UR_NO_REQUIRE_USER_VERIFY.pm
lib/UR/Env/UR_NR_CPU.pm
lib/UR/Env/UR_RUN_LONG_TESTS.pm
lib/UR/Env/UR_STACK_DUMP_ON_DIE.pm
lib/UR/Env/UR_STACK_DUMP_ON_WARN.pm
lib/UR/Env/UR_TEST_FILLDB.pm
lib/UR/Env/UR_TEST_QUIET.pm
lib/UR/Env/UR_USE_ANY.pm
lib/UR/Env/UR_USE_DUMMY_AUTOGENERATED_IDS.pm
lib/UR/Env/UR_USED_LIBS.pm
lib/UR/Env/UR_USED_MODS.pm
lib/UR/Exit.pm
lib/UR/Manual.pod
lib/UR/Manual/Cookbook.pod
lib/UR/Manual/Metadata.pod
lib/UR/Manual/Overview.pod
lib/UR/Manual/Presentation.pod
lib/UR/Manual/SchemaDesign.pod
lib/UR/Manual/Tutorial.pod
lib/UR/Manual/UR_Presentation.pdf
lib/UR/ModuleBase.pm
lib/UR/ModuleBuild.pm
lib/UR/ModuleConfig.pm
lib/UR/ModuleLoader.pm
lib/UR/Namespace.pm
lib/UR/Namespace/Command.pm
lib/UR/Namespace/Command.pm.opts
lib/UR/Namespace/Command/Base.pm
lib/UR/Namespace/Command/Define.pm
lib/UR/Namespace/Command/Define/Class.pm
lib/UR/Namespace/Command/Define/Datasource.pm
lib/UR/Namespace/Command/Define/Datasource/File.pm
lib/UR/Namespace/Command/Define/Datasource/Mysql.pm
lib/UR/Namespace/Command/Define/Datasource/Oracle.pm
lib/UR/Namespace/Command/Define/Datasource/Pg.pm
lib/UR/Namespace/Command/Define/Datasource/Rdbms.pm
lib/UR/Namespace/Command/Define/Datasource/RdbmsWithAuth.pm
lib/UR/Namespace/Command/Define/Datasource/Sqlite.pm
lib/UR/Namespace/Command/Define/Db.pm
lib/UR/Namespace/Command/Define/Namespace.pm
lib/UR/Namespace/Command/Init.pm
lib/UR/Namespace/Command/List.pm
lib/UR/Namespace/Command/List/Classes.pm
lib/UR/Namespace/Command/List/Modules.pm
lib/UR/Namespace/Command/List/Objects.pm
lib/UR/Namespace/Command/Old.pm
lib/UR/Namespace/Command/Old/DiffRewrite.pm
lib/UR/Namespace/Command/Old/DiffUpdate.pm
lib/UR/Namespace/Command/Old/ExportDbicClasses.pm
lib/UR/Namespace/Command/Old/Info.pm
lib/UR/Namespace/Command/Old/Redescribe.pm
lib/UR/Namespace/Command/RunsOnModulesInTree.pm
lib/UR/Namespace/Command/Show.pm
lib/UR/Namespace/Command/Show/Properties.pm
lib/UR/Namespace/Command/Show/Schema.pm
lib/UR/Namespace/Command/Show/Subclasses.pm
lib/UR/Namespace/Command/Sys.pm
lib/UR/Namespace/Command/Sys/ClassBrowser.pm
lib/UR/Namespace/Command/Test.pm
lib/UR/Namespace/Command/Test/Callcount.pm
lib/UR/Namespace/Command/Test/Callcount/List.pm
lib/UR/Namespace/Command/Test/Compile.pm
lib/UR/Namespace/Command/Test/Eval.pm
lib/UR/Namespace/Command/Test/Run.pm
lib/UR/Namespace/Command/Test/TrackObjectRelease.pm
lib/UR/Namespace/Command/Test/Use.pm
lib/UR/Namespace/Command/Test/Window.pm
lib/UR/Namespace/Command/Update.pm
lib/UR/Namespace/Command/Update/ClassDiagram.pm
lib/UR/Namespace/Command/Update/ClassesFromDb.pm
lib/UR/Namespace/Command/Update/Doc.pm
lib/UR/Namespace/Command/Update/Pod.pm
lib/UR/Namespace/Command/Update/RenameClass.pm
lib/UR/Namespace/Command/Update/RewriteClassHeader.pm
lib/UR/Namespace/Command/Update/SchemaDiagram.pm
lib/UR/Namespace/Command/Update/TabCompletionSpec.pm
lib/UR/Namespace/View/SchemaBrowser/CgiApp.pm
lib/UR/Namespace/View/SchemaBrowser/CgiApp/Base.pm
lib/UR/Namespace/View/SchemaBrowser/CgiApp/Class.pm
lib/UR/Namespace/View/SchemaBrowser/CgiApp/File.pm
lib/UR/Namespace/View/SchemaBrowser/CgiApp/Index.pm
lib/UR/Namespace/View/SchemaBrowser/CgiApp/Schema.pm
lib/UR/Object.pm
lib/UR/Object/Accessorized.pm
lib/UR/Object/Command/FetchAndDo.pm
lib/UR/Object/Command/List.pm
lib/UR/Object/Command/List.pod
lib/UR/Object/Command/List/Style.pm
lib/UR/Object/Ghost.pm
lib/UR/Object/Index.pm
lib/UR/Object/Iterator.pm
lib/UR/Object/Join.pm
lib/UR/Object/Property.pm
lib/UR/Object/Property/View/Default/Text.pm
lib/UR/Object/Property/View/DescriptionLineItem/Text.pm
lib/UR/Object/Property/View/ReferenceDescription/Text.pm
lib/UR/Object/Set.pm
lib/UR/Object/Set/View/Default/Html.pm
lib/UR/Object/Set/View/Default/Json.pm
lib/UR/Object/Set/View/Default/Text.pm
lib/UR/Object/Set/View/Default/Xml.pm
lib/UR/Object/Tag.pm
lib/UR/Object/Type.pm
lib/UR/Object/Type.pod
lib/UR/Object/Type/AccessorWriter.pm
lib/UR/Object/Type/AccessorWriter/Product.pm
lib/UR/Object/Type/AccessorWriter/Sum.pm
lib/UR/Object/Type/Initializer.pm
lib/UR/Object/Type/Initializer.pod
lib/UR/Object/Type/InternalAPI.pm
lib/UR/Object/Type/ModuleWriter.pm
lib/UR/Object/Type/View/AvailableViews/Json.pm
lib/UR/Object/Type/View/AvailableViews/Xml.pm
lib/UR/Object/Type/View/Default/Text.pm
lib/UR/Object/Type/View/Default/Xml.pm
lib/UR/Object/Value.pm
lib/UR/Object/View.pm
lib/UR/Object/View/Aspect.pm
lib/UR/Object/View/Default/Gtk.pm
lib/UR/Object/View/Default/Gtk2.pm
lib/UR/Object/View/Default/Html.pm
lib/UR/Object/View/Default/Json.pm
lib/UR/Object/View/Default/Text.pm
lib/UR/Object/View/Default/Xml.pm
lib/UR/Object/View/Default/Xsl.pm
lib/UR/Object/View/Lister/Text.pm
lib/UR/Object/View/Static/Html.pm
lib/UR/Object/View/Toolkit.pm
lib/UR/Object/View/Toolkit/Text.pm
lib/UR/ObjectDeprecated.pm
lib/UR/ObjectV001removed.pm
lib/UR/ObjectV04removed.pm
lib/UR/Observer.pm
lib/UR/Service/json.js
lib/UR/Service/JsonRpcServer.pm
lib/UR/Service/RPC/Executer.pm
lib/UR/Service/RPC/Message.pm
lib/UR/Service/RPC/Server.pm
lib/UR/Service/RPC/TcpConnectionListener.pm
lib/UR/Service/urinterface.js
lib/UR/Singleton.pm
lib/UR/Test.pm
lib/UR/Util.pm
lib/UR/Value.pm
lib/UR/Value/ARRAY.pm
lib/UR/Value/Blob.pm
lib/UR/Value/Boolean.pm
lib/UR/Value/Boolean/View/Default/Text.pm
lib/UR/Value/CODE.pm
lib/UR/Value/CSV.pm
lib/UR/Value/DateTime.pm
lib/UR/Value/Decimal.pm
lib/UR/Value/DirectoryPath.pm
lib/UR/Value/FilePath.pm
lib/UR/Value/FilesystemPath.pm
lib/UR/Value/Float.pm
lib/UR/Value/FOF.pm
lib/UR/Value/GLOB.pm
lib/UR/Value/HASH.pm
lib/UR/Value/Integer.pm
lib/UR/Value/Iterator.pm
lib/UR/Value/Number.pm
lib/UR/Value/PerlReference.pm
lib/UR/Value/REF.pm
lib/UR/Value/SCALAR.pm
lib/UR/Value/Set.pm
lib/UR/Value/SloppyPrimitive.pm
lib/UR/Value/String.pm
lib/UR/Value/Text.pm
lib/UR/Value/Timestamp.pm
lib/UR/Value/URL.pm
lib/UR/Value/View/Default/Html.pm
lib/UR/Value/View/Default/Json.pm
lib/UR/Value/View/Default/Text.pm
lib/UR/Value/View/Default/Xml.pm
lib/UR/Value/View/Default/Xml.t
lib/UR/Vocabulary.pm
LICENSE
MANIFEST This list of files
MANIFEST.SKIP
META.yml
pod/ur-define-class.pod
pod/ur-define-datasource-file.pod
pod/ur-define-datasource-mysql.pod
pod/ur-define-datasource-oracle.pod
pod/ur-define-datasource-pg.pod
pod/ur-define-datasource-sqlite.pod
pod/ur-define-datasource.pod
pod/ur-define-db.pod
pod/ur-define-namespace.pod
pod/ur-define.pod
pod/ur-describe.pod
pod/ur-init.pod
pod/ur-list-classes.pod
pod/ur-list-modules.pod
pod/ur-list-objects.pod
pod/ur-list.pod
pod/ur-old-diff-rewrite.pod
pod/ur-old-diff-update.pod
pod/ur-old-export-dbic-classes.pod
pod/ur-old-info.pod
pod/ur-old-redescribe.pod
pod/ur-old.pod
pod/ur-sys-class-browser.pod
pod/ur-sys.pod
pod/ur-test-callcount-list.pod
pod/ur-test-callcount.pod
pod/ur-test-compile.pod
pod/ur-test-eval.pod
pod/ur-test-run.pod
pod/ur-test-track-object-release.pod
pod/ur-test-use.pod
pod/ur-test-window.pod
pod/ur-test.pod
pod/ur-update-class-diagram.pod
pod/ur-update-classes-from-db.pod
pod/ur-update-pod.pod
pod/ur-update-rename-class.pod
pod/ur-update-rewrite-class-header.pod
pod/ur-update-schema-diagram.pod
pod/ur-update-tab-completion-spec.pod
pod/ur-update.pod
pod/ur.pod
README
t/above.t
t/alternate_namespace_layout/classes/URTAlternate/Person.pm
t/alternate_namespace_layout/classes/URTAlternate/Vocabulary.pm
t/alternate_namespace_layout/data_source/URTAlternate/DataSource/Meta.pm
t/alternate_namespace_layout/data_source/URTAlternate/DataSource/Meta.sqlite3-dump
t/alternate_namespace_layout/data_source/URTAlternate/DataSource/TheDB.pm
t/alternate_namespace_layout/data_source/URTAlternate/DataSource/TheDB.sqlite3-dump
t/alternate_namespace_layout/more_classes/URTAlternate/Car.pm
t/alternate_namespace_layout/namespace/URTAlternate.pm
t/alternate_namespace_layout/t/01_namespace.t
t/alternate_namespace_layout/t/02_update_classes.t
t/CdExample.pm
t/CdExample/Artist.pm
t/CdExample/Cd.pm
t/CmdTest.pm
t/CmdTest/C1.pm
t/CmdTest/C2.pm
t/CmdTest/C3.pm
t/CmdTest/Stuff.pm
t/CmdTest/t/01-mutual-resolution-via-to.t
t/newnamespace/01_command_define_namespace.t
t/Slimspace.pm
t/ur-cachetest.pl
t/urbenchmark.pl
t/URT.pm
t/URT/34Baseclass.pm
t/URT/34Subclass.pm
t/URT/38Primary.pm
t/URT/38Related.pm
t/URT/43Primary.pm
t/URT/43Related.pm
t/URT/Context/Testing.pm
t/URT/DataSource/CircFk.pm
t/URT/DataSource/Meta.pm
t/URT/DataSource/Meta.sqlite3
t/URT/DataSource/Meta.sqlite3-dump
t/URT/DataSource/Meta.sqlite3-schema
t/URT/DataSource/SomeFile.pm
t/URT/DataSource/SomeFileMux.pm
t/URT/DataSource/SomeMySQL.pm
t/URT/DataSource/SomeOracle.pm
t/URT/DataSource/SomePostgreSQL.pm
t/URT/DataSource/SomeSQLite.pm
t/URT/ObjWithHash.pm
t/URT/RAMThingy.pm
t/URT/t/001_util_on_destroy.t
t/URT/t/00_load.t
t/URT/t/01_object.t
t/URT/t/02_class_construction.t
t/URT/t/03a_rules.t
t/URT/t/03b_rule_constant_values.t
t/URT/t/03b_rule_subsets.t
t/URT/t/03c_rule_values.t
t/URT/t/03d_rule_construction.t
t/URT/t/03e_params_list.t
t/URT/t/03f_rule_from_filter_string.t
t/URT/t/03g_rule_constant_key_before.t
t/URT/t/03h_rule_for_property_meta.t
t/URT/t/03i_non_ur_types_as_values.t
t/URT/t/03i_rule_hard_refs.t
t/URT/t/03j_or_rules_with_meta.t
t/URT/t/04a_sqlite.t
t/URT/t/04a_sqlite_init_db_internal.t
t/URT/t/04a_sqlite_sync_database.t
t/URT/t/04b_mysql.t
t/URT/t/04c_postresql.t
t/URT/t/04d_oracle.t
t/URT/t/04e_file.t
t/URT/t/04e_file_sync_database.t
t/URT/t/04e_file_track_open_close.t
t/URT/t/04f_filemux.t
t/URT/t/04f_filemux_sync_database.t
t/URT/t/05_get_create_get.t
t/URT/t/06_accessor_simple.t
t/URT/t/07_create_get_simple.t
t/URT/t/08_create_get_complex1.t
t/URT/t/09_create_get_complex2.t
t/URT/t/10_accessor_object.t
t/URT/t/11_create_with_delegated_property.t
t/URT/t/11b_via_to_without_type.t
t/URT/t/11c_create_with_via_property.t
t/URT/t/11d_create_with_single_delegated_property_via_is_many_property.t
t/URT/t/12_properties_metadata_query.t
t/URT/t/13a_messaging.t
t/URT/t/13b_dump_message_inheritance.t
t/URT/t/13c_message_observers.t
t/URT/t/14_ghost_objects.t
t/URT/t/15_singleton.t
t/URT/t/16_viewer.t
t/URT/t/17_accessor_object_basic.t
t/URT/t/17b_mk_rw_accessor_signals_property_change.t
t/URT/t/17c_rw_property_alias.t
t/URT/t/18_indirect_accessor.t
t/URT/t/19_calculated_accessor.t
t/URT/t/20_has_many.t
t/URT/t/20a_has_many_with_multiple_ids.t
t/URT/t/21_observer.t
t/URT/t/21b_load_observer_autosubclass.t
t/URT/t/21c_load_observer_abstract_parent.t
t/URT/t/21d_db_entity_observers.t
t/URT/t/21e_old_subscription_api.t
t/URT/t/21f_observer_priority.t
t/URT/t/22_cached_get_with_subclasses.t
t/URT/t/23_id_class_by_accessor.t
t/URT/t/24_query_by_is_calculated.t
t/URT/t/24_query_by_is_transient.t
t/URT/t/24_query_via_method_call.t
t/URT/t/25_recurse_get.t
t/URT/t/26_indirect_mutator_with_where_via_is_many.t
t/URT/t/27_get_with_limit_offset.t
t/URT/t/28_dont_index_delegated_props.t
t/URT/t/29_indirect_calculated_accessor.t
t/URT/t/29b_join_calculated_accessor.t
t/URT/t/29c_join_indirect_accessor.t
t/URT/t/30_default_values.t
t/URT/t/31_ref_as_value.t
t/URT/t/32_ur_object_id.t
t/URT/t/34_autouse_with_circular_ur_classdef.t
t/URT/t/35_all_objects_are_loaded_subclass.t
t/URT/t/36_superclass_already_loaded.t
t/URT/t/37_caching_with_in_clause.t
t/URT/t/37b_caching_with_in_clause.t
t/URT/t/38_join_across_data_sources.t
t/URT/t/39_has_many.t
t/URT/t/40_has_many_direct.t
t/URT/t/41_rpc_basic.t
t/URT/t/42_rpc_between_processes.t
t/URT/t/43_infer_values_from_rule.t
t/URT/t/44_modulewriter.t
t/URT/t/45_deleted_subclassed_objects_stay_deleted.t
t/URT/t/45_rollback_deleted_object.t
t/URT/t/46_meta_property_relationships.t
t/URT/t/47_indirect_is_many_accessor.t
t/URT/t/47b_indirect_is_many_accessor_mutable_with_id_class_by.t
t/URT/t/47c_is_many_accessor_with_id_class_by.t
t/URT/t/48_inline_datasources.t
t/URT/t/49_complicated_get.t
t/URT/t/49b_complicated_get_2.t
t/URT/t/49c_complicated_get_3.t
t/URT/t/49d_complicated_get_joining_through_view.t
t/URT/t/49e_complicated_get_joining_through_view2.t
t/URT/t/49f_complicated_get_indirect_id_by.t
t/URT/t/49g_complicated_get_double_join.t
t/URT/t/49h_complicated_get_double_join.t
t/URT/t/49i_complicated_get_join_through_value_class.t
t/URT/t/49j_complicated_get_join_ends_at_value_class.t
t/URT/t/49k_complicated_get_joins_with_hangoff_filter.t
t/URT/t/49l_complicated_get_id_by_attribute.t
t/URT/t/49m_reverse_as_is_delegated.t
t/URT/t/50_force_always_reload.t
t/URT/t/50_get_and_reload.t
t/URT/t/50_load_objects_that_stringify_false.t
t/URT/t/50_unload_and_reload.t
t/URT/t/50b_get_via_sql.t
t/URT/t/51_get_with_hints.t
t/URT/t/51b_unmatched_hints_query_cache.t
t/URT/t/52_limit_cache_size.t
t/URT/t/53_abandoned_iterator.t
t/URT/t/54_valid_values.t
t/URT/t/55_on_the_fly_metadb.t
t/URT/t/55b_partial_metada_data.t
t/URT/t/56_order_by_returns_items_in_order.t
t/URT/t/56b_order_by_calculated_property.t
t/URT/t/57_order_by_merge_new_objects.t
t/URT/t/58_order_by_merge_changed_objects.t
t/URT/t/59_get_merge_new_objs_with_db.t
t/URT/t/60_get_merge_changed_objs_with_db.t
t/URT/t/60_sql_query_hint.t
t/URT/t/61_iterator.t
t/URT/t/61_iterator_merge_changed_objs_with_db.t
t/URT/t/61a_iterator_with_or_boolexpr.t
t/URT/t/62_in_not_in_operator.t
t/URT/t/62b_in_not_in_operator.t
t/URT/t/63_view_text.t
t/URT/t/63b_view_with_subviews.t
t/URT/t/63c_view_with_subviews.t
t/URT/t/63c_view_with_subviews.t.expected.cat_set.json
t/URT/t/63c_view_with_subviews.t.expected.cat_set.text
t/URT/t/63c_view_with_subviews.t.expected.cat_set.xml
t/URT/t/63c_view_with_subviews.t.expected.person.json
t/URT/t/63c_view_with_subviews.t.expected.person.text
t/URT/t/63c_view_with_subviews.t.expected.person.xml
t/URT/t/63d_delete_view.t
t/URT/t/63e_enumerate_available_views.t
t/URT/t/64_nullable_foreign_key_handling_on_insert_and_delete.t
t/URT/t/65_reload_with_changing_db_data.t
t/URT/t/66_nullable_hangoff_data.t
t/URT/t/67_composite_id_with_id_class_by_rt55121.t
t/URT/t/68_trapped_death_does_not_stack_trace.t
t/URT/t/69_subclassify_by.t
t/URT/t/69_subclassify_by_db.t
t/URT/t/70_command_arg_processing.t
t/URT/t/70_command_help_text.t
t/URT/t/70c_command_tree_usage_text.t
t/URT/t/71_ur_value.t
t/URT/t/72_command_name_validation.t
t/URT/t/73_opts_spec_creation_and_validation.t
t/URT/t/74_xsl_view_url_convert.t
t/URT/t/75_custom_loader.t
t/URT/t/76_is_many_default_values.t
t/URT/t/77_file_undef_value_handling.t
t/URT/t/77_index_undef_value_handling.t
t/URT/t/77_sql_undef_value_handling.t
t/URT/t/78_get_by_subclass_params_load_properly.t
t/URT/t/78b_get_by_subclass_property.t
t/URT/t/79_like_operator.t
t/URT/t/80_command_define_datasource.t
t/URT/t/80b_namespace_command_base.t
t/URT/t/80c_command_describe.t
t/URT/t/80d_command_list.t
t/URT/t/81_crud_custom_columnnames.t
t/URT/t/82_boolexpr_op_underscore.t
t/URT/t/82a_boolexpr_op_case_insensitive.t
t/URT/t/83_commit_between_schemas.t
t/URT/t/84_class_definition_errors.t
t/URT/t/84b_implied_properties.t
t/URT/t/85_avoid_loading_using_hints.t
t/URT/t/85_method_meta.t
t/URT/t/85b_avoid_loading_using_hints.t
t/URT/t/86_custom_load.t
t/URT/t/86b-custom-load-join.t
t/URT/t/87_attributes_have.t
t/URT/t/87_get_by_different_params_updates_query_cache.t
t/URT/t/87_is_many_indirect_is_efficient.t
t/URT/t/87a_many_to_many_query_is_efficient.t
t/URT/t/87b_is_many_id_class_by_is_efficient.t
t/URT/t/87c_query_by_is_many_indirect_is_efficient.t
t/URT/t/87d_query_by_is_many_indirect_is_efficient.t
t/URT/t/87e_missing_hangoff_data_is_efficient.t
t/URT/t/87f_via_property_joins_to_itself.t
t/URT/t/89_loading_with_boolexpr_evaluate.t
t/URT/t/90_comparison_value_and_escape_character_to_regex.t
t/URT/t/91_object_sets.t
t/URT/t/91b_sets_count_with_changes.t
t/URT/t/91c_set_relay.t
t/URT/t/91d_basic_set.t
t/URT/t/92_save_object_with_propertyless_column.t
t/URT/t/93_namespace.t
t/URT/t/93b_namespace_loaded_from_symlink.t
t/URT/t/94_chain_join.t
t/URT/t/94b_flatten_reframe.t
t/URT/t/95_detect_db_deleted.t
t/URT/t/95_normalize_property_description.t
t/URT/t/95b_subclass_description_preprocessor_errors.t
t/URT/t/95c_detect_changed_in_memory_filter.t
t/URT/t/96_context_clear_cache.t
t/URT/t/96b_ur_context_class_commit_triggers_observer.t
t/URT/t/96c_ur_context_current_and_process.t
t/URT/t/97_used_libs.t
t/URT/t/98_ur_update.t
t/URT/t/99_transaction-failed_commit_rollback.t
t/URT/t/99_transaction-observers.t
t/URT/t/99_transaction.t
t/URT/t/file_datasource/path_spec_expansion.t
t/URT/t/file_datasource/read.t
t/URT/t/file_datasource/read_columns_from_header.t
t/URT/t/file_datasource/read_efficiency.t
t/URT/t/file_datasource/read_files_as_tables.t
t/URT/t/file_datasource/read_linenum_as_column.t
t/URT/t/file_datasource/read_multichar_record_sep.t
t/URT/t/file_datasource/read_order_by.t
t/URT/t/file_datasource/write.t
t/URT/t/mro.t
t/URT/Thingy.pm
t/URT/Vocabulary.pm
t/Vending.pm
t/Vending/Coin.pm
t/Vending/CoinType.pm
t/Vending/Command.pm
t/Vending/Command/Buy.pm
t/Vending/Command/CoinReturn.pm
t/Vending/Command/Dime.pm
t/Vending/Command/Dollar.pm
t/Vending/Command/InsertMoney.pm
t/Vending/Command/Menu.pm
t/Vending/Command/Nickel.pm
t/Vending/Command/Outputter.pm
t/Vending/Command/Quarter.pm
t/Vending/Command/Service.pm
t/Vending/Command/Service/Add.pm
t/Vending/Command/Service/Add/Change.pm
t/Vending/Command/Service/Add/Inventory.pm
t/Vending/Command/Service/Add/Slot.pm
t/Vending/Command/Service/ConfigureSlot.pm
t/Vending/Command/Service/EmptyBank.pm
t/Vending/Command/Service/RemoveSlot.pm
t/Vending/Command/Service/Show.pm
t/Vending/Command/Service/Show/Bank.pm
t/Vending/Command/Service/Show/Change.pm
t/Vending/Command/Service/Show/Inventory.pm
t/Vending/Command/Service/Show/Money.pm
t/Vending/Command/Service/Show/Slots.pm
t/Vending/Content.pm
t/Vending/ContentType.pm
t/Vending/DataSource/coin_types.tsv
t/Vending/DataSource/CoinType.pm
t/Vending/DataSource/Machine.pm
t/Vending/DataSource/Machine.sqlite3-dump
t/Vending/DataSource/Meta.pm
t/Vending/DataSource/Meta.sqlite3-dump
t/Vending/get_coin_by_value.pl
t/Vending/Machine.pm
t/Vending/machine_classes_1.uxf
t/Vending/MachineLocation.pm
t/Vending/Merchandise.pm
t/Vending/notes.txt
t/Vending/Product.pm
t/Vending/ReturnedItem.pm
t/Vending/t/buy_a_different_change.t
t/Vending/t/buy_a_get_change_back.t
t/Vending/t/buy_a_not_enough_change.t
t/Vending/t/buy_b_not_enough_money.t
t/Vending/t/buy_b_with_exact_change.t
t/Vending/t/coin_return.t
t/Vending/vend
t/Vending/vend_interactive.pl
t/Vending/Vocabulary.pm
META.json
META.json 000444 023532 023421 113227 12121654174 13310 0 ustar 00abrummet gsc 000000 000000 UR-0.41 {
"abstract" : "rich declarative transactional objects",
"author" : [
"Anthony Brummett brummett@cpan.org",
"Scott Smith sakoht@cpan.org"
],
"dynamic_config" : 1,
"generated_by" : "Module::Build version 0.3901, CPAN::Meta::Converter version 2.120630",
"license" : [
"perl_5"
],
"meta-spec" : {
"url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
"version" : "2"
},
"name" : "UR",
"prereqs" : {
"configure" : {
"requires" : {
"Module::Build" : "0.39"
}
},
"runtime" : {
"requires" : {
"Carp" : "0",
"Class::AutoloadCAN" : "0.03",
"Class::Autouse" : "2.0",
"Clone::PP" : "1.02",
"DBD::SQLite" : "1.14",
"DBI" : "1.601",
"Data::Compare" : "0.13",
"Data::UUID" : "0.148",
"Date::Format" : "0",
"Devel::GlobalDestruction" : "0",
"File::Basename" : "2.73",
"File::Path" : "0",
"File::Temp" : "0",
"FreezeThaw" : "0.43",
"Getopt::Complete" : "0.26",
"JSON" : "0",
"Lingua::EN::Inflect" : "1.88",
"List::MoreUtils" : "0",
"MRO::Compat" : "0",
"Path::Class" : "0",
"Pod::Simple::HTML" : "3.03",
"Pod::Simple::Text" : "2.02",
"Sub::Install" : "0.924",
"Sub::Name" : "0.04",
"Sys::Hostname" : "1.11",
"Test::Fork" : "0",
"Text::Diff" : "0.35",
"Text::Glob" : "0",
"YAML" : "0",
"perl" : "v5.8.7",
"version" : "0"
}
}
},
"provides" : {
"Command" : {
"file" : "lib/Command.pm",
"version" : "0.41"
},
"Command::DynamicSubCommands" : {
"file" : "lib/Command/DynamicSubCommands.pm",
"version" : 0
},
"Command::Shell" : {
"file" : "lib/Command/Shell.pm",
"version" : 0
},
"Command::SubCommandFactory" : {
"file" : "lib/Command/SubCommandFactory.pm",
"version" : 0
},
"Command::Test" : {
"file" : "lib/Command/Test.pm",
"version" : 0
},
"Command::Test::Echo" : {
"file" : "lib/Command/Test/Echo.pm",
"version" : 0
},
"Command::Test::Tree1" : {
"file" : "lib/Command/Test/Tree1.pm",
"version" : 0
},
"Command::Test::Tree1::Echo1" : {
"file" : "lib/Command/Test/Tree1/Echo1.pm",
"version" : 0
},
"Command::Test::Tree1::Echo2" : {
"file" : "lib/Command/Test/Tree1/Echo2.pm",
"version" : 0
},
"Command::Tree" : {
"file" : "lib/Command/Tree.pm",
"version" : "0.41"
},
"Command::V1" : {
"file" : "lib/Command/V1.pm",
"version" : "0.41"
},
"Command::V2" : {
"file" : "lib/Command/V2.pm",
"version" : "0.41"
},
"Devel::callsfrom" : {
"file" : "lib/Devel/callcount.pm",
"version" : 0
},
"My::TAP::Parser::Iterator::Process::LSF" : {
"file" : "lib/UR/Namespace/Command/Test/Run.pm",
"version" : 0
},
"My::TAP::Parser::IteratorFactory::LSF" : {
"file" : "lib/UR/Namespace/Command/Test/Run.pm",
"version" : 0
},
"My::TAP::Parser::Multiplexer" : {
"file" : "lib/UR/Namespace/Command/Test/Run.pm",
"version" : 0
},
"My::TAP::Parser::Scheduler" : {
"file" : "lib/UR/Namespace/Command/Test/Run.pm",
"version" : 0
},
"My::TAP::Parser::Timer" : {
"file" : "lib/UR/Namespace/Command/Test/Run.pm",
"version" : 0
},
"UR" : {
"file" : "lib/UR.pm",
"version" : "0.41"
},
"UR::All" : {
"file" : "lib/UR/All.pm",
"version" : "0.41"
},
"UR::BoolExpr" : {
"file" : "lib/UR/BoolExpr.pm",
"version" : "0.41"
},
"UR::BoolExpr::BxParser" : {
"file" : "lib/UR/BoolExpr/BxParser.pm",
"version" : 0
},
"UR::BoolExpr::BxParser::Yapp::Driver" : {
"file" : "lib/UR/BoolExpr/BxParser.pm",
"version" : "1.05"
},
"UR::BoolExpr::Template" : {
"file" : "lib/UR/BoolExpr/Template.pm",
"version" : "0.41"
},
"UR::BoolExpr::Template::And" : {
"file" : "lib/UR/BoolExpr/Template/And.pm",
"version" : "0.41"
},
"UR::BoolExpr::Template::Composite" : {
"file" : "lib/UR/BoolExpr/Template/Composite.pm",
"version" : "0.41"
},
"UR::BoolExpr::Template::Or" : {
"file" : "lib/UR/BoolExpr/Template/Or.pm",
"version" : "0.41"
},
"UR::BoolExpr::Template::PropertyComparison" : {
"file" : "lib/UR/BoolExpr/Template/PropertyComparison.pm",
"version" : "0.41"
},
"UR::BoolExpr::Template::PropertyComparison::Between" : {
"file" : "lib/UR/BoolExpr/Template/PropertyComparison/Between.pm",
"version" : "0.41"
},
"UR::BoolExpr::Template::PropertyComparison::Equals" : {
"file" : "lib/UR/BoolExpr/Template/PropertyComparison/Equals.pm",
"version" : "0.41"
},
"UR::BoolExpr::Template::PropertyComparison::False" : {
"file" : "lib/UR/BoolExpr/Template/PropertyComparison/False.pm",
"version" : "0.41"
},
"UR::BoolExpr::Template::PropertyComparison::GreaterOrEqual" : {
"file" : "lib/UR/BoolExpr/Template/PropertyComparison/GreaterOrEqual.pm",
"version" : "0.41"
},
"UR::BoolExpr::Template::PropertyComparison::GreaterThan" : {
"file" : "lib/UR/BoolExpr/Template/PropertyComparison/GreaterThan.pm",
"version" : "0.41"
},
"UR::BoolExpr::Template::PropertyComparison::In" : {
"file" : "lib/UR/BoolExpr/Template/PropertyComparison/In.pm",
"version" : "0.41"
},
"UR::BoolExpr::Template::PropertyComparison::LessOrEqual" : {
"file" : "lib/UR/BoolExpr/Template/PropertyComparison/LessOrEqual.pm",
"version" : "0.41"
},
"UR::BoolExpr::Template::PropertyComparison::LessThan" : {
"file" : "lib/UR/BoolExpr/Template/PropertyComparison/LessThan.pm",
"version" : "0.41"
},
"UR::BoolExpr::Template::PropertyComparison::Like" : {
"file" : "lib/UR/BoolExpr/Template/PropertyComparison/Like.pm",
"version" : "0.41"
},
"UR::BoolExpr::Template::PropertyComparison::Matches" : {
"file" : "lib/UR/BoolExpr/Template/PropertyComparison/Matches.pm",
"version" : "0.41"
},
"UR::BoolExpr::Template::PropertyComparison::NotEqual" : {
"file" : "lib/UR/BoolExpr/Template/PropertyComparison/NotEqual.pm",
"version" : "0.41"
},
"UR::BoolExpr::Template::PropertyComparison::NotIn" : {
"file" : "lib/UR/BoolExpr/Template/PropertyComparison/NotIn.pm",
"version" : "0.41"
},
"UR::BoolExpr::Template::PropertyComparison::NotLike" : {
"file" : "lib/UR/BoolExpr/Template/PropertyComparison/NotLike.pm",
"version" : "0.41"
},
"UR::BoolExpr::Template::PropertyComparison::True" : {
"file" : "lib/UR/BoolExpr/Template/PropertyComparison/True.pm",
"version" : "0.41"
},
"UR::BoolExpr::Util" : {
"file" : "lib/UR/BoolExpr/Util.pm",
"version" : "0.41"
},
"UR::Change" : {
"file" : "lib/UR/Change.pm",
"version" : "0.41"
},
"UR::Context" : {
"file" : "lib/UR/Context.pm",
"version" : "0.41"
},
"UR::Context::DefaultRoot" : {
"file" : "lib/UR/Context/DefaultRoot.pm",
"version" : "0.41"
},
"UR::Context::LoadingIterator" : {
"file" : "lib/UR/Context/LoadingIterator.pm",
"version" : "0.41"
},
"UR::Context::ObjectFabricator" : {
"file" : "lib/UR/Context/ObjectFabricator.pm",
"version" : "0.41"
},
"UR::Context::Process" : {
"file" : "lib/UR/Context/Process.pm",
"version" : "0.41"
},
"UR::Context::Root" : {
"file" : "lib/UR/Context/Root.pm",
"version" : "0.41"
},
"UR::Context::Transaction" : {
"file" : "lib/UR/Context/Transaction.pm",
"version" : "0.41"
},
"UR::DBI" : {
"file" : "lib/UR/DBI.pm",
"version" : "0.41"
},
"UR::DBI::Report" : {
"file" : "lib/UR/DBI/Report.pm",
"version" : "0.41"
},
"UR::DBI::db" : {
"file" : "lib/UR/DBI.pm",
"version" : 0
},
"UR::DBI::st" : {
"file" : "lib/UR/DBI.pm",
"version" : 0
},
"UR::DataSource" : {
"file" : "lib/UR/DataSource.pm",
"version" : "0.41"
},
"UR::DataSource::CSV" : {
"file" : "lib/UR/DataSource/CSV.pm",
"version" : "0.41"
},
"UR::DataSource::Code" : {
"file" : "lib/UR/DataSource/Code.pm",
"version" : "0.41"
},
"UR::DataSource::Default" : {
"file" : "lib/UR/DataSource/Default.pm",
"version" : "0.41"
},
"UR::DataSource::File" : {
"file" : "lib/UR/DataSource/File.pm",
"version" : "0.41"
},
"UR::DataSource::FileMux" : {
"file" : "lib/UR/DataSource/FileMux.pm",
"version" : "0.41"
},
"UR::DataSource::Filesystem" : {
"file" : "lib/UR/DataSource/Filesystem.pm",
"version" : "0.41"
},
"UR::DataSource::Meta" : {
"file" : "lib/UR/DataSource/Meta.pm",
"version" : "0.41"
},
"UR::DataSource::MySQL" : {
"file" : "lib/UR/DataSource/MySQL.pm",
"version" : "0.41"
},
"UR::DataSource::Oracle" : {
"file" : "lib/UR/DataSource/Oracle.pm",
"version" : "0.41"
},
"UR::DataSource::Pg" : {
"file" : "lib/UR/DataSource/Pg.pm",
"version" : "0.41"
},
"UR::DataSource::QueryPlan" : {
"file" : "lib/UR/DataSource/QueryPlan.pm",
"version" : "0.41"
},
"UR::DataSource::RDBMS" : {
"file" : "lib/UR/DataSource/RDBMS.pm",
"version" : "0.41"
},
"UR::DataSource::RDBMS::BitmapIndex" : {
"file" : "lib/UR/DataSource/RDBMS/BitmapIndex.pm",
"version" : "0.41"
},
"UR::DataSource::RDBMS::Entity" : {
"file" : "lib/UR/DataSource/RDBMS/Entity.pm",
"version" : "0.41"
},
"UR::DataSource::RDBMS::FkConstraint" : {
"file" : "lib/UR/DataSource/RDBMS/FkConstraint.pm",
"version" : "0.41"
},
"UR::DataSource::RDBMS::FkConstraintColumn" : {
"file" : "lib/UR/DataSource/RDBMS/FkConstraintColumn.pm",
"version" : "0.41"
},
"UR::DataSource::RDBMS::PkConstraintColumn" : {
"file" : "lib/UR/DataSource/RDBMS/PkConstraintColumn.pm",
"version" : "0.41"
},
"UR::DataSource::RDBMS::Table" : {
"file" : "lib/UR/DataSource/RDBMS/Table.pm",
"version" : "0.41"
},
"UR::DataSource::RDBMS::Table::View::Default::Text" : {
"file" : "lib/UR/DataSource/RDBMS/Table/View/Default/Text.pm",
"version" : "0.41"
},
"UR::DataSource::RDBMS::TableColumn" : {
"file" : "lib/UR/DataSource/RDBMS/TableColumn.pm",
"version" : "0.41"
},
"UR::DataSource::RDBMS::TableColumn::View::Default::Text" : {
"file" : "lib/UR/DataSource/RDBMS/TableColumn/View/Default/Text.pm",
"version" : "0.41"
},
"UR::DataSource::RDBMS::UniqueConstraintColumn" : {
"file" : "lib/UR/DataSource/RDBMS/UniqueConstraintColumn.pm",
"version" : "0.41"
},
"UR::DataSource::SQLite" : {
"file" : "lib/UR/DataSource/SQLite.pm",
"version" : "0.41"
},
"UR::DataSource::ValueDomain" : {
"file" : "lib/UR/DataSource/ValueDomain.pm",
"version" : "0.41"
},
"UR::Debug" : {
"file" : "lib/UR/Debug.pm",
"version" : "0.41"
},
"UR::DeletedRef" : {
"file" : "lib/UR/DeletedRef.pm",
"version" : "0.41"
},
"UR::Doc::Pod2Html" : {
"file" : "lib/UR/Doc/Pod2Html.pm",
"version" : "0.41"
},
"UR::Doc::Section" : {
"file" : "lib/UR/Doc/Section.pm",
"version" : "0.41"
},
"UR::Doc::Writer" : {
"file" : "lib/UR/Doc/Writer.pm",
"version" : "0.41"
},
"UR::Doc::Writer::Html" : {
"file" : "lib/UR/Doc/Writer/Html.pm",
"version" : "0.41"
},
"UR::Doc::Writer::Pod" : {
"file" : "lib/UR/Doc/Writer/Pod.pm",
"version" : "0.41"
},
"UR::Env::UR_COMMAND_DUMP_STATUS_MESSAGES" : {
"file" : "lib/UR/Env/UR_COMMAND_DUMP_STATUS_MESSAGES.pm",
"version" : "0.41"
},
"UR::Env::UR_CONTEXT_BASE" : {
"file" : "lib/UR/Env/UR_CONTEXT_BASE.pm",
"version" : "0.41"
},
"UR::Env::UR_CONTEXT_CACHE_SIZE_HIGHWATER" : {
"file" : "lib/UR/Env/UR_CONTEXT_CACHE_SIZE_HIGHWATER.pm",
"version" : "0.41"
},
"UR::Env::UR_CONTEXT_CACHE_SIZE_LOWWATER" : {
"file" : "lib/UR/Env/UR_CONTEXT_CACHE_SIZE_LOWWATER.pm",
"version" : "0.41"
},
"UR::Env::UR_CONTEXT_LIBS" : {
"file" : "lib/UR/Env/UR_USED_LIBS.pm",
"version" : "0.41"
},
"UR::Env::UR_CONTEXT_MONITOR_QUERY" : {
"file" : "lib/UR/Env/UR_CONTEXT_MONITOR_QUERY.pm",
"version" : "0.41"
},
"UR::Env::UR_CONTEXT_ROOT" : {
"file" : "lib/UR/Env/UR_CONTEXT_ROOT.pm",
"version" : "0.41"
},
"UR::Env::UR_DBI_DUMP_STACK_ON_CONNECT" : {
"file" : "lib/UR/Env/UR_DBI_DUMP_STACK_ON_CONNECT.pm",
"version" : "0.41"
},
"UR::Env::UR_DBI_EXPLAIN_SQL_CALLSTACK" : {
"file" : "lib/UR/Env/UR_DBI_EXPLAIN_SQL_CALLSTACK.pm",
"version" : "0.41"
},
"UR::Env::UR_DBI_EXPLAIN_SQL_IF" : {
"file" : "lib/UR/Env/UR_DBI_EXPLAIN_SQL_IF.pm",
"version" : "0.41"
},
"UR::Env::UR_DBI_EXPLAIN_SQL_MATCH" : {
"file" : "lib/UR/Env/UR_DBI_EXPLAIN_SQL_MATCH.pm",
"version" : "0.41"
},
"UR::Env::UR_DBI_EXPLAIN_SQL_SLOW" : {
"file" : "lib/UR/Env/UR_DBI_EXPLAIN_SQL_SLOW.pm",
"version" : "0.41"
},
"UR::Env::UR_DBI_MONITOR_DML" : {
"file" : "lib/UR/Env/UR_DBI_MONITOR_DML.pm",
"version" : "0.41"
},
"UR::Env::UR_DBI_MONITOR_EVERY_FETCH" : {
"file" : "lib/UR/Env/UR_DBI_MONITOR_EVERY_FETCH.pm",
"version" : "0.41"
},
"UR::Env::UR_DBI_MONITOR_SQL" : {
"file" : "lib/UR/Env/UR_DBI_MONITOR_SQL.pm",
"version" : "0.41"
},
"UR::Env::UR_DBI_NO_COMMIT" : {
"file" : "lib/UR/Env/UR_DBI_NO_COMMIT.pm",
"version" : "0.41"
},
"UR::Env::UR_DBI_SUMMARIZE_SQL" : {
"file" : "lib/UR/Env/UR_DBI_SUMMARIZE_SQL.pm",
"version" : "0.41"
},
"UR::Env::UR_DEBUG_OBJECT_PRUNING" : {
"file" : "lib/UR/Env/UR_DEBUG_OBJECT_PRUNING.pm",
"version" : "0.41"
},
"UR::Env::UR_DEBUG_OBJECT_RELEASE" : {
"file" : "lib/UR/Env/UR_DEBUG_OBJECT_RELEASE.pm",
"version" : "0.41"
},
"UR::Env::UR_IGNORE" : {
"file" : "lib/UR/Env/UR_IGNORE.pm",
"version" : "0.41"
},
"UR::Env::UR_NO_REQUIRE_USER_VERIFY" : {
"file" : "lib/UR/Env/UR_NO_REQUIRE_USER_VERIFY.pm",
"version" : "0.41"
},
"UR::Env::UR_NR_CPU" : {
"file" : "lib/UR/Env/UR_NR_CPU.pm",
"version" : "0.41"
},
"UR::Env::UR_RUN_LONG_TESTS" : {
"file" : "lib/UR/Env/UR_RUN_LONG_TESTS.pm",
"version" : "0.41"
},
"UR::Env::UR_STACK_DUMP_ON_DIE" : {
"file" : "lib/UR/Env/UR_STACK_DUMP_ON_DIE.pm",
"version" : "0.41"
},
"UR::Env::UR_STACK_DUMP_ON_WARN" : {
"file" : "lib/UR/Env/UR_STACK_DUMP_ON_WARN.pm",
"version" : "0.41"
},
"UR::Env::UR_TEST_FILLDB" : {
"file" : "lib/UR/Env/UR_TEST_FILLDB.pm",
"version" : "0.41"
},
"UR::Env::UR_TEST_QUIET" : {
"file" : "lib/UR/Env/UR_TEST_QUIET.pm",
"version" : "0.41"
},
"UR::Env::UR_USED_MODS" : {
"file" : "lib/UR/Env/UR_USED_MODS.pm",
"version" : "0.41"
},
"UR::Env::UR_USE_ANY" : {
"file" : "lib/UR/Env/UR_USE_ANY.pm",
"version" : "0.41"
},
"UR::Env::UR_USE_DUMMY_AUTOGENERATED_IDS" : {
"file" : "lib/UR/Env/UR_USE_DUMMY_AUTOGENERATED_IDS.pm",
"version" : "0.41"
},
"UR::Exit" : {
"file" : "lib/UR/Exit.pm",
"version" : "0.41"
},
"UR::ModuleBase" : {
"file" : "lib/UR/ModuleBase.pm",
"version" : "0.41"
},
"UR::ModuleBase::Message" : {
"file" : "lib/UR/ObjectDeprecated.pm",
"version" : 0
},
"UR::ModuleBuild" : {
"file" : "lib/UR/ModuleBuild.pm",
"version" : 0
},
"UR::ModuleConfig" : {
"file" : "lib/UR/ModuleConfig.pm",
"version" : "0.41"
},
"UR::ModuleLoader" : {
"file" : "lib/UR/ModuleLoader.pm",
"version" : "0.41"
},
"UR::Namespace" : {
"file" : "lib/UR/Namespace.pm",
"version" : "0.41"
},
"UR::Namespace::Command" : {
"file" : "lib/UR/Namespace/Command.pm",
"version" : "0.41"
},
"UR::Namespace::Command::Base" : {
"file" : "lib/UR/Namespace/Command/Base.pm",
"version" : "0.41"
},
"UR::Namespace::Command::Define" : {
"file" : "lib/UR/Namespace/Command/Define.pm",
"version" : "0.41"
},
"UR::Namespace::Command::Define::Class" : {
"file" : "lib/UR/Namespace/Command/Define/Class.pm",
"version" : "0.41"
},
"UR::Namespace::Command::Define::Datasource" : {
"file" : "lib/UR/Namespace/Command/Define/Datasource.pm",
"version" : "0.41"
},
"UR::Namespace::Command::Define::Datasource::File" : {
"file" : "lib/UR/Namespace/Command/Define/Datasource/File.pm",
"version" : "0.41"
},
"UR::Namespace::Command::Define::Datasource::Mysql" : {
"file" : "lib/UR/Namespace/Command/Define/Datasource/Mysql.pm",
"version" : "0.41"
},
"UR::Namespace::Command::Define::Datasource::Oracle" : {
"file" : "lib/UR/Namespace/Command/Define/Datasource/Oracle.pm",
"version" : "0.41"
},
"UR::Namespace::Command::Define::Datasource::Pg" : {
"file" : "lib/UR/Namespace/Command/Define/Datasource/Pg.pm",
"version" : "0.41"
},
"UR::Namespace::Command::Define::Datasource::Rdbms" : {
"file" : "lib/UR/Namespace/Command/Define/Datasource/Rdbms.pm",
"version" : "0.41"
},
"UR::Namespace::Command::Define::Datasource::RdbmsWithAuth" : {
"file" : "lib/UR/Namespace/Command/Define/Datasource/RdbmsWithAuth.pm",
"version" : "0.41"
},
"UR::Namespace::Command::Define::Datasource::Sqlite" : {
"file" : "lib/UR/Namespace/Command/Define/Datasource/Sqlite.pm",
"version" : "0.41"
},
"UR::Namespace::Command::Define::Db" : {
"file" : "lib/UR/Namespace/Command/Define/Db.pm",
"version" : "0.41"
},
"UR::Namespace::Command::Define::Namespace" : {
"file" : "lib/UR/Namespace/Command/Define/Namespace.pm",
"version" : "0.41"
},
"UR::Namespace::Command::Init" : {
"file" : "lib/UR/Namespace/Command/Init.pm",
"version" : "0.41"
},
"UR::Namespace::Command::List" : {
"file" : "lib/UR/Namespace/Command/List.pm",
"version" : "0.41"
},
"UR::Namespace::Command::List::Classes" : {
"file" : "lib/UR/Namespace/Command/List/Classes.pm",
"version" : "0.41"
},
"UR::Namespace::Command::List::Modules" : {
"file" : "lib/UR/Namespace/Command/List/Modules.pm",
"version" : "0.41"
},
"UR::Namespace::Command::List::Objects" : {
"file" : "lib/UR/Namespace/Command/List/Objects.pm",
"version" : "0.41"
},
"UR::Namespace::Command::Old" : {
"file" : "lib/UR/Namespace/Command/Old.pm",
"version" : "0.41"
},
"UR::Namespace::Command::Old::DiffRewrite" : {
"file" : "lib/UR/Namespace/Command/Old/DiffRewrite.pm",
"version" : "0.41"
},
"UR::Namespace::Command::Old::DiffUpdate" : {
"file" : "lib/UR/Namespace/Command/Old/DiffUpdate.pm",
"version" : "0.41"
},
"UR::Namespace::Command::Old::ExportDbicClasses" : {
"file" : "lib/UR/Namespace/Command/Old/ExportDbicClasses.pm",
"version" : "0.41"
},
"UR::Namespace::Command::Old::Info" : {
"file" : "lib/UR/Namespace/Command/Old/Info.pm",
"version" : "0.41"
},
"UR::Namespace::Command::Old::Redescribe" : {
"file" : "lib/UR/Namespace/Command/Old/Redescribe.pm",
"version" : "0.41"
},
"UR::Namespace::Command::RunsOnModulesInTree" : {
"file" : "lib/UR/Namespace/Command/RunsOnModulesInTree.pm",
"version" : "0.41"
},
"UR::Namespace::Command::Show" : {
"file" : "lib/UR/Namespace/Command/Show.pm",
"version" : 0
},
"UR::Namespace::Command::Show::Properties" : {
"file" : "lib/UR/Namespace/Command/Show/Properties.pm",
"version" : "0.41"
},
"UR::Namespace::Command::Show::Schema" : {
"file" : "lib/UR/Namespace/Command/Show/Schema.pm",
"version" : 0
},
"UR::Namespace::Command::Show::Subclasses" : {
"file" : "lib/UR/Namespace/Command/Show/Subclasses.pm",
"version" : 0
},
"UR::Namespace::Command::Sys" : {
"file" : "lib/UR/Namespace/Command/Sys.pm",
"version" : "0.41"
},
"UR::Namespace::Command::Sys::ClassBrowser" : {
"file" : "lib/UR/Namespace/Command/Sys/ClassBrowser.pm",
"version" : "0.41"
},
"UR::Namespace::Command::Test" : {
"file" : "lib/UR/Namespace/Command/Test.pm",
"version" : "0.41"
},
"UR::Namespace::Command::Test::Callcount" : {
"file" : "lib/UR/Namespace/Command/Test/Callcount.pm",
"version" : "0.41"
},
"UR::Namespace::Command::Test::Callcount::List" : {
"file" : "lib/UR/Namespace/Command/Test/Callcount/List.pm",
"version" : "0.41"
},
"UR::Namespace::Command::Test::Compile" : {
"file" : "lib/UR/Namespace/Command/Test/Compile.pm",
"version" : "0.41"
},
"UR::Namespace::Command::Test::Eval" : {
"file" : "lib/UR/Namespace/Command/Test/Eval.pm",
"version" : "0.41"
},
"UR::Namespace::Command::Test::Run" : {
"file" : "lib/UR/Namespace/Command/Test/Run.pm",
"version" : "0.41"
},
"UR::Namespace::Command::Test::TrackObjectRelease" : {
"file" : "lib/UR/Namespace/Command/Test/TrackObjectRelease.pm",
"version" : "0.41"
},
"UR::Namespace::Command::Test::Use" : {
"file" : "lib/UR/Namespace/Command/Test/Use.pm",
"version" : "0.41"
},
"UR::Namespace::Command::Test::Window" : {
"file" : "lib/UR/Namespace/Command/Test/Window.pm",
"version" : "0.41"
},
"UR::Namespace::Command::Test::Window::Tk" : {
"file" : "lib/UR/Namespace/Command/Test/Window.pm",
"version" : 0
},
"UR::Namespace::Command::Update" : {
"file" : "lib/UR/Namespace/Command/Update.pm",
"version" : "0.41"
},
"UR::Namespace::Command::Update::ClassDiagram" : {
"file" : "lib/UR/Namespace/Command/Update/ClassDiagram.pm",
"version" : "0.41"
},
"UR::Namespace::Command::Update::ClassesFromDb" : {
"file" : "lib/UR/Namespace/Command/Update/ClassesFromDb.pm",
"version" : "0.41"
},
"UR::Namespace::Command::Update::Doc" : {
"file" : "lib/UR/Namespace/Command/Update/Doc.pm",
"version" : "0.41"
},
"UR::Namespace::Command::Update::Pod" : {
"file" : "lib/UR/Namespace/Command/Update/Pod.pm",
"version" : "0.41"
},
"UR::Namespace::Command::Update::RenameClass" : {
"file" : "lib/UR/Namespace/Command/Update/RenameClass.pm",
"version" : "0.41"
},
"UR::Namespace::Command::Update::RewriteClassHeader" : {
"file" : "lib/UR/Namespace/Command/Update/RewriteClassHeader.pm",
"version" : "0.41"
},
"UR::Namespace::Command::Update::SchemaDiagram" : {
"file" : "lib/UR/Namespace/Command/Update/SchemaDiagram.pm",
"version" : "0.41"
},
"UR::Namespace::Command::Update::TabCompletionSpec" : {
"file" : "lib/UR/Namespace/Command/Update/TabCompletionSpec.pm",
"version" : "0.41"
},
"UR::Namespace::View::SchemaBrowser::CgiApp" : {
"file" : "lib/UR/Namespace/View/SchemaBrowser/CgiApp.pm",
"version" : "0.41"
},
"UR::Namespace::View::SchemaBrowser::CgiApp::Base" : {
"file" : "lib/UR/Namespace/View/SchemaBrowser/CgiApp/Base.pm",
"version" : "0.41"
},
"UR::Namespace::View::SchemaBrowser::CgiApp::Class" : {
"file" : "lib/UR/Namespace/View/SchemaBrowser/CgiApp/Class.pm",
"version" : "0.41"
},
"UR::Namespace::View::SchemaBrowser::CgiApp::File" : {
"file" : "lib/UR/Namespace/View/SchemaBrowser/CgiApp/File.pm",
"version" : "0.41"
},
"UR::Namespace::View::SchemaBrowser::CgiApp::Index" : {
"file" : "lib/UR/Namespace/View/SchemaBrowser/CgiApp/Index.pm",
"version" : "0.41"
},
"UR::Namespace::View::SchemaBrowser::CgiApp::Schema" : {
"file" : "lib/UR/Namespace/View/SchemaBrowser/CgiApp/Schema.pm",
"version" : "0.41"
},
"UR::Object" : {
"file" : "lib/UR/Object.pm",
"version" : "0.41"
},
"UR::Object::Accessorized" : {
"file" : "lib/UR/Object/Accessorized.pm",
"version" : "0.41"
},
"UR::Object::Command::FetchAndDo" : {
"file" : "lib/UR/Object/Command/FetchAndDo.pm",
"version" : "0.41"
},
"UR::Object::Command::List" : {
"file" : "lib/UR/Object/Command/List.pm",
"version" : "0.41"
},
"UR::Object::Command::List::Csv" : {
"file" : "lib/UR/Object/Command/List/Style.pm",
"version" : 0
},
"UR::Object::Command::List::Html" : {
"file" : "lib/UR/Object/Command/List/Style.pm",
"version" : 0
},
"UR::Object::Command::List::Newtext" : {
"file" : "lib/UR/Object/Command/List/Style.pm",
"version" : 0
},
"UR::Object::Command::List::Pretty" : {
"file" : "lib/UR/Object/Command/List/Style.pm",
"version" : 0
},
"UR::Object::Command::List::Style" : {
"file" : "lib/UR/Object/Command/List/Style.pm",
"version" : "0.41"
},
"UR::Object::Command::List::Text" : {
"file" : "lib/UR/Object/Command/List/Style.pm",
"version" : 0
},
"UR::Object::Command::List::Tsv" : {
"file" : "lib/UR/Object/Command/List/Style.pm",
"version" : 0
},
"UR::Object::Command::List::Xml" : {
"file" : "lib/UR/Object/Command/List/Style.pm",
"version" : 0
},
"UR::Object::Ghost" : {
"file" : "lib/UR/Object/Ghost.pm",
"version" : "0.41"
},
"UR::Object::Index" : {
"file" : "lib/UR/Object/Index.pm",
"version" : "0.41"
},
"UR::Object::Iterator" : {
"file" : "lib/UR/Object/Iterator.pm",
"version" : "0.41"
},
"UR::Object::Join" : {
"file" : "lib/UR/Object/Join.pm",
"version" : "0.41"
},
"UR::Object::Property" : {
"file" : "lib/UR/Object/Property.pm",
"version" : "0.41"
},
"UR::Object::Property::View::Default::Text" : {
"file" : "lib/UR/Object/Property/View/Default/Text.pm",
"version" : "0.41"
},
"UR::Object::Property::View::DescriptionLineItem::Text" : {
"file" : "lib/UR/Object/Property/View/DescriptionLineItem/Text.pm",
"version" : "0.41"
},
"UR::Object::Property::View::ReferenceDescription::Text" : {
"file" : "lib/UR/Object/Property/View/ReferenceDescription/Text.pm",
"version" : "0.41"
},
"UR::Object::Set" : {
"file" : "lib/UR/Object/Set.pm",
"version" : "0.41"
},
"UR::Object::Set::View::Default::Html" : {
"file" : "lib/UR/Object/Set/View/Default/Html.pm",
"version" : "0.41"
},
"UR::Object::Set::View::Default::Json" : {
"file" : "lib/UR/Object/Set/View/Default/Json.pm",
"version" : "0.41"
},
"UR::Object::Set::View::Default::Text" : {
"file" : "lib/UR/Object/Set/View/Default/Text.pm",
"version" : "0.41"
},
"UR::Object::Set::View::Default::Xml" : {
"file" : "lib/UR/Object/Set/View/Default/Xml.pm",
"version" : "0.41"
},
"UR::Object::Tag" : {
"file" : "lib/UR/Object/Tag.pm",
"version" : "0.41"
},
"UR::Object::Type" : {
"file" : "lib/UR/Object/Type.pm",
"version" : "0.41"
},
"UR::Object::Type::AccessorWriter" : {
"file" : "lib/UR/Object/Type/AccessorWriter.pm",
"version" : 0
},
"UR::Object::Type::AccessorWriter::Product" : {
"file" : "lib/UR/Object/Type/AccessorWriter/Product.pm",
"version" : "0.41"
},
"UR::Object::Type::AccessorWriter::Sum" : {
"file" : "lib/UR/Object/Type/AccessorWriter/Sum.pm",
"version" : "0.41"
},
"UR::Object::Type::Initializer" : {
"file" : "lib/UR/Object/Type/Initializer.pm",
"version" : 0
},
"UR::Object::Type::ModuleWriter" : {
"file" : "lib/UR/Object/Type/ModuleWriter.pm",
"version" : 0
},
"UR::Object::Type::View::AvailableViews::Json" : {
"file" : "lib/UR/Object/Type/View/AvailableViews/Json.pm",
"version" : "0.41"
},
"UR::Object::Type::View::AvailableViews::Xml" : {
"file" : "lib/UR/Object/Type/View/AvailableViews/Xml.pm",
"version" : "0.41"
},
"UR::Object::Type::View::Default::Text" : {
"file" : "lib/UR/Object/Type/View/Default/Text.pm",
"version" : "0.41"
},
"UR::Object::Type::View::Default::Xml" : {
"file" : "lib/UR/Object/Type/View/Default/Xml.pm",
"version" : "0.41"
},
"UR::Object::Value" : {
"file" : "lib/UR/Object/Value.pm",
"version" : "0.41"
},
"UR::Object::View" : {
"file" : "lib/UR/Object/View.pm",
"version" : "0.41"
},
"UR::Object::View::Aspect" : {
"file" : "lib/UR/Object/View/Aspect.pm",
"version" : "0.41"
},
"UR::Object::View::Default::Gtk" : {
"file" : "lib/UR/Object/View/Default/Gtk.pm",
"version" : "0.41"
},
"UR::Object::View::Default::Gtk2" : {
"file" : "lib/UR/Object/View/Default/Gtk2.pm",
"version" : "0.41"
},
"UR::Object::View::Default::Html" : {
"file" : "lib/UR/Object/View/Default/Html.pm",
"version" : "0.41"
},
"UR::Object::View::Default::Json" : {
"file" : "lib/UR/Object/View/Default/Json.pm",
"version" : "0.41"
},
"UR::Object::View::Default::Text" : {
"file" : "lib/UR/Object/View/Default/Text.pm",
"version" : "0.41"
},
"UR::Object::View::Default::Xml" : {
"file" : "lib/UR/Object/View/Default/Xml.pm",
"version" : "0.41"
},
"UR::Object::View::Default::Xsl" : {
"file" : "lib/UR/Object/View/Default/Xsl.pm",
"version" : "0.41"
},
"UR::Object::View::Lister::Text" : {
"file" : "lib/UR/Object/View/Lister/Text.pm",
"version" : "0.41"
},
"UR::Object::View::Static::Html" : {
"file" : "lib/UR/Object/View/Static/Html.pm",
"version" : "0.41"
},
"UR::Object::View::Toolkit" : {
"file" : "lib/UR/Object/View/Toolkit.pm",
"version" : "0.41"
},
"UR::Object::View::Toolkit::Text" : {
"file" : "lib/UR/Object/View/Toolkit/Text.pm",
"version" : "0.41"
},
"UR::Observer" : {
"file" : "lib/UR/Observer.pm",
"version" : "0.41"
},
"UR::Service::JsonRpcServer" : {
"file" : "lib/UR/Service/JsonRpcServer.pm",
"version" : "0.41"
},
"UR::Service::RPC::Executer" : {
"file" : "lib/UR/Service/RPC/Executer.pm",
"version" : "0.41"
},
"UR::Service::RPC::Message" : {
"file" : "lib/UR/Service/RPC/Message.pm",
"version" : "0.41"
},
"UR::Service::RPC::Server" : {
"file" : "lib/UR/Service/RPC/Server.pm",
"version" : "0.41"
},
"UR::Service::RPC::TcpConnectionListener" : {
"file" : "lib/UR/Service/RPC/TcpConnectionListener.pm",
"version" : "0.41"
},
"UR::Singleton" : {
"file" : "lib/UR/Singleton.pm",
"version" : "0.41"
},
"UR::Test" : {
"file" : "lib/UR/Test.pm",
"version" : "0.41"
},
"UR::Util" : {
"file" : "lib/UR/Util.pm",
"version" : "0.41"
},
"UR::Value" : {
"file" : "lib/UR/Value.pm",
"version" : "0.41"
},
"UR::Value::ARRAY" : {
"file" : "lib/UR/Value/ARRAY.pm",
"version" : "0.41"
},
"UR::Value::Blob" : {
"file" : "lib/UR/Value/Blob.pm",
"version" : "0.41"
},
"UR::Value::Boolean" : {
"file" : "lib/UR/Value/Boolean.pm",
"version" : "0.41"
},
"UR::Value::Boolean::View::Default::Text" : {
"file" : "lib/UR/Value/Boolean/View/Default/Text.pm",
"version" : "0.41"
},
"UR::Value::CODE" : {
"file" : "lib/UR/Value/CODE.pm",
"version" : "0.41"
},
"UR::Value::CSV" : {
"file" : "lib/UR/Value/CSV.pm",
"version" : "0.41"
},
"UR::Value::DateTime" : {
"file" : "lib/UR/Value/DateTime.pm",
"version" : "0.41"
},
"UR::Value::Decimal" : {
"file" : "lib/UR/Value/Decimal.pm",
"version" : "0.41"
},
"UR::Value::DirectoryPath" : {
"file" : "lib/UR/Value/DirectoryPath.pm",
"version" : "0.41"
},
"UR::Value::FOF" : {
"file" : "lib/UR/Value/FOF.pm",
"version" : "0.41"
},
"UR::Value::FilePath" : {
"file" : "lib/UR/Value/FilePath.pm",
"version" : "0.41"
},
"UR::Value::FilesystemPath" : {
"file" : "lib/UR/Value/FilesystemPath.pm",
"version" : "0.41"
},
"UR::Value::Float" : {
"file" : "lib/UR/Value/Float.pm",
"version" : "0.41"
},
"UR::Value::GLOB" : {
"file" : "lib/UR/Value/GLOB.pm",
"version" : "0.41"
},
"UR::Value::HASH" : {
"file" : "lib/UR/Value/HASH.pm",
"version" : "0.41"
},
"UR::Value::Integer" : {
"file" : "lib/UR/Value/Integer.pm",
"version" : "0.41"
},
"UR::Value::Iterator" : {
"file" : "lib/UR/Value/Iterator.pm",
"version" : "0.41"
},
"UR::Value::Number" : {
"file" : "lib/UR/Value/Number.pm",
"version" : "0.41"
},
"UR::Value::PerlReference" : {
"file" : "lib/UR/Value/PerlReference.pm",
"version" : "0.41"
},
"UR::Value::REF" : {
"file" : "lib/UR/Value/REF.pm",
"version" : "0.41"
},
"UR::Value::SCALAR" : {
"file" : "lib/UR/Value/SCALAR.pm",
"version" : "0.41"
},
"UR::Value::Set" : {
"file" : "lib/UR/Value/Set.pm",
"version" : "0.41"
},
"UR::Value::SloppyPrimitive" : {
"file" : "lib/UR/Value/SloppyPrimitive.pm",
"version" : "0.41"
},
"UR::Value::String" : {
"file" : "lib/UR/Value/String.pm",
"version" : "0.41"
},
"UR::Value::Text" : {
"file" : "lib/UR/Value/Text.pm",
"version" : "0.41"
},
"UR::Value::Timestamp" : {
"file" : "lib/UR/Value/Timestamp.pm",
"version" : "0.41"
},
"UR::Value::URL" : {
"file" : "lib/UR/Value/URL.pm",
"version" : "0.41"
},
"UR::Value::View::Default::Html" : {
"file" : "lib/UR/Value/View/Default/Html.pm",
"version" : 0
},
"UR::Value::View::Default::Json" : {
"file" : "lib/UR/Value/View/Default/Json.pm",
"version" : 0
},
"UR::Value::View::Default::Text" : {
"file" : "lib/UR/Value/View/Default/Text.pm",
"version" : 0
},
"UR::Value::View::Default::Xml" : {
"file" : "lib/UR/Value/View/Default/Xml.pm",
"version" : 0
},
"UR::Vocabulary" : {
"file" : "lib/UR/Vocabulary.pm",
"version" : "0.41"
},
"above" : {
"file" : "lib/above.pm",
"version" : "0.02"
},
"class_name" : {
"file" : "lib/UR/Object/Type/Initializer.pm",
"version" : "2"
}
},
"release_status" : "testing",
"resources" : {
"license" : [
"http://dev.perl.org/licenses/"
]
},
"version" : "0.41"
}
Changes 000444 023532 023421 37532 12121654175 13147 0 ustar 00abrummet gsc 000000 000000 UR-0.41 Revision history for UR
0.41 2013-03-18
above.pm now imports symbols into the caller's package
Fix for database connections after fork() in the child process
Fixes for command-line parsing, implied property metadata and database joins
Many test updates to work on more architectures
0.40 2013-02-25
RDBMS data sources now have infrastructure for comparing text and
non-text columns during a join. When a number or date column
is joined with a text column, the non-text column is converted
with the to_char() function in the Oracle data source.
An object-type property's default_value can now be specified using a
hashref of keys/values.
Property definitions can now include example_values - a listref of
values shown to the user in the autogenerated documentation.
Documentation for the Object Lister base command is expanded.
0.392 2013-01-31
Changed the name for the Yapp driver package to avoid a CPAN warning
about unauthorized use of their namespace
0.39 2013-01-30
Better support for PostgreSQL. It is now on par with Oracle.
New datasource UR::DataSource::Filesystem. It obsoletes UR::DataSource::File
and UR::DataSource::FileMux, and is more flexible.
Classes can specify a query hint when they are used as the primary
class of a get() or when they are involved in a join.
BoolExprs with an or-clause now support hints and order-by correctly.
Messaging methods (error_message(), status_message(), etc) now trigger
observers of the same name. This means any number of message
observers can be attached at any point in the class hierarchy.
Using chained delegated properties with the dot-syntax (object.delegate.prop)
is accepted in more places.
Better support for queries using direct SQL.
Many fixes for the Boolean Expression syntax parser. Besides fixing
bugs, it now supports more operators and understands 'offset' and
'limit'.
Support for defining a property that is an alias for another.
Fixes for remaining connected to databases after fork().
Optimization for the case where a delegation goes through an abstract
class with no data source and back to the original data source. It
now does one query instead of many.
Improvements to the Command API documentation.
Removed some deps on XML-related modules.
0.38 2012-03-28
Bug fixes to support C3 inheritance on the Mac correctly.
Rich extensions to primitive/value data-types for files, etc.
Optimization for very large in-clauses.
Database updates now infer table structure from class meta-data instead of leaning on database metadata when inserting (update and delete already do this).
Bug fixes to the new boolean expression parser.
Fixes to complex inheritance in RDBMS data.
Fix to sorting issues in older Perl 5.8.
Bug fixes to boolean expressions with values which are non-UR objects
Smarter query plans when the join table is variable (not supported in SQL, but in the API), leading to multiple database queries where necessary.
0.37 2012-02-03
Added a proper parser for generating Boolean Expressions from text
strings. The object lister commands (UR::Object::Command::List)
use it to process the --filter, and it can be used directly
through the method UR::BoolExpr::resolve_for_string(). See the
UR::BoolExpr pod for more info.
Or-type Boolean Expressions now support -order, and can be the filter
for iterators.
Important Bugfixes:
* Better error messages when a module fails to load properly
during autoloading.
* Class methods called on Set instances are dispatched to the
proper class instead of called on the Set's members.
* Values in an SQL in-clause are escaped using DBI's quote() method.
0.36 2012-01-05
Fix for 'like' clause's escape string on PostgreSQL
Speed improvement for class initialization by normalizing metadata
more efficiently and only calculating the cached data for
property_meta_for_name() once.
Workaround for a bug in Perl 5.8 involving sorters by avoiding method
calls inside some sort subs
Fully deprecate the old Subscription API in favor of the new Observer api
UR::Value classes use UR::DataSource::Default and the normal loading
mechanism. Previously, UR::Values used a special codepath to get
loaded into memory
Add a json perspective for available views
Allow descending sorts in order-by. For example:
my @o = Some::Class->get(prop => 'value', -order => ['field1','-field2']
To get all objects where prop is equal to the string 'value', first
sorted by field1 in ascending order, then by field2 in descending
order
Standardize sorting results on columns with NULLs by having NULL/undef
always appears at the end for ascending sorts. Previously, the
order depended on the data source's behavior. Oracle and
PostgreSQL put them at the end, while MySQL, SQLite and cached
get()s put them at the beginning.
Fix exit code for 'ur test run' when the --lsf arg is used. It used
always return a false value (1). Now it returns true (0) if all
tests pass, and false (1) if any one test fails.
UR::Object now implements the messaging API that used to be in Command
(error_message, dump_error_messages, etc). The old messaging API
is now deprecated.
0.35 2011-10-28
Queries with the -recurse option are suppored for all datasources, not
just those that support recursive queries directly
Make the object listers more user-friendly by implicitly putting '%'
wildcards on either side of the user-supplied 'like' filter
Update to the latest version of Getopt::Complete for command-line completion
Object Set fixes (non-datasource expressable filters)
Bugfixes for queries involving multiple joins to the same table with
different join conditions
Queries with -offset/-limit and -page are now supported.
Query efficiency improvements:
* id_by properties with a know data_type have special code in
the bridging logic to handle them more efficiently
* large in-clause testing uses a binary search instead of linear
for cached objects
* no longer indexing delegated properties results in fewer unnecessary
queries during loading
* remove unnecessary rule evaluations against loaded objects
* When a query includes a filter or -hints for a calculated property,
implicitly add its calculate_from properties to the -hints list
* Rules in the query cache are always normalized, which makes
many lookups faster
* Fix a bug where rules in the query cache related to in-clause
queries were malformed, resulting in fewer queries to the data source
Command module fixes:
* running with --help no longer emits error messages about other
missing params
* Help output only lists properties that are is_input or is_param
Deleted objects hanging around as UR::DeletedRefs are recycled if the
original object gets re-created
0.34 2011-07-26
New class (Command::SubCommandFactory) which can act as a factory for a
tree of sub-commands
Remove the distinction between older and newer versions of DBD::SQLite
installed on the system. If you have SQLite databases (including
MetaDBs) with names like "*sqlite3n*", they will need to be
renamed to "*sqlite3*".
Make the tests emit fewer messages to the terminal when run in the
harness; improve coverage on non-Intel/Linux systems.
0.33 2011-06-30
New environment variable (UR_DBI_SUMMARIZE_SQL) to help find query
optimization targets
View aspects for objects' primitive values use the appropriate UR::Value
View classes
Query engine remembers cases where a left join matches nothing, and skips
asking the datasource on subsequent similar queries
Committing a software transaction now performs the same data consistancy
checking as the top-level transaction.
Improved document auto-generation for Command classes
Improved SQLite Data Source schema introspection
Updated database handling for Pg and mysql table case sensitivity
UR's developer tools (ur command-line tool) can operate on non-standard
source tree layouts, and can be forced to operate on a namespace
with a command-line option
Support for using a chain of properties in queries ('a.b.c like' => $v)
Set operations normalized: min, max, sum, count
Set-to-set relaying is now correctly lazy
Objects previously loaded from the database, and later deleted from the
database, are now detected as deleted and handled as another type of
change to be merged with in-memory changes.
0.32 (skipped)
0.31 (skipped)
0.30 2011-03-07
re-package 0.29 with versions correctly set
0.29 2011-03-07
query/iteration engine now solves n+1 in the one-to-many case as well as many-to-one
query optimization where the join table is variable across rows in a single resultset
automated manual page creation for commands
reduced deps (removed UR::Time)
0.28 2011-01-23
fix to the installer which caused a failure during docs generation
improvements to man page generation
0.27 2011-01-22
updated build process autogenerates man pages
0.26 2011-01-16
yet another refactoring to ensure VERSION appears on all modules
fixes for tests which fail only in the install harness
0.25 2011-01-15
Updated docs.
0.24 2011-01-15
Updated deps to compile fully on a new OSX installation (requires XCode).
0.22 2011-01-12
VERSION refactoring for cleaner uploads
0.20 2011-01-11
faster compile (<.5s)
faster object creation
faster install
documentation polish
0.19 2010-12-24
faster compile
faster query cache resolution
leaner meta-data
less build deps, build dep fixes
hideable commands
fixes for newer sqlite API
revamped UR::BoolExpr API
new command tree
0.18 2010-12-10
Bugfix for queries involving subclasses without tables
Preliminary support for building debian packages
Bugfixes for queries with the 'in' and 'not in' operators
Object cache indexing sped up by replacing regexes with direct string comparisons
0.17 2010-11-10
Fixed bug with default datasources dumping debug info during queries.
Deprecated old parts of the UR::Object API.
Bugfixes for MySQL data sources with handling of between and like operators, and table/column name case sensitivity
MySQL data sources will complain if the 'lower_case_table_names' setting is not set to 1
Bugfixes for FileMux data sources to return objects from iterators in correct sorted order
File data sources remember their file offsets more often to improve seeking
Bugfixes for handling is_many values passed in during create()
New class for JSON-formatted Set views
More consistent behavior during evaluation of BoolExprs with is_many values and undef/NULL values
Bugfixes for handling observers during software transaction commit and rollback
Addition of a new UR::Change type (external_change) to track non-UR entities that need undo-ing during a rollback
0.16 2010-09-27
File datasources build an on-the-fly index to improve its ability to seek within the file
Initial support for classes to supply custom logic for loading data
Compile-time speed improvements
Bug fixes for SQL generation with indirect properties, and the object cache pruner
0.15 2010-08-03
Improved 'ur update classes' interaction with MySQL databases
Integration with Getopt::Complete for bash command-line tab completion
0.14 2010-07-26
Metadata about data source entities (tables, columns, etc) is autodiscovered within commit() if it doesn't already exist in the MetaDB
The new View API now has working default toolkits for HTML, Text, XML and XSL. The old Viewer API has been removed.
Smarter property merging when the Context reloads an already cached object and the data in the data source has changed
Added a built-in 'product' calculation property type
Calculated properties can now be memoized
subclassify_by for an abstract class can now be a regular, indirect or calculated property
New environment variable UR_CONTEXT_MONITOR_QUERY for printing Context/query info to stdout
SQLite data sources can initialize themselves even if the sqlite3 executable cannot be found
Test harness improvements: --junit and --color options, control-C stops tests and reports results
'use lib' within an autoloaded module stays in effect after the module is loaded
0.13 2010-02-21
Circular foreign key constraints between tables are now handled smartly handled in UR::DataSource::RDBMS.
New meta-property properties: id_class_by, order_by, specify_by.
Updated autogenerated Command documentation.
Formalized the __extend_namespace__ callback for dynamic class creation.
New Command::DynamicSubCommands class makes command trees for a group of classes easy.
The new view API is available. The old "viewer" API is still available in this release, but is deprecated.
0.12 2009-09-09
'ur test run' can now run tests in parallel and can submit tests as jobs to LSF
Command modules now have support for Getopt::Complete for bash tab-completion
Bugfixes related to saving objects to File data sources.
Several more fixes for merging between database and in-memory objects.
Property names beginning with an underscore are now handled properly during rule
and object creation
0.11 2009-07-30
Fix bug in merge between database/in-memory data sets with changes.
0.10 2009-07-22
Updates to the UR::Object::Type MOP documentation.
Other documentation cleanup and file cleanup.
0.9 2009-06-19
Additional build fixes.
0.8 2009-06-17
David's build fixes.
0.7 2009-06-10
Fix to build process: the distribution will work if you do not have Module::Install installed.
0.6 2009-06-07
Fixed to build process: actually install the "ur" executable.
0.5 2009-06-06
Updates to POD. Additional API updates to UR::Object.
0.4 2009-06-04
Updates to POD. Extensive API updates to UR::Object.
0.3 2009-05-29
Fixed memory leak in cache pruner, and added additional debugging environment variable.
Additional laziness on file-based data-sources.
Updated lots of POD.
Switched to version numbers without zero padding!
0.02 2009-05-23
Cleanup of initial deployment issues.
UR uses a non-default version of Class::Autouse. This is now a special file to prevent problems with the old version.
Links to old DBIx::Class modules are now gone.
Updated boolean expression API.
0.01 2009-05-07
First public release for Lambda Lounge language shootout.
README 000444 023532 023421 2612 12121654175 12503 0 ustar 00abrummet gsc 000000 000000 UR-0.41 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.
META.yml 000444 023532 023421 63621 12121654175 13123 0 ustar 00abrummet gsc 000000 000000 UR-0.41 ---
name: UR
version: 0.41
author:
- Anthony Brummett brummett@cpan.org
- Scott Smith sakoht@cpan.org
abstract: rich declarative transactional objects
license: perl
resources:
license: http://dev.perl.org/licenses/
requires:
Carp: ''
Class::AutoloadCAN: 0.03
Class::Autouse: 2.0
Clone::PP: 1.02
DBD::SQLite: 1.14
DBI: 1.601
Data::Compare: 0.13
Data::UUID: 0.148
Date::Format: ''
Devel::GlobalDestruction: ''
File::Basename: 2.73
File::Path: ''
File::Temp: ''
FreezeThaw: 0.43
Getopt::Complete: 0.26
JSON: ''
Lingua::EN::Inflect: 1.88
List::MoreUtils: ''
MRO::Compat: ''
Path::Class: ''
Pod::Simple::HTML: 3.03
Pod::Simple::Text: 2.02
Sub::Install: 0.924
Sub::Name: 0.04
Sys::Hostname: 1.11
Test::Fork: ''
Text::Diff: 0.35
Text::Glob: ''
YAML: ''
perl: v5.8.7
version: ''
configure_requires:
Module::Build: 0.340201
provides:
Command:
file: lib/Command.pm
version: 0.41
Command::DynamicSubCommands:
file: lib/Command/DynamicSubCommands.pm
Command::Shell:
file: lib/Command/Shell.pm
Command::SubCommandFactory:
file: lib/Command/SubCommandFactory.pm
Command::Test:
file: lib/Command/Test.pm
Command::Test::Echo:
file: lib/Command/Test/Echo.pm
Command::Test::Tree1:
file: lib/Command/Test/Tree1.pm
Command::Test::Tree1::Echo1:
file: lib/Command/Test/Tree1/Echo1.pm
Command::Test::Tree1::Echo2:
file: lib/Command/Test/Tree1/Echo2.pm
Command::Tree:
file: lib/Command/Tree.pm
version: 0.41
Command::V1:
file: lib/Command/V1.pm
version: 0.41
Command::V2:
file: lib/Command/V2.pm
version: 0.41
DB:
file: lib/Devel/callcount.pm
Devel::callsfrom:
file: lib/Devel/callcount.pm
My::TAP::Parser::Iterator::Process::LSF:
file: lib/UR/Namespace/Command/Test/Run.pm
My::TAP::Parser::IteratorFactory::LSF:
file: lib/UR/Namespace/Command/Test/Run.pm
My::TAP::Parser::Multiplexer:
file: lib/UR/Namespace/Command/Test/Run.pm
My::TAP::Parser::Scheduler:
file: lib/UR/Namespace/Command/Test/Run.pm
My::TAP::Parser::Timer:
file: lib/UR/Namespace/Command/Test/Run.pm
UR:
file: lib/UR.pm
version: 0.41
UR::All:
file: lib/UR/All.pm
version: 0.41
UR::BoolExpr:
file: lib/UR/BoolExpr.pm
version: 0.41
UR::BoolExpr::BxParser:
file: lib/UR/BoolExpr/BxParser.pm
UR::BoolExpr::BxParser::Yapp::Driver:
file: lib/UR/BoolExpr/BxParser.pm
version: 1.05
UR::BoolExpr::Template:
file: lib/UR/BoolExpr/Template.pm
version: 0.41
UR::BoolExpr::Template::And:
file: lib/UR/BoolExpr/Template/And.pm
version: 0.41
UR::BoolExpr::Template::Composite:
file: lib/UR/BoolExpr/Template/Composite.pm
version: 0.41
UR::BoolExpr::Template::Or:
file: lib/UR/BoolExpr/Template/Or.pm
version: 0.41
UR::BoolExpr::Template::PropertyComparison:
file: lib/UR/BoolExpr/Template/PropertyComparison.pm
version: 0.41
UR::BoolExpr::Template::PropertyComparison::Between:
file: lib/UR/BoolExpr/Template/PropertyComparison/Between.pm
version: 0.41
UR::BoolExpr::Template::PropertyComparison::Equals:
file: lib/UR/BoolExpr/Template/PropertyComparison/Equals.pm
version: 0.41
UR::BoolExpr::Template::PropertyComparison::False:
file: lib/UR/BoolExpr/Template/PropertyComparison/False.pm
version: 0.41
UR::BoolExpr::Template::PropertyComparison::GreaterOrEqual:
file: lib/UR/BoolExpr/Template/PropertyComparison/GreaterOrEqual.pm
version: 0.41
UR::BoolExpr::Template::PropertyComparison::GreaterThan:
file: lib/UR/BoolExpr/Template/PropertyComparison/GreaterThan.pm
version: 0.41
UR::BoolExpr::Template::PropertyComparison::In:
file: lib/UR/BoolExpr/Template/PropertyComparison/In.pm
version: 0.41
UR::BoolExpr::Template::PropertyComparison::LessOrEqual:
file: lib/UR/BoolExpr/Template/PropertyComparison/LessOrEqual.pm
version: 0.41
UR::BoolExpr::Template::PropertyComparison::LessThan:
file: lib/UR/BoolExpr/Template/PropertyComparison/LessThan.pm
version: 0.41
UR::BoolExpr::Template::PropertyComparison::Like:
file: lib/UR/BoolExpr/Template/PropertyComparison/Like.pm
version: 0.41
UR::BoolExpr::Template::PropertyComparison::Matches:
file: lib/UR/BoolExpr/Template/PropertyComparison/Matches.pm
version: 0.41
UR::BoolExpr::Template::PropertyComparison::NotEqual:
file: lib/UR/BoolExpr/Template/PropertyComparison/NotEqual.pm
version: 0.41
UR::BoolExpr::Template::PropertyComparison::NotIn:
file: lib/UR/BoolExpr/Template/PropertyComparison/NotIn.pm
version: 0.41
UR::BoolExpr::Template::PropertyComparison::NotLike:
file: lib/UR/BoolExpr/Template/PropertyComparison/NotLike.pm
version: 0.41
UR::BoolExpr::Template::PropertyComparison::True:
file: lib/UR/BoolExpr/Template/PropertyComparison/True.pm
version: 0.41
UR::BoolExpr::Util:
file: lib/UR/BoolExpr/Util.pm
version: 0.41
UR::Change:
file: lib/UR/Change.pm
version: 0.41
UR::Context:
file: lib/UR/Context.pm
version: 0.41
UR::Context::DefaultRoot:
file: lib/UR/Context/DefaultRoot.pm
version: 0.41
UR::Context::LoadingIterator:
file: lib/UR/Context/LoadingIterator.pm
version: 0.41
UR::Context::ObjectFabricator:
file: lib/UR/Context/ObjectFabricator.pm
version: 0.41
UR::Context::Process:
file: lib/UR/Context/Process.pm
version: 0.41
UR::Context::Root:
file: lib/UR/Context/Root.pm
version: 0.41
UR::Context::Transaction:
file: lib/UR/Context/Transaction.pm
version: 0.41
UR::DBI:
file: lib/UR/DBI.pm
version: 0.41
UR::DBI::Report:
file: lib/UR/DBI/Report.pm
version: 0.41
UR::DBI::db:
file: lib/UR/DBI.pm
UR::DBI::st:
file: lib/UR/DBI.pm
UR::DataSource:
file: lib/UR/DataSource.pm
version: 0.41
UR::DataSource::CSV:
file: lib/UR/DataSource/CSV.pm
version: 0.41
UR::DataSource::Code:
file: lib/UR/DataSource/Code.pm
version: 0.41
UR::DataSource::Default:
file: lib/UR/DataSource/Default.pm
version: 0.41
UR::DataSource::File:
file: lib/UR/DataSource/File.pm
version: 0.41
UR::DataSource::FileMux:
file: lib/UR/DataSource/FileMux.pm
version: 0.41
UR::DataSource::Filesystem:
file: lib/UR/DataSource/Filesystem.pm
version: 0.41
UR::DataSource::Meta:
file: lib/UR/DataSource/Meta.pm
version: 0.41
UR::DataSource::MySQL:
file: lib/UR/DataSource/MySQL.pm
version: 0.41
UR::DataSource::Oracle:
file: lib/UR/DataSource/Oracle.pm
version: 0.41
UR::DataSource::Pg:
file: lib/UR/DataSource/Pg.pm
version: 0.41
UR::DataSource::QueryPlan:
file: lib/UR/DataSource/QueryPlan.pm
version: 0.41
UR::DataSource::RDBMS:
file: lib/UR/DataSource/RDBMS.pm
version: 0.41
UR::DataSource::RDBMS::BitmapIndex:
file: lib/UR/DataSource/RDBMS/BitmapIndex.pm
version: 0.41
UR::DataSource::RDBMS::Entity:
file: lib/UR/DataSource/RDBMS/Entity.pm
version: 0.41
UR::DataSource::RDBMS::FkConstraint:
file: lib/UR/DataSource/RDBMS/FkConstraint.pm
version: 0.41
UR::DataSource::RDBMS::FkConstraintColumn:
file: lib/UR/DataSource/RDBMS/FkConstraintColumn.pm
version: 0.41
UR::DataSource::RDBMS::PkConstraintColumn:
file: lib/UR/DataSource/RDBMS/PkConstraintColumn.pm
version: 0.41
UR::DataSource::RDBMS::Table:
file: lib/UR/DataSource/RDBMS/Table.pm
version: 0.41
UR::DataSource::RDBMS::Table::View::Default::Text:
file: lib/UR/DataSource/RDBMS/Table/View/Default/Text.pm
version: 0.41
UR::DataSource::RDBMS::TableColumn:
file: lib/UR/DataSource/RDBMS/TableColumn.pm
version: 0.41
UR::DataSource::RDBMS::TableColumn::View::Default::Text:
file: lib/UR/DataSource/RDBMS/TableColumn/View/Default/Text.pm
version: 0.41
UR::DataSource::RDBMS::UniqueConstraintColumn:
file: lib/UR/DataSource/RDBMS/UniqueConstraintColumn.pm
version: 0.41
UR::DataSource::SQLite:
file: lib/UR/DataSource/SQLite.pm
version: 0.41
UR::DataSource::ValueDomain:
file: lib/UR/DataSource/ValueDomain.pm
version: 0.41
UR::Debug:
file: lib/UR/Debug.pm
version: 0.41
UR::DeletedRef:
file: lib/UR/DeletedRef.pm
version: 0.41
UR::Doc::Pod2Html:
file: lib/UR/Doc/Pod2Html.pm
version: 0.41
UR::Doc::Section:
file: lib/UR/Doc/Section.pm
version: 0.41
UR::Doc::Writer:
file: lib/UR/Doc/Writer.pm
version: 0.41
UR::Doc::Writer::Html:
file: lib/UR/Doc/Writer/Html.pm
version: 0.41
UR::Doc::Writer::Pod:
file: lib/UR/Doc/Writer/Pod.pm
version: 0.41
UR::Env::UR_COMMAND_DUMP_STATUS_MESSAGES:
file: lib/UR/Env/UR_COMMAND_DUMP_STATUS_MESSAGES.pm
version: 0.41
UR::Env::UR_CONTEXT_BASE:
file: lib/UR/Env/UR_CONTEXT_BASE.pm
version: 0.41
UR::Env::UR_CONTEXT_CACHE_SIZE_HIGHWATER:
file: lib/UR/Env/UR_CONTEXT_CACHE_SIZE_HIGHWATER.pm
version: 0.41
UR::Env::UR_CONTEXT_CACHE_SIZE_LOWWATER:
file: lib/UR/Env/UR_CONTEXT_CACHE_SIZE_LOWWATER.pm
version: 0.41
UR::Env::UR_CONTEXT_LIBS:
file: lib/UR/Env/UR_USED_LIBS.pm
version: 0.41
UR::Env::UR_CONTEXT_MONITOR_QUERY:
file: lib/UR/Env/UR_CONTEXT_MONITOR_QUERY.pm
version: 0.41
UR::Env::UR_CONTEXT_ROOT:
file: lib/UR/Env/UR_CONTEXT_ROOT.pm
version: 0.41
UR::Env::UR_DBI_DUMP_STACK_ON_CONNECT:
file: lib/UR/Env/UR_DBI_DUMP_STACK_ON_CONNECT.pm
version: 0.41
UR::Env::UR_DBI_EXPLAIN_SQL_CALLSTACK:
file: lib/UR/Env/UR_DBI_EXPLAIN_SQL_CALLSTACK.pm
version: 0.41
UR::Env::UR_DBI_EXPLAIN_SQL_IF:
file: lib/UR/Env/UR_DBI_EXPLAIN_SQL_IF.pm
version: 0.41
UR::Env::UR_DBI_EXPLAIN_SQL_MATCH:
file: lib/UR/Env/UR_DBI_EXPLAIN_SQL_MATCH.pm
version: 0.41
UR::Env::UR_DBI_EXPLAIN_SQL_SLOW:
file: lib/UR/Env/UR_DBI_EXPLAIN_SQL_SLOW.pm
version: 0.41
UR::Env::UR_DBI_MONITOR_DML:
file: lib/UR/Env/UR_DBI_MONITOR_DML.pm
version: 0.41
UR::Env::UR_DBI_MONITOR_EVERY_FETCH:
file: lib/UR/Env/UR_DBI_MONITOR_EVERY_FETCH.pm
version: 0.41
UR::Env::UR_DBI_MONITOR_SQL:
file: lib/UR/Env/UR_DBI_MONITOR_SQL.pm
version: 0.41
UR::Env::UR_DBI_NO_COMMIT:
file: lib/UR/Env/UR_DBI_NO_COMMIT.pm
version: 0.41
UR::Env::UR_DBI_SUMMARIZE_SQL:
file: lib/UR/Env/UR_DBI_SUMMARIZE_SQL.pm
version: 0.41
UR::Env::UR_DEBUG_OBJECT_PRUNING:
file: lib/UR/Env/UR_DEBUG_OBJECT_PRUNING.pm
version: 0.41
UR::Env::UR_DEBUG_OBJECT_RELEASE:
file: lib/UR/Env/UR_DEBUG_OBJECT_RELEASE.pm
version: 0.41
UR::Env::UR_IGNORE:
file: lib/UR/Env/UR_IGNORE.pm
version: 0.41
UR::Env::UR_NO_REQUIRE_USER_VERIFY:
file: lib/UR/Env/UR_NO_REQUIRE_USER_VERIFY.pm
version: 0.41
UR::Env::UR_NR_CPU:
file: lib/UR/Env/UR_NR_CPU.pm
version: 0.41
UR::Env::UR_RUN_LONG_TESTS:
file: lib/UR/Env/UR_RUN_LONG_TESTS.pm
version: 0.41
UR::Env::UR_STACK_DUMP_ON_DIE:
file: lib/UR/Env/UR_STACK_DUMP_ON_DIE.pm
version: 0.41
UR::Env::UR_STACK_DUMP_ON_WARN:
file: lib/UR/Env/UR_STACK_DUMP_ON_WARN.pm
version: 0.41
UR::Env::UR_TEST_FILLDB:
file: lib/UR/Env/UR_TEST_FILLDB.pm
version: 0.41
UR::Env::UR_TEST_QUIET:
file: lib/UR/Env/UR_TEST_QUIET.pm
version: 0.41
UR::Env::UR_USED_MODS:
file: lib/UR/Env/UR_USED_MODS.pm
version: 0.41
UR::Env::UR_USE_ANY:
file: lib/UR/Env/UR_USE_ANY.pm
version: 0.41
UR::Env::UR_USE_DUMMY_AUTOGENERATED_IDS:
file: lib/UR/Env/UR_USE_DUMMY_AUTOGENERATED_IDS.pm
version: 0.41
UR::Exit:
file: lib/UR/Exit.pm
version: 0.41
UR::ModuleBase:
file: lib/UR/ModuleBase.pm
version: 0.41
UR::ModuleBase::Message:
file: lib/UR/ObjectDeprecated.pm
UR::ModuleBuild:
file: lib/UR/ModuleBuild.pm
UR::ModuleConfig:
file: lib/UR/ModuleConfig.pm
version: 0.41
UR::ModuleLoader:
file: lib/UR/ModuleLoader.pm
version: 0.41
UR::Namespace:
file: lib/UR/Namespace.pm
version: 0.41
UR::Namespace::Command:
file: lib/UR/Namespace/Command.pm
version: 0.41
UR::Namespace::Command::Base:
file: lib/UR/Namespace/Command/Base.pm
version: 0.41
UR::Namespace::Command::Define:
file: lib/UR/Namespace/Command/Define.pm
version: 0.41
UR::Namespace::Command::Define::Class:
file: lib/UR/Namespace/Command/Define/Class.pm
version: 0.41
UR::Namespace::Command::Define::Datasource:
file: lib/UR/Namespace/Command/Define/Datasource.pm
version: 0.41
UR::Namespace::Command::Define::Datasource::File:
file: lib/UR/Namespace/Command/Define/Datasource/File.pm
version: 0.41
UR::Namespace::Command::Define::Datasource::Mysql:
file: lib/UR/Namespace/Command/Define/Datasource/Mysql.pm
version: 0.41
UR::Namespace::Command::Define::Datasource::Oracle:
file: lib/UR/Namespace/Command/Define/Datasource/Oracle.pm
version: 0.41
UR::Namespace::Command::Define::Datasource::Pg:
file: lib/UR/Namespace/Command/Define/Datasource/Pg.pm
version: 0.41
UR::Namespace::Command::Define::Datasource::Rdbms:
file: lib/UR/Namespace/Command/Define/Datasource/Rdbms.pm
version: 0.41
UR::Namespace::Command::Define::Datasource::RdbmsWithAuth:
file: lib/UR/Namespace/Command/Define/Datasource/RdbmsWithAuth.pm
version: 0.41
UR::Namespace::Command::Define::Datasource::Sqlite:
file: lib/UR/Namespace/Command/Define/Datasource/Sqlite.pm
version: 0.41
UR::Namespace::Command::Define::Db:
file: lib/UR/Namespace/Command/Define/Db.pm
version: 0.41
UR::Namespace::Command::Define::Namespace:
file: lib/UR/Namespace/Command/Define/Namespace.pm
version: 0.41
UR::Namespace::Command::Init:
file: lib/UR/Namespace/Command/Init.pm
version: 0.41
UR::Namespace::Command::List:
file: lib/UR/Namespace/Command/List.pm
version: 0.41
UR::Namespace::Command::List::Classes:
file: lib/UR/Namespace/Command/List/Classes.pm
version: 0.41
UR::Namespace::Command::List::Modules:
file: lib/UR/Namespace/Command/List/Modules.pm
version: 0.41
UR::Namespace::Command::List::Objects:
file: lib/UR/Namespace/Command/List/Objects.pm
version: 0.41
UR::Namespace::Command::Old:
file: lib/UR/Namespace/Command/Old.pm
version: 0.41
UR::Namespace::Command::Old::DiffRewrite:
file: lib/UR/Namespace/Command/Old/DiffRewrite.pm
version: 0.41
UR::Namespace::Command::Old::DiffUpdate:
file: lib/UR/Namespace/Command/Old/DiffUpdate.pm
version: 0.41
UR::Namespace::Command::Old::ExportDbicClasses:
file: lib/UR/Namespace/Command/Old/ExportDbicClasses.pm
version: 0.41
UR::Namespace::Command::Old::Info:
file: lib/UR/Namespace/Command/Old/Info.pm
version: 0.41
UR::Namespace::Command::Old::Redescribe:
file: lib/UR/Namespace/Command/Old/Redescribe.pm
version: 0.41
UR::Namespace::Command::RunsOnModulesInTree:
file: lib/UR/Namespace/Command/RunsOnModulesInTree.pm
version: 0.41
UR::Namespace::Command::Show:
file: lib/UR/Namespace/Command/Show.pm
UR::Namespace::Command::Show::Properties:
file: lib/UR/Namespace/Command/Show/Properties.pm
version: 0.41
UR::Namespace::Command::Show::Schema:
file: lib/UR/Namespace/Command/Show/Schema.pm
UR::Namespace::Command::Show::Subclasses:
file: lib/UR/Namespace/Command/Show/Subclasses.pm
UR::Namespace::Command::Sys:
file: lib/UR/Namespace/Command/Sys.pm
version: 0.41
UR::Namespace::Command::Sys::ClassBrowser:
file: lib/UR/Namespace/Command/Sys/ClassBrowser.pm
version: 0.41
UR::Namespace::Command::Test:
file: lib/UR/Namespace/Command/Test.pm
version: 0.41
UR::Namespace::Command::Test::Callcount:
file: lib/UR/Namespace/Command/Test/Callcount.pm
version: 0.41
UR::Namespace::Command::Test::Callcount::List:
file: lib/UR/Namespace/Command/Test/Callcount/List.pm
version: 0.41
UR::Namespace::Command::Test::Compile:
file: lib/UR/Namespace/Command/Test/Compile.pm
version: 0.41
UR::Namespace::Command::Test::Eval:
file: lib/UR/Namespace/Command/Test/Eval.pm
version: 0.41
UR::Namespace::Command::Test::Run:
file: lib/UR/Namespace/Command/Test/Run.pm
version: 0.41
UR::Namespace::Command::Test::TrackObjectRelease:
file: lib/UR/Namespace/Command/Test/TrackObjectRelease.pm
version: 0.41
UR::Namespace::Command::Test::Use:
file: lib/UR/Namespace/Command/Test/Use.pm
version: 0.41
UR::Namespace::Command::Test::Window:
file: lib/UR/Namespace/Command/Test/Window.pm
version: 0.41
UR::Namespace::Command::Test::Window::Tk:
file: lib/UR/Namespace/Command/Test/Window.pm
UR::Namespace::Command::Update:
file: lib/UR/Namespace/Command/Update.pm
version: 0.41
UR::Namespace::Command::Update::ClassDiagram:
file: lib/UR/Namespace/Command/Update/ClassDiagram.pm
version: 0.41
UR::Namespace::Command::Update::ClassesFromDb:
file: lib/UR/Namespace/Command/Update/ClassesFromDb.pm
version: 0.41
UR::Namespace::Command::Update::Doc:
file: lib/UR/Namespace/Command/Update/Doc.pm
version: 0.41
UR::Namespace::Command::Update::Pod:
file: lib/UR/Namespace/Command/Update/Pod.pm
version: 0.41
UR::Namespace::Command::Update::RenameClass:
file: lib/UR/Namespace/Command/Update/RenameClass.pm
version: 0.41
UR::Namespace::Command::Update::RewriteClassHeader:
file: lib/UR/Namespace/Command/Update/RewriteClassHeader.pm
version: 0.41
UR::Namespace::Command::Update::SchemaDiagram:
file: lib/UR/Namespace/Command/Update/SchemaDiagram.pm
version: 0.41
UR::Namespace::Command::Update::TabCompletionSpec:
file: lib/UR/Namespace/Command/Update/TabCompletionSpec.pm
version: 0.41
UR::Namespace::View::SchemaBrowser::CgiApp:
file: lib/UR/Namespace/View/SchemaBrowser/CgiApp.pm
version: 0.41
UR::Namespace::View::SchemaBrowser::CgiApp::Base:
file: lib/UR/Namespace/View/SchemaBrowser/CgiApp/Base.pm
version: 0.41
UR::Namespace::View::SchemaBrowser::CgiApp::Class:
file: lib/UR/Namespace/View/SchemaBrowser/CgiApp/Class.pm
version: 0.41
UR::Namespace::View::SchemaBrowser::CgiApp::File:
file: lib/UR/Namespace/View/SchemaBrowser/CgiApp/File.pm
version: 0.41
UR::Namespace::View::SchemaBrowser::CgiApp::Index:
file: lib/UR/Namespace/View/SchemaBrowser/CgiApp/Index.pm
version: 0.41
UR::Namespace::View::SchemaBrowser::CgiApp::Schema:
file: lib/UR/Namespace/View/SchemaBrowser/CgiApp/Schema.pm
version: 0.41
UR::Object:
file: lib/UR/Object.pm
version: 0.41
UR::Object::Accessorized:
file: lib/UR/Object/Accessorized.pm
version: 0.41
UR::Object::Command::FetchAndDo:
file: lib/UR/Object/Command/FetchAndDo.pm
version: 0.41
UR::Object::Command::List:
file: lib/UR/Object/Command/List.pm
version: 0.41
UR::Object::Command::List::Csv:
file: lib/UR/Object/Command/List/Style.pm
UR::Object::Command::List::Html:
file: lib/UR/Object/Command/List/Style.pm
UR::Object::Command::List::Newtext:
file: lib/UR/Object/Command/List/Style.pm
UR::Object::Command::List::Pretty:
file: lib/UR/Object/Command/List/Style.pm
UR::Object::Command::List::Style:
file: lib/UR/Object/Command/List/Style.pm
version: 0.41
UR::Object::Command::List::Text:
file: lib/UR/Object/Command/List/Style.pm
UR::Object::Command::List::Tsv:
file: lib/UR/Object/Command/List/Style.pm
UR::Object::Command::List::Xml:
file: lib/UR/Object/Command/List/Style.pm
UR::Object::Ghost:
file: lib/UR/Object/Ghost.pm
version: 0.41
UR::Object::Index:
file: lib/UR/Object/Index.pm
version: 0.41
UR::Object::Iterator:
file: lib/UR/Object/Iterator.pm
version: 0.41
UR::Object::Join:
file: lib/UR/Object/Join.pm
version: 0.41
UR::Object::Property:
file: lib/UR/Object/Property.pm
version: 0.41
UR::Object::Property::View::Default::Text:
file: lib/UR/Object/Property/View/Default/Text.pm
version: 0.41
UR::Object::Property::View::DescriptionLineItem::Text:
file: lib/UR/Object/Property/View/DescriptionLineItem/Text.pm
version: 0.41
UR::Object::Property::View::ReferenceDescription::Text:
file: lib/UR/Object/Property/View/ReferenceDescription/Text.pm
version: 0.41
UR::Object::Set:
file: lib/UR/Object/Set.pm
version: 0.41
UR::Object::Set::View::Default::Html:
file: lib/UR/Object/Set/View/Default/Html.pm
version: 0.41
UR::Object::Set::View::Default::Json:
file: lib/UR/Object/Set/View/Default/Json.pm
version: 0.41
UR::Object::Set::View::Default::Text:
file: lib/UR/Object/Set/View/Default/Text.pm
version: 0.41
UR::Object::Set::View::Default::Xml:
file: lib/UR/Object/Set/View/Default/Xml.pm
version: 0.41
UR::Object::Tag:
file: lib/UR/Object/Tag.pm
version: 0.41
UR::Object::Type:
file: lib/UR/Object/Type.pm
version: 0.41
UR::Object::Type::AccessorWriter:
file: lib/UR/Object/Type/AccessorWriter.pm
UR::Object::Type::AccessorWriter::Product:
file: lib/UR/Object/Type/AccessorWriter/Product.pm
version: 0.41
UR::Object::Type::AccessorWriter::Sum:
file: lib/UR/Object/Type/AccessorWriter/Sum.pm
version: 0.41
UR::Object::Type::Initializer:
file: lib/UR/Object/Type/Initializer.pm
UR::Object::Type::ModuleWriter:
file: lib/UR/Object/Type/ModuleWriter.pm
UR::Object::Type::View::AvailableViews::Json:
file: lib/UR/Object/Type/View/AvailableViews/Json.pm
version: 0.41
UR::Object::Type::View::AvailableViews::Xml:
file: lib/UR/Object/Type/View/AvailableViews/Xml.pm
version: 0.41
UR::Object::Type::View::Default::Text:
file: lib/UR/Object/Type/View/Default/Text.pm
version: 0.41
UR::Object::Type::View::Default::Xml:
file: lib/UR/Object/Type/View/Default/Xml.pm
version: 0.41
UR::Object::Value:
file: lib/UR/Object/Value.pm
version: 0.41
UR::Object::View:
file: lib/UR/Object/View.pm
version: 0.41
UR::Object::View::Aspect:
file: lib/UR/Object/View/Aspect.pm
version: 0.41
UR::Object::View::Default::Gtk:
file: lib/UR/Object/View/Default/Gtk.pm
version: 0.41
UR::Object::View::Default::Gtk2:
file: lib/UR/Object/View/Default/Gtk2.pm
version: 0.41
UR::Object::View::Default::Html:
file: lib/UR/Object/View/Default/Html.pm
version: 0.41
UR::Object::View::Default::Json:
file: lib/UR/Object/View/Default/Json.pm
version: 0.41
UR::Object::View::Default::Text:
file: lib/UR/Object/View/Default/Text.pm
version: 0.41
UR::Object::View::Default::Xml:
file: lib/UR/Object/View/Default/Xml.pm
version: 0.41
UR::Object::View::Default::Xsl:
file: lib/UR/Object/View/Default/Xsl.pm
version: 0.41
UR::Object::View::Lister::Text:
file: lib/UR/Object/View/Lister/Text.pm
version: 0.41
UR::Object::View::Static::Html:
file: lib/UR/Object/View/Static/Html.pm
version: 0.41
UR::Object::View::Toolkit:
file: lib/UR/Object/View/Toolkit.pm
version: 0.41
UR::Object::View::Toolkit::Text:
file: lib/UR/Object/View/Toolkit/Text.pm
version: 0.41
UR::Observer:
file: lib/UR/Observer.pm
version: 0.41
UR::Service::JsonRpcServer:
file: lib/UR/Service/JsonRpcServer.pm
version: 0.41
UR::Service::RPC::Executer:
file: lib/UR/Service/RPC/Executer.pm
version: 0.41
UR::Service::RPC::Message:
file: lib/UR/Service/RPC/Message.pm
version: 0.41
UR::Service::RPC::Server:
file: lib/UR/Service/RPC/Server.pm
version: 0.41
UR::Service::RPC::TcpConnectionListener:
file: lib/UR/Service/RPC/TcpConnectionListener.pm
version: 0.41
UR::Singleton:
file: lib/UR/Singleton.pm
version: 0.41
UR::Test:
file: lib/UR/Test.pm
version: 0.41
UR::Util:
file: lib/UR/Util.pm
version: 0.41
UR::Value:
file: lib/UR/Value.pm
version: 0.41
UR::Value::ARRAY:
file: lib/UR/Value/ARRAY.pm
version: 0.41
UR::Value::Blob:
file: lib/UR/Value/Blob.pm
version: 0.41
UR::Value::Boolean:
file: lib/UR/Value/Boolean.pm
version: 0.41
UR::Value::Boolean::View::Default::Text:
file: lib/UR/Value/Boolean/View/Default/Text.pm
version: 0.41
UR::Value::CODE:
file: lib/UR/Value/CODE.pm
version: 0.41
UR::Value::CSV:
file: lib/UR/Value/CSV.pm
version: 0.41
UR::Value::DateTime:
file: lib/UR/Value/DateTime.pm
version: 0.41
UR::Value::Decimal:
file: lib/UR/Value/Decimal.pm
version: 0.41
UR::Value::DirectoryPath:
file: lib/UR/Value/DirectoryPath.pm
version: 0.41
UR::Value::FOF:
file: lib/UR/Value/FOF.pm
version: 0.41
UR::Value::FilePath:
file: lib/UR/Value/FilePath.pm
version: 0.41
UR::Value::FilesystemPath:
file: lib/UR/Value/FilesystemPath.pm
version: 0.41
UR::Value::Float:
file: lib/UR/Value/Float.pm
version: 0.41
UR::Value::GLOB:
file: lib/UR/Value/GLOB.pm
version: 0.41
UR::Value::HASH:
file: lib/UR/Value/HASH.pm
version: 0.41
UR::Value::Integer:
file: lib/UR/Value/Integer.pm
version: 0.41
UR::Value::Iterator:
file: lib/UR/Value/Iterator.pm
version: 0.41
UR::Value::Number:
file: lib/UR/Value/Number.pm
version: 0.41
UR::Value::PerlReference:
file: lib/UR/Value/PerlReference.pm
version: 0.41
UR::Value::REF:
file: lib/UR/Value/REF.pm
version: 0.41
UR::Value::SCALAR:
file: lib/UR/Value/SCALAR.pm
version: 0.41
UR::Value::Set:
file: lib/UR/Value/Set.pm
version: 0.41
UR::Value::SloppyPrimitive:
file: lib/UR/Value/SloppyPrimitive.pm
version: 0.41
UR::Value::String:
file: lib/UR/Value/String.pm
version: 0.41
UR::Value::Text:
file: lib/UR/Value/Text.pm
version: 0.41
UR::Value::Timestamp:
file: lib/UR/Value/Timestamp.pm
version: 0.41
UR::Value::URL:
file: lib/UR/Value/URL.pm
version: 0.41
UR::Value::View::Default::Html:
file: lib/UR/Value/View/Default/Html.pm
UR::Value::View::Default::Json:
file: lib/UR/Value/View/Default/Json.pm
UR::Value::View::Default::Text:
file: lib/UR/Value/View/Default/Text.pm
UR::Value::View::Default::Xml:
file: lib/UR/Value/View/Default/Xml.pm
UR::Vocabulary:
file: lib/UR/Vocabulary.pm
version: 0.41
above:
file: lib/above.pm
version: 0.02
class_name:
file: lib/UR/Object/Type/Initializer.pm
version: 2
generated_by: Module::Build version 0.340201
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
version: 1.4
pod 000755 023532 023421 0 12121654175 12247 5 ustar 00abrummet gsc 000000 000000 UR-0.41 ur-old-diff-rewrite.pod 000444 023532 023421 572 12121654172 16660 0 ustar 00abrummet gsc 000000 000000 UR-0.41/pod
=pod
=head1 NAME
ur old diff-rewrite - a command which operates on classes/modules in a UR namespace directory
=head1 VERSION
This document describes ur old diff-rewrite version 0.29.
=head1 SYNOPSIS
ur old diff-rewrite (no execute or sub commands implemented)
=head1 DESCRIPTION:
a command which operates on classes/modules in a UR namespace directory
=cut
ur-define-class.pod 000444 023532 023421 1303 12121654172 16063 0 ustar 00abrummet gsc 000000 000000 UR-0.41/pod
=pod
=head1 NAME
ur define class - Add one or more classes to the current namespace
=head1 VERSION
This document describes ur define class version 0.29.
=head1 SYNOPSIS
ur define class --extends=? [NAMES]
$ cd Acme
$ ur define class Animal Vegetable Mineral
A Acme::Animal
A Acme::Vegetable
A Acme::Mineral
$ ur define class Dog Cat Bird --extends Animal
A Acme::Dog
A Acme::Cat
A Acme::Bird
=head1 REQUIRED ARGUMENTS
=over
=item extends
The base class. Defaults to UR::Object.
Default value 'UR::Object' if not specified
=back
=head1 OPTIONAL ARGUMENTS
=over
=item NAMES
(undocumented)
=back
=head1 DESCRIPTION:
Add one or more classes to the current namespace
=cut
ur-old.pod 000444 023532 023421 2260 12121654172 14307 0 ustar 00abrummet gsc 000000 000000 UR-0.41/pod
=pod
=head1 NAME
ur old - define namespaces, data sources and classes
=head1 VERSION
This document describes ur old version 0.29.
=head1 SUB-COMMANDS
diff-rewrite (no execute or su... a command which operates on classes/modules in a UR
namespace directory
diff-update (no execute or su... a command which operates on classes/modules in a UR
namespace directory
export-dbic-classes [BARE-ARGS] [CLAS... Create or update a DBIx::Class class from an already
existing UR class
info [SUBJECT] Outputs description(s) of UR entities such as classes and
tables to stdout
redescribe [CLASSES-OR-MODULES] Outputs class description(s) formatted to the latest
standard.
=cut
ur-test-eval.pod 000444 023532 023421 1235 12121654172 15436 0 ustar 00abrummet gsc 000000 000000 UR-0.41/pod
=pod
=head1 NAME
ur test eval - Evaluate a string of Perl source
=head1 VERSION
This document describes ur test eval version 0.29.
=head1 SYNOPSIS
ur test eval [BARE-ARGS]
ur test eval 'print "hello\n"'
ur test eval 'print "hello\n"' 'print "goodbye\n"'
ur test eval 'print "Testing in the " . \$self->namespace_name . " namespace.\n"'
=head1 OPTIONAL ARGUMENTS
=over
=item BARE-ARGS
(undocumented)
=back
=head1 DESCRIPTION:
This command is for testing and debugging. It simply eval's the Perl
source supplied on the command line, after using the current namespace.
A $self object is in scope representing the current context.
=cut
ur-old-diff-update.pod 000444 023532 023421 567 12121654172 16465 0 ustar 00abrummet gsc 000000 000000 UR-0.41/pod
=pod
=head1 NAME
ur old diff-update - a command which operates on classes/modules in a UR namespace directory
=head1 VERSION
This document describes ur old diff-update version 0.29.
=head1 SYNOPSIS
ur old diff-update (no execute or sub commands implemented)
=head1 DESCRIPTION:
a command which operates on classes/modules in a UR namespace directory
=cut
ur-define-datasource-file.pod 000444 023532 023421 1657 12121654172 20041 0 ustar 00abrummet gsc 000000 000000 UR-0.41/pod
=pod
=head1 NAME
ur define datasource file - Add a file-based data source (not yet implemented)
=head1 VERSION
This document describes ur define datasource file version 0.29.
=head1 SYNOPSIS
ur define datasource file --server=? [--singleton] [--dsid=?] [DSNAME]
=head1 REQUIRED ARGUMENTS
=over
=item server I
"server" attribute for this data source, such as a database name
=item singleton I
by default all data sources are singletons, but this can be turned off
Default value 'true' if not specified
=item nosingleton I
Make singleton 'false'
=back
=head1 OPTIONAL ARGUMENTS
=over
=item dsid I
The full class name to give this data source.
=item DSNAME I
The distinctive part of the class name for this data source. Will be prefixed with the namespace then '::DataSource::'.
=back
=head1 DESCRIPTION:
Add a file-based data source (not yet implemented)
=cut
ur-list-modules.pod 000444 023532 023421 657 12121654172 16142 0 ustar 00abrummet gsc 000000 000000 UR-0.41/pod
=pod
=head1 NAME
ur list modules - a command which operates on classes/modules in a UR namespace directory
=head1 VERSION
This document describes ur list modules version 0.29.
=head1 SYNOPSIS
ur list modules [CLASSES-OR-MODULES]
=head1 OPTIONAL ARGUMENTS
=over
=item CLASSES-OR-MODULES
(undocumented)
=back
=head1 DESCRIPTION:
a command which operates on classes/modules in a UR namespace directory
=cut
ur-list.pod 000444 023532 023421 1110 12121654172 14475 0 ustar 00abrummet gsc 000000 000000 UR-0.41/pod
=pod
=head1 NAME
ur list - list objects, classes, modules
=head1 VERSION
This document describes ur list version 0.29.
=head1 SUB-COMMANDS
objects --subject-class-n... lists objects matching specified params
classes [CLASSES-OR-MODULES] a command which operates on classes/modules in a UR
namespace directory
modules [CLASSES-OR-MODULES] a command which operates on classes/modules in a UR
namespace directory
=cut
ur-update.pod 000444 023532 023421 2626 12121654172 15021 0 ustar 00abrummet gsc 000000 000000 UR-0.41/pod
=pod
=head1 NAME
ur update - update parts of the source tree of a UR namespace
=head1 VERSION
This document describes ur update version 0.29.
=head1 SUB-COMMANDS
classes-from-db [--class-name=?] ... Update class definitions (and data dictionary cache) to
reflect changes in the database schema.
schema-diagram --file=? [--data-... Update an Umlet diagram based on the current schema
class-diagram --file=? [--data-... Update an Umlet diagram based on the current class
definitions
pod [--input-path=?] ... generate man-page-like POD for a commands
rename-class [--force] [CLASSE... Update::RewriteClassHeaders class descriptions headers to
normalize manual changes.
rewrite-class-header [--force] [CLASSE... Update::RewriteClassHeaders class descriptions headers to
normalize manual changes.
tab-completion-spec [--output=?] CLAS... Creates a .opts file beside class/module passed as
argument, e.g. UR::Namespace::Command.
=cut
ur-define-namespace.pod 000444 023532 023421 622 12121654172 16675 0 ustar 00abrummet gsc 000000 000000 UR-0.41/pod
=pod
=head1 NAME
ur define namespace - create a new namespace tree and top-level module
=head1 VERSION
This document describes ur define namespace version 0.29.
=head1 SYNOPSIS
ur define namespace NSNAME
=head1 REQUIRED ARGUMENTS
=over
=item NSNAME
the name of the namespace, and first "word" in all classes
=back
=head1 DESCRIPTION:
!!! define help_detail() in module
=cut
ur-test-callcount-list.pod 000444 023532 023421 4673 12121654173 17456 0 ustar 00abrummet gsc 000000 000000 UR-0.41/pod
=pod
=head1 NAME
ur test callcount list - Filter and list Callcount items
=head1 VERSION
This document describes ur test callcount list version 0.29.
=head1 SYNOPSIS
ur test callcount list --file=? --show=? [--csv-delimiter=?] [--filter=?] [--noheaders] [--style=?]
=head1 REQUIRED ARGUMENTS
=over
=item file I
Specify the .callcount file
Default value '/dev/null' if not specified
=item show
Specify which columns to show, in order.
Default value 'count,subname,subloc,callers' if not specified
=back
=head1 OPTIONAL ARGUMENTS
=over
=item csv-delimiter I
For the csv output style, specify the field delimiter
Default value ',' if not specified
=item filter I
Filter results based on the parameters. See below for how to.
=item noheaders I
Do not include headers
Default value 'false' (--nonoheaders) if not specified
=item nonoheaders I
Make noheaders 'false'
=item style I
Style of the list: text (default), csv, pretty, html, xml
Default value 'text' if not specified
=back
=head1 DESCRIPTION:
Listing Styles:
---------------
text - table like
csv - comma separated values
pretty - objects listed singly with color enhancements
html - html table
xml - xml document using elements
Filtering:
----------
Create filter equations by combining filterable properties with operators and
values.
Combine and separate these 'equations' by commas.
Use single quotes (') to contain values with spaces: name='genome institute'
Use percent signs (%) as wild cards in like (~).
Use backslash or single quotes to escape characters which have special meaning
to the shell such as < > and &
Operators:
----------
= (exactly equal to)
~ (like the value)
: (in the list of several values, slash "/" separated)
(or between two values, dash "-" separated)
> (greater than)
>= (greater than or equal to)
< (less than)
<= (less than or equal to)
Examples:
---------
lister-command --filter name=Bob --show id,name,address
lister-command --filter name='something with space',employees>200,job~%manager
lister-command --filter cost:20000-90000
lister-command --filter answer:yes/maybe
Filterable Properties:
----------------------
callers (String): (undocumented)
count (Integer): (undocumented)
subloc (String): (undocumented)
subname (String): (undocumented)
=cut
ur-test-run.pod 000444 023532 023421 7063 12121654173 15321 0 ustar 00abrummet gsc 000000 000000 UR-0.41/pod
=pod
=head1 NAME
ur test run - Run the test suite against the source tree.
=head1 VERSION
This document describes ur test run version 0.29.
=head1 SYNOPSIS
ur test run [--color] [--junit] [--list] [--lsf] [--recurse] [--callcount] [--cover=?] [--cover-cvs-changes] [--cover-svk-changes] [--cover-svn-changes] [--coverage] [--inc=?[,?]] [--jobs=?] [--long] [--lsf-params=?] [--noisy] [--perl-opts=?] [--run-as-lsf-helper=?] [--script-opts=?] [--time=?] [BARE-ARGS]
cd MyNamespace
ur test run --recurse # run all tests in the namespace
ur test run # runs all tests in the t/ directory under pwd
ur test run t/mytest1.t My/Class.t # run specific tests
ur test run -v -t --cover-svk-changes # run tests to cover latest svk updates
ur test run -I ../some/path/ # Adds ../some/path to perl's @INC through -I
ur test run --junit # writes test output in junit's xml format (consumable by Hudson integration system)
=head1 REQUIRED ARGUMENTS
=over
=item color I
Use TAP::Harness::Color to generate color output
Default value 'false' (--nocolor) if not specified
=item nocolor I
Make color 'false'
=item junit I
Run all tests with junit style XML output. (requires TAP::Formatter::JUnit)
=item nojunit I
Make junit 'false'
=item list I
List the tests, but do not actually run them.
=item nolist I
Make list 'false'
=item lsf I
If true, tests will be submitted as jobs via bsub
=item nolsf I
Make lsf 'false'
=item recurse I
Run all .t files in the current directory, and in recursive subdirectories.
=item norecurse I
Make recurse 'false'
=back
=head1 OPTIONAL ARGUMENTS
=over
=item callcount I
Count the number of calls to each subroutine/method
=item nocallcount I
Make callcount 'false'
=item cover I
Cover only this(these) modules
=item cover-cvs-changes I
Cover modules modified in cvs status
=item nocover-cvs-changes I
Make cover-cvs-changes 'false'
=item cover-svk-changes I
Cover modules modified in svk status
=item nocover-svk-changes I
Make cover-svk-changes 'false'
=item cover-svn-changes I
Cover modules modified in svn status
=item nocover-svn-changes I
Make cover-svn-changes 'false'
=item coverage I
Invoke Devel::Cover
=item nocoverage I
Make coverage 'false'
=item inc I
Additional paths for @INC, alias for -I
=item jobs I
How many tests to run in parallel
Default value '1' if not specified
=item long I
Run tests including those flagged as long
=item nolong I
Make long 'false'
=item lsf-params I
Params passed to bsub while submitting jobs to lsf
Default value '-q short -R select[type==LINUX64]' if not specified
=item noisy I
doesn't redirect stdout
=item nonoisy I
Make noisy 'false'
=item perl-opts I
Override options to the Perl interpreter when running the tests (-d:Profile, etc.)
Default value '' if not specified
=item run-as-lsf-helper I
Used internally by the test harness
=item script-opts I
Override options to the test case when running the tests (--dump-sql --no-commit)
Default value '' if not specified
=item time I
Write timelog sum to specified file
=item BARE-ARGS
(undocumented)
=back
=head1 DESCRIPTION:
This command is like "prove" or "make test", running the test suite for the current namespace.
=cut
ur-define-datasource-pg.pod 000444 023532 023421 2210 12121654173 17513 0 ustar 00abrummet gsc 000000 000000 UR-0.41/pod
=pod
=head1 NAME
ur define datasource pg - Add a PostgreSQL data source to the current namespace.
=head1 VERSION
This document describes ur define datasource pg version 0.29.
=head1 SYNOPSIS
ur define datasource pg --auth=? --login=? [--nosingleton] --owner=? [--dsid=?] [--server=?] [DSNAME]
=head1 REQUIRED ARGUMENTS
=over
=item auth I
Password to log in with
=item login I
User to log in with
=item nosingleton I
Created data source should not inherit from UR::Singleton (defalt is that it will)
Default value 'false' (--nonosingleton) if not specified
=item nonosingleton I
Make nosingleton 'false'
=item owner I
Owner/schema to connect to
=back
=head1 OPTIONAL ARGUMENTS
=over
=item dsid I
The full class name to give this data source.
=item server I
"server" attribute for this data source, such as a database name
=item DSNAME I
The distinctive part of the class name for this data source. Will be prefixed with the namespace then '::DataSource::'.
=back
=head1 DESCRIPTION:
Add a PostgreSQL data source to the current namespace.
=cut
ur-define-db.pod 000444 023532 023421 1651 12121654173 15352 0 ustar 00abrummet gsc 000000 000000 UR-0.41/pod
=pod
=head1 NAME
ur define db - add a data source to the current namespace
=head1 VERSION
This document describes ur define db version 0.29.
=head1 SYNOPSIS
ur define db URI NAME
ur define db dbi:SQLite:/some/file.db Db1
ur define db me@dbi:mysql:myserver MainDb
ur define db me@dbi:Oracle:someserver ProdDb
ur define db me@dbi:Oracle:someserver~schemaname BigDb
ur define db me@dbi:Pg:prod Db1
ur define db me@dbi:Pg:dev Testing::Db1 # alternate for "Testing" (arbitrary) context
ur define db me@dbi:Pg:stage Staging::Db1 # alternate for "Staging" (arbitrary) context
=head1 REQUIRED ARGUMENTS
=over
=item URI I
a DBI connect string like dbi:mysql:someserver or user/passwd@dbi:Oracle:someserver~defaultns
=item NAME I
the name for this data source (used for class naming)
Default value 'Db1' if not specified
=back
=head1 DESCRIPTION:
add a data source to the current namespace
=cut
ur-update-pod.pod 000444 023532 023421 1751 12121654173 15600 0 ustar 00abrummet gsc 000000 000000 UR-0.41/pod
=pod
=head1 NAME
ur update pod - generate man-page-like POD for a commands
=head1 VERSION
This document describes ur update pod version 0.29.
(built on 2011-03-07 at 10:34:30)
=head1 SYNOPSIS
ur update pod [--input-path=?] [--output-path=?] EXECUTABLE-NAME CLASS-NAME TARGETS
ur update pod -i ./lib -o ./pod ur UR::Namespace::Command
=head1 REQUIRED ARGUMENTS
=over
=item EXECUTABLE-NAME I
the name of the executable to document
=item CLASS-NAME I
the command class which maps to the executable
=item TARGETS I
specific classes to document (documents all unless specified)
=back
=head1 OPTIONAL ARGUMENTS
=over
=item input-path I
optional location of the modules to document
=item output-path I
optional location to output .pod files
=back
=head1 DESCRIPTION:
This tool generates POD documentation for each all of the commands in a tree for a given executable.
This command must be run from within the namespace directory.
=cut
ur.pod 000444 023532 023421 1341 12121654173 13533 0 ustar 00abrummet gsc 000000 000000 UR-0.41/pod
=pod
=head1 NAME
ur - tools to create and maintain a ur class tree
=head1 VERSION
This document describes ur version 0.29.
=head1 SUB-COMMANDS
init NAMESPACE [DB] create a new ur app with default classes in place
define ... define namespaces, data sources and classes
describe CLASSES-OR-MODULES show class properties, relationships, meta-data
update ... update parts of the source tree of a UR namespace
list ... list objects, classes, modules
sys ... service launchers
test ... tools for testing and debugging
=cut
ur-init.pod 000444 023532 023421 760 12121654173 14460 0 ustar 00abrummet gsc 000000 000000 UR-0.41/pod
=pod
=head1 NAME
ur init - create a new ur app with default classes in place
=head1 VERSION
This document describes ur init version 0.29.
=head1 SYNOPSIS
ur init NAMESPACE [DB]
=head1 REQUIRED ARGUMENTS
=over
=item NAMESPACE I
the name of the namespace/app to create
=back
=head1 OPTIONAL ARGUMENTS
=over
=item DB I
the (optional) DBI connection string for the primary data source
=back
=head1 DESCRIPTION:
!!! define help_detail() in module
=cut
ur-test.pod 000444 023532 023421 2456 12121654173 14520 0 ustar 00abrummet gsc 000000 000000 UR-0.41/pod
=pod
=head1 NAME
ur test - tools for testing and debugging
=head1 VERSION
This document describes ur test version 0.29.
=head1 SUB-COMMANDS
callcount ... Collect the data from a prior 'ur test run --callcount' run
into a single output file
compile [CLASSES-OR-MODULES] Attempts to compile each module in the namespace in its own
process.
eval [BARE-ARGS] Evaluate a string of Perl source
run [--color] [--juni... Run the test suite against the source tree.
track-object-release --file=? Parse the data produced by UR_DEBUG_OBJECT_RELEASE and
report possible memory leaks
use [--exec=?] [--sum... Tests each module for compile errors by 'use'-ing it. Also
reports on any libs added to @INC by any modules (bad!).
window [SRC] repl tk window
=cut
ur-sys-class-browser.pod 000444 023532 023421 525 12121654173 17116 0 ustar 00abrummet gsc 000000 000000 UR-0.41/pod
=pod
=head1 NAME
ur sys class-browser - Start a web server to browse through the class and database structures.
=head1 VERSION
This document describes ur sys class-browser version 0.29.
=head1 SYNOPSIS
ur sys class-browser
=head1 DESCRIPTION:
Start a web server to browse through the class and database structures.
=cut
ur-define-datasource-oracle.pod 000444 023532 023421 2216 12121654173 20360 0 ustar 00abrummet gsc 000000 000000 UR-0.41/pod
=pod
=head1 NAME
ur define datasource oracle - Add an Oracle data source to the current namespace.
=head1 VERSION
This document describes ur define datasource oracle version 0.29.
=head1 SYNOPSIS
ur define datasource oracle --auth=? --login=? [--nosingleton] --owner=? [--dsid=?] [--server=?] [DSNAME]
=head1 REQUIRED ARGUMENTS
=over
=item auth I
Password to log in with
=item login I
User to log in with
=item nosingleton I
Created data source should not inherit from UR::Singleton (defalt is that it will)
Default value 'false' (--nonosingleton) if not specified
=item nonosingleton I
Make nosingleton 'false'
=item owner I
Owner/schema to connect to
=back
=head1 OPTIONAL ARGUMENTS
=over
=item dsid I
The full class name to give this data source.
=item server I
"server" attribute for this data source, such as a database name
=item DSNAME I
The distinctive part of the class name for this data source. Will be prefixed with the namespace then '::DataSource::'.
=back
=head1 DESCRIPTION:
Add an Oracle data source to the current namespace.
=cut
ur-list-classes.pod 000444 023532 023421 657 12121654174 16131 0 ustar 00abrummet gsc 000000 000000 UR-0.41/pod
=pod
=head1 NAME
ur list classes - a command which operates on classes/modules in a UR namespace directory
=head1 VERSION
This document describes ur list classes version 0.29.
=head1 SYNOPSIS
ur list classes [CLASSES-OR-MODULES]
=head1 OPTIONAL ARGUMENTS
=over
=item CLASSES-OR-MODULES
(undocumented)
=back
=head1 DESCRIPTION:
a command which operates on classes/modules in a UR namespace directory
=cut
ur-update-rewrite-class-header.pod 000444 023532 023421 1610 12121654174 21023 0 ustar 00abrummet gsc 000000 000000 UR-0.41/pod
=pod
=head1 NAME
ur update rewrite-class-header - Update::RewriteClassHeaders class descriptions headers to normalize manual changes.
=head1 VERSION
This document describes ur update rewrite-class-header version 0.29.
=head1 SYNOPSIS
ur update rewrite-class-header [--force] [CLASSES-OR-MODULES]
=head1 OPTIONAL ARGUMENTS
=over
=item force I
(undocumented)
=item noforce I
Make force 'false'
=item CLASSES-OR-MODULES
(undocumented)
=back
=head1 DESCRIPTION:
UR classes have a header at the top which defines the class in terms of its metadata.
This command replaces that text in the source module with a fresh copy.
It is most useful to fix formatting problems, since the data from which the new
version is made is the data supplied by the old version of the file.
It's somewhat of a "perltidy" for the module header.
=cut
ur-update-classes-from-db.pod 000444 023532 023421 3521 12121654174 17775 0 ustar 00abrummet gsc 000000 000000 UR-0.41/pod
=pod
=head1 NAME
ur update classes-from-db - Update class definitions (and data dictionary cache) to reflect changes in the database schema.
=head1 VERSION
This document describes ur update classes-from-db version 0.29.
=head1 SYNOPSIS
ur update classes-from-db [--class-name=?] [--data-source=?] [--force-check-all-tables] [--force-rewrite-all-classes] [--table-name=?] [CLASSES-OR-MODULES]
=head1 OPTIONAL ARGUMENTS
=over
=item class-name I
Update only the specified classes.
=item data-source I
Limit updates to these data sources
=item force-check-all-tables I
By default we only look at tables with a new DDL time for changed database schema information. This explicitly (slowly) checks each table against our cache.
=item noforce-check-all-tables I
Make force-check-all-tables 'false'
=item force-rewrite-all-classes I
By default we only rewrite classes where there are database changes. Set this flag to rewrite all classes even where there are no schema changes.
=item noforce-rewrite-all-classes I
Make force-rewrite-all-classes 'false'
=item table-name I
Update the specified table.
=item CLASSES-OR-MODULES
(undocumented)
=back
=head1 DESCRIPTION:
Reads from the data sources in the current working directory's namespace,
and updates the local class tree.
This hits the data dictionary for the remote database, and gets changes there
first. Those changes are then used to mutate the class tree.
If specific data sources are specified on the command-line, it will limit
its database examination to just data in those data sources. This command
will, however, always load ALL classes in the namespace when doing this update,
to find classes which currently reference the updated table, or are connected
to its class indirectly.
=cut
ur-update-tab-completion-spec.pod 000444 023532 023421 1257 12121654174 20665 0 ustar 00abrummet gsc 000000 000000 UR-0.41/pod
=pod
=head1 NAME
ur update tab-completion-spec - Creates a .opts file beside class/module passed as argument, e.g. UR::Namespace::Command.
=head1 VERSION
This document describes ur update tab-completion-spec version 0.29.
=head1 SYNOPSIS
ur update tab-completion-spec [--output=?] CLASSNAME
=head1 REQUIRED ARGUMENTS
=over
=item CLASSNAME I
The base class to use as trunk of command tree, e.g. UR::Namespace::Command
=back
=head1 OPTIONAL ARGUMENTS
=over
=item output I
Override output location of the opts spec file.
=back
=head1 DESCRIPTION:
Creates a .opts file beside class/module passed as argument, e.g. UR::Namespace::Command.
=cut
ur-test-track-object-release.pod 000444 023532 023421 1473 12121654174 20503 0 ustar 00abrummet gsc 000000 000000 UR-0.41/pod
=pod
=head1 NAME
ur test track-object-release - Parse the data produced by UR_DEBUG_OBJECT_RELEASE and report possible memory leaks
=head1 VERSION
This document describes ur test track-object-release version 0.29.
=head1 SYNOPSIS
ur test track-object-release --file=?
ur test track-object-release --file /path/to/text.file > /path/to/results
=head1 REQUIRED ARGUMENTS
=over
=item file I
pathname of the input file
=back
=head1 DESCRIPTION:
When a UR-based program is run with the UR_DEBUG_OBJECT_RELEASE environment
variable set to 1, it will emit messages to STDERR describing the various
stages of releasing an object. This command parses those messages and
provides a report on objects which did not completely deallocate themselves,
usually because of a reference being held.
=cut
ur-old-export-dbic-classes.pod 000444 023532 023421 1143 12121654174 20161 0 ustar 00abrummet gsc 000000 000000 UR-0.41/pod
=pod
=head1 NAME
ur old export-dbic-classes - Create or update a DBIx::Class class from an already existing UR class
=head1 VERSION
This document describes ur old export-dbic-classes version 0.29.
=head1 SYNOPSIS
ur old export-dbic-classes [BARE-ARGS] [CLASSES-OR-MODULES]
=head1 OPTIONAL ARGUMENTS
=over
=item BARE-ARGS
(undocumented)
=item CLASSES-OR-MODULES
(undocumented)
=back
=head1 DESCRIPTION:
Given one or more UR class names on the command line, this will create
or update a DBIx::Class class. The files will appear under the DBIx directory
in the namespace.
=cut
ur-define-datasource.pod 000444 023532 023421 1074 12121654174 17117 0 ustar 00abrummet gsc 000000 000000 UR-0.41/pod
=pod
=head1 NAME
ur define datasource - add a data source to the current namespace
=head1 VERSION
This document describes ur define datasource version 0.29.
=head1 SYNOPSIS
ur define datasource [file|mysql|oracle|pg|sqlite] ...
=head1 OPTIONAL ARGUMENTS
=over
=item dsid I
The full class name to give this data source.
=item DSNAME I
The distinctive part of the class name for this data source. Will be prefixed with the namespace then '::DataSource::'.
=back
=head1 DESCRIPTION:
add a data source to the current namespace
=cut
ur-test-use.pod 000444 023532 023421 3035 12121654174 15305 0 ustar 00abrummet gsc 000000 000000 UR-0.41/pod
=pod
=head1 NAME
ur test use - Tests each module for compile errors by 'use'-ing it. Also reports on any libs added to @INC by any modules (bad!).
=head1 VERSION
This document describes ur test use version 0.29.
=head1 SYNOPSIS
ur test use [--exec=?] [--summarize-externals] [--verbose] [CLASSES-OR-MODULES]
ur test use
ur test use Some::Module Some::Other::Module
ur test use ./Module.pm Other/Module.pm
=head1 OPTIONAL ARGUMENTS
=over
=item exec I
Execute the specified Perl _after_ using all of the modules.
=item summarize-externals I
List all modules used which are outside the namespace.
=item nosummarize-externals I
Make summarize-externals 'false'
=item verbose I
List each explicitly.
=item noverbose I
Make verbose 'false'
=item CLASSES-OR-MODULES
(undocumented)
=back
=head1 DESCRIPTION:
Tests each module by "use"-ing it. Failures are reported individually.
Successes are only reported individualy if the --verbose option is specified.
A count of total successes/failures is returned as a summary in all cases.
This command requires that the current working directory be under a namespace module.
If no modules or class names are specified as parameters, it runs on all modules in the namespace.
If modules or class names ARE listed, it will operate only on those.
Words containing double-colons will be interpreted as absolute class names.
All other words will be interpreted as relative file paths to modules.
=cut
ur-list-objects.pod 000444 023532 023421 4424 12121654174 16141 0 ustar 00abrummet gsc 000000 000000 UR-0.41/pod
=pod
=head1 NAME
ur list objects - lists objects matching specified params
=head1 VERSION
This document describes ur list objects version 0.29.
=head1 SYNOPSIS
ur list objects --subject-class-name=? [--csv-delimiter=?] [--filter=?] [--noheaders] [--show=?] [--style=?]
=head1 REQUIRED ARGUMENTS
=over
=item subject-class-name I
(undocumented)
=back
=head1 OPTIONAL ARGUMENTS
=over
=item csv-delimiter I
For the csv output style, specify the field delimiter
Default value ',' if not specified
=item filter I
Filter results based on the parameters. See below for how to.
=item noheaders I
Do not include headers
Default value 'false' (--nonoheaders) if not specified
=item nonoheaders I
Make noheaders 'false'
=item show I
Specify which columns to show, in order.
=item style I
Style of the list: text (default), csv, pretty, html, xml
Default value 'text' if not specified
=back
=head1 DESCRIPTION:
Listing Styles:
---------------
text - table like
csv - comma separated values
pretty - objects listed singly with color enhancements
html - html table
xml - xml document using elements
Filtering:
----------
Create filter equations by combining filterable properties with operators and
values.
Combine and separate these 'equations' by commas.
Use single quotes (') to contain values with spaces: name='genome institute'
Use percent signs (%) as wild cards in like (~).
Use backslash or single quotes to escape characters which have special meaning
to the shell such as < > and &
Operators:
----------
= (exactly equal to)
~ (like the value)
: (in the list of several values, slash "/" separated)
(or between two values, dash "-" separated)
> (greater than)
>= (greater than or equal to)
< (less than)
<= (less than or equal to)
Examples:
---------
lister-command --filter name=Bob --show id,name,address
lister-command --filter name='something with space',employees>200,job~%manager
lister-command --filter cost:20000-90000
lister-command --filter answer:yes/maybe
Filterable Properties:
----------------------
Can't determine the list of filterable properties without a subject_class_name
=cut
ur-update-class-diagram.pod 000444 023532 023421 3324 12121654175 17525 0 ustar 00abrummet gsc 000000 000000 UR-0.41/pod
=pod
=head1 NAME
ur update class-diagram - Update an Umlet diagram based on the current class definitions
=head1 VERSION
This document describes ur update class-diagram version 0.29.
=head1 SYNOPSIS
ur update class-diagram --file=? [--data-source=?] [--depth=?] [--include-ur-object] [--show-attributes] [--show-methods] [INITIAL-NAME]
=head1 REQUIRED ARGUMENTS
=over
=item file I
Pathname of the Umlet (.uxf) file
=back
=head1 OPTIONAL ARGUMENTS
=over
=item data-source I
Which datasource to use
=item depth I
Max distance of related classes to include. Default is 1. 0 means show only the named class(es), -1 means to include everything
=item include-ur-object I
Include UR::Object and UR::Entity in the diagram (default = no)
Default value 'false' (--noinclude-ur-object) if not specified
=item noinclude-ur-object I
Make include-ur-object 'false'
=item show-attributes I
Include class attributes in the diagram
Default value 'true' if not specified
=item noshow-attributes I
Make show-attributes 'false'
=item show-methods I
Include methods in the diagram (not implemented yet
Default value 'false' (--noshow-methods) if not specified
=item noshow-methods I
Make show-methods 'false'
=item INITIAL-NAME
(undocumented)
=back
=head1 DESCRIPTION:
Creates a new Umlet diagram, or updates an existing diagram. Bare arguments
are taken as class names to include in the diagram. Other classes may be
included in the diagram based on their distance from the names classes
and the --depth parameter.
If an existing file is being updated, the position of existing elements
will not change.
=cut
ur-update-rename-class.pod 000444 023532 023421 1560 12121654175 17370 0 ustar 00abrummet gsc 000000 000000 UR-0.41/pod
=pod
=head1 NAME
ur update rename-class - Update::RewriteClassHeaders class descriptions headers to normalize manual changes.
=head1 VERSION
This document describes ur update rename-class version 0.29.
=head1 SYNOPSIS
ur update rename-class [--force] [CLASSES-OR-MODULES]
=head1 OPTIONAL ARGUMENTS
=over
=item force I
(undocumented)
=item noforce I
Make force 'false'
=item CLASSES-OR-MODULES
(undocumented)
=back
=head1 DESCRIPTION:
UR classes have a header at the top which defines the class in terms of its metadata.
This command replaces that text in the source module with a fresh copy.
It is most useful to fix formatting problems, since the data from which the new
version is made is the data supplied by the old version of the file.
It's somewhat of a "perltidy" for the module header.
=cut
ur-sys.pod 000444 023532 023421 460 12121654175 14332 0 ustar 00abrummet gsc 000000 000000 UR-0.41/pod
=pod
=head1 NAME
ur sys - service launchers
=head1 VERSION
This document describes ur sys version 0.29.
=head1 SUB-COMMANDS
class-browser Start a web server to browse through the class and database
structures.
=cut
ur-describe.pod 000444 023532 023421 750 12121654175 15276 0 ustar 00abrummet gsc 000000 000000 UR-0.41/pod
=pod
=head1 NAME
ur describe - show class properties, relationships, meta-data
=head1 VERSION
This document describes ur describe version 0.29.
=head1 SYNOPSIS
ur describe CLASSES-OR-MODULES
ur describe UR::Object
ur describe Acme::Order Acme::Product Acme::Order::LineItem
=head1 REQUIRED ARGUMENTS
=over
=item CLASSES-OR-MODULES
classes to describe by class name or module path
=back
=head1 DESCRIPTION:
show class properties, relationships, meta-data
=cut
ur-define.pod 000444 023532 023421 651 12121654175 14750 0 ustar 00abrummet gsc 000000 000000 UR-0.41/pod
=pod
=head1 NAME
ur define - define namespaces, data sources and classes
=head1 VERSION
This document describes ur define version 0.29.
=head1 SUB-COMMANDS
namespace NSNAME create a new namespace tree and top-level module
db URI NAME add a data source to the current namespace
class --extends=? [NAMES] Add one or more classes to the current namespace
=cut
ur-old-redescribe.pod 000444 023532 023421 643 12121654175 16402 0 ustar 00abrummet gsc 000000 000000 UR-0.41/pod
=pod
=head1 NAME
ur old redescribe - Outputs class description(s) formatted to the latest standard.
=head1 VERSION
This document describes ur old redescribe version 0.29.
=head1 SYNOPSIS
ur old redescribe [CLASSES-OR-MODULES]
=head1 OPTIONAL ARGUMENTS
=over
=item CLASSES-OR-MODULES
(undocumented)
=back
=head1 DESCRIPTION:
Outputs class description(s) formatted to the latest standard.
=cut
ur-update-schema-diagram.pod 000444 023532 023421 2325 12121654175 17660 0 ustar 00abrummet gsc 000000 000000 UR-0.41/pod
=pod
=head1 NAME
ur update schema-diagram - Update an Umlet diagram based on the current schema
=head1 VERSION
This document describes ur update schema-diagram version 0.29.
=head1 SYNOPSIS
ur update schema-diagram --file=? [--data-source=?] [--depth=?] [--show-columns] [INITIAL-NAME]
=head1 REQUIRED ARGUMENTS
=over
=item file I
Pathname of the Umlet (.uxf) file
=back
=head1 OPTIONAL ARGUMENTS
=over
=item data-source I
Which datasource to use
=item depth I
Max distance of related tables to include. Default is 1. 0 means show only the named tables, -1 means to include everything
=item show-columns I
Include column names in the diagram
Default value 'true' if not specified
=item noshow-columns I
Make show-columns 'false'
=item INITIAL-NAME
(undocumented)
=back
=head1 DESCRIPTION:
Creates a new Umlet diagram, or updates an existing diagram. Bare arguments
are taken as table names to include in the diagram. Other tables may be
included in the diagram based on their distance from the names tables
and the --depth parameter.
If an existing file is being updated, the position of existing elements
will not change.
=cut
ur-test-window.pod 000444 023532 023421 461 12121654175 16001 0 ustar 00abrummet gsc 000000 000000 UR-0.41/pod
=pod
=head1 NAME
ur test window - repl tk window
=head1 VERSION
This document describes ur test window version 0.29.
=head1 SYNOPSIS
ur test window [SRC]
=head1 OPTIONAL ARGUMENTS
=over
=item SRC
(undocumented)
=back
=head1 DESCRIPTION:
!!! define help_detail() in module
=cut
ur-define-datasource-sqlite.pod 000444 023532 023421 2407 12121654175 20420 0 ustar 00abrummet gsc 000000 000000 UR-0.41/pod
=pod
=head1 NAME
ur define datasource sqlite - Add a SQLite data source to the current namespace.
=head1 VERSION
This document describes ur define datasource sqlite version 0.29.
=head1 SYNOPSIS
ur define datasource sqlite [--nosingleton] [--dsid=?] [--server=?] [DSNAME]
cd Acme
ur define datasource sqlite --dsname MyDB1
# writes Acme::DataSource::MyDB1 to work with Acme/DataSource/MyDB1.sqlite3
ur define datasource sqlite --dsname MyDB2 --server /var/lib/acmeapp/mydb2.sqlite3
# writes Acme::DataSource::MyDB2 to work with the specified sqlite file
=head1 REQUIRED ARGUMENTS
=over
=item nosingleton I
Created data source should not inherit from UR::Singleton (defalt is that it will)
Default value 'false' (--nonosingleton) if not specified
=item nonosingleton I
Make nosingleton 'false'
=back
=head1 OPTIONAL ARGUMENTS
=over
=item dsid I
The full class name to give this data source.
=item server I
"server" attribute for this data source, such as a database name
=item DSNAME I
The distinctive part of the class name for this data source. Will be prefixed with the namespace then '::DataSource::'.
=back
=head1 DESCRIPTION:
Add a SQLite data source to the current namespace.
=cut
ur-test-callcount.pod 000444 023532 023421 450 12121654175 16454 0 ustar 00abrummet gsc 000000 000000 UR-0.41/pod
=pod
=head1 NAME
ur test callcount - Collect the data from a prior 'ur test run --callcount' run into a single output file
=head1 VERSION
This document describes ur test callcount version 0.29.
=head1 SUB-COMMANDS
list --file=? --show=?... Filter and list Callcount items
=cut
ur-test-compile.pod 000444 023532 023421 1335 12121654175 16143 0 ustar 00abrummet gsc 000000 000000 UR-0.41/pod
=pod
=head1 NAME
ur test compile - Attempts to compile each module in the namespace in its own process.
=head1 VERSION
This document describes ur test compile version 0.29.
=head1 SYNOPSIS
ur test compile [CLASSES-OR-MODULES]
ur test complie
ur test compile Some::Module Some::Other::Module
ur test complile Some/Module.pm Some/Other/Mod*.pm
=head1 OPTIONAL ARGUMENTS
=over
=item CLASSES-OR-MODULES
(undocumented)
=back
=head1 DESCRIPTION:
This command runs "perl -c" on each module in a separate process and aggregates results.
Running with --verbose will list specific modules instead of just a summary.
Try "ur test use" for a faster evaluation of whether your software tree is broken. :)
=cut
ur-define-datasource-mysql.pod 000444 023532 023421 2207 12121654175 20262 0 ustar 00abrummet gsc 000000 000000 UR-0.41/pod
=pod
=head1 NAME
ur define datasource mysql - Add a MySQL data source to the current namespace.
=head1 VERSION
This document describes ur define datasource mysql version 0.29.
=head1 SYNOPSIS
ur define datasource mysql --auth=? --login=? [--nosingleton] --owner=? [--dsid=?] [--server=?] [DSNAME]
=head1 REQUIRED ARGUMENTS
=over
=item auth I
Password to log in with
=item login I
User to log in with
=item nosingleton I
Created data source should not inherit from UR::Singleton (defalt is that it will)
Default value 'false' (--nonosingleton) if not specified
=item nonosingleton I
Make nosingleton 'false'
=item owner I
Owner/schema to connect to
=back
=head1 OPTIONAL ARGUMENTS
=over
=item dsid I
The full class name to give this data source.
=item server I
"server" attribute for this data source, such as a database name
=item DSNAME I
The distinctive part of the class name for this data source. Will be prefixed with the namespace then '::DataSource::'.
=back
=head1 DESCRIPTION:
Add a MySQL data source to the current namespace.
=cut
ur-old-info.pod 000444 023532 023421 623 12121654175 15224 0 ustar 00abrummet gsc 000000 000000 UR-0.41/pod
=pod
=head1 NAME
ur old info - Outputs description(s) of UR entities such as classes and tables to stdout
=head1 VERSION
This document describes ur old info version 0.29.
=head1 SYNOPSIS
ur old info [SUBJECT]
=head1 OPTIONAL ARGUMENTS
=over
=item SUBJECT
(undocumented)
=back
=head1 DESCRIPTION:
Outputs description(s) of UR entities such as classes and tables to stdout
=cut
lib 000755 023532 023421 0 12121654175 12233 5 ustar 00abrummet gsc 000000 000000 UR-0.41 above.pm 000444 023532 023421 5227 12121654173 14026 0 ustar 00abrummet gsc 000000 000000 UR-0.41/lib package above;
use strict;
use warnings;
our $VERSION = '0.02';
sub import {
my $package = shift;
for (@_) {
use_package($_);
}
}
our %used_libs;
BEGIN {
%used_libs = ($ENV{PERL_USED_ABOVE} ? (map { $_ => 1 } split(":",$ENV{PERL_USED_ABOVE})) : ());
for my $path (keys %used_libs) {
#print STDERR "Using (parent process') libraries at $path\n";
eval "use lib '$path';";
die "Failed to use library path '$path' from the environment PERL_USED_ABOVE?: $@" if $@;
}
};
sub use_package {
my $class = shift;
my $caller = (caller(1))[0];
my $module = $class;
$module =~ s/::/\//g;
$module .= ".pm";
## paths already found in %used_above have
## higher priority than paths based on cwd
for my $path (keys %used_libs) {
if (-e "$path/$module") {
eval "package $caller; use $class";
die $@ if $@;
return;
}
}
require Cwd;
my $cwd = Cwd::cwd();
my @parts = ($cwd =~ /\//g);
my $dirs_above = scalar(@parts);
my $path=$cwd.'/';
until (-e "$path./$module") {
if ($dirs_above == 0) {
# Not found. Use the one out under test.
# When deployed.
$path = "";
last;
};
#print "Didn't find it in $path, trying higher\n";
$path .= "../";
$dirs_above--;
}
# Get the special path in place
if (length($path)) {
while ($path =~ s:/[^/]+/\.\./:/:) { 1 } # simplify
unless ($used_libs{$path}) {
print STDERR "Using libraries at $path\n" unless $ENV{PERL_ABOVE_QUIET} or $ENV{COMP_LINE};
eval "use lib '$path';";
die $@ if $@;
$used_libs{$path} = 1;
my $env_value = join(":",sort keys %used_libs);
$ENV{PERL_USED_ABOVE} = $env_value;
}
}
# Now use the module.
eval "package $caller; use $class";
die $@ if $@;
};
1;
=pod
=head1 NAME
above - auto "use lib" when a module is in the tree of the PWD
=head1 SYNOPSIS
use above "My::Module";
=head1 DESCRIPTION
Used by the command-line wrappers for Command modules which are developer tools.
Do NOT use this in modules, or user applications.
Uses a module as though the cwd and each of its parent directories were at the beginnig of @INC.
If found in that path, the parent directory is kept as though by "use lib".
=head1 EXAMPLES
# given
/home/me/perlsrc/My/Module.pm
# in
/home/me/perlsrc/My/Module/Some/Path/
# in myapp.pl:
use above "My::Module";
# does this ..if run anywhere under /home/me/perlsrc:
use lib '/home/me/perlsrc/'
use My::Module;
=head1 AUTHOR
Scott Smith
=cut
Command.pm 000444 023532 023421 323 12121654175 14262 0 ustar 00abrummet gsc 000000 000000 UR-0.41/lib package Command;
use strict;
use warnings;
use UR;
our $VERSION = "0.41"; # UR $VERSION;
UR::Object::Type->define(
class_name => __PACKAGE__,
is_abstract => 1,
subclassify_by_version => 1,
);
1;
UR.pm 000444 023532 023421 103203 12121654175 13313 0 ustar 00abrummet gsc 000000 000000 UR-0.41/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.41"; # UR $VERSION
BEGIN {
# unless otherwise specified, begin uncaching at 1 million objects
#$ENV{'UR_CONTEXT_CACHE_SIZE_HIGHWATER'} ||= 1_000_000;
#$ENV{'UR_CONTEXT_CACHE_SIZE_LOWWATER'} ||= 1_000;
}
# 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::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' }
]
);
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 },
default_value => { is_optional => 1 },
valid_values => { is => 'ARRAY', is_optional => 1, },
example_values => { is => 'ARRAY', is_optional => 1, },
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.41
=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 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-2011 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
Command 000755 023532 023421 0 12121654175 13611 5 ustar 00abrummet gsc 000000 000000 UR-0.41/lib V2.pm 000444 023532 023421 30725 12121654172 14617 0 ustar 00abrummet gsc 000000 000000 UR-0.41/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.41"; # UR $VERSION;
our $entry_point_class;
our $entry_point_bin;
UR::Object::Type->define(
class_name => __PACKAGE__,
is => 'Command',
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 => [
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 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 __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 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);
}
$self->delete() if $was_called_as_class_method;
return;
}
my $result = $self->_execute_body(@_);
$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;
}
sub exit_code_for_return_value {
my $self = shift;
my $return_value = shift;
# 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
if (! $return_value) {
$return_value = 1;
} elsif ($return_value < 0) {
$return_value = 0 - $return_value;
} else {
$return_value = 0
}
return $return_value;
}
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
DynamicSubCommands.pm 000444 023532 023421 17410 12121654173 20045 0 ustar 00abrummet gsc 000000 000000 UR-0.41/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
Tree.pm 000444 023532 023421 40245 12121654173 15226 0 ustar 00abrummet gsc 000000 000000 UR-0.41/lib/Command package Command::Tree;
use strict;
use warnings;
use UR;
use File::Basename qw/basename/;
our $VERSION = "0.41"; # 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
SubCommandFactory.pm 000444 023532 023421 7256 12121654174 17675 0 ustar 00abrummet gsc 000000 000000 UR-0.41/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;
V1.pm 000444 023532 023421 143155 12121654174 14642 0 ustar 00abrummet gsc 000000 000000 UR-0.41/lib/Command package Command::V1;
use strict;
use warnings;
use UR;
use Data::Dumper;
use File::Basename;
use Getopt::Long;
use Term::ANSIColor;
require Text::Wrap;
our $VERSION = "0.41"; # UR $VERSION;
UR::Object::Type->define(
class_name => __PACKAGE__,
is => 'Command',
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 => [
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";
};
# Override method in UR::Object to support error_die and error_rv_false
sub validate_subscription {
my $self = shift;
my $subscription_property = shift;
my $retval = $self->SUPER::validate_subscription($subscription_property, @_);
return $retval if $retval;
unless ( defined($subscription_property) and $subscription_property eq 'error_die') {
$subscription_property = '(undef)' unless defined ($subscription_property);
Carp::croak("Unrecognized subscription aspect '$subscription_property'");
}
return 1;
}
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;
}
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 { $result = $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
my $self = shift;
my $class = ref($self) || $self;
if ($class eq __PACKAGE__) {
die "The execute() method is not defined for $_[0]!";
}
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(0);
my $rv = $command_object->execute($params);
if ($command_object->__errors__) {
$command_object->delete;
}
return $rv;
}
#
# Standard programmatic interface
#
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.
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;
}
#
# 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;
}
# 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;
}
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 = '';
$DB::single = 1;
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;
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;
}
$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 = $property_meta->default_value;
if (defined $default_value) {
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";
}
#$DB::single = 1;
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
V1.t 000444 023532 023421 1225 12121654174 14420 0 ustar 00abrummet gsc 000000 000000 UR-0.41/lib/Command use strict;
use warnings;
use Test::More;
use above 'UR';
UR::Object::Type->define(
class_name => 'Test::Command',
is => ['Command::V1'],
);
my $command = Test::Command->create;
ok($command, 'Command Object created');
is($command->status_message('foo'),'foo','Returns message in scalar context');
my @ret = $command->status_message('foo');
is($ret[0],'foo','Returns message as first element in list context');
is($ret[1],'main','Returns package as second element in list context');
ok($ret[2] =~ /V1.t$/,'Returns file name as third element in list context');
ok($ret[3] =~ /\d+/,'Returns line number as fourth element in list context');
done_testing;
Shell.pm 000444 023532 023421 6764 12121654175 15370 0 ustar 00abrummet gsc 000000 000000 UR-0.41/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 ($@) {
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;
V2Deprecated.pm 000444 023532 023421 17213 12121654175 16600 0 ustar 00abrummet gsc 000000 000000 UR-0.41/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;
Test.pm 000444 023532 023421 172 12121654175 15203 0 ustar 00abrummet gsc 000000 000000 UR-0.41/lib/Command use strict;
use warnings;
use UR;
use Command;
package Command::Test;
class Command::Test{
is => 'Command',
};
1;
Test 000755 023532 023421 0 12121654173 14526 5 ustar 00abrummet gsc 000000 000000 UR-0.41/lib/Command Tree1.pm 000444 023532 023421 270 12121654173 16160 0 ustar 00abrummet gsc 000000 000000 UR-0.41/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;
Echo.pm 000444 023532 023421 1320 12121654173 16073 0 ustar 00abrummet gsc 000000 000000 UR-0.41/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 000755 023532 023421 0 12121654175 15510 5 ustar 00abrummet gsc 000000 000000 UR-0.41/lib/Command/Test Echo2.pm 000444 023532 023421 1103 12121654172 17133 0 ustar 00abrummet gsc 000000 000000 UR-0.41/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;
Echo1.pm 000444 023532 023421 1104 12121654175 17136 0 ustar 00abrummet gsc 000000 000000 UR-0.41/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;
Dispatch 000755 023532 023421 0 12121654173 15346 5 ustar 00abrummet gsc 000000 000000 UR-0.41/lib/Command Shell.pm 000444 023532 023421 123517 12121654173 17161 0 ustar 00abrummet gsc 000000 000000 UR-0.41/lib/Command/Dispatch package Command::V2; # additional methods to dispatch from a command-line
use strict;
use warnings;
# 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);
my @changed_objects = (
UR::Context->all_objects_loaded('UR::Object::Ghost'),
grep { $_->__changes__ } UR::Context->all_objects_loaded('UR::Object')
);
# Only commit if we have things to do.
my @committable_changed_objects = grep {UR::Context->resolve_data_source_for_object($_)} @changed_objects;
if (@committable_changed_objects > 0) {
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(0);
my $rv = $command_object->execute($params);
unless ($rv) {
my $command_name = $command_object->command_name;
$command_object->error_message("Please see '$command_name --help' for more information.");
}
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} = 1;
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 = $self->_unique_elements(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) {
# outputs with a data source do not need a specification
# on the cmdline to "store" them after execution
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);
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);
if (%extra) {
$DB::single = 1;
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) {
push @optional_input, $property_meta;
}
elsif ($property_meta->is_param) {
push @optional_param, $property_meta;
}
}
else {
if ($property_meta->is_input) {
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) {
$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 = $self->_unique_elements(@results);
if ($require_user_verify) {
if (!$pmeta->{'is_many'} && @results > 1) {
$MESSAGE .= "\n" if ($MESSAGE);
$MESSAGE .= "'$param_name' expects only one result.";
}
@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} 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 = $self->_unique_elements(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;
}
$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 _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!");
}
alarm($timeout) if ($timeout);
chomp($input = );
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;
}
}
sub _unique_elements {
my ($self, @list) = @_;
my %seen = ();
my @unique = grep { ! $seen{$_} ++ } @list;
return @unique;
}
1;
View 000755 023532 023421 0 12121654173 14521 5 ustar 00abrummet gsc 000000 000000 UR-0.41/lib/Command DocMethods.pm 000444 023532 023421 43726 12121654173 17301 0 ustar 00abrummet gsc 000000 000000 UR-0.41/lib/Command/View package Command::V2; # additional methods to produce documentation, TODO: turn into a real view
use strict;
use warnings;
use Term::ANSIColor;
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_params = $self->help_options(is_optional => 0, is_param => 1);
my $optional_inputs = $self->help_options(is_optional => 1, is_input => 1);
my $optional_params = $self->help_options(is_optional => 1, is_param => 1);
$DB::single = 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,
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\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;
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;
}
$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 = $property_meta->default_value;
if (defined $default_value) {
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];
}
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;
UR 000755 023532 023421 0 12121654175 12561 5 ustar 00abrummet gsc 000000 000000 UR-0.41/lib Util.pm 000444 023532 023421 35762 12121654172 14223 0 ustar 00abrummet gsc 000000 000000 UR-0.41/lib/UR
package UR::Util;
use warnings;
use strict;
require UR;
our $VERSION = "0.41"; # UR $VERSION;
use Cwd;
use Data::Dumper;
use Clone::PP;
sub on_destroy(&) {
my $sub = shift;
unless ($sub) {
Carp::confess("expected an anonymous sub!")
}
return bless($sub, "UR::Util::CallOnDestroy");
}
# used only by the above sub
# the local $@ ensures that we this does not stomp on thrown exceptions
sub UR::Util::CallOnDestroy::DESTROY { local $@; shift->(); }
sub d {
Data::Dumper->new([@_])->Terse(1)->Indent(0)->Useqq(1)->Dump;
}
sub null_sub { }
sub used_libs {
my @extra;
my @compiled_inc = UR::Util::compiled_inc();
my @perl5lib = split(':', $ENV{PERL5LIB});
map { $_ =~ s/\/+$// } (@compiled_inc, @perl5lib); # remove trailing slashes
map { $_ = Cwd::abs_path($_) || $_ } (@compiled_inc, @perl5lib);
for my $inc (@INC) {
$inc =~ s/\/+$//;
my $abs_inc = Cwd::abs_path($inc) || $inc; # should already be expanded by UR.pm
next if (grep { $_ =~ /^$abs_inc$/ } @compiled_inc);
next if (grep { $_ =~ /^$abs_inc$/ } @perl5lib);
push @extra, $inc;
}
unshift @extra, ($ENV{PERL_USED_ABOVE} ? split(":", $ENV{PERL_USED_ABOVE}) : ());
map { $_ =~ s/\/+$// } @extra; # remove trailing slashes again
@extra = _unique_elements(@extra);
return @extra;
}
sub _unique_elements {
my @list = @_;
my %seen = ();
my @unique = grep { ! $seen{$_} ++ } @list;
return @unique;
}
sub used_libs_perl5lib_prefix {
my $prefix = "";
for my $i (used_libs()) {
$prefix .= "$i:";
}
return $prefix;
}
my @compiled_inc;
BEGIN {
use Config;
my @var_list = (
'updatesarch', 'updateslib',
'archlib', 'privlib',
'sitearch', 'sitelib', 'sitelib_stem',
'vendorarch', 'vendorlib', 'vendorlib_stem',
'extrasarch', 'extraslib',
);
for my $var_name (@var_list) {
if ($var_name =~ /_stem$/ && $Config{$var_name}) {
my @stem_list = (split(' ', $Config{'inc_version_list'}), '');
push @compiled_inc, map { $Config{$var_name} . "/$_" } @stem_list
} else {
push @compiled_inc, $Config{$var_name} if $Config{$var_name};
}
}
# UR locks in relative paths when loaded so instead of adding '.' we add cwd
push @compiled_inc, Cwd::cwd() if (${^TAINT} == 0);
map { $_ =~ s/\/+/\//g } @compiled_inc;
map { $_ =~ s/\/+$// } @compiled_inc;
}
sub compiled_inc {
return @compiled_inc;
}
sub deep_copy {
return Clone::PP::clone($_[0]);
}
sub value_positions_map {
my ($array) = @_;
my %value_pos;
for (my $pos = 0; $pos < @$array; $pos++) {
my $value = $array->[$pos];
if (exists $value_pos{$value}) {
die "Array has duplicate values, which cannot unambiguously be given value positions!"
. Data::Dumper::Dumper($array);
}
$value_pos{$value} = $pos;
}
return \%value_pos;
}
sub positions_of_values {
# my @pos = positions_of_values(\@unordered_crap, \@correct_order);
# my @fixed = @unordered_crap[@pos];
my ($unordered_array,$ordered_array) = @_;
my $map = value_positions_map($unordered_array);
my @translated_positions;
$#translated_positions = $#$ordered_array;
for (my $pos = 0; $pos < @$ordered_array; $pos++) {
my $value = $ordered_array->[$pos];
my $unordered_position = $map->{$value};
$translated_positions[$pos] = $unordered_position;
}
# self-test:
# my @now_ordered = @$unordered_array[@translated_positions];
# unless ("@now_ordered" eq "@$ordered_array") {
# Carp::confess()
# }
return @translated_positions;
}
# Get all combinations of values
# input is a list of listrefs of values
sub combinations_of_values {
return [] unless @_;
my $first_values = shift;
$first_values = [ $first_values ] unless (ref($first_values) and ref($first_values) eq 'ARRAY');
my @retval;
foreach my $sub_combination ( &combinations_of_values(@_) ) {
foreach my $value ( @$first_values ) {
push @retval, [$value, @$sub_combination];
}
}
return @retval;
}
# generate a method
sub _define_method {
my $class = shift;
my (%opts) = @_;
# create method name
my $method = $opts{pkg} . '::' . $opts{property};
# determine return value type
my $retval;
if (defined($opts{value}))
{
my $refval = ref($opts{value});
$retval = ($refval) ? $refval : 'SCALAR';
}
else
{
$retval = 'SCALAR';
}
# start defining method
my $substr = "sub $method { my \$self = shift; ";
# set default value
$substr .= "\$self->{$opts{property}} = ";
my $dd = Data::Dumper->new([ $opts{value} ]);
$dd->Terse(1); # do not print ``$VAR1 =''
$substr .= $dd->Dump;
$substr .= " unless defined(\$self->{$opts{property}}); ";
# array or scalar?
if ($retval eq 'ARRAY') {
if ($opts{access} eq 'rw') {
# allow setting of array
$substr .= "\$self->{$opts{property}} = [ \@_ ] if (\@_); ";
}
# add return value
$substr .= "return \@{ \$self->{$opts{property}} }; ";
}
else { # scalar
if ($opts{access} eq 'rw') {
# allow setting of scalar
$substr .= "\$self->{$opts{property}} = \$_[0] if (\@_); ";
}
# add return value
$substr .= "return \$self->{$opts{property}}; ";
}
# end the subroutine definition
$substr .= "}";
# actually define the method
no warnings qw(redefine);
eval($substr);
if ($@) {
# fatal error since this is like a failed compilation
die("failed to defined method $method {$substr}:$@");
}
return 1;
}
=pod
=over
=item path_relative_to
$rel_path = UR::Util::path_relative_to($base, $target);
Returns the pathname to $target relative to $base. If $base
and $target are the same, then it returns '.'. If $target is
a subdirectory of of $base, then it returns the portion of $target
that is unique compared to $base. If $target is not a subdirectory
of $base, then it returns a relative pathname starting with $base.
=back
=cut
sub path_relative_to {
my($base,$target) = @_;
$base = Cwd::abs_path($base);
$target = Cwd::abs_path($target);
my @base_path_parts = split('/', $base);
my @target_path_parts = split('/', $target);
my $i;
for ($i = 0;
$i < @base_path_parts and $base_path_parts[$i] eq $target_path_parts[$i];
$i++
) { ; }
my $rel_path = '../' x (scalar(@base_path_parts) - $i)
.
join('/', @target_path_parts[$i .. $#target_path_parts]);
$rel_path = '.' unless length($rel_path);
return $rel_path;
}
=pod
=over
=item generate_readwrite_methods
UR::Util->generate_readwrite_methods
(
some_scalar_property => 1,
some_array_property => []
);
This method generates accessor/set methods named after the keys of its
hash argument. The type of function generated depends on the default
value provided as the hash key value. If the hash key is a scalar, a
scalar method is generated. If the hash key is a reference to an
array, an array method is generated.
This method does not overwrite class methods that already exist.
=back
=cut
sub generate_readwrite_methods
{
my $class = shift;
my %properties = @_;
# get package of caller
my $pkg = caller;
# loop through properties
foreach my $property (keys(%properties)) {
# do not overwrite defined methods
next if $pkg->can($property);
# create method
$class->_define_method
(
pkg => $pkg,
property => $property,
value => $properties{$property},
access => 'rw'
);
}
return 1;
}
=pod
=over
=item generate_readwrite_methods_override
UR::Util->generate_readwrite_methods_override
(
some_scalar_property => 1,
some_array_property => []
);
Same as generate_readwrite_function except that we force the functions
into the namespace even if the function is already defined
=back
=cut
sub generate_readwrite_methods_override
{
my $class = shift;
my %properties = @_;
# get package of caller
my $pkg = caller;
# generate the methods for each property
foreach my $property (keys(%properties)) {
# create method
$class->_define_method
(
pkg => $pkg,
property => $property,
value => $properties{$property},
access => 'rw'
);
}
return 1;
}
=pod
=over
=item generate_readonly_methods
UR::Util->generate_readonly_methods
(
some_scalar_property => 1,
some_array_property => []
);
This method generates accessor methods named after the keys of its
hash argument. The type of function generated depends on the default
value provided as the hash key value. If the hash key is a scalar, a
scalar method is generated. If the hash key is a reference to an
array, an array method is generated.
This method does not overwrite class methods that already exist.
=back
=cut
sub generate_readonly_methods
{
my $class = shift;
my %properties = @_;
# get package of caller
my ($pkg) = caller;
# loop through properties
foreach my $property (keys(%properties)) {
# do no overwrite already defined methods
next if $pkg->can($property);
# create method
$class->_define_method
(
pkg => $pkg,
property => $property,
value => $properties{$property},
access => 'ro'
);
}
return 1;
}
=pod
=over
=item mapreduce_grep
my @matches = UR::Util->map_reduce_grep { shift->some_test } @candidates;
Works similar to the Perl C builtin, but in a possibly-parallel fashion.
If the environment variable UR_NR_CPU is set to a number greater than one, it
will fork off child processes to perform the test on slices of the input
list, collect the results, and return the matching items as a list.
The test function is called with a single argument, an item from the list to
be tested, and should return a true of false value.
=back
=cut
sub mapreduce_grep($&@) {
my $class = shift;
my $subref = shift;
#$DB::single = 1;
# First check fast... should we do parallel at all?
if (!$ENV{'UR_NR_CPU'} or $ENV{'UR_NR_CPU'} < 2) {
#return grep { $subref->($_) } @_;
my @ret = grep { $subref->($_) } @_;
return @ret;
}
my(@read_handles, @child_pids);
my $cleanup = sub {
foreach my $handle ( @read_handles ) {
$handle->close();
}
kill 'TERM', @child_pids;
foreach my $pid ( @child_pids ) {
waitpid($pid,0);
}
};
my @things_to_check = @_;
my($children, $length,$parent_last);
if ($ENV{'UR_NR_CPU'}) {
$length = POSIX::ceil(scalar(@things_to_check) / $ENV{'UR_NR_CPU'});
$children = $ENV{'UR_NR_CPU'} - 1;
} else {
$children = 0;
$parent_last = $#things_to_check;
}
# FIXME - There needs to be some code in here to disconnect datasources
# Oracle in particular (maybe all DBs?), stops working right unless you
# disconnect before forking
my $start = $length; # First child starts checking after parent's range
$parent_last = $length - 1;
while ($children-- > 0) {
my $pipe = IO::Pipe->new();
unless ($pipe) {
Carp::carp("pipe() failed: $!\nUnable to create pipes to communicate with child processes to verify transact+ion, falling back to serial verification");
$cleanup->();
$parent_last = $#things_to_check;
last;
}
my $pid = fork();
if ($pid) {
$pipe->reader();
push @read_handles, $pipe;
$start += $length;
} elsif (defined $pid) {
$pipe->writer();
my $last = $start + $length;
$last = $#things_to_check if ($last > $#things_to_check);
#my @objects = grep { $subref->($_) } @things_to_check[$start .. $last];
my @matching;
for (my $i = $start; $i <= $last; $i++) {
if ($subref->($things_to_check[$i])) {
push @matching, $i;
}
}
# FIXME - when there's a more general framework for passing objects between
# processes, use that instead
#$pipe->printf("%s\n%s\n",$_->class, $_->id) foreach @objects;
$pipe->print("$_\n") foreach @matching;
exit;
} else {
Carp::carp("fork() failed: $!\nUnable to create child processes to ver+ify transaction, falling back to seri+al verification");
$cleanup->();
$parent_last = $#things_to_check;
}
}
my @matches = grep { $subref->($_) } @things_to_check[0 .. $parent_last];
foreach my $handle ( @read_handles ) {
READ_FROM_CHILD:
while(1) {
my $match_idx = $handle->getline();
last READ_FROM_CHILD unless $match_idx;
chomp $match_idx;
push @matches, $things_to_check[$match_idx];
#my $match_class = $handle->getline();
#last READ_FROM_CHILD unless $match_class;
#chomp($match_class);
#my $match_id = $handle->getline();
#unless (defined $match_id) {
# Carp::carp("Protocol error. Tried to get object ID for class $match_class while verifying transaction"+);
# last READ_FROM_CHILD;
#}
#chomp($match_id);
#push @objects, $match_class->get($match_id);
}
$handle->close();
}
$cleanup->();
return @matches;
}
# Used in several places when printing out hash-like parameters
# to the user, such as in error messages
sub display_string_for_params_list {
my $class = shift;
my %params;
if (ref($_[0]) =~ 'HASH') {
%params = %{$_[0]};
} else {
%params = @_;
}
my @strings;
foreach my $key ( keys %params ) {
my $val = $params{$key};
$val = defined($val) ? "'$val'" : '(undef)';
push @strings, "$key => $val";
}
return join(', ', @strings);
}
# why isn't something like this in List::Util?
# Return a list of 3 listrefs:
# 0: items common to both lists
# 1: items in the first list only
# 2: items in the second list only
sub intersect_lists {
my ($m,$n) = @_;
my %shared;
my %monly;
my %nonly;
@monly{@$m} = @$m;
for my $v (@$n) {
if ($monly{$v}) {
$shared{$v} = delete $monly{$v};
}
else{
$nonly{$v} = $v;
}
}
return (
[ values %shared ],
[ values %monly ],
[ values %nonly ],
);
}
1;
=pod
=head1 NAME
UR::Util - Collection of utility subroutines and methods
=head1 DESCRIPTION
This package contains subroutines and methods used by other parts of the
infrastructure. These subs are not likely to be useful to outside code.
=cut
Test.pm 000444 023532 023421 5211 12121654172 14167 0 ustar 00abrummet gsc 000000 000000 UR-0.41/lib/UR package UR::Test;
use strict;
use warnings;
require UR;
our $VERSION = "0.41"; # UR $VERSION;
use Test::More;
sub check_properties {
my $o_list = shift;
my %params = @_;
my $skip = delete $params{skip};
if (%params) {
die "odd params passed: " . join(" ", %params);
}
ok(
scalar(@$o_list),
"got " . scalar(@$o_list) . " objects "
. " of type " . ref($o_list->[0])
);
my $cn = ref($o_list->[0]);
my $c = UR::Object::Type->get($cn);
ok($c, "got class meta for $cn");
my @pm =
map { $_->[1] }
sort { $a->[0] cmp $b->[0] }
map { [ $_->property_name, $_ ] }
$c->all_property_metas;
ok(scalar(@pm), "got " . scalar(@pm) . " properties");
if ($skip) {
$skip = { map { $_ => 1 } @$skip };
my @pm_remove;
my @pm_keep;
for my $p (@pm) {
if ($skip->{$p->property_name}) {
push @pm_remove, $p;
}
else {
push @pm_keep, $p;
}
}
if (@pm_remove) {
note(
'skipping ' . (@pm_remove) . " properties: "
. join(", ", map { $_->property_name } @pm_remove)
);
@pm = @pm_keep;
}
}
my (@v,$v, $last_property_name);
for my $pm (@pm) {
my $p = $pm->property_name;
next if defined($last_property_name) and $p eq $last_property_name;
$last_property_name = $p;
my $is_mutable = $pm->is_mutable;
my $is_many = $pm->is_many;
my %errors;
#diag($p);
for my $o (@$o_list) {
eval {
if ($is_many) {
@v = $o->$p();
if ($is_mutable) {
#$o->$p([]);
#$o->$p(\@v);
}
}
else {
my $v = $o->$p();
if ($is_mutable) {
#$o->$p(undef);
#$o->$p($v);
}
}
};
if ($@) {
my ($e) = split(/\n/,$@);
my $a = $errors{$e} ||= [];
push @$a, $o;
}
}
my $msg;
if (%errors) {
for my $error (keys %errors) {
my $objects = $errors{$error};
$msg .= 'on ' . scalar(@$objects) . ' of ' . scalar(@$o_list) . "objects: " . $error;
chomp $msg;
$msg .= "\n";
}
}
ok(!$msg, "property check: $p") or diag $msg;
}
}
1;
ModuleBase.pm 000444 023532 023421 54443 12121654172 15323 0 ustar 00abrummet gsc 000000 000000 UR-0.41/lib/UR # A base class supplying error, warning, status, and debug facilities.
package UR::ModuleBase;
use Sub::Name;
use Sub::Install;
BEGIN {
use Class::Autouse;
# the file above now does this, but just in case:
# subsequent uses of this module w/o the special override should just do nothing...
$INC{"Class/Autouse_1_99_02.pm"} = 1;
$INC{"Class/Autouse_1_99_04.pm"} = 1;
no strict;
no warnings;
# ensure that modules which inherit from this never fall into the
# replaced UNIVERSAL::can/isa
*can = $Class::Autouse::ORIGINAL_CAN;
*isa = $Class::Autouse::ORIGINAL_ISA;
}
=pod
=head1 NAME
UR::ModuleBase - Methods common to all UR classes and object instances.
=head1 DESCRIPTION
This is a base class for packages, classes, and objects which need to
manage basic functionality in the UR framework such as inheritance,
AUTOLOAD/AUTOSUB methods, error/status/warning/etc messages.
UR::ModuleBase is in the @ISA list for UR::Object, but UR::ModuleBase is not
a formal UR class.
=head1 METHODS
=cut
# set up package
require 5.006_000;
use warnings;
use strict;
our $VERSION = "0.41"; # UR $VERSION;;
# set up module
use Carp;
use IO::Handle;
use UR::Util;
=pod
=over
=item C
$class = $obj->class;
This returns the class name of a class or an object as a string.
It is exactly equivalent to:
(ref($self) ? ref($self) : $self)
=cut
sub class
{
my $class = shift;
$class = ref($class) if ref($class);
return $class;
}
=pod
=item C
$sub_ref = $obj->super_can('func');
This method determines if any of the super classes of the C<$obj>
object can perform the method C. If any one of them can,
reference to the subroutine that would be called (determined using a
depth-first search of the C<@ISA> array) is returned. If none of the
super classes provide a method named C, C is returned.
=cut
sub super_can
{
my $class = shift;
foreach my $parent_class ( $class->parent_classes )
{
my $code = $parent_class->can(@_);
return $code if $code;
}
return;
}
=pod
=item C
@classes = $obj->inheritance;
This method returns a depth-first list of all the classes (packages)
that the class that C<$obj> was blessed into inherits from. This
order is the same order as is searched when searching for inherited
methods to execute. If the class has no super classes, an empty list
is returned. The C class is not returned unless explicitly
put into the C<@ISA> array by the class or one of its super classes.
=cut
sub inheritance {
my $self = $_[0];
my $class = ref($self) || $self;
return unless $class;
no strict;
my @parent_classes = @{$class . '::ISA'};
my @ordered_inheritance;
foreach my $parent_class (@parent_classes) {
push @ordered_inheritance, $parent_class, ($parent_class eq 'UR' ? () : inheritance($parent_class) );
}
return @ordered_inheritance;
}
=pod
=item C
MyClass->parent_classes;
This returns the immediate parent class, or parent classes in the case
of multiple inheritance. In no case does it follow the inheritance
hierarchy as ->inheritance() does.
=cut
sub parent_classes
{
my $self = $_[0];
my $class = ref($self) || $self;
no strict 'refs';
my @parent_classes = @{$class . '::ISA'};
return (wantarray ? @parent_classes : $parent_classes[0]);
}
=pod
=item C
MyModule->base_dir;
This returns the base directory for a given module, in which the modules's
supplemental data will be stored, such as config files and glade files,
data caches, etc.
It uses %INC.
=cut
sub base_dir
{
my $self = shift;
my $class = ref($self) || $self;
$class =~ s/\:\:/\//g;
my $dir = $INC{$class . '.pm'} || $INC{$class . '.pl'};
die "Failed to find module $class in \%INC: " . Data::Dumper(%INC) unless ($dir);
$dir =~ s/\.p[lm]\s*$//;
return $dir;
}
=pod
=item methods
Undocumented.
=cut
sub methods
{
my $self = shift;
my @methods;
my %methods;
my ($class, $possible_method, $possible_method_full, $r, $r1, $r2);
no strict;
no warnings;
for $class (reverse($self, $self->inheritance()))
{
print "$class\n";
for $possible_method (sort grep { not /^_/ } keys %{$class . "::"})
{
$possible_method_full = $class . "::" . $possible_method;
$r1 = $class->can($possible_method);
next unless $r1; # not implemented
$r2 = $class->super_can($possible_method);
next if $r2 eq $r1; # just inherited
{
push @methods, $possible_method_full;
push @{ $methods{$possible_method} }, $class;
}
}
}
print Dumper(\%methods);
return @methods;
}
=pod
=item C
return MyClass->context_return(@return_values);
Attempts to return either an array or scalar based on the calling context.
Will die if called in scalar context and @return_values has more than 1
element.
=cut
sub context_return {
my $class = shift;
return unless defined wantarray;
return @_ if wantarray;
if (@_ > 1) {
my @caller = caller(1);
Carp::croak("Method $caller[3] on $class called in scalar context, but " . scalar(@_) . " items need to be returned");
}
return $_[0];
}
=pod
=back
=head1 C
This package impliments AUTOLOAD so that derived classes can use
AUTOSUB instead of AUTOLOAD.
When a class or object has a method called which is not found in the
final class or any derived classes, perl checks up the tree for
AUTOLOAD. We impliment AUTOLOAD at the top of the tree, and then
check each class in the tree in order for an AUTOSUB method. Where a
class implements AUTOSUB, it will receive a function name as its first
parameter, and it is expected to return either a subroutine reference,
or undef. If undef is returned then the inheritance tree search will
continue. If a subroutine reference is returned it will be executed
immediately with the @_ passed into AUTOLOAD. Typically, AUTOSUB will
be used to generate a subroutine reference, and will then associate
the subref with the function name to avoid repeated calls to AUTOLOAD
and AUTOSUB.
Why not use AUTOLOAD directly in place of AUTOSUB?
On an object with a complex inheritance tree, AUTOLOAD is only found
once, after which, there is no way to indicate that the given AUTOLOAD
has failed and that the inheritance tree trek should continue for
other AUTOLOADS which might impliment the given method.
Example:
package MyClass;
our @ISA = ('UR');
##- use UR;
sub AUTOSUB
{
my $sub_name = shift;
if ($sub_name eq 'foo')
{
*MyClass::foo = sub { print "Calling MyClass::foo()\n" };
return \&MyClass::foo;
}
elsif ($sub_name eq 'bar')
{
*MyClass::bar = sub { print "Calling MyClass::bar()\n" };
return \&MyClass::bar;
}
else
{
return;
}
}
package MySubClass;
our @ISA = ('MyClass');
sub AUTOSUB
{
my $sub_name = shift;
if ($sub_name eq 'baz')
{
*MyClass::baz = sub { print "Calling MyClass::baz()\n" };
return \&MyClass::baz;
}
else
{
return;
}
}
package main;
my $obj = bless({},'MySubClass');
$obj->foo;
$obj->bar;
$obj->baz;
=cut
our $AUTOLOAD;
sub AUTOLOAD {
my $self = $_[0];
# The debugger can't see $AUTOLOAD. This is just here for debugging.
my $autoload = $AUTOLOAD;
$autoload =~ /(.*)::([^\:]+)$/;
my $package = $1;
my $function = $2;
return if $function eq 'DESTROY';
unless ($package) {
Carp::confess("Failed to determine package name from autoload string $autoload");
}
# switch these to use Class::AutoCAN / CAN?
no strict;
no warnings;
my @classes = grep {$_} ($self, inheritance($self) );
for my $class (@classes) {
if (my $AUTOSUB = $class->can("AUTOSUB"))
# FIXME The above causes hard-to-read error messages if $class isn't really a class or object ref
# The 2 lines below should fix the problem, but instead make other more impoartant things not work
#my $AUTOSUB = eval { $class->can('AUTOSUB') };
#if ($AUTOSUB) {
{
if (my $subref = $AUTOSUB->($function,@_)) {
goto $subref;
}
}
}
if ($autoload and $autoload !~ /::DESTROY$/) {
my $subref = \&Carp::confess;
@_ = ("Can't locate object method \"$function\" via package \"$package\" (perhaps you forgot to load \"$package\"?)");
goto $subref;
}
}
=pod
=head1 MESSAGING
UR::ModuleBase implements several methods for sending and storing error, warning and
status messages to the user.
# common usage
sub foo {
my $self = shift;
...
if ($problem) {
$self->error_message("Something went wrong...");
return;
}
return 1;
}
unless ($obj->foo) {
print LOG $obj->error_message();
}
=head2 Messaging Methods
=over 4
=item message_types
@types = UR::ModuleBase->message_types;
UR::ModuleBase->message_types(@more_types);
With no arguments, this method returns all the types of messages that
this class handles. With arguments, it adds a new type to the
list.
Standard message types are error, status, warning, debug and usage.
Note that the addition of new types is not fully supported/implemented
yet.
=back
=cut
my $create_subs_for_message_type; # filled in lower down
my @message_types = qw(error status warning debug usage);
sub message_types
{
my $self = shift;
if (@_)
{
foreach my $msg_type ( @_ ) {
if (! $self->can("${msg_type}_message")) {
# This is a new one
$create_subs_for_message_type->($self, $msg_type);
push @message_types, $msg_type;
}
}
} else {
return grep { $self->can($_ . '_message') } @message_types;
}
}
# Most defaults are false
my %default_messaging_settings;
$default_messaging_settings{dump_error_messages} = 1;
$default_messaging_settings{dump_warning_messages} = 1;
$default_messaging_settings{dump_status_messages} = 1;
#
# Implement error_mesage/warning_message/status_message in a way
# which handles object-specific callbacks.
#
# Build a set of methods for getting/setting/printing error/warning/status messages
# $class->dump_error_messages() Turn on/off printing the messages to STDERR
# error and warnings default to on, status messages default to off
# $class->queue_error_messages() Turn on/off queueing of messages
# defaults to off
# $class->error_message("blah"): set an error message
# $class->error_message() return the last message
# $class->error_messages() return all the messages that have been queued up
# $class->error_messages_arrayref() return the reference to the underlying
# list messages get queued to. This is the method for truncating the list
# or altering already queued messages
# $class->error_messages_callback() Specify a callback for when error
# messages are set. The callback runs before printing or queueing, so
# you can alter @_ and change the message that gets printed or queued
# And then the same thing for status and warning messages
=pod
For each message type, several methods are created for sending and retrieving messages,
registering a callback to run when messages are sent, controlling whether the messages
are printed on the terminal, and whether the messages are queued up.
For example, for the "error" message type, these methods are created:
=over 4
=item error_message
$obj->error_message("Something went wrong...");
$msg = $obj->error_message();
When called with one argument, it sends an error message to the object. The
error_message_callback will be run, if one is registered, and the message will
be printed to the terminal. When called with no arguments, the last message
sent will be returned. If the message is C then no message is printed
or queued, and the next time error_message is run as an accessor, it will
return undef.
=item dump_error_messages
$obj->dump_error_messages(0);
$flag = $obj->dump_error_messages();
Get or set the flag which controls whether messages sent via C
is printed to the terminal. This flag defaults to true for warning and error
messages, and false for others.
=item queue_error_messages
$obj->queue_error_messages(0);
$flag = $obj->queue_error_messages();
Get or set the flag which control whether messages send via C
are saved into a list. If true, every message sent is saved and can be retrieved
with L or L. This flag defaults to
false for all message types.
=item error_messages_callback
$obj->error_messages_callback($subref);
$subref = $obj->error_messages_callback();
Get or set the callback run whenever an error_message is sent. This callback
is run with two arguments: The object or class error_message() was called on,
and a string containing the message. This callback is run before the message
is printed to the terminal or queued into its list. The callback can modify
the message (by writing to $_[1]) and affect the message that is printed or
queued. If $_[1] is set to C, then no message is printed or queued,
and the last recorded message is set to undef as when calling error_message
with undef as the argument.
=item error_messages
@list = $obj->error_messages();
If the queue_error_messages flag is on, then this method returns the entire list
of queued messages.
=item error_messages_arrayref
$listref = $obj->error_messages_arrayref();
If the queue_error_messages flag is on, then this method returns a reference to
the actual list where messages get queued. This list can be manipulated to add
or remove items.
=item error_message_source
%source_info = $obj->error_message_source
Returns a hash of information about the most recent call to error_message.
The key "error_message" contains the message. The keys error_package,
error_file, error_line and error_subroutine contain info about the location
in the code where error_message() was called.
=item error_package
=item error_file
=item error_line
=item error_subroutine
These methods return the same data as $obj->error_message_source().
=back
=cut
our $stderr = \*STDERR;
our $stdout = \*STDOUT;
my %message_settings;
# This sub creates the settings mutator subs for each message type
# For example, when passed in 'error', it creates the subs error_messages_callback,
# queue_error_messages, dump_error_messages, etc
$create_subs_for_message_type = sub {
my($self, $type) = @_;
my $class = ref($self) ? $self->class : $self;
my $save_setting = sub {
my($self, $name, $val) = @_;
if (ref $self) {
$message_settings{ $self->class . '::' . $name . '_by_id' }->{$self->id} = $val;
} else {
$message_settings{ $self->class . '::' . $name } = $val;
}
};
my $get_setting = sub {
my($self, $name) = @_;
if (ref $self) {
return exists($message_settings{ $self->class . '::' . $name . '_by_id' })
? $message_settings{ $self->class . '::' . $name . '_by_id' }->{$self->id}
: undef;
} else {
return $message_settings{ $self->class . '::' . $name };
}
};
my $make_mutator = sub {
my $name = shift;
return sub {
my $self = shift;
if (@_) {
# setting the value
$save_setting->($self, $name, @_);
} else {
# getting the value
my $val = $get_setting->($self, $name);
if (defined $val) {
return $val;
} elsif (ref $self) {
# called on an object and no value set, try the class
return $self->class->$name();
} else {
# called on a class name
my @super = $self->inheritance();
foreach my $super ( @super ) {
if (my $super_sub = $super->can($name)) {
return $super_sub->($super);
}
}
# None of the parent classes implement it, or there aren't
# any parent classes
return $default_messaging_settings{$name};
}
}
};
};
foreach my $base ( qw( %s_messages_callback queue_%s_messages %s_package
%s_file %s_line %s_subroutine )
) {
my $method = sprintf($base, $type);
my $full_name = $class . '::' . $method;
my $method_subref = Sub::Name::subname $full_name => $make_mutator->($method);
Sub::Install::install_sub({
code => $method_subref,
into => $class,
as => $method,
});
}
my $should_dump_messages = "dump_${type}_messages";
my $dump_mutator = $make_mutator->($should_dump_messages);
my @dump_env_vars = map { $_ . uc($should_dump_messages) } ('UR_', 'UR_COMMAND_');
my $should_dump_messages_subref = Sub::Name::subname $class . '::' . $should_dump_messages => sub {
my $self = shift;
if (@_) {
return $dump_mutator->($self, @_);
}
foreach my $varname ( @dump_env_vars ) {
return $ENV{$varname} if (defined $ENV{$varname});
}
return $dump_mutator->($self);
};
Sub::Install::install_sub({
code => $should_dump_messages_subref,
into => $class,
as => $should_dump_messages,
});
my $messages_arrayref = "${type}_messages_arrayref";
my $message_arrayref_sub = Sub::Name::subname "${class}::${messages_arrayref}" => sub {
my $self = shift;
my $a = $get_setting->($self, $messages_arrayref);
if (! defined $a) {
$save_setting->($self, $messages_arrayref, $a = []);
}
return $a;
};
Sub::Install::install_sub({
code => $message_arrayref_sub,
into => $class,
as => $messages_arrayref,
});
my $array_subname = "${type}_messages";
my $array_subref = Sub::Name::subname "${class}::${array_subname}" => sub {
my $self = shift;
my $a = $get_setting->($self, $messages_arrayref);
return $a ? @$a : ();
};
Sub::Install::install_sub({
code => $array_subref,
into => $class,
as => $array_subname,
});
my $messageinfo_subname = "${type}_message_source";
my @messageinfo_keys = map { $type . $_ } qw( _message _package _file _line _subroutine );
my $messageinfo_subref = Sub::Name::subname "${class}::${messageinfo_subname}" => sub {
my $self = shift;
return map { $_ => $self->$_ } @messageinfo_keys;
};
Sub::Install::install_sub({
code => $messageinfo_subref,
into => $class,
as => $messageinfo_subname,
});
# usage messages go to STDOUT, others to STDERR
my $default_fh = $type eq 'usage' ? \$stdout : \$stderr;
my $should_queue_messages = "queue_${type}_messages";
my $check_callback = "${type}_messages_callback";
my $message_text_prefix = ($type eq 'status' or $type eq 'usage') ? '' : uc($type) . ': ';
my $message_package = "${type}_package";
my $message_file = "${type}_file";
my $message_line = "${type}_line";
my $message_subroutine = "${type}_subroutine";
my $logger_subname = "${type}_message";
my $logger_subref = Sub::Name::subname "${class}::${logger_subname}" => sub {
my $self = shift;
foreach ( @_ ) {
my $msg = $_;
chomp($msg) if defined;
# old-style callback registered with error_messages_callback
if (my $code = $self->$check_callback()) {
if (ref $code) {
$code->($self, $msg);
} else {
$self->$code($msg);
}
}
# New-style callback registered as an observer
# Some non-UR classes inherit from UR::ModuleBase, and can't __signal
if ($UR::initialized && $self->can('__signal_observers__')) {
$self->__signal_observers__($logger_subname, $msg);
}
$save_setting->($self, $logger_subname, $msg);
# If the callback set $msg to undef with "$_[1] = undef", then they didn't want the message
# processed further
next unless defined($msg);
if (my $fh = $self->$should_dump_messages()) {
$fh = $$default_fh unless (ref $fh);
$fh->print($message_text_prefix . $msg . "\n");
}
if ($self->$should_queue_messages()) {
my $a = $self->$messages_arrayref();
push @$a, $msg;
}
my ($package, $file, $line, $subroutine) = caller;
$self->$message_package($package);
$self->$message_file($file);
$self->$message_line($line);
$self->$message_subroutine($subroutine);
}
return $get_setting->($self, $logger_subname);
};
Sub::Install::install_sub({
code => $logger_subref,
into => $class,
as => $logger_subname,
});
};
# at init time, make messaging subs for the initial message types
$create_subs_for_message_type->(__PACKAGE__, $_) foreach @message_types;
sub _current_call_stack
{
my @stack = reverse split /\n/, Carp::longmess("\t");
# Get rid of the final line from carp, showing the line number
# above from which we called it.
pop @stack;
# Get rid any other function calls which are inside of this
# package besides the first one. This allows wrappers to
# get_message to look at just the external call stack.
# (i.e. AUTOSUB above, set_message/get_message which called this,
# and AUTOLOAD in UniversalParent)
pop(@stack) while ($stack[-1] =~ /^\s*(UR::ModuleBase|UR)::/ && $stack[-2] && $stack[-2] =~ /^\s*(UR::ModuleBase|UR)::/);
return \@stack;
}
1;
__END__
=pod
=head1 SEE ALSO
UR(3)
=cut
# $Header$
ObjectV04removed.pm 000444 023532 023421 3115 12121654172 16333 0 ustar 00abrummet gsc 000000 000000 UR-0.41/lib/UR =pod
=head1 NAME
UR::ObjectV04removed - restores changes removed in UR version 0.04
=head1 SYNOPSIS
use UR::ObjectV04removed
=head1 DESCRIPTION
Extends the UR::Object API have methods removed in the 0.04 release.
If you upgrade UR, but depend on old APIs, use this module.
For version 0.xx of UR, APIs may change with each release. After 1.0, APIs will
only change with major releases number increments.
=cut
# version 0.4 commits significant refactoring of the UR::BoolExpr API
# this brings back those parts which got new names
package UR::BoolExpr;
use strict;
use warnings;
our $VERSION = "0.41"; # UR $VERSION;
*get_rule_template = \&template;
*rule_template = \&template;
*get_rule_template_and_values = \&template_and_values;
*get_template_and_values = \&template_and_values;
*get_values = \&values;
*get_underlying_rules = \&underlying_rules;
*specifies_value_for_property_name = \&specifies_value_for;
*specified_operator_for = \&operator_for;
*specified_operator_for_propety_name = \&operator_for;
*specified_value_for_id = \&value_for_id;
*specified_value_for_position = \&value_for_position;
*specified_value_for_property_name = \&value_for;
*create_from_filter_string = \&resolve_for_string;
*create_from_command_line_format_filters = \&_resolve_from_filter_array;
*create_from_filters = \&_resolve_from_filter_array;
*create_from_subject_class_name_keys_and_values = \&_resolve_from_subject_class_name_keys_and_values;
*resolve_normalized_rule_for_class_and_params = \&resolve_normalized;
*resolve_for_class_and_params = \&resolve;
*get_normalized_rule_equivalent = \&normalize;
Singleton.pm 000444 023532 023421 14562 12121654172 15243 0 ustar 00abrummet gsc 000000 000000 UR-0.41/lib/UR
package UR::Singleton;
use strict;
use warnings;
require UR;
our $VERSION = "0.41"; # UR $VERSION;
UR::Object::Type->define(
class_name => 'UR::Singleton',
is => ['UR::Object'],
is_abstract => 1,
);
sub _init_subclass {
my $class_name = shift;
my $class_meta_object = $class_name->__meta__;
# Write into the class's namespace the correct singleton overrides
# to standard UR::Object methods.
my $src;
if ($class_meta_object->is_abstract) {
$src = qq|sub ${class_name}::_singleton_object { Carp::confess("${class_name} is an abstract singleton! Select a concrete sub-class.") }|
. "\n"
. qq|sub ${class_name}::_singleton_class_name { Carp::confess("${class_name} is an abstract singleton! Select a concrete sub-class.") }|
. "\n"
. qq|sub ${class_name}::_load { shift->_abstract_load(\@_) }|
}
else {
$src = qq|sub ${class_name}::_singleton_object { \$${class_name}::singleton or shift->_concrete_load() }|
. "\n"
. qq|sub ${class_name}::_singleton_class_name { '${class_name}' }|
. "\n"
. qq|sub ${class_name}::_load { shift->_concrete_load(\@_) }|
. "\n"
. qq|sub ${class_name}::get { shift->_concrete_get(\@_) }|
. "\n"
. qq|sub ${class_name}::is_loaded { shift->_concrete_is_loaded(\@_) }|
;
}
eval $src;
Carp::confess($@) if $@;
return 1;
}
# Abstract singletons havd a different load() method than concrete ones.
# We could do this with forking logic, but since many of the concrete methods
# get non-default handling, it's more efficient to do it this way.
sub _abstract_load {
my $class = shift;
my $bx = $class->define_boolexpr(@_);
my $id = $bx->value_for_id;
unless (defined $id) {
use Data::Dumper;
my $params = { $bx->params_list };
Carp::confess("Cannot load a singleton ($class) except by specific identity. " . Dumper($params));
}
my $subclass_name = $class->_resolve_subclass_name_for_id($id);
eval "use $subclass_name";
if ($@) {
undef $@;
return;
}
return $subclass_name->get();
}
# Concrete singletons have overrides to the most basic acccessors to
# accomplish class/object duality smoothly.
sub _concrete_get {
if (@_ == 1 or (@_ == 2 and $_[0] eq $_[1])) {
my $self = $_[0]->_singleton_object;
return $self if $self;
}
return shift->_concrete_load(@_);
}
sub _concrete_is_loaded {
if (@_ == 1 or (@_ == 2 and $_[0] eq $_[1])) {
my $self = $_[0]->_singleton_object;
return $self if $self;
}
return shift->SUPER::is_loaded(@_);
}
sub _concrete_load {
my $class = shift;
$class = ref($class) || $class;
no strict 'refs';
my $varref = \${ $class . "::singleton" };
unless ($$varref) {
my $id = $class->_resolve_id_for_subclass_name($class);
my $class_object = $class->__meta__;
my @prop_names = $class_object->all_property_names;
my %default_values;
foreach my $prop_name ( @prop_names ) {
my $prop = $class_object->property_meta_for_name($prop_name);
next unless $prop;
my $val = $prop->{'default_value'};
next unless defined $val;
$default_values{$prop_name} = $val;
}
$$varref = $UR::Context::current->_construct_object($class,%default_values, id => $id);
$$varref->{db_committed} = { %$$varref };
$$varref->__signal_change__("load");
Scalar::Util::weaken($$varref);
}
my $self = $class->_concrete_is_loaded(@_);
return unless $self;
unless ($self->init) {
Carp::confess("Failed to initialize singleton $class!");
}
return $self;
}
# This is implemented in the singleton to do any post-load processing.
sub init {
return 1;
}
# All singletons require special deletion logic since they keep a
#weakened reference to the singleton.
sub delete {
my $self = shift;
my $class = $self->class;
$self->SUPER::delete();
no strict 'refs';
${ $class . "::singleton" } = undef if ${ $class . "::singleton" } eq $self;
return $self;
}
# In most cases, the id is the class name itself, but this is not necessary.
sub _resolve_subclass_name_for_id {
my $class = shift;
my $id = shift;
return $id;
}
sub _resolve_id_for_subclass_name {
my $class = shift;
my $subclass_name = shift;
return $subclass_name;
}
sub create {
my $class = shift;
my $bx = $class->define_boolexpr(@_);
my $id = $bx->value_for_id;
unless (defined $id) {
use Data::Dumper;
my $params = { $bx->params_list };
Carp::confess("No singleton ID class specified for constructor?");
}
my $subclass = $class->_resolve_subclass_name_for_id($id);
eval "use $subclass";
unless ($subclass->isa(__PACKAGE__)) {
eval '@' . $subclass . "::ISA = ('" . __PACKAGE__ . "')";
}
return $subclass->SUPER::create(@_);
}
1;
=pod
=head1 NAME
UR::Singleton - Abstract class for implementing singleton objects
=head1 SYNOPSIS
package MyApp::SomeClass;
use UR;
class MyApp::SomeClass {
is => 'UR::Singleton',
has => [
foo => { is => 'Number' },
]
};
$obj = MyApp::SomeClass->get();
$obj->foo(1);
=head1 DESCRIPTION
This class provides the infrastructure for singleton classes. Singletons
are classes of which there can only be one instance, and that instance's ID
is the class name.
If a class inherits from UR::Singleton, it overrides the default
implementation of C and C in UR::Object with code that
fabricates an appropriate object the first time it's needed.
Singletons are most often used as one of the parent classes for data sources
within a Namespace. This makes it convienent to refer to them using only
their name, as in a class definition.
=head1 METHODS
=over 4
=item _singleton_object
$obj = Class::Name->_singleton_object;
$obj = $obj->_singleton_object;
Returns the object instance whether it is called as a class or object method.
=item _singleton_class_name
$class_name = Class::Name->_singleton_class_name;
$class_name = $obj->_singleton_class_name;
Returns the class name whether it is called as a class or object method.
=back
=head1 SEE ALSO
UR::Object
=cut
Env.pod 000444 023532 023421 12111 12121654172 14163 0 ustar 00abrummet gsc 000000 000000 UR-0.41/lib/UR =pod
=head1 NAME
UR::Env - Environment variables that control UR behavior
=head1 DESCRIPTION
UR uses several environment variables to change its behavior or provide
additional debugging information.
=over 4
=item UR_STACK_DUMP_ON_DIE
When true, has the effect of turning any die() into a Carp::confess, meaning
a stack dump will be printed after the die message.
=item UR_STACK_DUMP_ON_WARN
When true, has the effect of turning any warn() into a Carp::cluck, meaning
a stack dump will be printed after the warn message.
=item UR_CONTEXT_ROOT
The name of the Root context to instantiate when the program initializes.
The default is UR::Context::DefaultRoot. Other Root Contexts can be used,
for example, to connect to alternate databases when running in test mode.
=item UR_CONTEXT_BASE
This value only changes in a sub-process which goes to its parent
process for object I/O instead of the root (which is the default
value for the base context in an application).
=item UR_CONTEXT_CACHE_SIZE_HIGHWATER
Set the object count highwater mark for the object cache pruner. See also
L
=item UR_CONTEXT_CACHE_SIZE_LOWWATER
Set the object count lowwater mark for the object cache pruner. See also
L
=item UR_DEBUG_OBJECT_RELEASE
When true, messages will be printed to STDERR whenever objects are removed
from the object cache, such as when the object pruner marks them for removal,
when they are garbage collected, unloaded, or deleted.
=item UR_DEBUG_OBJECT_RELEASE
When true, messages will be printed to STDERR whenever the object pruner finishes
its work, and show how many objects of each class were marked for removal.
=item UR_CONTEXT_MONITOR_QUERY
When true (non-zero), messages will be printed as the Context satisfies queries,
such as when get() is called on a class, or while processing an iterator created
through SomeClass->create_iterator and iterator->next(). If the value is 1,
then only queries about Non-UR classes are printed. If 2, then all queries'
information is printed.
=item UR_DBI_MONITOR_SQL
If this is true, most interactions with data sources such as connecting,
disconnecting and querying will print messages to STDERR. Same as
Cmonitor_sql()>. Note that this affects non-DBI
data sources as well, such as file-based data sources, which will
render file I/O information instead of SQL.
=item UR_DBI_SUMMARIZE_SQL
If true, a report will be printed to STDERR as the program finishes about what
SQL queries have been done during the program's execution, and how many times
they were executed. This is helpful during optimization.
=item UR_DBI_MONITOR_EVERY_FETCH
Used in conjunction with UR_DBI_MONITOR_SQL, tells the data sources to also
print messages to STDERR for each row fetched from the underlying data
source. Same as Cmonitor_every_fetch()>.
=item UR_DBI_DUMP_STACK_ON_CONNECT
Print a message to STDERR only when connecting to an underlying data source.
Same as Cdump_stack_on_connect()>
=item UR_DBI_EXPLAIN_SQL_MATCH
If the query to a data source matches the given string (interpreted as a
regex), then it will attempt to do an "explain plan" and print the results
before executing the query. Same as Cexplain_sql_match()>
=item UR_DBI_EXPLAIN_SQL_SLOW
If the time between a prepare and the first fetch of a query is longer than
the given number of seconds, then it will do an "explain plan" and print the
results. Same as Cexplain_sql_slow()>
=item UR_DBI_EXPLAIN_SQL_CALLSTACK
Used in conjunction with UR_DBI_EXPLAIN_SQL_MATCH and UR_DBI_EXPLAIN_SQL_SLOW,
prints a stack trace with Carp::longmess. Same as Cexplain_sql_callstack()>
=item UR_DBI_MONITOR_DML
Like UR_DBI_MONITOR_SQL, but only prints information during data-altering
statements, like INSERT, UPDATE or DELETE. Same as Cmonitor_dml()>
=item UR_DBI_NO_COMMIT
If true, data source commits will be ignored. Note that saving still occurs.
If you are working with a RDBMS database, this means During
UR::Context->commit(), the insert, update and delete SQL statements will be
issued, but the changes will not be committed. Useful for testing. Same
as Cno_commit()>
=item UR_USE_DUMMY_AUTOGENERATED_IDS
If true, objects created without ID params will use a special algorithm to
generate IDs. Objects with these special IDs will never be saved to a
data source. Useful during testing. Same as Cuse_dummy_autogenerated_ids>
=item UR_USED_LIBS
If true, prints a message to STDERR with the contents of @INC just before
the program exits.
=item UR_USED_MODS
If true, prints a message to STDERR with the keys of %INC just before the
program exits. This will be a list of what modules had been loaded during
the life of the program. If UR_USED_MODS is greater than 1, then it will
show the key/value pairs of %INC, which will show the path each module was
loaded from.
=back
=cut
ObjectV001removed.pm 000444 023532 023421 6715 12121654173 16422 0 ustar 00abrummet gsc 000000 000000 UR-0.41/lib/UR package UR::Object;
=pod
=head1 NAME
UR::ObjectV001removed - restores changes removed in UR version 0.01
=head1 SYNOPSIS
use UR::ObjectV001removed
=head1 DESCRIPTION
Extends the UR::Object API have methods removed in the 0.01 release.
If you upgrade UR, but depend on old APIs, use this module.
For version 0.xx of UR, APIs may change with each release. After 1.0, APIs will
only change with major releases number increments.
=cut
use warnings;
use strict;
our $VERSION = "0.41"; # UR $VERSION;
use Data::Dumper;
use Scalar::Util qw(blessed);
*get_class_meta = sub { shift->__meta__ };
*get_class_object = sub { shift->__meta__ };
*get_rule_for_params = \&define_boolexpr;
*get_boolexpr_for_params = \&define_boolexpr;
*get_object_set = \&define_set;
our ($all_objects_loaded, $all_change_subscriptions, $all_objects_are_loaded, $all_params_loaded);
*all_objects_loaded = \$UR::Context::all_objects_loaded;
*all_change_subscriptions = \$UR::Context::all_change_subscriptions;
*all_objects_are_loaded = \$UR::Context::all_objects_are_loaded;
*all_params_loaded = \$UR::Context::all_params_loaded;
# These live in UR::Context, where they may switch to point to
# different data structures depending on sub-context, transaction, etc.
# They are aliased here for backward compatability, since many parts
# of the system use $UR::Object::whatever to work with them directly.
sub load {
# 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") {
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);
}
sub _load {
Carp::cluck();
my ($class,$rule) = @_;
return $UR::Context::current->get_objects_for_class_and_rule($class,$rule,1);
}
sub dbh {
Carp::confess("Attempt to call dbh() on a UR::Object.\n"
. "Objects no longer have DB handles, data_sources do\n"
. "use resolve_data_sources_for_class_meta_and_rule() on a UR::Context instead");
my $ds = $UR::Context::current->resolve_data_sources_for_class_meta_and_rule(shift->__meta__);
return $ds->get_default_dbh;
}
sub matches {
no warnings;
my $self = shift;
my %param = $self->preprocess_params(@_);
for my $key (keys %param) {
next unless $self->can($key);
return 0 unless $self->$key eq $param{$key}
}
return 1;
}
sub property_names {
my $class = shift;
my $meta = $class->__meta__;
return $meta->all_property_names;
}
sub _is_loaded {
Carp::cluck();
my ($class,$rule) = @_;
return $UR::Context::current->get_objects_for_class_and_rule($class,$rule,0);
}
# as we remove more logic from the default API, add extensions here.
use UR::ObjectV04removed;
DBI.pm 000444 023532 023421 70427 12121654173 13702 0 ustar 00abrummet gsc 000000 000000 UR-0.41/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.41"; # 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;
# Always rollback. Oracle commits by default on disconnect.
$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$
Exit.pm 000444 023532 023421 7652 12121654173 14175 0 ustar 00abrummet gsc 000000 000000 UR-0.41/lib/UR package UR::Exit;
=pod
=head1 NAME
UR::Exit - methods to allow clean application exits.
=head1 SYNOPSIS
UR::Exit->exit_handler(\&mysub);
UR::Exit->clean_exit($value);
=head1 DESCRIPTION
This module provides the ability to perform certain operations before
an application exits.
=cut
# set up module
require 5.006_000;
use warnings;
use strict;
require UR;
our $VERSION = "0.41"; # UR $VERSION;;
our (@ISA, @EXPORT, @EXPORT_OK);
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw();
@EXPORT_OK = qw();
use Carp;
=pod
=head1 METHODS
These methods provide exit functionality.
=over 4
=item exit_handler
UR::Exit->exit_handler(\&mysub);
Specifies that a given subroutine be run when the application exits.
(Unimplimented!)
=cut
sub exit_handler
{
die "Unimplimented";
}
=pod
=item clean_exit
UR::Exit->clean_exit($value);
Exit the application, running all registered subroutines.
(Unimplimented! Just exits the application directly.)
=cut
sub clean_exit
{
my $class = shift;
my ($value) = @_;
$value = 0 unless defined($value);
exit($value);
}
=pod
=item death
Catch any die or warn calls. This is a universal place to catch die
and warn if debugging.
=cut
sub death
{
unless ($ENV{'UR_STACK_DUMP_ON_DIE'}) {
return;
}
# workaround common error
if ($_[0] =~ /Can.*t upgrade that kind of scalar during global destruction/)
{
exit 1;
}
if (defined $^S) {
# $^S is defined when perl is executing (as opposed to interpreting)
if ($^S) {
# $^S is true when its executing in an eval, false outside of one
return;
}
} else {
# interpreter is parsing a module or string eval
# check the call stack depth for up-stream evals
# fall back to perls default handler if there is one
my $call_stack_depth = 0;
for (1) {
my @details = caller($call_stack_depth);
#print Data::Dumper::Dumper(\@details);
last if scalar(@details) == 0;
if ($details[1] =~ /\(eval .*\)/) {
#print "";
return;
}
elsif ($details[3] eq "(eval)") {
#print "";
return;
}
$call_stack_depth++;
redo;
}
}
if
(
$_[0] =~ /\n$/
and UNIVERSAL::can("UR::Context::Process","is_initialized")
and defined(UR::Context::Process->is_initialized)
and (UR::Context::Process->is_initialized == 1)
)
{
# Do normal death if there is a newline at the end, and all other
# things are sane.
return;
}
else
{
# Dump the call stack in other cases.
# This is a developer error occurring while things are
# initializing.
local $Carp::CarpLevel = 1;
Carp::confess(@_);
return;
}
}
=pod
=item warning
Give more informative warnings.
=cut
sub warning
{
unless ($ENV{'UR_STACK_DUMP_ON_WARN'}) {
warn @_;
return;
}
return if $_[0] =~ /Attempt to free unreferenced scalar/;
return if $_[0] =~ /Use of uninitialized value in exit at/;
return if $_[0] =~ /Use of uninitialized value in subroutine entry at/;
return if $_[0] =~ /One or more DATA sections were not processed by Inline/;
UR::ModuleBase->warning_message(@_);
if ($_[0] =~ /Deep recursion on subroutine/)
{
print STDERR "Forced exit by UR::Exit on deep recursion.\n";
print STDERR Carp::longmess("Stack tail:");
exit 1;
}
return;
}
#$SIG{__DIE__} = \&death unless ($SIG{__DIE__});
#$SIG{__WARN__} = \&warning unless ($SIG{__WARN__});
sub enable_hooks_for_warn_and_die {
$SIG{__DIE__} = \&death;
$SIG{__WARN__} = \&warning;
}
&enable_hooks_for_warn_and_die();
1;
__END__
=pod
=back
=head1 SEE ALSO
UR(3), Carp(3)
=cut
#$Header$
Vocabulary.pm 000444 023532 023421 3756 12121654173 15374 0 ustar 00abrummet gsc 000000 000000 UR-0.41/lib/UR
package UR::Vocabulary;
use strict;
use warnings;
use Lingua::EN::Inflect ("PL_V","PL");
require UR;
our $VERSION = "0.41"; # UR $VERSION;
UR::Object::Type->define(
class_name => 'UR::Vocabulary',
is => ['UR::Singleton'],
doc => 'A word in the vocabulary of a given namespace.',
);
sub get_words_with_special_case {
shift->_singleton_class_name->_words_with_special_case;
}
sub _words_with_special_case {
return ('UR');
}
sub convert_to_title_case {
my $conversion_hashref = shift->_words_with_special_case_hashref;
my @results;
for my $word_in(@_) {
my $word = lc($word_in);
if (my $uc = $conversion_hashref->{$word}) {
push @results, $uc;
}
else {
push @results, ucfirst($word);
}
}
return $results[0] if @results == 1 and !wantarray;
return @results;
}
sub convert_to_special_case {
my $conversion_hashref = shift->_words_with_special_case_hashref;
my @results;
for my $word_in(@_) {
my $word = lc($word_in);
if (my $sc = $conversion_hashref->{$word}) {
push @results, $sc;
}
else {
push @results, $word_in;
}
}
return $results[0] if @results == 1 and !wantarray;
return @results;
}
sub _words_with_special_case_hashref {
my $self = shift->_singleton_object;
my $hashref = $self->{_words_with_special_case_hashref};
return $hashref if $hashref;
$hashref = { map { lc($_) => $_ } $self->get_words_with_special_case };
$self->{_words_with_special_case_hashref} = $hashref;
return $hashref;
}
sub singular_to_plural {
my $self = shift;
return map { PL($_) } @_;
}
our %exceptions =
(
statuses => 'status',
is => 'is',
has => 'has',
cds => 'cds',
);
sub plural_to_singular {
my $self = shift;
my ($lc,$override);
return map {
$lc = lc($_);
$override = $exceptions{$lc};
( $override ? $override : PL_V($_) )
} @_;
}
1;
ObjectDeprecated.pm 000444 023532 023421 33357 12121654173 16474 0 ustar 00abrummet gsc 000000 000000 UR-0.41/lib/UR package UR::Object;
# deprecated parts of the UR::Object API
use warnings;
use strict;
require UR;
our $VERSION = "0.41"; # UR $VERSION;
use Data::Dumper;
use Scalar::Util qw(blessed);
sub get_with_special_parameters {
# When overridden, this allows a class to take non-properties as parameters
# to get(), and handle loading in a special way. Ideally this is handled by
# a custom data source, or properties with smart definitions.
my $class = shift;
my $rule = shift;
Carp::confess(
"Unknown parameters to $class get(). "
. "Implement get_with_special_parameters() to handle non-standard"
. " (non-property) query options.\n"
. "The special params were "
. Dumper(\@_)
. "Rule ID: " . $rule->id . "\n"
);
}
sub get_or_create {
my $self = shift;
return $self->get( @_ ) || $self->create( @_ );
}
sub set {
my $self = shift;
my @rvals;
while (@_) {
my $property_name = shift;
my $value = shift;
push(@rvals, $self->$property_name($value));
}
if(wantarray) {
return @rvals;
}
else {
return \@rvals;
}
}
sub property_diff {
# Ret hashref of the differences between the object and some other object.
# The "other object" may be a hashref or hash, in which case it will
# treat each key as a property.
my ($self, $other) = @_;
my $diff = {};
# If we got a hash instead of a hashref...
if (@_ > 2)
{
shift;
$other = { @_ }
}
no warnings;
my $self_value;
my $other_value;
my $class_object = $self->__meta__;
for my $property ($class_object->all_property_names)
{
if (ref($other) eq 'HASH')
{
next unless exists $other->{$property};
$other_value = $other->{$property};
}
else
{
$other_value = $other->$property;
}
$self_value = $self->$property;
$diff->{$property} = $self_value if ($other_value ne $self_value);
}
return $diff;
}
# TODO: make this a context operation
sub unload {
my $proto = shift;
my ($self, $class);
ref $proto ? $self = $proto : $class = $proto;
my $cx = $UR::Context::current;
if ( $self ) {
# object method
# The only things which can be unloaded are things committed to
# their database in the exact same state. Everything else must
# be reverted or deleted.
return unless $self->{db_committed};
if ($self->__changes__) {
#warn "NOT UNLOADING CHANGED OBJECT! $self $self->{id}\n";
return;
}
$self->__signal_change__('unload');
if ($ENV{'UR_DEBUG_OBJECT_RELEASE'}) {
print STDERR "MEM UNLOAD object $self class ",$self->class," id ",$self->id,"\n";
}
$cx->_abandon_object($self);
return $self;
}
else {
# class method
# unload the objects in the class
# where there are subclasses of the class
# delegate to them
my @unloaded;
# unload all objects of this class
my @involved_classes = ( $class );
for my $obj ($cx->all_objects_loaded_unsubclassed($class))
{
push @unloaded, $obj->unload;
}
# unload any objects that belong to any subclasses
for my $subclass ($cx->__meta__->subclasses_loaded($class))
{
push @involved_classes, $subclass;
push @unloaded, $subclass->unload;
}
# get rid of the loading info matching this class
foreach my $template_id ( keys %$UR::Context::all_params_loaded ) {
if (UR::BoolExpr::Template->get($template_id)->subject_class_name->isa($class)) {
delete $UR::Context::all_params_loaded->{$template_id};
}
}
# Turn off the all_objects_are_loaded flags
delete @$UR::Context::all_objects_are_loaded{@involved_classes};
return @unloaded;
}
}
# TODO: replace internal calls to go right to the context method
sub is_loaded {
# this is just here for backward compatability for external calls
# get() now goes to the context for data
# This shortcut handles the most common case rapidly.
# A single ID is passed-in, and the class name used is
# not a super class of the specified object.
# This logic is in both get() and is_loaded().
my $quit_early = 0;
if ( @_ == 2 && !ref($_[1]) ) {
unless (defined($_[1])) {
Carp::confess();
}
my $obj = $UR::Context::all_objects_loaded->{$_[0]}->{$_[1]};
return $obj if $obj;
# we could safely return nothing right now, except
# that a subclass of this type may have the object
return unless $_[0]->__meta__->subclasses_loaded; # nope, there were no subclasses
}
my $class = shift;
my $rule = UR::BoolExpr->resolve_normalized($class,@_);
return $UR::Context::current->get_objects_for_class_and_rule($class,$rule,0);
}
sub subclasses_loaded {
return shift->__meta__->subclasses_loaded();
}
# THESE SHOULD PROBABLY GO ON THE CLASS META
sub all_objects_are_loaded {
# Keep track of which classes claim that they are completely loaded, and that no more loading should be done.
# Classes which have the above function return true should set this after actually loading everything.
# This class will do just that if it has to load everything itself.
my $class = shift;
#$meta = $class->__meta__;
if (@_) {
# Setting the attribute
$UR::Context::all_objects_are_loaded->{$class} = shift;
} elsif (! exists $UR::Context::all_objects_are_loaded->{$class}) {
# unknown... ask the parent classes and remember the answer
foreach my $parent_class ( $class->inheritance ) {
if (exists $UR::Context::all_objects_are_loaded->{$parent_class}) {
$UR::Context::all_objects_are_loaded->{$class} = $UR::Context::all_objects_are_loaded->{$parent_class};
last;
}
}
}
return $UR::Context::all_objects_are_loaded->{$class};
}
# Observer pattern (old)
sub create_subscription {
my $self = shift;
my %params = @_;
# parse parameters
my ($class,$id,$method,$callback,$note,$priority);
my %observer_params;
@observer_params{'aspect','callback','note','priority','subject_id'} = delete @params{'method','callback','note','priority','id'};
$observer_params{'subject_class_name'} = $self->class;
$observer_params{'priority'} = 1 unless defined $observer_params{'priority'};
if (!defined $observer_params{'subject_id'} and ref($self)) {
$observer_params{'subject_id'} = $self->id;
}
if (my @unknown = keys %params) {
Carp::croak "Unknown options @unknown passed to create_subscription!";
}
# validate
if (my @bad_params = %params) {
Carp::croak "Bad params passed to add_listener: @bad_params";
}
my $observer = UR::Observer->create(%observer_params);
return unless $observer;
return [@observer_params{'subject_class_name','subject_id','aspect','callback','note'}];
}
sub validate_subscription
{
return 1;
my ($self,$subscription_property) = @_;
Carp::confess("The _create_object and _delete_object signals are no longer emitted!")
if defined($subscription_property)
and ($subscription_property eq '_create_object' or $subscription_property eq '_delete_object');
# Undefined attributes indicate that the subscriber wants any changes at all to generate a callback.
return 1 if (!defined($subscription_property));
# All standard creation and destruction methods emit a signal.
return 1 if ($subscription_property =~ /^(create|delete|commit|rollback|load|unload|load_external)$/);
# A defined attribute in our property list indicates the caller wants callbacks from our properties.
my $class_object = $self->__meta__;
for my $property ($class_object->all_property_names)
{
return 1 if $property eq $subscription_property;
}
return 1 if ($class_object->_is_valid_signal($subscription_property));
# Bad subscription request.
return;
}
sub inform_subscription_cancellation
{
# This can be overridden in derived classes if the class wants to know
# when subscriptions are cancelled.
return 1;
}
sub cancel_change_subscription ($@)
{
my ($class,$id,$property,$callback,$note);
if (@_ >= 4)
{
($class,$id,$property,$callback,$note) = @_;
die "Bad parameters." if ref($class);
}
elsif ( (@_==3) or (@_==2) )
{
($class, $property, $callback) = @_;
if (ref($_[0]))
{
$class = ref($_[0]);
$id = $_[0]->id;
}
}
else
{
die "Bad parameters.";
}
my %params;
if (defined $class) {
$params{'subject_class_name'} = $class;
}
if (defined $id) {
$params{'subject_id'} = $id;
}
if (defined $property) {
$params{'aspect'} = $property;
}
if (defined $callback) {
$params{'callback'} = $callback;
}
if (defined $note) {
$params{'note'} = $note;
}
my @observers = UR::Observer->get(%params);
return unless @observers;
if (@observers > 1) {
Carp::croak('Matched more than one observer within cancel_change_subscription(). Params were: '
. join(', ', map { "$_ => " . $params{$_} } keys %params));
}
$observers[0]->delete();
}
# This should go away when we shift to fully to a transaction log for deletions.
sub ghost_class {
my $class = $_[0]->class;
$class = $class . '::Ghost';
return $class;
}
package UR::ModuleBase;
# Method for setting a callback using the old, non-command messaging API
=pod
=over
=item message_callback
$sub_ref = UR::ModuleBase->message_callback($type);
UR::ModuleBase->message_callback($type, $sub_ref);
This method returns and optionally sets the subroutine that handles
messages of a specific type.
=cut
## set or return a callback that has been created for a message type
sub message_callback
{
my $self = shift;
my ($type, $callback) = @_;
my $methodname = $type . '_messages_callback';
if (!$callback) {
# to clear the old, deprecated non-command messaging API callback
return UR::Object->$methodname($callback);
}
my $wrapper_callback = sub {
my($obj,$msg) = @_;
my $obj_class = $obj->class;
my $obj_id = (ref($obj) ? ($obj->can("id") ? $obj->id : $obj) : $obj);
my $message_package = $type . '_package';
my $message_object = UR::ModuleBase::Message->create
(
text => $msg,
level => 1,
package_name => $obj->$message_package(),
call_stack => ($type eq "error" ? _current_call_stack() : []),
time_stamp => time,
type => $type,
owner_class => $obj_class,
owner_id => $obj_id,
);
$callback->($message_object, $obj, $type);
$_[1] = $message_object->text;
};
# To support the old, deprecated, non-command messaging API
UR::Object->$methodname($wrapper_callback);
}
sub message_object
{
my $self = shift;
# see how we were called
if (@_ < 2)
{
no strict 'refs';
# return the message object
my ($type) = @_;
my $method = $type . '_message';
my $msg_text = $self->method();
my $obj_class = $self->class;
my $obj_id = (ref($self) ? ($self->can("id") ? $self->id : $self) : $self);
my $msgdata = $self->_get_msgdata();
return UR::ModuleBase::Message->create
(
text => $msg_text,
level => 1,
package_name => $msgdata->{$type . '_package'},
call_stack => ($type eq "error" ? _current_call_stack() : []),
time_stamp => time,
type => $type,
owner_class => $obj_class,
owner_id => $obj_id,
);
}
}
foreach my $type ( UR::ModuleBase->message_types ) {
my $retriever_name = $type . '_text';
my $compat_name = $type . '_message';
my $sub = sub {
my $self = shift;
return $self->$compat_name();
};
no strict 'refs';
*$retriever_name = $sub;
}
# class that stores and manages messages for the deprecated API
package UR::ModuleBase::Message;
use Scalar::Util qw(weaken);
##- use UR::Util;
UR::Util->generate_readonly_methods
(
text => undef,
level => undef,
package_name => undef,
call_stack => [],
time_stamp => undef,
owner_class => undef,
owner_id => undef,
type => undef,
);
sub create
{
my $class = shift;
my $obj = {@_};
bless ($obj,$class);
weaken $obj->{'owner_id'} if (ref($obj->{'owner_id'}));
return $obj;
}
sub owner
{
my $self = shift;
my ($owner_class,$owner_id) = ($self->owner_class, $self->owner_id);
if (not defined($owner_id))
{
return $owner_class;
}
elsif (ref($owner_id))
{
return $owner_id;
}
else
{
return $owner_class->get($owner_id);
}
}
sub string
{
my $self = shift;
"$self->{time_stamp} $self->{type}: $self->{text}\n";
}
sub _stack_item_params
{
my ($self, $stack_item) = @_;
my ($function, $parameters, @parameters);
return unless ($stack_item =~ s/\) called at [^\)]+ line [^\)]+\s*$/\)/);
if ($stack_item =~ /^\s*([^\(]*)(.*)$/)
{
$function = $1;
$parameters = $2;
@parameters = eval $parameters;
return ($function, @parameters);
}
else
{
return;
}
}
package UR::Object;
1;
Value.pm 000444 023532 023421 3403 12121654173 14326 0 ustar 00abrummet gsc 000000 000000 UR-0.41/lib/UR package UR::Value;
use strict;
use warnings;
require UR;
our $VERSION = "0.41"; # UR $VERSION;
our @CARP_NOT = qw( UR::Context );
UR::Object::Type->define(
class_name => 'UR::Value',
is => 'UR::Object',
has => ['id'],
data_source => 'UR::DataSource::Default',
);
sub __display_name__ {
return shift->id;
}
sub __load__ {
my $class = shift;
my $rule = shift;
my $expected_headers = shift;
my $id = $rule->value_for_id;
unless (defined $id) {
#$DB::single = 1;
Carp::croak "Can't load an infinite set of $class. Some id properties were not specified in the rule $rule";
}
if (ref($id) and ref($id) eq 'ARRAY') {
# We're being asked to load up more than one object. In the basic case, this is only
# possible if the rule _only_ contains ID properties. For anything more complicated,
# the subclass should implement its own behavior
my $class_meta = $class->__meta__;
my %id_properties = map { $_ => 1 } $class_meta->all_id_property_names;
my @non_id = grep { ! $id_properties{$_} } $rule->template->_property_names;
if (@non_id) {
Carp::croak("Cannot load class $class via UR::DataSource::Default when 'id' is a listref and non-id properties appear in the rule:" . join(', ', @non_id));
}
my $count = @$expected_headers;
my $listifier = sub { my $c = $count; my @l; push(@l,$_[0]) while ($c--); return \@l };
return ($expected_headers, [ map { &$listifier($_) } @$id ]);
}
my @values;
foreach my $header ( @$expected_headers ) {
my $value = $rule->value_for($header);
push @values, $value;
}
return $expected_headers, [\@values];
}
sub underlying_data_types {
return ();
}
1;
Manual.pod 000444 023532 023421 1601 12121654173 14633 0 ustar 00abrummet gsc 000000 000000 UR-0.41/lib/UR =pod
=head1 NAME
UR::Manual - Short list of UR's documentation
=head1 Manuals
L - Short introduction
L - UR from Ten Thousand Feet
L - Getting started with UR
L - A few things to keep in mind when designing a database schema
L - Slides for a presentation on UR
L - Recepies for getting stuff working
L - UR's metadata system
L - Defining classes
L - UR's command line tool
=head1 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
DataSource.pm 000444 023532 023421 66267 12121654173 15345 0 ustar 00abrummet gsc 000000 000000 UR-0.41/lib/UR package UR::DataSource;
use strict;
use warnings;
require UR;
our $VERSION = "0.41"; # UR $VERSION;
use Sys::Hostname;
*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 },
],
);
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 { ''; }
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;
for my $co ( $class_meta, @parent_class_objects ) {
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, $class_name) = @$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_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++;
}
# Post-process the template objects a bit to get the exact id positions.
for my $template (@templates) {
next unless $template; # This join may have resulted in no template?!
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 _CopyToAlternateDB {
# This is used to copy data loaded from the primary database into
# a secondary database. One use is for setting up an alternate DB
# for testing by priming it from data from the "live" DB
#
# This is called from inside load() when the env var UR_TEST_FILLDB
# is set. For now, this alternate DB is always an SQLIte DB, and the
# value of the env var is the base name of the file used as its storage.
my($self,$load_class_name,$orig_dbh,$data) = @_;
our %ALTERNATE_DB;
my $dbname = $orig_dbh->{'Name'};
my $dbh;
if ($ALTERNATE_DB{$dbname}->{'dbh'}) {
$dbh = $ALTERNATE_DB{$dbname}->{'dbh'};
} else {
my $filename = sprintf("%s.%s.sqlite", $ENV{'UR_TEST_FILLDB'}, $dbname);
# FIXME - The right way to do this is to create a new UR::DataSource::SQLite object instead of making a DBI object directly
unless ($dbh = $ALTERNATE_DB{$dbname}->{'dbh'} = DBI->connect("dbi:SQLite:dbname=$filename","","")) {
$self->error_message("_CopyToAlternateDB: Can't DBI::connect() for filename $filename" . $DBI::errstr);
return;
}
$dbh->{'AutoCommit'} = 0;
}
# Find out what tables this query will require
my @isa = ($load_class_name);
my(%tables,%class_tables);
while (@isa) {
my $class = shift @isa;
next if $class_tables{$class};
my $class_obj = $class->__meta__;
next unless $class_obj;
my $table_name = $class_obj->table_name;
next unless $table_name;
$class_tables{$class} = $table_name;
foreach my $col ( $class_obj->direct_column_names ) {
# FIXME Why are some of the returned column_names undef?
next unless defined($col); # && defined($data->{$col});
$tables{$table_name}->{$col} = $data->{$col}
}
{ no strict 'refs';
my @parents = @{$class . '::ISA'};
push @isa, @parents;
}
}
# For each parent class with a table, tell it to create itself
foreach my $class ( keys %class_tables ) {
next if (! $class_tables{$class} || $ALTERNATE_DB{$dbname}->{'tables'}->{$class_tables{$class}}++);
my $class_obj = $class->__meta__();
$class_obj->mk_table($dbh);
#unless ($class_obj->mk_table($dbh)) {
# $dbh->rollback();
# return undef;
#}
}
# Insert the data into the alternate DB
foreach my $table_name ( keys %tables ) {
my $sql = "INSERT INTO $table_name ";
my $num_values = (values %{$tables{$table_name}});
$sql .= "(" . join(',',keys %{$tables{$table_name}}) . ") VALUES (" . join(',', map {'?'} (1 .. $num_values)) . ")";
my $sth = $dbh->prepare_cached($sql);
unless ($sth) {
$self->error_message("Error in prepare to alternate DB: $DBI::errstr\nSQL: $sql");
$dbh->rollback();
return undef;
}
unless ( $sth->execute(values %{$tables{$table_name}}) ) {
$self->warning_message("Can't insert into $table_name in alternate DB: ".$DBI::errstr."\nSQL: $sql\nPARAMS: ".
join(',',values %{$tables{$table_name}}));
# We might just be inserting data that's already there...
# This is the error message sqlite returns
if ($DBI::errstr !~ m/column (\w+) is not unique/i) {
$dbh->rollback();
return undef;
}
}
}
$dbh->commit();
1;
}
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;
}
# basic, dumb datasources do not have a handle
sub get_default_handle {
return;
}
# 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 }
1;
BoolExpr.pm 000444 023532 023421 142771 12121654173 15060 0 ustar 00abrummet gsc 000000 000000 UR-0.41/lib/UR package UR::BoolExpr;
use warnings;
use strict;
use Scalar::Util qw(blessed);
require UR;
use Carp;
our @CARP_NOT = ('UR::Context');
our $VERSION = "0.41"; # 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)->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 $value_class_name = $meta->property($property_name)->data_type;
next unless $value_class_name;
my $id = $value->id;
my $value2 = eval {
$value_class_name->get($id)
};
if (not $value2) {
next;
}
if ($value2 == $value) {
# safe to re-represent as .id
my $new_key = $property_name . '.id';
$new_key .= ' ' . $op if $op;
my $new_value = $value->id;
delete $params{$key};
$params{$new_key} = $new_value;
$changes++;
}
}
}
if ($changes) {
return $self->resolve($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 (substr($key,0,1) eq '-') {
# 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 = 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,%in_clause_values_are_strings);
for my $value (@values) {
$key = $keys[$kn++];
if (substr($key,0,1) eq '-') {
$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
if (!exists $subject_class_props->{$property_name} and index($property_name,'.') == -1) {
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 {
$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
if ($operator ne 'between' and $operator ne 'not between') {
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);
#print ":: @xkeys\n::@xvalues\n\n";
}
push @xremove_keys, $kn-1;
push @xremove_values, $vn-1;
}
# This is disabled here because it is good for get() but not create()
# The flatten_hard_refs() method is run before doing a get() to create the same effect.
# elsif ($property_meta->is_delegated and not $property_meta->is_many) {
# print STDERR "adding $property_name.id\n";
# push @xadd_keys, $property_name . '.id' . ' ' . $operator;
# push @xadd_values, $value->id;
# 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
#$DB::single = 1;
# 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 @new;
my $next_pos_to_remove = $xremove_keys[0];
for (my $n = 0; $n < @keys; $n++) {
if (defined $next_pos_to_remove and $n == $next_pos_to_remove) {
shift @xremove_keys;
$next_pos_to_remove = $xremove_keys[0];
next;
}
push @new, $keys[$n];
}
@keys = @new;
}
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 @new;
my $next_pos_to_remove = $xremove_values[0];
for (my $n = 0; $n < @values; $n++) {
if (defined $next_pos_to_remove and $n == $xremove_values[0]) {
shift @xremove_values;
$next_pos_to_remove = $xremove_values[0];
next;
}
push @new, $values[$n];
}
@values = @new;
}
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 = ($complex_values ? UR::BoolExpr::Util->values_to_value_id(@values) : UR::BoolExpr::Util->values_to_value_id_simple(@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;
$rule->{_in_clause_values_are_strings} = \%in_clause_values_are_strings if (keys %in_clause_values_are_strings);
$vn = 0;
$cn = 0;
my @list;
for my $key (@keys) {
push @list, $key;
if (substr($key,0,1) eq '-') {
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 (substr($key,0,1) eq '-') {
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 = 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."'");
}
return $bx;
}
# TODO: these methods need a better home, since they are a cmdline/UI standard
sub _old_filter_regex_for_string {
return '^\s*([\w\.\-]+)\s*(\@|\=|!=|=|\>|\<|~|!~|!\:|\:|\blike\b|\bbetween\b|\bin\b)\s*[\'"]?([^\'"]*)[\'"]?\s*$';
}
# TODO: these methods need a better home, since they are a cmdline/UI standard
sub _old_resolve_for_string {
my ($self, $subject_class_name, $filter_string, $usage_hints_string, $order_string, $page_string) = @_;
my ($property, $op, $value);
no warnings;
my $filter_regex = $self->_old_filter_regex_for_string();
my @filters = map {
unless (($property, $op, $value) = ($_ =~ /$filter_regex/)) {
Carp::croak "Unable to process filter $_\n";
}
if ($op eq '~') {
$op = "like";
# If the user asked for 'like', but didn't put in a wildcard, then put wildcards
# on each side of the value
$value = '%'.$value.'%' if (length($value) and $value !~ m/\%|_/);
} elsif ($op eq '!~') {
$op = 'not like';
$value = '%'.$value.'%' if (length($value) and $value !~ m/\%|_/);
}
[$property, $op, $value]
} split(/,/, $filter_string);
my @hints = split(",",$usage_hints_string);
my @order = split(",",$order_string);
my @page = split(",",$page_string);
use warnings;
return __PACKAGE__->_resolve_from_filter_array($subject_class_name, \@filters, \@hints, \@order, \@page);
}
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
ModuleConfig.pm 000444 023532 023421 16511 12121654173 15651 0 ustar 00abrummet gsc 000000 000000 UR-0.41/lib/UR # Manage dynamic configuration of modules.
package UR::ModuleConfig;
=pod
=head1 NAME
UR::ModuleConfig - manage dynamic configuration of modules.
=head1 SYNOPSIS
package MyModule;
use base qw(UR::ModuleConfig);
MyModule->config(%conf);
$val = MyModule->config('key');
%conf = MyModule->config;
=head1 DESCRIPTION
This module manages the configuration for modules. Configurations can
be read from files or set dynamically. Modules wishing to use the
configuration methods should inherit from the module.
=cut
# set up package
require 5.006_000;
use warnings;
use strict;
require UR;
our $VERSION = "0.41"; # UR $VERSION;;
use base qw(UR::ModuleBase);
use IO::File;
=pod
=head2 METHODS
The methods deal with managing configuration.
=cut
# hash containing all configuration information
our %config;
# create a combined configuration hash from inheritance tree
sub _inherit_config
{
my $self = shift;
my $class = ref($self) || $self;
my %cfg;
# get all packages inherited from
my @inheritance = $self->inheritance;
# reverse loop through inheritance tree and construct config
foreach my $cls (reverse(@inheritance))
{
if (exists($config{$cls}))
{
# add hash, overriding previous values
%cfg = (%cfg, %{$config{$cls}});
}
}
# now add the current class config
if (exists($config{$class}))
{
%cfg = (%cfg, %{$config{$class}});
}
# now add the object config
if (ref($self))
{
# add the objects config
if (exists($config{"$class;$self"}))
{
%cfg = (%cfg, %{$config{"$class;$self"}});
}
}
return %cfg;
}
=pod
=over 4
=item config
MyModule->config(%config);
$val = MyModule->config('key');
%conf = MyModule->config;
my $obj = MyModule->new;
$obj->config(%config);
This method can be called three ways, as either a class or object
method. The first method takes a hash as its argument and sets the
configuration parameters given in the hash. The second method takes a
single argument which should be one of the keys of the hash that set
the config parameters and returns the value of that config hash key.
The final method takes no arguments and returns the entire
configuration hash.
When called as an object method, the config for both the object and
all classes in its inheritance hierarchy are referenced, with the
object config taking precedence over class methods and class methods
closer to the object (first in the @ISA array) taking precedence over
those further away (later in the @ISA array). When called as a class
method, the same procedure is used, except no object configuration is
referenced.
Do not use configuration keys that begin with an underscore (C<_>).
These are reserved for internal use.
=cut
sub config
{
my $self = shift;
my $class = ref($self) || $self;
# handle both object and class configuration
my $target;
if (ref($self))
{
# object config
$target = "$class;$self";
}
else
{
# class config
$target = $self;
}
# lay claim to the modules configuration
$config{$target}{_Manager} = __PACKAGE__;
# see if values are being set
if (@_ > 1)
{
# set values in config hash, overriding any current values
my (%opts) = @_;
%{$config{$target}} = (%{$config{$target}}, %opts);
return 1;
}
# else they want one key or the whole hash
# store config for object and inheritance tree
my %cfg = $self->_inherit_config;
# see how we were called
if (@_ == 1)
{
# return value of key
my ($key) = @_;
# make sure hash key exists
my $val;
if (exists($cfg{$key}))
{
$self->debug_message("config key $key exists");
$val = $cfg{$key};
}
else
{
$self->error_message("config key $key does not exist");
return;
}
return $val;
}
# else return the entire config hash
return %cfg;
}
=pod
=item check_config
$obj->check_config($key);
This method checks to see if a value is set. Unlike config, it does
not issue a warning if the key is not set. If the key is not set,
C is returned. If the key has been set, the value of the key
is returned (which may be C).
=cut
sub check_config
{
my $self = shift;
my ($key) = @_;
# get config for inheritance tree
my %cfg = $self->_inherit_config;
if (exists($cfg{$key}))
{
$self->debug_message("configuration key $key set: $cfg{$key}");
return $cfg{$key};
}
# else
$self->debug_message("configuration key $key not set");
return;
}
=pod
=item default_config
$class->default_config(%defaults);
This method allows the developer to set configuration values, only if
they are not already set.
=cut
sub default_config
{
my $self = shift;
my (%opts) = @_;
# get config for inheritance tree
my %cfg = $self->_inherit_config;
# loop through arguments
while (my ($k, $v) = each(%opts))
{
# see is config value is already set
if (exists($cfg{$k}))
{
$self->debug_message("config $k already set");
next;
}
$self->debug_message("setting default for $k");
# set config key
$self->config($k => $v);
}
return 1;
}
=pod
=item config_file
$rv = $class->config_file(path => $path);
$rv = $class->config_file(handle => $fh);
This method reads in the given file and expects key-value pairs, one
per line. The key and value should be separated by an equal sign,
C<=>, with optional surrounding space. It currently only handles
single value values.
The method returns true upon success, C on failure.
=cut
sub config_file
{
my $self = shift;
my (%opts) = @_;
my $fh;
if ($opts{path})
{
# make sure file is ok
if (-f $opts{path})
{
$self->debug_message("config file exists: $opts{path}");
}
else
{
$self->error_message("config file does not exist: $opts{path}");
return;
}
if (-r $opts{path})
{
$self->debug_message("config file is readable: $opts{path}");
}
else
{
$self->error_message("config file is not readable: $opts{path}");
return;
}
# open file
$fh = IO::File->new("<$opts{path}");
if (defined($fh))
{
$self->debug_message("opened config file for reading: $opts{path}");
}
else
{
$self->error_message("failed to open config file for reading: "
. $opts{path});
return;
}
}
elsif ($opts{handle})
{
$fh = $opts{handle};
}
else
{
$self->error_message("no config file input specified");
return;
}
# read through file
my %fconfig;
while (defined(my $line = $fh->getline))
{
# clean up
chomp($line);
$line =~ s/\#.*//;
$line =~ s/^\s*//;
$line =~ s/\s*$//;
next unless $line =~ m/\S/;
# parse
my ($k, $v) = split(m/\s*=\s*/, $line, 2);
$fconfig{$k} = $v;
}
$fh->close;
# update config
return $self->config(%fconfig);
}
1;
#$Header$
All.pm 000444 023532 023421 21276 12121654174 14013 0 ustar 00abrummet gsc 000000 000000 UR-0.41/lib/UR package UR::All;
use strict;
use warnings;
our $VERSION = "0.41"; # 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::NotEqual;
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_FILLDB;
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::Test;
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
ModuleBuild.pm 000444 023532 023421 4237 12121654174 15466 0 ustar 00abrummet gsc 000000 000000 UR-0.41/lib/UR package UR::ModuleBuild;
use strict;
use warnings;
use base 'Module::Build';
sub ACTION_clean {
# FIXME: is this safe?
use File::Path qw/rmtree/;
rmtree "./_build";
rmtree "./blib";
unlink "./Build";
unlink "./MYMETA.yml";
}
our $ns = 'UR';
our $cmd_class = 'UR::Namespace::Command';
sub ACTION_ur_docs {
# We want to use UR to autodocument our code. This is done
# with module introspection and requires some namespace hackery
# to work. ./Build doc comes after ./Build and copies the root
# namespace module into ./blib to fake a Genome namespace so this will work.
use File::Copy qw/copy/;
$ENV{ANSI_COLORS_DISABLED} = 1;
eval {
my $oldpwd = $ENV{PWD};
unshift @INC, "$ENV{PWD}/blib/lib";
my ($namespace_src_dr) = grep { -s "$_/$ns.pm" } @INC;
unless ($namespace_src_dr) {
die "Failed to find $ns.pm in \@INC.\n";
}
chdir "$ENV{PWD}/blib/lib/$ns" || die "Can't find $ns/";
unless (-e "../$ns.pm") {
copy "$namespace_src_dr/$ns.pm", "../$ns.pm" || die "Can't find $ns.pm";
}
eval "use $ns";
$cmd_class->class();
UR::Namespace::Command::Update::Pod->execute(
base_commands => [ $cmd_class ],
);
# We need to move back for perl install to find ./lib
chdir $oldpwd;
};
die "failed to extract pod: $!: $@" if ($@);
}
sub ACTION_docs {
my $self = shift;
$self->depends_on('ur_docs');
$self->depends_on('code');
$self->depends_on('manpages', 'html');
}
print "@UR::ModuleBuild::ISA\n";
1;
__END__
=pod
=head1 NAME
UR::ModuleBuild - a Module::Build subclass with UR extensions
=head1 VERSION
This document describes UR::ModuleBuild version 0.41.
=head1 SYNOPOSIS
In your Build.PL:
use UR::ModuleBuild;
my $build = UR::ModuleBuild->new(
module_name => 'MyApp',
license => 'perl',
dist_version => '0.01',
dist_abstract => 'my app rocks because I get to focus on the problem, not the crud',
build_requires => {
'UR' => '0.32',
},
requires => {
'Text::CSV_XS' => '',
'Statistics::Distributions' => '',
},
);
$build->create_build_script;
DataSource.pod 000444 023532 023421 22426 12121654174 15501 0 ustar 00abrummet gsc 000000 000000 UR-0.41/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