Mercurial > pub > Impl
changeset 426:eed50c01e758 ref20150831
Split off the core module, added Dist-Zilla config
| author | cin |
|---|---|
| date | Tue, 15 May 2018 00:51:01 +0300 |
| parents | 87af445663d7 |
| children | 09e0086a82a7 |
| files | .hg_archival.txt _test/temp.pl deps.txt dist.ini impl.komodoproject impl.kpf lib/IMPL.pm lib/IMPL/Config.pm lib/IMPL/DOM/Document.pm lib/IMPL/DOM/Navigator.pm lib/IMPL/DOM/Navigator/Builder.pm lib/IMPL/DOM/Navigator/SchemaNavigator.pm lib/IMPL/DOM/Navigator/SimpleBuilder.pm lib/IMPL/DOM/Node.pm lib/IMPL/DOM/Property.pm lib/IMPL/DOM/Schema.pm lib/IMPL/DOM/Schema/AnyNode.pm lib/IMPL/DOM/Schema/ComplexNode.pm lib/IMPL/DOM/Schema/ComplexType.pm lib/IMPL/DOM/Schema/Label.pm lib/IMPL/DOM/Schema/Node.pm lib/IMPL/DOM/Schema/NodeList.pm lib/IMPL/DOM/Schema/NodeSet.pm lib/IMPL/DOM/Schema/Property.pm lib/IMPL/DOM/Schema/SimpleNode.pm lib/IMPL/DOM/Schema/SimpleType.pm lib/IMPL/DOM/Schema/SwitchNode.pm lib/IMPL/DOM/Schema/ValidationError.pm lib/IMPL/DOM/Schema/Validator.pm lib/IMPL/DOM/Schema/Validator/Compare.pm lib/IMPL/DOM/Schema/Validator/RegExp.pm lib/IMPL/DOM/Transform.pm lib/IMPL/DOM/Transform/ObjectToDOM.pm lib/IMPL/DOM/Transform/PostToDOM.pm lib/IMPL/DOM/Transform/QueryToDOM.pm lib/IMPL/DOM/XMLReader.pm lib/IMPL/Mailer.pm lib/IMPL/ORM.pm lib/IMPL/ORM/Adapter/Generic.pm lib/IMPL/ORM/Entity.pm lib/IMPL/ORM/Helpers.pm lib/IMPL/ORM/Object.pm lib/IMPL/ORM/PropertyImplementor.pm lib/IMPL/ORM/Schema.pm lib/IMPL/ORM/Schema/Entity.pm lib/IMPL/ORM/Schema/Field.pm lib/IMPL/ORM/Schema/GenericClass.pm lib/IMPL/ORM/Schema/Relation.pm lib/IMPL/ORM/Schema/Relation/HasMany.pm lib/IMPL/ORM/Schema/Relation/HasOne.pm lib/IMPL/ORM/Schema/Relation/Subclass.pm lib/IMPL/ORM/Schema/TransformToSQL.pm lib/IMPL/ORM/Schema/ValueType.pm lib/IMPL/ORM/Store/DBIC.pm lib/IMPL/ORM/Store/SQL.pm lib/IMPL/ORM/Unit.pm lib/IMPL/SQL/Schema.pm lib/IMPL/SQL/Schema/Column.pm lib/IMPL/SQL/Schema/Constraint.pm lib/IMPL/SQL/Schema/Constraint/ForeignKey.pm lib/IMPL/SQL/Schema/Constraint/Index.pm lib/IMPL/SQL/Schema/Constraint/PrimaryKey.pm lib/IMPL/SQL/Schema/Constraint/Unique.pm lib/IMPL/SQL/Schema/Diff.pm lib/IMPL/SQL/Schema/MySQL/CharType.pm lib/IMPL/SQL/Schema/MySQL/EnumType.pm lib/IMPL/SQL/Schema/MySQL/Formatter.pm lib/IMPL/SQL/Schema/MySQL/Processor.pm lib/IMPL/SQL/Schema/Processor.pm lib/IMPL/SQL/Schema/Table.pm lib/IMPL/SQL/Schema/Traits.pm lib/IMPL/SQL/Schema/Traits/Diff.pm lib/IMPL/SQL/Schema/Traits/mysql.pm lib/IMPL/SQL/Schema/Type.pm lib/IMPL/SQL/Types.pm lib/IMPL/Serialization.pm lib/IMPL/Serialization/XmlFormatter.pm lib/IMPL/TargetException.pm lib/IMPL/Test.pm lib/IMPL/Test/BadUnit.pm lib/IMPL/Test/FailException.pm lib/IMPL/Test/HarnessRunner.pm lib/IMPL/Test/Plan.pm lib/IMPL/Test/Result.pm lib/IMPL/Test/SkipException.pm lib/IMPL/Test/Straps/ShellExecutor.pm lib/IMPL/Test/TAPListener.pm lib/IMPL/Test/Unit.pm lib/IMPL/Transform.pm lib/IMPL/Web/Application.pm lib/IMPL/Web/Application/Action.pm lib/IMPL/Web/Application/HttpResponseResource.pm lib/IMPL/Web/Application/Resource.pm lib/IMPL/Web/Application/ResourceBase.pm lib/IMPL/Web/Application/ResourceInterface.pm lib/IMPL/Web/AutoLocator.pm lib/IMPL/Web/BadRequestException.pm lib/IMPL/Web/CGIApplication.pm lib/IMPL/Web/CGIWrapper.pm lib/IMPL/Web/DOM/FileNode.pm lib/IMPL/Web/Exception.pm lib/IMPL/Web/ForbiddenException.pm lib/IMPL/Web/Handler/ErrorHandler.pm lib/IMPL/Web/Handler/JSONView.pm lib/IMPL/Web/Handler/LocaleHandler.pm lib/IMPL/Web/Handler/RestController.pm lib/IMPL/Web/Handler/SecureCookie.pm lib/IMPL/Web/Handler/View.pm lib/IMPL/Web/Handler/ViewSelector.pm lib/IMPL/Web/HttpResponse.pm lib/IMPL/Web/NotAcceptableException.pm lib/IMPL/Web/NotAllowedException.pm lib/IMPL/Web/NotFoundException.pm lib/IMPL/Web/OutOfRangeException.pm lib/IMPL/Web/PreconditionException.pm lib/IMPL/Web/Security.pm lib/IMPL/Web/Security/Session.pm lib/IMPL/Web/UnauthorizedException.pm lib/IMPL/Web/UnsupportedMediaException.pm lib/IMPL/Web/View/Metadata/BaseMeta.pm lib/IMPL/Web/View/Metadata/FormMeta.pm lib/IMPL/Web/View/Metadata/ObjectMeta.pm lib/IMPL/Web/View/ObjectFactory.pm lib/IMPL/Web/View/TTContext.pm lib/IMPL/Web/View/TTControl.pm lib/IMPL/Web/View/TTView.pm lib/IMPL/Web/View/TemplateView.pm lib/IMPL/Web/ViewResult.pm nohup.out |
| diffstat | 129 files changed, 13 insertions(+), 16289 deletions(-) [+] |
line wrap: on
line diff
--- a/.hg_archival.txt Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,5 +0,0 @@ -repo: 03e58a454b208a22e4b4ca287c68fd43942a03d3 -node: de83ecba0fd753fbee216945ba2fe2e225e10a7c -branch: default -latesttag: null -latesttagdistance: 209
--- a/_test/temp.pl Tue Apr 03 10:54:09 2018 +0300 +++ b/_test/temp.pl Tue May 15 00:51:01 2018 +0300 @@ -44,7 +44,7 @@ my $t = [gettimeofday]; for(my $i=0; $i <1000000; $i++) { - my $v = new Bar2; + my $v = new Foo2; } say tv_interval($t);
--- a/deps.txt Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,8 +0,0 @@ -Class::Accessor -Template -XML::Writer -JSON -DBIx::Class -DateTime::Format::Parser -DateTime::Format::MySQL -Sub::Name \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/dist.ini Tue May 15 00:51:01 2018 +0300 @@ -0,0 +1,12 @@ +name = Impl-Core +main_module = lib/IMPL.pm +abstract = IMPL module +author = Sergey Smirnov <perl@implab.org> +license = BSD +copyright_holder = Sergey Smirnov +copyright_year = 2018 +version = 0.002 + +[@Basic] +[PkgVersion] +finder=:MainModule \ No newline at end of file
--- a/impl.komodoproject Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,21 +0,0 @@ -<?xml version="1.0" encoding="UTF-8"?> -<!-- Komodo Project File - DO NOT EDIT --> -<project id="66c7d414-175f-45b6-92fe-dbda51c64843" kpf_version="5" name="impl.komodoproject"> -<file id="c255e877-43b0-4625-a9f2-fbf8e65179c8" idref="66c7d414-175f-45b6-92fe-dbda51c64843/Lib/IMPL/DOM" name="Node.pm" url="Lib/IMPL/DOM/Node.pm"> -</file> -<preference-set idref="66c7d414-175f-45b6-92fe-dbda51c64843" id="project" preftype="project"> - <string relative="path" id="import_dirname"></string> - <boolean id="import_live">1</boolean> - <string id="last_local_directory">None</string> - <string id="last_remote_directory">None</string> - <string relative="path" id="perlExtraPaths">lib</string> - <long id="prefs_version">1</long> -<preference-set id="testPlans"> -<preference-set id="impl.kpf - test plan # 1"> - <string id="command_line"></string> - <string relative="url" id="directory"></string> - <string id="language">Perl - TAP (*.t)</string> -</preference-set> -</preference-set> -</preference-set> -</project>
--- a/impl.kpf Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1109 +0,0 @@ -<?xml version="1.0" encoding="UTF-8"?> -<!-- Komodo Project File - DO NOT EDIT --> -<project id="66c7d414-175f-45b6-92fe-dbda51c64843" kpf_version="4" name="impl.kpf"> -<file id="c255e877-43b0-4625-a9f2-fbf8e65179c8" idref="66c7d414-175f-45b6-92fe-dbda51c64843/Lib/IMPL/DOM" name="Node.pm" url="Lib/IMPL/DOM/Node.pm"> -</file> -<preference-set idref="155f1fd9-8a20-46fe-90d5-8fbe879632d8"> -<preference-set id="Invocations"> -<preference-set id="default"> - <string id="cookieparams"></string> - <string id="cwd"></string> - <long id="debugger.io-port">9011</long> - <string id="documentRoot"></string> - <string id="executable-params"></string> - <string relative="path" id="filename">_test/object.t</string> - <string id="getparams"></string> - <string id="language">Perl</string> - <string id="mpostparams"></string> - <string id="params"></string> - <string id="postparams"></string> - <string id="posttype">application/x-www-form-urlencoded</string> - <string id="request-method">GET</string> - <boolean id="show-dialog">1</boolean> - <boolean id="sim-cgi">0</boolean> - <boolean id="use-console">0</boolean> - <string id="userCGIEnvironment"></string> - <string id="userEnvironment"></string> - <string id="warnings">enabled</string> -</preference-set> -</preference-set> - <string id="lastInvocation">default</string> -</preference-set> -<preference-set idref="231b32db-32cc-4b4f-a1fd-ec418c60fb9e"> -<preference-set id="Invocations"> -<preference-set id="default"> - <string id="cookieparams"></string> - <string id="cwd"></string> - <long id="debugger.io-port">9011</long> - <string id="documentRoot"></string> - <string id="executable-params"></string> - <string relative="path" id="filename">_test/object.t</string> - <string id="getparams"></string> - <string id="language">Perl</string> - <string id="mpostparams"></string> - <string id="params"></string> - <string id="postparams"></string> - <string id="posttype">application/x-www-form-urlencoded</string> - <string id="request-method">GET</string> - <boolean id="show-dialog">1</boolean> - <boolean id="sim-cgi">0</boolean> - <boolean id="use-console">0</boolean> - <string id="userCGIEnvironment"></string> - <string id="userEnvironment"></string> - <string id="warnings">enabled</string> -</preference-set> -</preference-set> - <string id="lastInvocation">default</string> -</preference-set> -<preference-set idref="348513f9-f7e1-48ab-834f-a76f43719a26"> -<preference-set id="Invocations"> -<preference-set id="default"> - <string id="cookieparams"></string> - <string id="cwd"></string> - <long id="debugger.io-port">9011</long> - <string id="documentRoot"></string> - <string id="executable-params"></string> - <string relative="path" id="filename">_test/object.t</string> - <string id="getparams"></string> - <string id="language">Perl</string> - <string id="mpostparams"></string> - <string id="params"></string> - <string id="postparams"></string> - <string id="posttype">application/x-www-form-urlencoded</string> - <string id="request-method">GET</string> - <boolean id="show-dialog">1</boolean> - <boolean id="sim-cgi">0</boolean> - <boolean id="use-console">0</boolean> - <string id="userCGIEnvironment"></string> - <string id="userEnvironment"></string> - <string id="warnings">enabled</string> -</preference-set> -</preference-set> - <string id="lastInvocation">default</string> -</preference-set> -<preference-set idref="3780f0c1-052f-4f34-8cb6-468c31e84394"> -<preference-set id="Invocations"> -<preference-set id="default"> - <string id="cookieparams"></string> - <string id="cwd"></string> - <long id="debugger.io-port">9011</long> - <string id="documentRoot"></string> - <string id="executable-params"></string> - <string relative="path" id="filename">_test/object.t</string> - <string id="getparams"></string> - <string id="language">Perl</string> - <string id="mpostparams"></string> - <string id="params"></string> - <string id="postparams"></string> - <string id="posttype">application/x-www-form-urlencoded</string> - <string id="request-method">GET</string> - <boolean id="show-dialog">1</boolean> - <boolean id="sim-cgi">0</boolean> - <boolean id="use-console">0</boolean> - <string id="userCGIEnvironment"></string> - <string id="userEnvironment"></string> - <string id="warnings">enabled</string> -</preference-set> -</preference-set> - <string id="lastInvocation">default</string> -</preference-set> -<preference-set idref="66c7d414-175f-45b6-92fe-dbda51c64843"> - <boolean id="import_live">1</boolean> - <string relative="path" id="perlExtraPaths">Lib</string> -<preference-set id="testPlans"> -<preference-set id="impl.kpf - test plan # 1"> - <string id="command_line"></string> - <string relative="url" id="directory"></string> - <string id="language">Perl - TAP (*.t)</string> -</preference-set> -</preference-set> -</preference-set> -<preference-set idref="66c7d414-175f-45b6-92fe-dbda51c64843/Lib/IMPL/DOM/Navigator/Builder.pm"> -<preference-set id="Invocations"> -<preference-set id="default"> - <string id="cookieparams"></string> - <string id="cwd"></string> - <long id="debugger.io-port">9011</long> - <string id="documentRoot"></string> - <string id="executable-params"></string> - <string relative="path" id="filename">Lib/IMPL/DOM/Navigator/Builder.pm</string> - <string id="getparams"></string> - <string id="language">Perl</string> - <string id="mpostparams"></string> - <string id="params"></string> - <string id="postparams"></string> - <string id="posttype">application/x-www-form-urlencoded</string> - <string id="request-method">GET</string> - <boolean id="show-dialog">1</boolean> - <boolean id="sim-cgi">0</boolean> - <boolean id="use-console">0</boolean> - <string id="userCGIEnvironment"></string> - <string id="userEnvironment"></string> - <string id="warnings">enabled</string> -</preference-set> -</preference-set> - <string id="lastInvocation">default</string> -</preference-set> -<preference-set idref="66c7d414-175f-45b6-92fe-dbda51c64843/Lib/IMPL/DOM/Navigator/SimpleBuilder.pm"> -<preference-set id="Invocations"> -<preference-set id="default"> - <string id="cookieparams"></string> - <string id="cwd"></string> - <long id="debugger.io-port">9011</long> - <string id="documentRoot"></string> - <string id="executable-params"></string> - <string relative="path" id="filename">Lib/IMPL/DOM/Navigator/SimpleBuilder.pm</string> - <string id="getparams"></string> - <string id="language">Perl</string> - <string id="mpostparams"></string> - <string id="params"></string> - <string id="postparams"></string> - <string id="posttype">application/x-www-form-urlencoded</string> - <string id="request-method">GET</string> - <boolean id="show-dialog">1</boolean> - <boolean id="sim-cgi">0</boolean> - <boolean id="use-console">0</boolean> - <string id="userCGIEnvironment"></string> - <string id="userEnvironment"></string> - <string id="warnings">enabled</string> -</preference-set> -</preference-set> - <string id="lastInvocation">default</string> -</preference-set> -<preference-set idref="66c7d414-175f-45b6-92fe-dbda51c64843/Lib/IMPL/DOM/Schema.pm"> -<preference-set id="Invocations"> -<preference-set id="default"> - <string id="cookieparams"></string> - <string id="cwd"></string> - <long id="debugger.io-port">9011</long> - <string id="documentRoot"></string> - <string id="executable-params"></string> - <string relative="path" id="filename">Lib/IMPL/DOM/Schema.pm</string> - <string id="getparams"></string> - <string id="language">Perl</string> - <string id="mpostparams"></string> - <string id="params"></string> - <string id="postparams"></string> - <string id="posttype">application/x-www-form-urlencoded</string> - <string id="request-method">GET</string> - <boolean id="show-dialog">1</boolean> - <boolean id="sim-cgi">0</boolean> - <boolean id="use-console">0</boolean> - <string id="userCGIEnvironment"></string> - <string id="userEnvironment"></string> - <string id="warnings">enabled</string> -</preference-set> -</preference-set> - <string id="lastInvocation">default</string> -</preference-set> -<preference-set idref="66c7d414-175f-45b6-92fe-dbda51c64843/Lib/IMPL/DOM/Schema/ComplexNode.pm"> -<preference-set id="Invocations"> -<preference-set id="default"> - <string id="cookieparams"></string> - <string id="cwd"></string> - <long id="debugger.io-port">9011</long> - <string id="documentRoot"></string> - <string id="executable-params"></string> - <string relative="path" id="filename">Lib/IMPL/DOM/Schema/ComplexNode.pm</string> - <string id="getparams"></string> - <string id="language">Perl</string> - <string id="mpostparams"></string> - <string id="params"></string> - <string id="postparams"></string> - <string id="posttype">application/x-www-form-urlencoded</string> - <string id="request-method">GET</string> - <boolean id="show-dialog">1</boolean> - <boolean id="sim-cgi">0</boolean> - <boolean id="use-console">0</boolean> - <string id="userCGIEnvironment"></string> - <string id="userEnvironment"></string> - <string id="warnings">enabled</string> -</preference-set> -</preference-set> - <string id="lastInvocation">default</string> -</preference-set> -<preference-set idref="66c7d414-175f-45b6-92fe-dbda51c64843/Lib/IMPL/DOM/Schema/Item.pm"> -<preference-set id="Invocations"> -<preference-set id="default"> - <string id="cookieparams"></string> - <string id="cwd"></string> - <long id="debugger.io-port">9011</long> - <string id="documentRoot"></string> - <string id="executable-params"></string> - <string relative="path" id="filename">Lib/IMPL/DOM/Schema/Item.pm</string> - <string id="getparams"></string> - <string id="language">Perl</string> - <string id="mpostparams"></string> - <string id="params"></string> - <string id="postparams"></string> - <string id="posttype">application/x-www-form-urlencoded</string> - <string id="request-method">GET</string> - <boolean id="show-dialog">1</boolean> - <boolean id="sim-cgi">0</boolean> - <boolean id="use-console">0</boolean> - <string id="userCGIEnvironment"></string> - <string id="userEnvironment"></string> - <string id="warnings">enabled</string> -</preference-set> -</preference-set> - <string id="lastInvocation">default</string> -</preference-set> -<preference-set idref="66c7d414-175f-45b6-92fe-dbda51c64843/Lib/IMPL/DOM/Schema/Property.pm"> -<preference-set id="Invocations"> -<preference-set id="default"> - <string id="cookieparams"></string> - <string id="cwd"></string> - <long id="debugger.io-port">9011</long> - <string id="documentRoot"></string> - <string id="executable-params"></string> - <string relative="path" id="filename">Lib/IMPL/DOM/Schema/Property.pm</string> - <string id="getparams"></string> - <string id="language">Perl</string> - <string id="mpostparams"></string> - <string id="params"></string> - <string id="postparams"></string> - <string id="posttype">application/x-www-form-urlencoded</string> - <string id="request-method">GET</string> - <boolean id="show-dialog">1</boolean> - <boolean id="sim-cgi">0</boolean> - <boolean id="use-console">0</boolean> - <string id="userCGIEnvironment"></string> - <string id="userEnvironment"></string> - <string id="warnings">enabled</string> -</preference-set> -</preference-set> - <string id="lastInvocation">default</string> -</preference-set> -<preference-set idref="66c7d414-175f-45b6-92fe-dbda51c64843/Lib/IMPL/DOM/XMLReader.pm"> -<preference-set id="Invocations"> -<preference-set id="default"> - <string id="cookieparams"></string> - <string id="cwd"></string> - <long id="debugger.io-port">9011</long> - <string id="documentRoot"></string> - <string id="executable-params"></string> - <string relative="path" id="filename">Lib/IMPL/DOM/XMLReader.pm</string> - <string id="getparams"></string> - <string id="language">Perl</string> - <string id="mpostparams"></string> - <string id="params"></string> - <string id="postparams"></string> - <string id="posttype">application/x-www-form-urlencoded</string> - <string id="request-method">GET</string> - <boolean id="show-dialog">1</boolean> - <boolean id="sim-cgi">0</boolean> - <boolean id="use-console">0</boolean> - <string id="userCGIEnvironment"></string> - <string id="userEnvironment"></string> - <string id="warnings">enabled</string> -</preference-set> -</preference-set> - <string id="lastInvocation">default</string> -</preference-set> -<preference-set idref="66c7d414-175f-45b6-92fe-dbda51c64843/Lib/IMPL/ORM/Entity.pm"> -<preference-set id="Invocations"> -<preference-set id="default"> - <string id="cookieparams"></string> - <string id="cwd"></string> - <long id="debugger.io-port">9011</long> - <string id="documentRoot"></string> - <string id="executable-params"></string> - <string relative="path" id="filename">Lib/IMPL/ORM/Entity.pm</string> - <string id="getparams"></string> - <string id="language">Perl</string> - <string id="mpostparams"></string> - <string id="params"></string> - <string id="postparams"></string> - <string id="posttype">application/x-www-form-urlencoded</string> - <string id="request-method">GET</string> - <boolean id="show-dialog">1</boolean> - <boolean id="sim-cgi">0</boolean> - <boolean id="use-console">0</boolean> - <string id="userCGIEnvironment"></string> - <string id="userEnvironment"></string> - <string id="warnings">enabled</string> -</preference-set> -</preference-set> - <string id="lastInvocation">default</string> -</preference-set> -<preference-set idref="66c7d414-175f-45b6-92fe-dbda51c64843/Lib/IMPL/ORM/Object.pm"> -<preference-set id="Invocations"> -<preference-set id="default"> - <string id="cookieparams"></string> - <string id="cwd"></string> - <long id="debugger.io-port">9011</long> - <string id="documentRoot"></string> - <string id="executable-params"></string> - <string relative="path" id="filename">Lib/IMPL/ORM/Object.pm</string> - <string id="getparams"></string> - <string id="language">Perl</string> - <string id="mpostparams"></string> - <string id="params"></string> - <string id="postparams"></string> - <string id="posttype">application/x-www-form-urlencoded</string> - <string id="request-method">GET</string> - <boolean id="show-dialog">1</boolean> - <boolean id="sim-cgi">0</boolean> - <boolean id="use-console">0</boolean> - <string id="userCGIEnvironment"></string> - <string id="userEnvironment"></string> - <string id="warnings">enabled</string> -</preference-set> -</preference-set> - <string id="lastInvocation">default</string> -</preference-set> -<preference-set idref="66c7d414-175f-45b6-92fe-dbda51c64843/Lib/IMPL/Object.pm"> -<preference-set id="Invocations"> -<preference-set id="default"> - <string id="cookieparams"></string> - <string id="cwd"></string> - <long id="debugger.io-port">9011</long> - <string id="documentRoot"></string> - <string id="executable-params"></string> - <string relative="path" id="filename">Lib/IMPL/Object.pm</string> - <string id="getparams"></string> - <string id="language">Perl</string> - <string id="mpostparams"></string> - <string id="params"></string> - <string id="postparams"></string> - <string id="posttype">application/x-www-form-urlencoded</string> - <string id="request-method">GET</string> - <boolean id="show-dialog">1</boolean> - <boolean id="sim-cgi">0</boolean> - <boolean id="use-console">0</boolean> - <string id="userCGIEnvironment"></string> - <string id="userEnvironment"></string> - <string id="warnings">enabled</string> -</preference-set> -</preference-set> - <string id="lastInvocation">default</string> -</preference-set> -<preference-set idref="66c7d414-175f-45b6-92fe-dbda51c64843/Lib/IMPL/Security/Auth/Simple.pm"> -<preference-set id="Invocations"> -<preference-set id="default"> - <string id="cookieparams"></string> - <string id="cwd"></string> - <long id="debugger.io-port">9011</long> - <string id="documentRoot"></string> - <string id="executable-params"></string> - <string relative="path" id="filename">Lib/IMPL/Security/Auth/Simple.pm</string> - <string id="getparams"></string> - <string id="language">Perl</string> - <string id="mpostparams"></string> - <string id="params"></string> - <string id="postparams"></string> - <string id="posttype">application/x-www-form-urlencoded</string> - <string id="request-method">GET</string> - <boolean id="show-dialog">1</boolean> - <boolean id="sim-cgi">0</boolean> - <boolean id="use-console">0</boolean> - <string id="userCGIEnvironment"></string> - <string id="userEnvironment"></string> - <string id="warnings">enabled</string> -</preference-set> -</preference-set> - <string id="lastInvocation">default</string> -</preference-set> -<preference-set idref="66c7d414-175f-45b6-92fe-dbda51c64843/_test/DOM.t"> -<preference-set id="Invocations"> -<preference-set id="default"> - <string id="cookieparams"></string> - <string id="cwd"></string> - <long id="debugger.io-port">9011</long> - <string id="documentRoot"></string> - <string id="executable-params"></string> - <string relative="path" id="filename">_test/DOM.t</string> - <string id="getparams"></string> - <string id="language">Perl</string> - <string id="mpostparams"></string> - <string id="params"></string> - <string id="postparams"></string> - <string id="posttype">application/x-www-form-urlencoded</string> - <string id="request-method">GET</string> - <boolean id="show-dialog">1</boolean> - <boolean id="sim-cgi">0</boolean> - <boolean id="use-console">0</boolean> - <string id="userCGIEnvironment"></string> - <string id="userEnvironment"></string> - <string id="warnings">enabled</string> -</preference-set> -</preference-set> - <string id="lastInvocation">default</string> -</preference-set> -<preference-set idref="66c7d414-175f-45b6-92fe-dbda51c64843/_test/ORM.t"> -<preference-set id="Invocations"> -<preference-set id="default"> - <string id="cookieparams"></string> - <string id="cwd"></string> - <long id="debugger.io-port">9011</long> - <string id="documentRoot"></string> - <string id="executable-params"></string> - <string relative="path" id="filename">_test/ORM.t</string> - <string id="getparams"></string> - <string id="language">Perl</string> - <string id="mpostparams"></string> - <string id="params"></string> - <string id="postparams"></string> - <string id="posttype">application/x-www-form-urlencoded</string> - <string id="request-method">GET</string> - <boolean id="show-dialog">1</boolean> - <boolean id="sim-cgi">0</boolean> - <boolean id="use-console">0</boolean> - <string id="userCGIEnvironment"></string> - <string id="userEnvironment"></string> - <string id="warnings">enabled</string> -</preference-set> -</preference-set> - <string id="lastInvocation">default</string> -</preference-set> -<preference-set idref="66c7d414-175f-45b6-92fe-dbda51c64843/_test/Resources.t"> -<preference-set id="Invocations"> -<preference-set id="default"> - <string id="cookieparams"></string> - <string id="cwd"></string> - <long id="debugger.io-port">9011</long> - <string id="documentRoot"></string> - <string id="executable-params"></string> - <string relative="path" id="filename">_test/Resources.t</string> - <string id="getparams"></string> - <string id="language">Perl</string> - <string id="mpostparams"></string> - <string id="params"></string> - <string id="postparams"></string> - <string id="posttype">application/x-www-form-urlencoded</string> - <string id="request-method">GET</string> - <boolean id="show-dialog">1</boolean> - <boolean id="sim-cgi">0</boolean> - <boolean id="use-console">0</boolean> - <string id="userCGIEnvironment"></string> - <string id="userEnvironment"></string> - <string id="warnings">enabled</string> -</preference-set> -</preference-set> - <string id="lastInvocation">default</string> -</preference-set> -<preference-set idref="66c7d414-175f-45b6-92fe-dbda51c64843/_test/SQL.t"> -<preference-set id="Invocations"> -<preference-set id="default"> - <string id="cookieparams"></string> - <string id="cwd"></string> - <long id="debugger.io-port">9011</long> - <string id="documentRoot"></string> - <string id="executable-params"></string> - <string relative="path" id="filename">_test/SQL.t</string> - <string id="getparams"></string> - <string id="language">Perl</string> - <string id="mpostparams"></string> - <string id="params"></string> - <string id="postparams"></string> - <string id="posttype">application/x-www-form-urlencoded</string> - <string id="request-method">GET</string> - <boolean id="show-dialog">1</boolean> - <boolean id="sim-cgi">0</boolean> - <boolean id="use-console">0</boolean> - <string id="userCGIEnvironment"></string> - <string id="userEnvironment"></string> - <string id="warnings">enabled</string> -</preference-set> -</preference-set> - <string id="lastInvocation">default</string> -</preference-set> -<preference-set idref="66c7d414-175f-45b6-92fe-dbda51c64843/_test/Test/DOM/Builder.pm"> -<preference-set id="Invocations"> -<preference-set id="default"> - <string id="cookieparams"></string> - <string id="cwd"></string> - <long id="debugger.io-port">9011</long> - <string id="documentRoot"></string> - <string id="executable-params"></string> - <string relative="path" id="filename">_test/Test/DOM/Builder.pm</string> - <string id="getparams"></string> - <string id="language">Perl</string> - <string id="mpostparams"></string> - <string id="params"></string> - <string id="postparams"></string> - <string id="posttype">application/x-www-form-urlencoded</string> - <string id="request-method">GET</string> - <boolean id="show-dialog">1</boolean> - <boolean id="sim-cgi">0</boolean> - <boolean id="use-console">0</boolean> - <string id="userCGIEnvironment"></string> - <string id="userEnvironment"></string> - <string id="warnings">enabled</string> -</preference-set> -</preference-set> - <string id="lastInvocation">default</string> -</preference-set> -<preference-set idref="66c7d414-175f-45b6-92fe-dbda51c64843/_test/Test/DOM/Node.pm"> -<preference-set id="Invocations"> -<preference-set id="default"> - <string id="cookieparams"></string> - <string id="cwd"></string> - <long id="debugger.io-port">9011</long> - <string id="documentRoot"></string> - <string id="executable-params"></string> - <string relative="path" id="filename">_test/Test/DOM/Node.pm</string> - <string id="getparams"></string> - <string id="language">Perl</string> - <string id="mpostparams"></string> - <string id="params"></string> - <string id="postparams"></string> - <string id="posttype">application/x-www-form-urlencoded</string> - <string id="request-method">GET</string> - <boolean id="show-dialog">1</boolean> - <boolean id="sim-cgi">0</boolean> - <boolean id="use-console">0</boolean> - <string id="userCGIEnvironment"></string> - <string id="userEnvironment"></string> - <string id="warnings">enabled</string> -</preference-set> -</preference-set> - <string id="lastInvocation">default</string> -</preference-set> -<preference-set idref="66c7d414-175f-45b6-92fe-dbda51c64843/_test/Test/DOM/Schema.pm"> -<preference-set id="Invocations"> -<preference-set id="default"> - <string id="cookieparams"></string> - <string id="cwd"></string> - <long id="debugger.io-port">9011</long> - <string id="documentRoot"></string> - <string id="executable-params"></string> - <string relative="path" id="filename">_test/Test/DOM/Schema.pm</string> - <string id="getparams"></string> - <string id="language">Perl</string> - <string id="mpostparams"></string> - <string id="params"></string> - <string id="postparams"></string> - <string id="posttype">application/x-www-form-urlencoded</string> - <string id="request-method">GET</string> - <boolean id="show-dialog">1</boolean> - <boolean id="sim-cgi">0</boolean> - <boolean id="use-console">0</boolean> - <string id="userCGIEnvironment"></string> - <string id="userEnvironment"></string> - <string id="warnings">enabled</string> -</preference-set> -</preference-set> - <string id="lastInvocation">default</string> -</preference-set> -<preference-set idref="66c7d414-175f-45b6-92fe-dbda51c64843/_test/Test/ORM/Schema.pm"> -<preference-set id="Invocations"> -<preference-set id="default"> - <string id="cookieparams"></string> - <string id="cwd"></string> - <long id="debugger.io-port">9011</long> - <string id="documentRoot"></string> - <string id="executable-params"></string> - <string relative="path" id="filename">_test/Test/ORM/Schema.pm</string> - <string id="getparams"></string> - <string id="language">Perl</string> - <string id="mpostparams"></string> - <string id="params"></string> - <string id="postparams"></string> - <string id="posttype">application/x-www-form-urlencoded</string> - <string id="request-method">GET</string> - <boolean id="show-dialog">1</boolean> - <boolean id="sim-cgi">0</boolean> - <boolean id="use-console">0</boolean> - <string id="userCGIEnvironment"></string> - <string id="userEnvironment"></string> - <string id="warnings">enabled</string> -</preference-set> -</preference-set> - <string id="lastInvocation">default</string> -</preference-set> -<preference-set idref="66c7d414-175f-45b6-92fe-dbda51c64843/_test/Web.t"> -<preference-set id="Invocations"> -<preference-set id="default"> - <string id="cookieparams"></string> - <string id="cwd"></string> - <long id="debugger.io-port">9011</long> - <string id="documentRoot"></string> - <string id="executable-params"></string> - <string relative="path" id="filename">_test/Web.t</string> - <string id="getparams"></string> - <string id="language">Perl</string> - <string id="mpostparams"></string> - <string id="params"></string> - <string id="postparams"></string> - <string id="posttype">application/x-www-form-urlencoded</string> - <string id="request-method">GET</string> - <boolean id="show-dialog">1</boolean> - <boolean id="sim-cgi">0</boolean> - <boolean id="use-console">0</boolean> - <string id="userCGIEnvironment"></string> - <string id="userEnvironment"></string> - <string id="warnings">enabled</string> -</preference-set> -</preference-set> - <string id="lastInvocation">default</string> -</preference-set> -<preference-set idref="66c7d414-175f-45b6-92fe-dbda51c64843/_test/any.pl"> -<preference-set id="Invocations"> -<preference-set id="default"> - <string id="cookieparams"></string> - <string id="cwd"></string> - <long id="debugger.io-port">9011</long> - <string id="documentRoot"></string> - <string id="executable-params"></string> - <string relative="path" id="filename">_test/any.pl</string> - <string id="getparams"></string> - <string id="language">Perl</string> - <string id="mpostparams"></string> - <string id="params"></string> - <string id="postparams"></string> - <string id="posttype">application/x-www-form-urlencoded</string> - <string id="request-method">GET</string> - <boolean id="show-dialog">1</boolean> - <boolean id="sim-cgi">0</boolean> - <boolean id="use-console">0</boolean> - <string id="userCGIEnvironment"></string> - <string id="userEnvironment"></string> - <string id="warnings">enabled</string> -</preference-set> -</preference-set> - <string id="lastInvocation">default</string> -</preference-set> -<preference-set idref="66c7d414-175f-45b6-92fe-dbda51c64843/_test/object.t"> -<preference-set id="Invocations"> -<preference-set id="default"> - <string id="cookieparams"></string> - <string id="cwd"></string> - <long id="debugger.io-port">9011</long> - <string id="documentRoot"></string> - <string id="executable-params"></string> - <string relative="path" id="filename">_test/object.t</string> - <string id="getparams"></string> - <string id="language">Perl</string> - <string id="mpostparams"></string> - <string id="params"></string> - <string id="postparams"></string> - <string id="posttype">application/x-www-form-urlencoded</string> - <string id="request-method">GET</string> - <boolean id="show-dialog">1</boolean> - <boolean id="sim-cgi">0</boolean> - <boolean id="use-console">0</boolean> - <string id="userCGIEnvironment"></string> - <string id="userEnvironment"></string> - <string id="warnings">enabled</string> -</preference-set> -</preference-set> - <string id="lastInvocation">default</string> -</preference-set> -<preference-set idref="66c7d414-175f-45b6-92fe-dbda51c64843/_test/run_tests.pl"> -<preference-set id="Invocations"> -<preference-set id="default"> - <string id="cookieparams"></string> - <string id="cwd"></string> - <long id="debugger.io-port">9011</long> - <string id="documentRoot"></string> - <string id="executable-params"></string> - <string relative="path" id="filename">_test/run_tests.pl</string> - <string id="getparams"></string> - <string id="language">Perl</string> - <string id="mpostparams"></string> - <string id="params"></string> - <string id="postparams"></string> - <string id="posttype">application/x-www-form-urlencoded</string> - <string id="request-method">GET</string> - <boolean id="show-dialog">1</boolean> - <boolean id="sim-cgi">0</boolean> - <boolean id="use-console">0</boolean> - <string id="userCGIEnvironment"></string> - <string id="userEnvironment"></string> - <string id="warnings">enabled</string> -</preference-set> -</preference-set> - <string id="lastInvocation">default</string> -</preference-set> -<preference-set idref="66c7d414-175f-45b6-92fe-dbda51c64843/_test/wmi.pl"> -<preference-set id="Invocations"> -<preference-set id="default"> - <string id="cookieparams"></string> - <string id="cwd"></string> - <long id="debugger.io-port">9011</long> - <string id="documentRoot"></string> - <string id="executable-params"></string> - <string relative="path" id="filename">_test/wmi.pl</string> - <string id="getparams"></string> - <string id="language">Perl</string> - <string id="mpostparams"></string> - <string id="params"></string> - <string id="postparams"></string> - <string id="posttype">application/x-www-form-urlencoded</string> - <string id="request-method">GET</string> - <boolean id="show-dialog">1</boolean> - <boolean id="sim-cgi">0</boolean> - <boolean id="use-console">0</boolean> - <string id="userCGIEnvironment"></string> - <string id="userEnvironment"></string> - <string id="warnings">enabled</string> -</preference-set> -</preference-set> - <string id="lastInvocation">default</string> -</preference-set> -<preference-set idref="7e7fa5c6-0123-4570-8540-b1366b09b7dd"> -<preference-set id="Invocations"> -<preference-set id="default"> - <string id="cookieparams"></string> - <string id="cwd"></string> - <long id="debugger.io-port">9011</long> - <string id="documentRoot"></string> - <string id="executable-params"></string> - <string relative="path" id="filename">_test/object.t</string> - <string id="getparams"></string> - <string id="language">Perl</string> - <string id="mpostparams"></string> - <string id="params"></string> - <string id="postparams"></string> - <string id="posttype">application/x-www-form-urlencoded</string> - <string id="request-method">GET</string> - <boolean id="show-dialog">1</boolean> - <boolean id="sim-cgi">0</boolean> - <boolean id="use-console">0</boolean> - <string id="userCGIEnvironment"></string> - <string id="userEnvironment"></string> - <string id="warnings">enabled</string> -</preference-set> -</preference-set> - <string id="lastInvocation">default</string> -</preference-set> -<preference-set idref="8299da70-10fd-4473-9ebd-34fb743d1271"> -<preference-set id="Invocations"> -<preference-set id="default"> - <string id="cookieparams"></string> - <string id="cwd"></string> - <long id="debugger.io-port">9011</long> - <string id="documentRoot"></string> - <string id="executable-params"></string> - <string relative="path" id="filename">_test/object.t</string> - <string id="getparams"></string> - <string id="language">Perl</string> - <string id="mpostparams"></string> - <string id="params"></string> - <string id="postparams"></string> - <string id="posttype">application/x-www-form-urlencoded</string> - <string id="request-method">GET</string> - <boolean id="show-dialog">1</boolean> - <boolean id="sim-cgi">0</boolean> - <boolean id="use-console">0</boolean> - <string id="userCGIEnvironment"></string> - <string id="userEnvironment"></string> - <string id="warnings">enabled</string> -</preference-set> -</preference-set> - <string id="lastInvocation">default</string> -</preference-set> -<preference-set idref="8c398590-1760-4ade-a1cb-1b8a5e391306"> -<preference-set id="Invocations"> -<preference-set id="default"> - <string id="cookieparams"></string> - <string id="cwd"></string> - <long id="debugger.io-port">9011</long> - <string id="documentRoot"></string> - <string id="executable-params"></string> - <string relative="path" id="filename">_test/object.t</string> - <string id="getparams"></string> - <string id="language">Perl</string> - <string id="mpostparams"></string> - <string id="params"></string> - <string id="postparams"></string> - <string id="posttype">application/x-www-form-urlencoded</string> - <string id="request-method">GET</string> - <boolean id="show-dialog">1</boolean> - <boolean id="sim-cgi">0</boolean> - <boolean id="use-console">0</boolean> - <string id="userCGIEnvironment"></string> - <string id="userEnvironment"></string> - <string id="warnings">enabled</string> -</preference-set> -</preference-set> - <string id="lastInvocation">default</string> -</preference-set> -<preference-set idref="8cc14854-53cc-4857-bed8-bf9bb929620e"> -<preference-set id="Invocations"> -<preference-set id="default"> - <string id="cookieparams"></string> - <string id="cwd"></string> - <long id="debugger.io-port">9011</long> - <string id="documentRoot"></string> - <string id="executable-params"></string> - <string relative="path" id="filename">_test/object.t</string> - <string id="getparams"></string> - <string id="language">Perl</string> - <string id="mpostparams"></string> - <string id="params"></string> - <string id="postparams"></string> - <string id="posttype">application/x-www-form-urlencoded</string> - <string id="request-method">GET</string> - <boolean id="show-dialog">1</boolean> - <boolean id="sim-cgi">0</boolean> - <boolean id="use-console">0</boolean> - <string id="userCGIEnvironment"></string> - <string id="userEnvironment"></string> - <string id="warnings">enabled</string> -</preference-set> -</preference-set> - <string id="lastInvocation">default</string> -</preference-set> -<preference-set idref="b2468e36-4932-4ffc-9ab9-200b1e54a7f0"> -<preference-set id="Invocations"> -<preference-set id="default"> - <string id="cookieparams"></string> - <string id="cwd"></string> - <long id="debugger.io-port">9011</long> - <string id="documentRoot"></string> - <string id="executable-params"></string> - <string relative="path" id="filename">_test/object.t</string> - <string id="getparams"></string> - <string id="language">Perl</string> - <string id="mpostparams"></string> - <string id="params"></string> - <string id="postparams"></string> - <string id="posttype">application/x-www-form-urlencoded</string> - <string id="request-method">GET</string> - <boolean id="show-dialog">1</boolean> - <boolean id="sim-cgi">0</boolean> - <boolean id="use-console">0</boolean> - <string id="userCGIEnvironment"></string> - <string id="userEnvironment"></string> - <string id="warnings">enabled</string> -</preference-set> -</preference-set> - <string id="lastInvocation">default</string> -</preference-set> -<preference-set idref="c01c5f46-5002-426d-9a5a-0bb1a41bf197"> -<preference-set id="Invocations"> -<preference-set id="default"> - <string id="cookieparams"></string> - <string id="cwd"></string> - <long id="debugger.io-port">9011</long> - <string id="documentRoot"></string> - <string id="executable-params"></string> - <string relative="path" id="filename">_test/object.t</string> - <string id="getparams"></string> - <string id="language">Perl</string> - <string id="mpostparams"></string> - <string id="params"></string> - <string id="postparams"></string> - <string id="posttype">application/x-www-form-urlencoded</string> - <string id="request-method">GET</string> - <boolean id="show-dialog">1</boolean> - <boolean id="sim-cgi">0</boolean> - <boolean id="use-console">0</boolean> - <string id="userCGIEnvironment"></string> - <string id="userEnvironment"></string> - <string id="warnings">enabled</string> -</preference-set> -</preference-set> - <string id="lastInvocation">default</string> -</preference-set> -<preference-set idref="ca1ec41d-47db-484f-8eae-b3d4f4b901b7"> -<preference-set id="Invocations"> -<preference-set id="default"> - <string id="cookieparams"></string> - <string id="cwd"></string> - <long id="debugger.io-port">9011</long> - <string id="documentRoot"></string> - <string id="executable-params"></string> - <string relative="path" id="filename">_test/object.t</string> - <string id="getparams"></string> - <string id="language">Perl</string> - <string id="mpostparams"></string> - <string id="params"></string> - <string id="postparams"></string> - <string id="posttype">application/x-www-form-urlencoded</string> - <string id="request-method">GET</string> - <boolean id="show-dialog">1</boolean> - <boolean id="sim-cgi">0</boolean> - <boolean id="use-console">0</boolean> - <string id="userCGIEnvironment"></string> - <string id="userEnvironment"></string> - <string id="warnings">enabled</string> -</preference-set> -</preference-set> - <string id="lastInvocation">default</string> -</preference-set> -<preference-set idref="d1e2b231-7a47-44e7-97f9-d51957c66878"> -<preference-set id="Invocations"> -<preference-set id="default"> - <string id="cookieparams"></string> - <string id="cwd"></string> - <long id="debugger.io-port">9011</long> - <string id="documentRoot"></string> - <string id="executable-params"></string> - <string relative="path" id="filename">_test/object.t</string> - <string id="getparams"></string> - <string id="language">Perl</string> - <string id="mpostparams"></string> - <string id="params"></string> - <string id="postparams"></string> - <string id="posttype">application/x-www-form-urlencoded</string> - <string id="request-method">GET</string> - <boolean id="show-dialog">1</boolean> - <boolean id="sim-cgi">0</boolean> - <boolean id="use-console">0</boolean> - <string id="userCGIEnvironment"></string> - <string id="userEnvironment"></string> - <string id="warnings">enabled</string> -</preference-set> -</preference-set> - <string id="lastInvocation">default</string> -</preference-set> -<preference-set idref="d92426a8-1235-4c1e-88ee-7501053cfacb"> -<preference-set id="Invocations"> -<preference-set id="default"> - <string id="cookieparams"></string> - <string id="cwd"></string> - <long id="debugger.io-port">9011</long> - <string id="documentRoot"></string> - <string id="executable-params"></string> - <string relative="path" id="filename">_test/object.t</string> - <string id="getparams"></string> - <string id="language">Perl</string> - <string id="mpostparams"></string> - <string id="params"></string> - <string id="postparams"></string> - <string id="posttype">application/x-www-form-urlencoded</string> - <string id="request-method">GET</string> - <boolean id="show-dialog">1</boolean> - <boolean id="sim-cgi">0</boolean> - <boolean id="use-console">0</boolean> - <string id="userCGIEnvironment"></string> - <string id="userEnvironment"></string> - <string id="warnings">enabled</string> -</preference-set> -</preference-set> - <string id="lastInvocation">default</string> -</preference-set> -<preference-set idref="da9d3317-c70c-485c-abf4-cd8bb1cba727"> -<preference-set id="Invocations"> -<preference-set id="default"> - <string id="cookieparams"></string> - <string id="cwd"></string> - <long id="debugger.io-port">9011</long> - <string id="documentRoot"></string> - <string id="executable-params"></string> - <string relative="path" id="filename">_test/object.t</string> - <string id="getparams"></string> - <string id="language">Perl</string> - <string id="mpostparams"></string> - <string id="params"></string> - <string id="postparams"></string> - <string id="posttype">application/x-www-form-urlencoded</string> - <string id="request-method">GET</string> - <boolean id="show-dialog">1</boolean> - <boolean id="sim-cgi">0</boolean> - <boolean id="use-console">0</boolean> - <string id="userCGIEnvironment"></string> - <string id="userEnvironment"></string> - <string id="warnings">enabled</string> -</preference-set> -</preference-set> - <string id="lastInvocation">default</string> -</preference-set> -<preference-set idref="dbdc5a72-bd97-4191-812d-cefac1b65891"> -<preference-set id="Invocations"> -<preference-set id="default"> - <string id="cookieparams"></string> - <string id="cwd"></string> - <long id="debugger.io-port">9011</long> - <string id="documentRoot"></string> - <string id="executable-params"></string> - <string relative="path" id="filename">_test/object.t</string> - <string id="getparams"></string> - <string id="language">Perl</string> - <string id="mpostparams"></string> - <string id="params"></string> - <string id="postparams"></string> - <string id="posttype">application/x-www-form-urlencoded</string> - <string id="request-method">GET</string> - <boolean id="show-dialog">1</boolean> - <boolean id="sim-cgi">0</boolean> - <boolean id="use-console">0</boolean> - <string id="userCGIEnvironment"></string> - <string id="userEnvironment"></string> - <string id="warnings">enabled</string> -</preference-set> -</preference-set> - <string id="lastInvocation">default</string> -</preference-set> -<preference-set idref="e999586b-011c-4db1-bf57-6bdede03ca91"> -<preference-set id="Invocations"> -<preference-set id="default"> - <string id="cookieparams"></string> - <string id="cwd"></string> - <long id="debugger.io-port">9011</long> - <string id="documentRoot"></string> - <string id="executable-params"></string> - <string relative="path" id="filename">_test/object.t</string> - <string id="getparams"></string> - <string id="language">Perl</string> - <string id="mpostparams"></string> - <string id="params"></string> - <string id="postparams"></string> - <string id="posttype">application/x-www-form-urlencoded</string> - <string id="request-method">GET</string> - <boolean id="show-dialog">1</boolean> - <boolean id="sim-cgi">0</boolean> - <boolean id="use-console">0</boolean> - <string id="userCGIEnvironment"></string> - <string id="userEnvironment"></string> - <string id="warnings">enabled</string> -</preference-set> -</preference-set> - <string id="lastInvocation">default</string> -</preference-set> -<preference-set idref="f1269b8e-02ae-42cc-98a6-6373ee338440"> -<preference-set id="Invocations"> -<preference-set id="default"> - <string id="cookieparams"></string> - <string id="cwd"></string> - <long id="debugger.io-port">9011</long> - <string id="documentRoot"></string> - <string id="executable-params"></string> - <string relative="path" id="filename">_test/object.t</string> - <string id="getparams"></string> - <string id="language">Perl</string> - <string id="mpostparams"></string> - <string id="params"></string> - <string id="postparams"></string> - <string id="posttype">application/x-www-form-urlencoded</string> - <string id="request-method">GET</string> - <boolean id="show-dialog">1</boolean> - <boolean id="sim-cgi">0</boolean> - <boolean id="use-console">0</boolean> - <string id="userCGIEnvironment"></string> - <string id="userEnvironment"></string> - <string id="warnings">enabled</string> -</preference-set> -</preference-set> - <string id="lastInvocation">default</string> -</preference-set> -<preference-set idref="f1aa4569-54e1-499d-a6f5-f4b27c1ed611"> -<preference-set id="Invocations"> -<preference-set id="default"> - <string id="cookieparams"></string> - <string id="cwd"></string> - <long id="debugger.io-port">9011</long> - <string id="documentRoot"></string> - <string id="executable-params"></string> - <string relative="path" id="filename">_test/object.t</string> - <string id="getparams"></string> - <string id="language">Perl</string> - <string id="mpostparams"></string> - <string id="params"></string> - <string id="postparams"></string> - <string id="posttype">application/x-www-form-urlencoded</string> - <string id="request-method">GET</string> - <boolean id="show-dialog">1</boolean> - <boolean id="sim-cgi">0</boolean> - <boolean id="use-console">0</boolean> - <string id="userCGIEnvironment"></string> - <string id="userEnvironment"></string> - <string id="warnings">enabled</string> -</preference-set> -</preference-set> - <string id="lastInvocation">default</string> -</preference-set> -</project>
--- a/lib/IMPL.pm Tue Apr 03 10:54:09 2018 +0300 +++ b/lib/IMPL.pm Tue May 15 00:51:01 2018 +0300 @@ -1,15 +1,5 @@ package IMPL; use strict; -use IMPL::_core qw(setDebug); -use IMPL::_core::version; - -sub import { - my ($opts) = @_; - - if (ref $opts eq 'HASH') { - setDebug($$opts{Debug}) if exists $$opts{Debug}; - } -} 1;
--- a/lib/IMPL/Config.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,291 +0,0 @@ -package IMPL::Config; -use strict; -use warnings; -use mro; - -use Carp qw(carp); - -use IMPL::lang qw(is); -use IMPL::Exception; -use IMPL::Const qw(:access); -use IMPL::declare { - require => { - PropertyInfo => 'IMPL::Class::PropertyInfo', - XmlFormatter => 'IMPL::Serialization::XmlFormatter', - Serializer => '-IMPL::Serializer', - Activator => '-IMPL::Config::Activator', - - Exception => 'IMPL::Exception', - IOException => '-IMPL::IOException' - }, - base => [ - 'IMPL::Object::Accessor' => undef, - 'IMPL::Object::Serializable' => undef, - 'IMPL::Object::Autofill' => '@_' - ] -}; - -use File::Spec(); - - -our $ConfigBase ||= ''; -our $AppBase; - -sub LoadXMLFile { - my ($self,$file) = @_; - - my $class = ref $self || $self; - - my $serializer = Serializer->new( - formatter => XmlFormatter->new( - IdentOutput => 1, - SkipWhitespace => 1 - ) - ); - - open my $hFile,'<',$file or die IOException->new("Failed to open file",$file,$!); - - my $obj; - eval { - $obj = $serializer->Deserialize($hFile); - }; - - if ($@) { - my $e=$@; - die Exception->new("Can't load the configuration file",$file,$e); - } - return $obj; -} - -sub SaveXMLFile { - my ($this,$file) = @_; - - my $serializer = Serializer->new( - formatter => XmlFormatter->new( - IdentOutput => 1, - SkipWhitespace => 1 - ) - ); - - open my $hFile,'>',$file or die IOException->new("Failed to open file",$file,$!); - - $serializer->Serialize($hFile, $this); -} - -sub xml { - my $this = shift; - my $serializer = Serializer->new( - formatter => XmlFormatter->new( - IdentOutput => 1, - SkipWhitespace => 1 - ) - ); - my $str = ''; - open my $hFile,'>',\$str or die IOException->new("Failed to open stream",$!); - - $serializer->Serialize($hFile, $this); - - undef $hFile; - - return $str; -} - -sub save { - my ($this,$ctx) = @_; - - my $val; - - $val = $this->rawGet($_) and $ctx->AddVar($_ => $val) foreach map $_->Name, $this->get_meta( - PropertyInfo, - sub { - $_->access == ACCESS_PUBLIC and - $_->setter; - }, - 1); -} - -sub spawn { - my ($this,$file) = @_; - unless ($file) { - ($file = ref $this || $this) =~ s/:+/./g; - $file .= ".xml"; - } - return $this->LoadXMLFile( File::Spec->catfile($ConfigBase,$file) ); -} - -sub get { - my $this = shift; - - if (@_ == 1) { - my $obj = $this->SUPER::get(@_); - return is($obj,Activator) ? $obj->activate : $obj; - } else { - my @objs = $this->SUPER::get(@_); - return map is($_,Activator) ? $_->activate : $_, @objs ; - } -} - -sub rawGet { - my $this = shift; - return $this->SUPER::get(@_); -} - -sub Exists { - $_[0]->SUPER::get($_[1]) ? 1 : 0; -} - -sub AppBase { - carp "obsolete"; - shift; - File::Spec->catdir($AppBase,@_); -} - -sub AppDir { - shift; - File::Spec->catdir($AppBase,@_); -} - -sub AppFile { - shift; - File::Spec->catfile($AppBase,@_); -} - -sub ConfigBase { - carp "obsolete"; - shift; - File::Spec->catdir($ConfigBase,@_); -} - -sub ConfigDir { - shift; - File::Spec->catdir($ConfigBase,@_); -} - -sub ConfigFile { - shift; - File::Spec->catfile($ConfigBase,@_); -} - -1; -__END__ - -=pod - -=head1 NAME - -C<IMPL::Config> - базовый класс для настраиваемого приложения. - -=head1 SYNOPSIS - -=begin code - -# define application - -package MyApp; -use parent qw(IMPL::Config); - -use IMPL::Class::Property; -use IMPL::Config::Class; - -BEGIN { - public property SimpleString => prop_all; - public property DataSource => prop_all; -} - -sub CTOR { - my $this = shift; - - $this->DataSource( - new IMPL::Config::Activator( - factory => 'MyDataSource', - parameters=>{ - host => 'localhost', - user => 'dbuser' - } - ) - ) unless $this->Exists('DataSource'); -} - -# using application object - -my $app = spawn MyApp('default.xml'); - -$app->Run(); - -=end code - -Ниже приведен пример файла C<default.xml> содержащего настройки приложения - -=begin code xml - -<app type='MyApp'> - <SimpleString>The application</SimpleString> - <DataSource type='IMPL::Config::Activator'> - <factory>MyDataSourceClass</factory> - <parameters type='HASH'> - <host>localhost</host> - <user>dbuser</user> - </parameters> - </DataSource> -</app> - -=end code xml - -=head1 DESCRIPTION - -C<[Serializable]> - -C<[Autofill]> - -C<use parent IMPL::Object::Accessor> - -Базовый класс для приложений. Использует подход, что приложение -является объектом, состояние которого предтавляет собой конфигурацию, -а методы - логику. - -Данный класс реализует функционал десериализации (и сериализации) экземпляра -приложения из XML документа. Для этого используется механизм C<IMPL::Serialization>. -При этом используются опции C<IMPL::Serialization::XmlFormatter> C<IdentOutput> и -C<SkipWhitespace> для записи документа в легко читаемом виде. - -Поскольку в результате восстановления приложения восстанавливаются все элементы -из файла конфигурации, то это может потребовать значительных ресурсов для -создания частей, которые могут никогда не понадобиться. Например, не требуется инициализация -источника данных для передачи пользователю статических данных, сохраненных на диске. - -Для решения этой проблемы используются специальные объекты C<IMPL::Config::Activator>. - -Если у приложения описано свойство, в котором хранится C<IMPL::Config::Activator>, то -при первом обращении к такому свойству, будет создан объект вызовом метода -C<< IMPL::Config::Activator->activate() >> и возвращен как значение этого свойства. -Таким образом реализуется прозрачная отложенная активация объектов, что позволяет -экономить ресурсы. - -=head1 MEMBERS - -=over - -=item C<[static] LoadXMLFile($fileName) > - -Создает из XML файла C<$fileName> экземпляр приложения - -=item C<SaveXMLFile($fileName)> - -Сохраняет приложение в файл C<$fileName> - -=item C<[get] xml > - -Сохраняет конфигурацию приложения в XML строку. - -=item C<[static,operator] spawn($file)> - -Синоним для C<LoadXMLFile>, предполагается использование как оператора. - -=item C<rawGet($propname,...)> - -Метод для получения значений свойств приложения. Данный метод позволяет избежать -использование активации объектов через C<IMPL::Config::Activator>. - -=back - -=cut
--- a/lib/IMPL/DOM/Document.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,132 +0,0 @@ -package IMPL::DOM::Document; -use strict; -use warnings; - -use IMPL::lang; -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - DOMNode => 'IMPL::DOM::Node' - }, - base => [ - DOMNode => '@_' - ], - props => [ - schemaDocument => PROP_RW - ] -}; - -sub document { - return $_[0]; -} - -sub Create { - my ($this,$nodeName,$class,$refProps) = @_; - - if ( ref $class eq 'HASH' ) { - $refProps = $class; - $class = undef; - } - - $class ||= DOMNode; - $refProps ||= {}; - - delete $refProps->{nodeName}; - - die new IMPL::Exception("class is not specified") unless $class; - return $class->new( - nodeName => $nodeName, - document => $this, - %$refProps - ); -} - -sub save { - my ($this,$writer) = @_; - - $writer->xmlDecl(undef,'yes'); - $this->SUPER::save($writer); - $writer->end(); -} - -{ - my $empty; - sub Empty() { - return $empty ? $empty : ($empty = __PACKAGE__->new(nodeName => 'Empty')); - } -} - -1; -__END__ - -=pod - -=head1 NAME - -C<IMPL::DOM::Document> DOM документ. - -=head1 DESCRIPTION - -Документ, позволяет создавать узлы определенных типов, что позволяет абстрагироваться -от механизмов реального создания объектов. Т.о. например C<IMPL::DOM::Navigator::Builder> -может формировать произвольные документы. - -=head1 SYNOPSIS - -=begin code - -package MyDocument; -use parent qw(IMPL::DOM::Document); - -sub Create { - my $this = shift; - my ($name,$class,$hashProps) = @_; - - if ($class eq 'Info') { - return MyInfo->new($name,$hashProps->{date},$hashProps->{description}); - } else { - # leave as it is - return $this->SUPER::Create(@_); - } -} - -=end code - -=head1 METHODS - -=over - -=item C< Create($nodeName,$class,$hashProps) > - -Реализация по умолчанию. Создает узел определеннго типа с определенным именем и свойствами. - -=begin code - -sub Create { - my ($this,$nodeName,$class,$hashProps) = @_; - - return $class->new ( - nodeName => $nodeName, - document => $this, - %$hashProps - ); -} - -=end code - -=item C< save($writer) > - -Сохраняет документ в виде XML узла и вызывает C<< $writer->end() >>. - -=over - -=item C<$writer> - -Объект с интерфейсом C<XML::Writer> который будет использован для записи -содержимого документа - -=back - -=back - -=cut
--- a/lib/IMPL/DOM/Navigator.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,276 +0,0 @@ -package IMPL::DOM::Navigator; -use strict; -use warnings; - -use parent qw(IMPL::Object); -use IMPL::Class::Property; -BEGIN { - private _direct property _path => prop_all; - private _direct property _state => prop_all; - private _direct property _savedstates => prop_all; - public property Current => {get => \&_getCurrent}; -} - -sub CTOR { - my ($this,$CurrentNode) = @_; - - die IMPL::InvalidArgumentException->new("A starting node is a required paramater") unless $CurrentNode; - - $this->{$_state} = { alternatives => [ $CurrentNode ], current => 0 }; -} - -sub _initNavigator { - my ($this,$CurrentNode) = @_; - - die IMPL::InvalidArgumentException->new("A starting node is a required paramater") unless $CurrentNode; - - $this->{$_state} = { alternatives => [ $CurrentNode ], current => 0 }; - delete $this->{$_path}; - delete $this->{$_savedstates}; -} - -sub _getCurrent { - $_[0]->{$_state}{alternatives}[$_[0]->{$_state}{current}] -} - -sub Navigate { - my ($this,@path) = @_; - - return unless @path; - - my $node; - - foreach my $query (@path) { - if (my $current = $this->Current) { - - my @alternatives = $current->selectNodes($query); - - unless (@alternatives) { - $current = $this->advanceNavigator or return; - @alternatives = $current->selectNodes($query); - } - - push @{$this->{$_path}},$this->{$_state}; - $this->{$_state} = { - alternatives => \@alternatives, - current => 0, - query => $query - }; - - $node = $alternatives[0]; - } else { - return; - } - } - - $node; -} - -sub selectNodes { - my ($this,@path) = @_; - - return $this->Current->selectNodes(@path); -} - -sub internalNavigateNodeSet { - my ($this,@nodeSet) = @_; - - push @{$this->{$_path}}, $this->{$_state}; - - $this->{$_state} = { - alternatives => \@nodeSet, - current => 0 - }; - - $nodeSet[0]; -} - -sub fetch { - my ($this) = @_; - - my $result = $this->Current; - $this->advanceNavigator; - return $result; -} - -sub advanceNavigator { - my ($this) = @_; - - $this->{$_state}{current}++; - - if (@{$this->{$_state}{alternatives}} <= $this->{$_state}{current}) { - if ( exists $this->{$_state}{query} ) { - my $query = $this->{$_state}{query}; - - $this->Back or return; # that meams the end of the history - - undef while ( $this->advanceNavigator and not $this->Navigate($query)); - - return $this->Current; - } - return; - } - - return $this->Current; -} - -sub doeach { - my ($this,$code) = @_; - local $_; - - do { - for (my $i = $this->{$_state}{current}; $i < @{$this->{$_state}{alternatives}}; $i++) { - $_ = $this->{$_state}{alternatives}[$i]; - $code->(); - } - $this->{$_state}{current} = @{$this->{$_state}{alternatives}}; - } while ($this->advanceNavigator); -} - -sub Back { - my ($this,$steps) = @_; - - if ($this->{$_path} and @{$this->{$_path}}) { - if ( (not defined $steps) || $steps == 1) { - $this->{$_state} = pop @{$this->{$_path}}; - } elsif ($steps > 0) { - $steps = @{$this->{$_path}} - 1 if $steps >= @{$this->{$_path}}; - - $this->{$_state} = (splice @{$this->{$_path}},-$steps)[0]; - } - $this->Current if defined wantarray; - } else { - return; - } -} - -sub PathToString { - my ($this,$delim) = @_; - - $delim ||= '/'; - - join($delim,map $_->{alternatives}[$_->{current}]->nodeName, $this->{$_path} ? (@{$this->{$_path}}, $this->{$_state}) : $this->{$_state}); -} - -sub pathLength { - my ($this) = @_; - $this->{$_path} ? scalar @{$this->{$_path}} : 0; -} - -sub GetNodeFromHistory { - my ($this,$index) = @_; - - if (my $state = $this->{$_path} ? $this->{$_path}->[$index] : undef ) { - return $state->{alternatives}[$state->{current}] - } else { - return; - } -} - -sub clone { - my ($this) = @_; - - my $newNavi = __PACKAGE__->surrogate; - - $newNavi->{$_path} = [ map { { %{ $_ } } } @{$this->{$_path}} ] if $this->{$_path}; - $newNavi->{$_state} = { %{$this->{$_state}} }; - - return $newNavi; - -} - -sub saveState { - my ($this) = @_; - - my %state; - - $state{path} = [ map { { %{ $_ } } } @{$this->{$_path}} ] if $this->{$_path}; - $state{state} = { %{$this->{$_state}} }; - - push @{$this->{$_savedstates}}, \%state; -} - -sub restoreState { - my ($this) = @_; - - if ( my $state = pop @{$this->{$_savedstates}||[]} ) { - $this->{$_path} = $state->{path}; - $this->{$_state} = $state->{state}; - } -} - -sub applyState { - my ($this) = @_; - - pop @{$this->{$_savedstates}||[]}; -} - -sub dosafe { - my ($this,$transaction) = @_; - - $this->saveState(); - - my $result; - - eval { - $result = $transaction->(); - }; - - if ($@) { - $this->restoreState(); - return; - } else { - $this->applyState(); - return $result; - } -} - -1; - -__END__ -=pod - -=head1 DESCRIPTION - -Объект для хождения по дереву DOM объектов. - -Результатом навигации является множество узлов (альтернатив). - -Состоянием навигатора является текущий набор узлов, позиция в данном наборе, -а также запрос по которому были получены данные результаты. - -Если при навигации указан путь сосящий из нескольких фильтров, то он разбивается -этапы простой навигации по кадой из частей пути. На каждом элементарном этапе -навигации образуется ряд альтернатив, и при каждом следующем этапе навигации -альтернативы предыдущих этапов могут перебираться, до получения положительного -результата навигации, в противном случае навигация считается невозможной. - -=head1 METHODS - -=over - -=item C<<$obj->new($nodeStart)>> - -Создает объект навигатора с указанной начальной позицией. - -=item C<<$obj->Navigate([$query,...])>> - -Перейти в новый узел используя запрос C<$query>. На данный момент запросом может -быть только имя узла и будет взят только первый узел. Если по запросу ничего не -найдено, переход не будет осуществлен. - -Возвращает либо новый узел в который перешли, либо C<undef>. - -=item C<<$obj->Back()>> - -Возвращается в предыдущий узел, если таковой есть. - -Возвращает либо узел в который перешли, либо C<undef>. - -=item C<<$obj->advanceNavigator()>> - -Переходит в следующую альтернативу, соответствующую текущему запросу. - -=back - -=cut
--- a/lib/IMPL/DOM/Navigator/Builder.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,167 +0,0 @@ -package IMPL::DOM::Navigator::Builder; -use strict; -use warnings; - -use IMPL::Const qw(:prop); - -use parent qw(IMPL::DOM::Navigator); -use IMPL::Class::Property; -require IMPL::DOM::Navigator::SchemaNavigator; -require IMPL::DOM::Schema::ValidationError; -use IMPL::DOM::Document; - -BEGIN { - private _direct property _schemaNavi => PROP_RW; - private _direct property _docClass => PROP_RW; - public _direct property Document => PROP_RO; - public _direct property ignoreUndefined => PROP_RO; -} - -our %CTOR = ( - 'IMPL::DOM::Navigator' => sub { IMPL::DOM::Document->Empty; } -); - -sub CTOR { - my ($this,$docClass,$schema,%opts) = @_; - - $this->{$_docClass} = $docClass; - $this->{$_schemaNavi} = $schema ? IMPL::DOM::Navigator::SchemaNavigator->new($schema) : undef; - - $this->{$ignoreUndefined} = $opts{ignoreUndefined} if $opts{ignoreUndefined}; -} - -sub NavigateCreate { - my ($this,$nodeName,%props) = @_; - - if (my $schemaType = $this->{$_schemaNavi}->NavigateName($nodeName)) { - my $class = $schemaType->can('nativeType') ? $schemaType->nativeType || 'IMPL::DOM::Node' : 'IMPL::DOM::Node'; - - my $schemaNode = $this->{$_schemaNavi}->SourceSchemaNode; - - $props{schemaType} = $schemaType; - $props{schemaNode} = $schemaNode; - - my $node; - if (! $this->{$Document}) { - # keep reference to the schema document - $props{schemaDocument} = $this->{$_schemaNavi}->schema; - $node = $this->{$Document} = $this->{$_docClass}->new(nodeName => $nodeName,%props); - $this->_initNavigator($node); - } else { - die new IMPL::InvalidOperationException('Can\'t create a second top level element') unless $this->Current; - $node = $this->{$Document}->Create($nodeName,$class,\%props); - $this->Current->appendChild($node); - $this->internalNavigateNodeSet($node); - } - - return $node; - } else { - die new IMPL::InvalidOperationException("The specified node is undefined", $nodeName) - if !$this->ignoreUndefined; - return; - } -} - -sub Back { - my ($this) = @_; - - $this->{$_schemaNavi}->SchemaBack(); - $this->SUPER::Back(); -} - -sub saveState { - my ($this) = @_; - - $this->{$_schemaNavi}->saveState; - $this->SUPER::saveState; -} - -sub restoreState { - my ($this) = @_; - - $this->{$_schemaNavi}->restoreState; - $this->SUPER::restoreState; -} - -sub document { - goto &Document; -} - -1; - -__END__ - -=pod - -=head1 NAME - -C< IMPL::DOM::Navigator::Builder > - Навигатор, строящий документ по указанной схеме. - -=head1 SYNOPSIS - -=begin code - -my $builder = new IMPL::DOM::Navigator::Builder(new MyApp::Document,$schema); -my $reader = new IMPL::DOM::XMLReader(Navigator => $builder); - -$reader->ParseFile("document.xml"); - -my @errors = $schema->Validate($builder->Document); - -=end code - -=head1 DESCRIPTION - -Построитель DOM документов по указанной схеме. Обычно используется в связке -с объектами для чтения такими как C<IMPL::DOM::XMLReader>. - -=head1 MEMBERS - -=head2 C< CTOR($classDocument,$schema, %opts) > - -Создает новый объект, принимает на вход класс документа (или фабрику, например -L<IMPL::Object::Factory>) и схему. В процессе процедуры построения документа -будет создан объект документа. - -Необязательные именованные параметры - -=over - -=item C<ignoreUndefined> - -C<NavigateCreate> не будет вызывать исключение, если запрашиваемый узел не -найден в схеме, но будет возвращать C<undef>. - -=back - -=head2 C< NavigateCreate($nodeName,%props) > - -Создает новый узел с указанным именем и переходит в него. В случае если в схеме -подходящий узел не найден, то вызывается исключение или будет возвращено -C<undef> см. C<ignoreUndefined>. - -При этом по имени узла ищется его схема, после чего определяется класс для -создания экземпляра узла и созданный узел доавляется в документ. При создании -нового узла используется метод документа C<< IMPL::DOM::Document->Create >> - -Свойства узла передаются при создании через параметр C<%props>, но имя -создаваемого узла НЕ может быть переопределено свойством C<nodeName>, оно будет -проигнорировано. - -Свойства узла будут преобразованы при помощи заданных в схеме заполнителей -C<inflator>. - -=head2 C<[get]document > - -Свойство, которое содержит документ по окончании процедуры построения. - -=head2 C<[get]buildErrors> - -Ошибки, возникшие в процессе построения документа. - -=head2 C<[get]ignoreUndefined> - -Опция, заданная при создании построителя, отвечающая за обработку узлов -не найденных в схеме. - -=cut
--- a/lib/IMPL/DOM/Navigator/SchemaNavigator.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,152 +0,0 @@ -package IMPL::DOM::Navigator::SchemaNavigator; -use strict; -use warnings; - -use IMPL::Class::Property; - -require IMPL::DOM::Schema::ComplexType; -require IMPL::DOM::Schema::NodeSet; -require IMPL::DOM::Schema::AnyNode; - -use IMPL::declare { - base => [ - 'IMPL::DOM::Navigator' => '@_' - ] -}; - -BEGIN { - public _direct property Schema => prop_get; - private _direct property _historySteps => prop_all; -} - -sub CTOR { - my ($this,$schema) = @_; - - $this->{$Schema} = $schema->isa('IMPL::DOM::Schema::ComplexNode') ? $schema->document : $schema; - - die new IMPL::InvalidArgumentException("A schema object is required") unless ref $this->{$Schema} && eval { $this->{$Schema}->isa('IMPL::DOM::Schema') }; -} - -my $schemaAnyNode = IMPL::DOM::Schema::ComplexType->new(type => '::AnyNodeType', nativeType => 'IMPL::DOM::ComplexNode')->appendRange( - IMPL::DOM::Schema::NodeSet->new()->appendRange( - IMPL::DOM::Schema::AnyNode->new() - ) -); - -sub NavigateName { - my ($this,$name) = @_; - - die new IMPL::InvalidArgumentException('name is required') unless defined $name; - - # perform a safe navigation - #return dosafe $this sub { - my $steps = 0; - # if we are currently in a ComplexNode, first go to it's content - if ($this->Current->isa('IMPL::DOM::Schema::ComplexNode')) { - # navigate to it's content - # ComplexNode - $this->internalNavigateNodeSet($this->Current->content); - $steps ++; - } - - # navigate to node - if ( - my $node = $this->Navigate( sub { - $_->isa('IMPL::DOM::Schema::Node') and ( - $_->name eq $name - or - $_->nodeName eq 'AnyNode' - or - ( $_->nodeName eq 'SwitchNode' and $_->selectNodes( sub { $_->name eq $name } ) ) - ) - }) - ) { - $steps ++; - if ($node->nodeName eq 'AnyNode') { - # if we navigate to the anynode - # assume it to be ComplexType by default - $node = $node->type ? $this->{$Schema}->resolveType($node->type) : $schemaAnyNode; - $this->internalNavigateNodeSet($node); - $steps ++; - } elsif ($node->nodeName eq 'SwitchNode') { - # if we are in the switchnode - # navigate to the target node - $node = $this->Navigate(sub { $_->name eq $name }); - $steps ++; - } - - die IMPL::Exception->new("A node is expected") - unless $node; - if ($node->nodeName eq 'Node') { - # if we navigate to a reference - # resolve it - $node = $this->{$Schema}->resolveType($node->type); - $this->internalNavigateNodeSet($node); - $steps++; - } - - push @{$this->{$_historySteps}},$steps; - - # return found node schema - return $node; - } else { - return; # abort navigation - } - #} -} - -sub SchemaBack { - my ($this) = @_; - - $this->Back(pop @{$this->{$_historySteps}}) if $this->{$_historySteps}; -} - -sub SourceSchemaNode { - my ($this) = @_; - - if ($this->Current->isa('IMPL::DOM::Schema::SimpleType') or - $this->Current->isa('IMPL::DOM::Schema::ComplexType') - ) { - # we are redirected - return $this->GetNodeFromHistory(-1); - } else { - return $this->Current; - } -} - -sub schema { - goto &Schema; -} - -1; -__END__ - -=pod - -=head1 DESCRIPTION - -Помимо стандартных методов навигации позволяет переходить по элементам документа, -который данной схемой описывается. - -=head1 METHODS - -=over - -=item C<NavigateName($name)> - -Переходит на схему узла с указанным именем. Тоесть использует свойство C<name>. - -=item C<SchemaBack> - -Возвращается на позицию до последней операции C<NavigateName>. Данный метод нужен -посокольку операция навигации по элементам описываемым схемой может приводить к -нескольким операциям навигации по самой схеме. - -=item C<SourceSchemaNode> - -Получает схему узла из которого было выполнено перенаправление, например, C<IMPL::DOM::Schema::Node>. -В остальных случаях совпадает со свойством C<Current>. - -=back - -=cut
--- a/lib/IMPL/DOM/Navigator/SimpleBuilder.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,40 +0,0 @@ -package IMPL::DOM::Navigator::SimpleBuilder; -use strict; -use warnings; - -use parent qw(IMPL::DOM::Navigator); - -use IMPL::Class::Property; - -require IMPL::DOM::Navigator::SchemaNavigator; -use IMPL::DOM::Document; - -BEGIN { - public _direct property Document => prop_get | owner_set; -} - -our %CTOR = ( - 'IMPL::DOM::Navigator' => sub { IMPL::DOM::Document::Empty; } -); - -sub NavigateCreate { - my ($this,$nodeName,%props) = @_; - - my $node; - if (! $this->{$Document}) { - $node = $this->{$Document} = IMPL::DOM::Document->new(nodeName => $nodeName,%props); - $this->_initNavigator($node); - } else { - die new IMPL::InvalidOperationException('Can create a second top level element') unless $this->Current; - $node = $this->{$Document}->Create($nodeName,'IMPL::DOM::Node',\%props); - $this->Current->appendChild($node); - $this->internalNavigateNodeSet($node); - } - return $node; -} - -sub inflateValue { - $_[1]; -} - -1;
--- a/lib/IMPL/DOM/Node.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,505 +0,0 @@ -package IMPL::DOM::Node; -use strict; -use warnings; - -use Scalar::Util qw(weaken); - -use IMPL::lang; -use IMPL::Object::List; - -use IMPL::Exception(); -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - PropertyInfo => '-IMPL::Class::PropertyInfo' - }, - base => [ - 'IMPL::Object' => undef - ], - props => [ - nodeName => PROP_RO | PROP_DIRECT, - document => PROP_RO | PROP_DIRECT, - isComplex => { get => \&_getIsComplex }, - nodeValue => PROP_RW | PROP_DIRECT, - childNodes => { get => \&_getChildNodes, isList => 1, direct => 1 }, - parentNode => PROP_RO | PROP_DIRECT, - schemaNode => PROP_RO | PROP_DIRECT, - schemaType => PROP_RO | PROP_DIRECT, - _propertyMap => PROP_RW | PROP_DIRECT - ] -}; - -our %Axes = ( - parent => \&selectParent, - siblings => \&selectSiblings, - child => \&childNodes, - document => \&selectDocument, - ancestor => \&selectAncestors, - descendant => \&selectDescendant -); - -sub CTOR { - my ($this,%args) = @_; - - $this->{$nodeName} = delete $args{nodeName} or die new IMPL::InvalidArgumentException("A name is required"); - $this->{$nodeValue} = delete $args{nodeValue} if exists $args{nodeValue}; - if ( exists $args{document} ) { - $this->{$document} = delete $args{document}; - weaken($this->{$document}); - } - - while ( my ($key,$value) = each %args ) { - $this->nodeProperty($key,$value); - } -} - -sub insertNode { - my ($this,$node,$pos) = @_; - - die new IMPL::InvalidOperationException("You can't insert the node to itselft") if $this == $node; - - $node->{$parentNode}->removeNode($node) if ($node->{$parentNode}); - - $this->childNodes->InsertAt($pos,$node); - - $node->_setParent( $this ); - - return $node; -} - -sub appendChild { - my ($this,$node) = @_; - - die new IMPL::InvalidOperationException("You can't insert the node to itselft") if $this == $node; - - $node->{$parentNode}->removeNode($node) if ($node->{$parentNode}); - - my $children = $this->childNodes; - $children->Push($node); - - $node->_setParent( $this ); - - return $node; -} - -sub appendNode { - goto &appendChild; -} - -sub appendRange { - my ($this,@range) = @_; - - die new IMPL::InvalidOperationException("You can't insert the node to itselft") if grep $_ == $this, @range; - - foreach my $node (@range) { - $node->{$parentNode}->removeNode($node) if ($node->{$parentNode}); - $node->_setParent( $this ); - } - - $this->childNodes->Push(@range); - - return $this; -} - -sub _getChildNodes { - my ($this) = @_; - - $this->{$childNodes} = new IMPL::Object::List() unless $this->{$childNodes}; - return wantarray ? @{ $this->{$childNodes} } : $this->{$childNodes}; -} - -sub childNodesRef { - my ($this) = @_; - return scalar $this->_getChildNodes; -} - -sub removeNode { - my ($this,$node) = @_; - - if ($this == $node->{$parentNode}) { - $this->childNodes->RemoveItem($node); - $node->_setParent(undef); - return $node; - } else { - die new IMPL::InvalidOperationException("The specified node isn't belong to this node"); - } -} - -sub replaceNodeAt { - my ($this,$index,$node) = @_; - - my $nodeOld = $this->childNodes->[$index]; - - die new IMPL::InvalidOperationException("You can't insert the node to itselft") if $this == $node; - - # unlink node from previous parent - $node->{$parentNode}->removeNode($node) if ($node->{$parentNode}); - - # replace (or set) old node - $this->childNodes->[$index] = $node; - - # set new parent - $node->_setParent( $this ); - - # unlink old node if we have one - $nodeOld->_setParent(undef) if $nodeOld; - - # return old node - return $nodeOld; -} - -sub removeAt { - my ($this,$pos) = @_; - - if ( my $node = $this->childNodes->RemoveAt($pos) ) { - $node->_setParent(undef); - return $node; - } else { - return undef; - } -} - -sub removeLast { - my ($this) = @_; - - if ( my $node = $this->{$childNodes} ? $this->{$childNodes}->RemoveLast() : undef) { - $node->_setParent(undef); - return $node; - } else { - return undef; - } -} - -sub removeSelected { - my ($this,$query) = @_; - - my @newSet; - my @result; - - if (ref $query eq 'CODE') { - &$query($_) ? push @result, $_ : push @newSet, $_ foreach @{$this->childNodes}; - } elsif (defined $query) { - $_->nodeName eq $query ? push @result, $_ : push @newSet, $_ foreach @{$this->childNodes}; - } else { - my $children = $this->childNodes; - $_->_setParent(undef) foreach @$children; - delete $this->{$childNodes}; - return wantarray ? @$children : $children; - } - - $_->_setParent(undef) foreach @result; - - $this->{$childNodes} = @newSet ? bless \@newSet ,'IMPL::Object::List' : undef; - - return wantarray ? @result : \@result; -} - -sub resolveAxis { - my ($this,$axis) = @_; - return $Axes{$axis}->($this) -} - -sub selectNodes { - my $this = shift; - my $path; - - if (@_ == 1) { - $path = $this->translatePath($_[0]); - } else { - $path = [@_]; - } - - my @set = ($this); - - while (@$path) { - my $query = shift @$path; - @set = map $_->selectNodesAxis($query), @set; - } - - return wantarray ? @set : \@set; -} - -sub selectSingleNode { - my $this = shift; - my @result = $this->selectNodes(@_); - return $result[0]; -} - -sub selectNodesRef { - my $this = shift; - - my @result = $this->selectNodes(@_); - return \@result; -} - -sub translatePath { - my ($this,$path) = @_; - - # TODO: Move path compilation here from IMPL::DOM::Schema::Validator::Compare - return [$path]; -} - -sub selectNodesAxis { - my ($this,$query,$axis) = @_; - - $axis ||= 'child'; - - die new IMPL::InvalidOperationException('Unknown axis',$axis) unless exists $Axes{$axis}; - - my $nodes = $this->resolveAxis($axis); - - my @result; - - if (ref $query eq 'CODE') { - @result = grep &$query($_), @{$nodes}; - } elsif (ref $query eq 'ARRAY' ) { - my %keys = map (($_,1),@$query); - @result = grep $keys{$_->nodeName}, @{$nodes}; - } elsif (ref $query eq 'HASH') { - while( my ($axis,$filter) = each %$query ) { - push @result, $this->selectNodesAxis($filter,$axis); - } - } elsif (defined $query) { - @result = grep $_->nodeName eq $query, @{$nodes}; - } else { - return wantarray ? @{$nodes} : $nodes; - } - - return wantarray ? @result : \@result; -} - -sub selectParent { - my ($this) = @_; - - if ($this->parentNode) { - return wantarray ? $this->parentNode : [$this->parentNode]; - } else { - return wantarray ? () : []; - } -} - -sub selectSiblings { - my ($this) = @_; - - if ($this->parentNode) { - return $this->parentNode->selectNodes( sub { $_ != $this } ); - } else { - return wantarray ? () : []; - } -} - -sub selectDocument { - my ($this) = @_; - - if ($this->document) { - return wantarray ? $this->document : [$this->document]; - } else { - return wantarray ? () : []; - } -} - -sub selectDescendant { - wantarray ? - map $_->selectAll(), $_[0]->childNodes : - [map $_->selectAll(), $_[0]->childNodes] -} - -sub selectAll { - map(selectAll($_),@{$_[0]->childNodes}) , $_[0] -} - -sub selectAncestors { - my $parent = $_[0]->parentNode; - - wantarray ? - ($parent ? ($parent->selectAncestors,$parent) : ()) : - [$parent ? ($parent->selectAncestors,$parent) : ()] -} - -sub firstChild { - @_ >=2 ? $_[0]->replaceNodeAt(0,$_[1]) : $_[0]->childNodes->[0]; -} - -sub _getIsComplex { - ($_[0]->{$childNodes} and $_[0]->{$childNodes}->Count) ? 1 : 0; -} - -sub _updateDocRefs { - my ($this) = @_; - - # this method is called by the parent node on his children, so we need no to check parent - $this->{$document} = $this->{$parentNode}->document; - - # prevent cyclic - weaken($this->{$document}) if $this->{$document}; - - map $_->_updateDocRefs, @{$this->{$childNodes}} if $this->{$childNodes}; -} - -sub _setParent { - my ($this,$node) = @_; - - - if (($node || 0) != ($this->{$parentNode} || 0)) { - my $newOwner; - if ($node) { - $this->{$parentNode} = $node; - $newOwner = $node->document || 0; - - # prevent from creating cyclicreferences - weaken($this->{$parentNode}); - - } else { - delete $this->{$parentNode}; - - #keep document - $newOwner = $this->{$document}; - } - - if (($this->{$document}||0) != $newOwner) { - $this->{$document} = $newOwner; - weaken($this->{$document}) if $newOwner; - $_->_updateDocRefs foreach @{$this->childNodes}; - } - } -} - -sub text { - my ($this) = @_; - - join ('', $this->nodeValue || '', map ($_->text || '', @{$this->childNodes})); -} - -sub nodeProperty { - my $this = shift; - my $name = shift; - - return unless defined $name; - - if (my $method = $this->can($name)) { - unshift @_,$this; - # use goto to preserve calling context - goto &$method; - } - # dynamic property - if (@_) { - # set - return $this->{$_propertyMap}{$name} = shift; - } else { - return $this->{$_propertyMap}{$name}; - } -} - -sub listProperties { - my ($this) = @_; - - my %props = map {$_->name, 1} $this->GetMeta(PropertyInfo, sub { $_->attributes->{dom} },1); - - return (keys %props,keys %{$this->{$_propertyMap}}); -} - -sub save { - my ($this,$writer) = @_; - - if ( not ( $this->isComplex or defined $this->{$nodeValue} ) ) { - $writer->emptyTag( - $this->{$nodeName}, - map { - $_, - $this->nodeProperty($_) - } grep defined $this->nodeProperty($_), $this->listProperties - ); - } else { - $writer->startTag( - $this->{$nodeName}, - map { - $_, - $this->nodeProperty($_) - } grep defined $this->nodeProperty($_), $this->listProperties - ); - $writer->characters($this->{$nodeValue}) if $this->{$nodeValue}; - - $_->save($writer) foreach $this->childNodes; - - $writer->endTag($this->{$nodeName}); - } -} - -sub qname { - $_[0]->{$nodeName}; -} - -sub path { - my ($this) = @_; - - if ($this->parentNode) { - return $this->parentNode->path.'.'.$this->qname; - } else { - return $this->qname; - } -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::DOM::Node> Элемент DOM модели - -=head1 DESCRIPTION - -Базовый узел DOM модели. От него можно наследовать другие элементы DOM модели. - -=head1 MEMBERS - -=head2 PROPERTIES - -=over - -=item C<[get] nodeName> - -Имя узла. Задается при создании. - -=item C<[get] document> - -Документ к которому принадлежит узел. Задается при поздании узла. - -=item C<[get] isComplex> - -Определяет является ли узел сложным (тоесть есть ли дети). - -C<true> - есть, C<false> - нет. - -=item C<[get,set] nodeValue> - -Значение узла, обычно простой скаляр, но ничто не мешает туда -устанавливать любое значение. - -=item C<[get,list] childNodes> - -Список детей, является списокм C<IMPL::Object::List>. - -=item C<[get] parentNode> - -Ссылка на родительский элемент, если таковой имеется. - -=item C<[get] schemaType> - -Ссылка на узел из C<IMPL::DOM::Schema>, представляющий схему данных текущего узла. Может быть C<undef>. - -=item C<[get] schemaNode> - -Ссылка на узел из C<IMPL::DOM::Schema>, представляющий элемент схемы, объявляющий данный узел. Может быть C<undef>. - -Отличается от свойства C<schemaType> тем, что узел в случае ссылки на тип узла, данной свойство будет содержать -описание ссылки C<IMPL::DOM::Schema::Node>, а свойство C<schema> например будет ссылаться на -C<IMPL::DOM::Schema::ComplexType>. - -=back - -=head2 METHODS - -=cut
--- a/lib/IMPL/DOM/Property.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,37 +0,0 @@ -package IMPL::DOM::Property; -use strict; -use warnings; - -require IMPL::Exception; - -use parent qw(Exporter); -our @EXPORT_OK = qw(_dom); - -sub _dom($) { - my ($prop_info) = @_; - $prop_info->{dom} = 1; - return $prop_info; -} - -1; -__END__ -=pod - -=head1 SYNOPSIS - -package TypedNode; - -use parent qw(IMPL::DOM::Node); -use IMPL::DOM::Property qw(_dom); - -BEGIN { - public _dom property Age => prop_all; - public _dom property Address => prop_all; - public property ServiceData => prop_all; -} - -=head1 DESCRIPTION - -Позволяет объявлять свойства, которые будут видны в списке свойств. - -=cut
--- a/lib/IMPL/DOM/Schema.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,371 +0,0 @@ -package IMPL::DOM::Schema; -use strict; -use warnings; - -use File::Spec; -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - ComplexNode => 'IMPL::DOM::Schema::ComplexNode', - ComplexType => 'IMPL::DOM::Schema::ComplexType', - SimpleNode => 'IMPL::DOM::Schema::SimpleNode', - SimpleType => 'IMPL::DOM::Schema::SimpleType', - Node => 'IMPL::DOM::Schema::Node', - AnyNode => 'IMPL::DOM::Schema::AnyNode', - NodeList => 'IMPL::DOM::Schema::NodeList', - NodeSet => 'IMPL::DOM::Schema::NodeSet', - Property => 'IMPL::DOM::Schema::Property', - SwitchNode => 'IMPL::DOM::Schema::SwitchNode', - Validator => 'IMPL::DOM::Schema::Validator', - Builder => 'IMPL::DOM::Navigator::Builder', - XMLReader => 'IMPL::DOM::XMLReader', # XMLReader references Schema - Loader => 'IMPL::Code::Loader', - StringMap => 'IMPL::Resources::StringLocaleMap' - }, - base => [ - 'IMPL::DOM::Document' => sub { - nodeName => 'schema' - } - ], - props => [ - _typesMap => PROP_RW | PROP_DIRECT, - baseDir => PROP_RW | PROP_DIRECT, - schemaName => PROP_RW | PROP_DIRECT, - baseSchemas => PROP_RO | PROP_LIST | PROP_DIRECT, - stringMap => { - get => '_getStringMap', - direct => 1 - } - ] -}; - -my $validatorLoader = Loader->new(prefix => Validator, verifyNames => 1); - -#TODO rename and remove -sub resolveType { - goto &ResolveType; -} - -sub CTOR { - my ($this,%args) = @_; - - $this->{$baseDir} = ($args{baseDir} || '.'); -} - -# compat -sub ResolveType { - my ($this,$typeName) = @_; - - my $type = $this->{$_typesMap}{$typeName}; - return $type if $type; - - foreach my $base ($this->baseSchemas) { - last if $type = $base->ResolveType($typeName); - } - - die IMPL::KeyNotFoundException->new($typeName) - unless $type; - return $this->{$_typesMap}{$typeName} = $type; -} - -sub Create { - my ($this,$nodeName,$class,$refArgs) = @_; - - die new IMPL::Exception('Invalid node class') unless $class->isa('IMPL::DOM::Node'); - - if ($class->isa('IMPL::DOM::Schema::Validator')) { - $class = $validatorLoader->GetFullName($nodeName); - unless (eval {$class->can('new')}) { - eval { - $validatorLoader->Require($nodeName); - }; - my $e = $@; - die new IMPL::Exception("Invalid validator",$class,$e) if $e; - } - } - - return $this->SUPER::Create($nodeName,$class,$refArgs); -} - -sub _getStringMap { - my ($this) = @_; - - return $this->{$stringMap} - if $this->{$stringMap}; - - my $map = StringMap->new(); - if ($this->baseDir and $this->schemaName) { - - $map->paths( File::Spec->catdir($this->baseDir,'locale') ); - $map->name( $this->schemaName ); - } - - return $this->{$stringMap} = $map; -} - -sub Process { - my ($this) = @_; - - # process instructions - $this->Include($_) foreach map $_->nodeProperty('source'), $this->selectNodes('Include'); - - # build types map - $this->{$_typesMap} = { map { $_->type, $_ } $this->selectNodes(sub { $_[0]->nodeName eq 'ComplexType' || $_[0]->nodeName eq 'SimpleType' } ) }; -} - -sub Include { - my ($this,$file) = @_; - - my $schema = $this->LoadSchema(File::Spec->catfile($this->baseDir, $file)); - - $this->baseSchemas->Push( $schema ); -} - -sub LoadSchema { - my ($this,$file) = @_; - - $file = File::Spec->rel2abs($file); - - my $class = ref $this || $this; - - my $reader = XMLReader->new( - Navigator => Builder->new( - $class, - $class->MetaSchema - ), - SkipWhitespace => 1 - ); - - $reader->ParseFile($file); - - my $schema = $reader->Navigator->Document; - - my ($vol,$dir,$name) = File::Spec->splitpath($file); - - $name =~ s/\.xml$//; - - $schema->baseDir($dir); - $schema->schemaName($name); - - my @errors = $class->MetaSchema->Validate($schema); - - die new IMPL::Exception("Schema is invalid",$file,map( $_->message, @errors ) ) if @errors; - - $schema->Process; - - return $schema; -} - -sub Validate { - my ($this,$node) = @_; - - if ( my ($schemaNode) = $this->selectNodes(sub { $_->isa(Node) and $_[0]->name eq $node->nodeName })) { - $schemaNode->Validate($node); - } else { - return new IMPL::DOM::Schema::ValidationError(node => $node, message=> "A specified document (%Node.nodeName%) doesn't match the schema"); - } -} - -my $schema; - -sub MetaSchema { - - return $schema if $schema; - - $schema = __PACKAGE__->new(); - - $schema->appendRange( - ComplexNode->new(name => 'schema')->appendRange( - NodeSet->new()->appendRange( - Node->new(name => 'ComplexNode', type => 'ComplexNode', minOccur => 0, maxOccur=>'unbounded'), - Node->new(name => 'ComplexType', type => 'ComplexType', minOccur => 0, maxOccur=>'unbounded'), - Node->new(name => 'SimpleNode', type => 'SimpleNode', minOccur => 0, maxOccur=>'unbounded'), - Node->new(name => 'SimpleType', type => 'SimpleType', minOccur => 0, maxOccur=>'unbounded'), - Node->new(name => 'Node', type => 'Node', minOccur => 0, maxOccur=>'unbounded'), - SimpleNode->new(name => 'Include', minOccur => 0, maxOccur=>'unbounded')->appendRange( - Property->new(name => 'source') - ) - ), - ), - ComplexType->new(type => 'NodeSet', nativeType => 'IMPL::DOM::Schema::NodeSet')->appendRange( - NodeSet->new()->appendRange( - Node->new(name => 'ComplexNode', type => 'ComplexNode', minOccur => 0, maxOccur=>'unbounded'), - Node->new(name => 'SimpleNode', type => 'SimpleNode', minOccur => 0, maxOccur=>'unbounded'), - Node->new(name => 'Node', type=>'Node', minOccur => 0, maxOccur=>'unbounded'), - SwitchNode->new(minOccur => 0, maxOccur => 1)->appendRange( - Node->new(name => 'AnyNode', type => 'AnyNode'), - Node->new(name => 'SwitchNode',type => 'SwitchNode') - ) - ) - ), - ComplexType->new(type => 'SwitchNode', nativeType => 'IMPL::DOM::Schema::SwitchNode')->appendRange( - NodeSet->new()->appendRange( - Node->new(name => 'ComplexNode', type=>'ComplexNode', minOccur => 0, maxOccur=>'unbounded'), - Node->new(name => 'SimpleNode', type=>'SimpleNode', minOccur => 0, maxOccur=>'unbounded'), - Node->new(name => 'Node', type=>'Node', minOccur => 0, maxOccur=>'unbounded'), - ) - ), - ComplexType->new(type => 'NodeList', nativeType => 'IMPL::DOM::Schema::NodeList')->appendRange( - NodeSet->new()->appendRange( - Node->new(name => 'ComplexNode', type => 'ComplexNode', minOccur => 0, maxOccur=>'unbounded'), - Node->new(name => 'SimpleNode', type => 'SimpleNode', minOccur => 0, maxOccur=>'unbounded'), - Node->new(name => 'SwitchNode',type => 'SwitchNode', minOccur => 0, maxOccur=>'unbounded'), - Node->new(name => 'Node', type => 'Node', minOccur => 0, maxOccur=>'unbounded'), - Node->new(name => 'AnyNode', type => 'AnyNode', minOccur => 0, maxOccur=>'unbounded'), - ) - ), - ComplexType->new(type => 'ComplexType', nativeType => 'IMPL::DOM::Schema::ComplexType')->appendRange( - NodeList->new()->appendRange( - SwitchNode->new()->appendRange( - Node->new(name => 'NodeSet', type => 'NodeSet'), - Node->new(name => 'NodeList',type => 'NodeList'), - ), - Node->new(name => 'Property', type=>'Property', maxOccur=>'unbounded', minOccur=>0), - AnyNode->new(maxOccur => 'unbounded', minOccur => 0, type=>'Validator') - ), - Property->new(name => 'type') - ), - ComplexType->new(type => 'ComplexNode', nativeType => 'IMPL::DOM::Schema::ComplexNode')->appendRange( - NodeList->new()->appendRange( - SwitchNode->new()->appendRange( - Node->new(name => 'NodeSet', type => 'NodeSet'), - Node->new(name => 'NodeList',type => 'NodeList'), - ), - Node->new(name => 'Property', type=>'Property', maxOccur=>'unbounded', minOccur=>0), - AnyNode->new(maxOccur => 'unbounded', minOccur => 0, type=>'Validator') - ), - Property->new(name => 'name') - ), - ComplexType->new(type => 'SimpleType', nativeType => 'IMPL::DOM::Schema::SimpleType')->appendRange( - NodeList->new()->appendRange( - Node->new(name => 'Property', type=>'Property', maxOccur=>'unbounded', minOccur=>0), - AnyNode->new(maxOccur => 'unbounded', minOccur => 0, type=>'Validator') - ), - Property->new(name => 'type') - ), - ComplexType->new(type => 'SimpleNode', nativeType => 'IMPL::DOM::Schema::SimpleNode')->appendRange( - NodeList->new()->appendRange( - Node->new(name => 'Property', type=>'Property', maxOccur=>'unbounded', minOccur=>0), - AnyNode->new(maxOccur => 'unbounded', minOccur => 0, type=>'Validator') - ), - Property->new(name => 'name') - ), - ComplexType->new(type => 'Validator', nativeType => 'IMPL::DOM::Schema::Validator')->appendRange( - NodeList->new()->appendRange( - AnyNode->new(maxOccur => 'unbounded', minOccur => 0) - ) - ), - ComplexType->new(type => 'Property', nativeType => 'IMPL::DOM::Schema::Property' )->appendRange( - NodeList->new()->appendRange( - AnyNode->new(maxOccur => 'unbounded', minOccur => 0) - ), - Property->new(name => 'name') - ), - SimpleType->new(type => 'Node', nativeType => 'IMPL::DOM::Schema::Node')->appendRange( - Property->new(name => 'name'), - Property->new(name => 'type') - ), - SimpleType->new(type => 'AnyNode', nativeType => 'IMPL::DOM::Schema::AnyNode') - ); - - $schema->Process; - - return $schema; -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::DOM::Schema> - Схема документа. - -=head1 DESCRIPTION - -C<use parent qw(IMPL::DOM::Document)> - -DOM схема - это документ, состоящий из определенных узлов, описывающая структуру -других документов. - -=head1 METHODS - -=over - -=item C<< $obj->Process() >> - -Обновляет таблицу типов из содержимого. - -=item C<< $obj->ResolveType($typeName) >> - -Возвращает схему типа c именем C<$typeName>. - -=back - -=head1 META SCHEMA - -Схема для описания схемы, эта схема используется для постороения других схем, выглядит приблизительно так - -=begin code xml - -<schema> - <ComplexNode name="schema"> - <NodeSet> - <Node minOcuur="0" maxOccur="unbounded" name="ComplexNode" type="ComplexNode"/> - <Node minOcuur="0" maxOccur="unbounded" name="SimpleNode" type="SimpleNode"/> - <Node minOcuur="0" maxOccur="unbounded" name="ComplexType" type="ComplexType"/> - <Node minOcuur="0" maxOccur="unbounded" name="SimpleType" type="SimpleType"/> - <SimpleNode minOcuur="0" maxOccur="unbounded" name="Node"/> - <SimpleNode minOcuur="0" maxOccur="unbounded" name="Include"/> - </NodeSet> - </ComplexNode> - - <ComplexType type="NodeContainer"> - <NodeSet> - <Node minOcuur="0" maxOccur="unbounded" name="ComplexNode" type="ComplexNode"/> - <Node minOcuur="0" maxOccur="unbounded" name="SimpleNode" type="SimpleNode"/> - <SimpleNode minOcuur="0" maxOccur="unbounded" name="Node"/> - </NodeSet> - </ComplexType> - - <ComplexType type="ComplexType"> - <NodeList> - <Node name="NodeSet" type="NodeContainer" minOcuur=0/> - <Node name="NodeList" type="NodeContainer" minOccur=0/> - <AnyNode minOccur="0" maxOccur="unbounded" type="Validator"/> - </NodeList> - </ComplexType> - - <ComplexType type="ComplexNode"> - <NodeList> - <Node name="NodeSet" type="NodeContainer" minOcuur=0/> - <Node name="NodeList" type="NodeContainer" minOccur=0/> - <AnyNode minOccur="0" maxOccur="unbounded" type="Validator"/> - </NodeList> - </ComplexType> - - <ComplexType type="SimpleNode"> - <NodeSet> - <AnyNode minOccur=0 maxOccur="unbounded" type="Validator"/> - </NodeSet> - </ComplexType> - - <ComplexType type="SimpleType"> - <NodeSet> - <AnyNode minOccur=0 maxOccur="unbounded" type="Validator"/> - </NodeSet> - </ComplexType> - - <ComplexType type="Validator"> - <NodeSet> - <AnyNode minOccur=0 maxOccur="unbounded"/> - </NodeSet> - </ComplexType> - -</schema> - -=end code xml - -=cut
--- a/lib/IMPL/DOM/Schema/AnyNode.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,42 +0,0 @@ -package IMPL::DOM::Schema::AnyNode; -use strict; -use warnings; - -use IMPL::declare { - base => [ - 'IMPL::DOM::Schema::Node' => sub { - my %args = @_; - $args{nodeName} ||= 'AnyNode'; - $args{name} = '::any'; - - %args; - } - ] -}; - -1; - -__END__ - -=pod - -=head1 DESCRIPTION - -Узел с произвольным именем, для этого узла предусмотрена специальная проверка -в контейнерах. - -В контейнерах типа C<IMPL::DOM::Schema::NodeSet> этот узел можно использовать только один раз -причем его использование исключает использование узла C<IMPL::DOM::Schema::SwitchNode>. - -В контейнерах типа С<IMPL::DOM::Schema::NodeList> данный узел может применяться несколько раз -для решения таких задач как последовательности разноименных узлов с одним типом. - -<NodeList> - <SimpleNode name="firstName"/> - <SimpleNode name="age"/> - <AnyNode type="Notes" minOccur="0" maxOccur="unbounded"/> - <Node name="primaryAddress" type="Address"/> - <AnyNode/> -</NodeList> - -=cut
--- a/lib/IMPL/DOM/Schema/ComplexNode.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,62 +0,0 @@ -package IMPL::DOM::Schema::ComplexNode; -use strict; -use warnings; - -use IMPL::declare { - base => [ - 'IMPL::DOM::Schema::Node' => sub {my %args = @_; $args{nodeName} ||= 'ComplexNode'; %args } - ], - props => [ - content => { - get => \&_getContent, - set => \&_setContent - } - ] -}; - - -sub _getContent { - $_[0]->firstChild; -} - -sub _setContent { - $_[0]->firstChild($_[1]); -} - -sub Validate { - my ($this,$node,$ctx) = @_; - - # для случаев анонимных типов, указанных прямо в узле - $ctx->{schemaNode} ||= $this; - $ctx->{schemaType} = $this; - - map $_->Validate($node,$ctx), @{$this->childNodes}; -} - -1; - -__END__ - -=pod - -=head1 DESCRIPTION - -Описывает сложный узел. Требует либо соответствие структуры, либо соответствия -типу. - -Дочерними элементами могут быть правила контроля свойств и т.п. -Первым дочерним элементом может быть только содержимое узла, см. C<content> - -=head2 PROPERTIES - -=over - -=item C<content> - -Содержимое узла, может быть либо C<IMPL::DOM::Schema::NodeSet> либо -C<IMPL::DOM::Schema::NodeList>, в зависимости от того важен порядок или нет. -Это свойство ссылается на первый дочерний элемент узла. - -=back - -=cut
--- a/lib/IMPL/DOM/Schema/ComplexType.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,64 +0,0 @@ -package IMPL::DOM::Schema::ComplexType; -use strict; -use warnings; - -use IMPL::declare { - require => { - Label => 'IMPL::DOM::Schema::Label', - ValidationError => 'IMPL::DOM::Schema::ValidationError' - }, - base => [ - 'IMPL::DOM::Schema::ComplexNode' => sub { - my %args = @_; - $args{nodeName} ||= 'ComplexType'; - $args{minOccur} = 0; - $args{maxOccur} = 'unbounded'; - $args{name} ||= 'ComplexType'; - delete @args{qw(nativeType messageWrongType)}; - %args - } - ], - props => [ - nativeType => { get => 1, set => 1, direct => 1, dom => 1 }, - messageWrongType => { get => 1, set => 1, direct => 1, dom => 1 } - ] -}; - -sub CTOR { - my ($this,%args) = @_; - - $this->{$nativeType} = $args{nativeType}; - $this->{$messageWrongType} = $args{messageWrongType} || "A complex node '%node.path%' is expected to be %schemaType.nativeType%"; -} - -sub Validate { - my ($this, $node,$ctx) = @_; - - if ($this->{$nativeType}) { - return ValidationError->new ( - node => $node, - schemaNode => $ctx->{schemaNode} || $this, - schemaType => $this, - message => $this->_MakeLabel($this->messageWrongType) - ) unless $node->isa($this->{$nativeType}); - } - - return $this->SUPER::Validate($node,$ctx); -} - -sub qname { - $_[0]->nodeName.'[type='.$_[0]->type.']'; -} - -sub _MakeLabel { - my ($this,$label) = @_; - - if ($label =~ /^ID:(\w+)$/) { - return Label->new($this->document->stringMap, $1); - } else { - return $label; - } -} - - -1;
--- a/lib/IMPL/DOM/Schema/Label.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,59 +0,0 @@ -package IMPL::DOM::Schema::Label; -use strict; -use overload - '""' => 'ToString', - 'bool' => sub { return 1; }, - 'fallback' => 1; - -use IMPL::Const qw(:prop); -use IMPL::Exception(); -use IMPL::declare { - require => { - ArgException => '-IMPL::InvalidArgumentException' - }, - base => [ - 'IMPL::Object' => undef - ], - props => [ - _map => PROP_RW, - _id => PROP_RW - ] -}; - -sub CTOR { - my ($this,$map,$id) = @_; - - die ArgException->new('map' => 'A strings map is required') - unless $map; - die ArgException->new('id' => 'A lable identifier is required') - unless $id; - - $this->_map($map); - $this->_id($id); -} - -our $AUTOLOAD; -sub AUTOLOAD { - my ($this) = @_; - - my ($method) = ($AUTOLOAD =~ /(\w+)$/); - return - if $method eq 'DESTROY'; - - warn $this->_id . ".$method"; - - return $this->new($this->_map,$this->_id . ".$method"); -} - -sub ToString { - my ($this) = @_; - return $this->_map->GetString($this->_id); -} - -sub Format { - my ($this,$args) = @_; - - return $this->_map->GetString($this->_id,$args); -} - -1; \ No newline at end of file
--- a/lib/IMPL/DOM/Schema/Node.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,124 +0,0 @@ -package IMPL::DOM::Schema::Node; -use strict; -use warnings; - -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - Label => 'IMPL::DOM::Schema::Label' - }, - base => [ - 'IMPL::DOM::Node' => sub { - my %args = @_; - delete @args{qw( - minOccur - maxOccur - type - name - )} ; - $args{nodeName} ||= 'Node'; - %args - } - ], - props => [ - minOccur => { get => 1, set => 1, direct => 1, dom => 1}, - maxOccur => { get => 1, set => 1, direct => 1, dom => 1}, - type => { get => 1, set => 1, direct => 1, dom => 1}, - name => { get => 1, set => 1, direct => 1, dom => 1}, - label => { get => '_getLabel', direct => 1 } - ] -}; - -sub _getLabel { - my ($this) = @_; - - $this->{$label} ||= Label->new($this->document->stringMap, $this->name ); -} - -sub CTOR { - my ($this,%args) = @_; - - $this->{$minOccur} = defined $args{minOccur} ? $args{minOccur} : 1; - $this->{$maxOccur} = defined $args{maxOccur} ? $args{maxOccur} : 1; - $this->{$type} = $args{type}; - $this->{$name} = $args{name} or die new IMPL::InvalidArgumentException('Argument is required','name'); -} - -sub Validate { - my ($this,$node,$ctx) = @_; - - $ctx->{schemaNode} = $this; # запоминаем источник ссылки - - if (my $schemaType = $this->{$type} ? $this->document->ResolveType($this->{$type}) : undef ) { - my @errors = $schemaType->Validate($node,$ctx); - return @errors; - } else { - return (); - } -} - -sub isOptional { - my ($this) = @_; - - return $this->{$minOccur} ? 0 : 1; -} - -sub isMultiple { - my ($this) = @_; - - return ($this->{$maxOccur} eq 'unbounded' || $this->{$maxOccur} > 1 ) ? 1 : 0; -} - -sub qname { - $_[0]->nodeName.'[name='.$_[0]->{$name}.']'; -} - -1; - -__END__ -=pod - -=head1 SYNOPSIS - -package SchemaEntity; -use parent qw(IMPL::DOM::Schema::Node); - -sub Validate { - my ($this,$node) = @_; -} - -=head1 DESCRIPTION - -Базовый класс для элементов схемы. Также позволяет объявлять узлы определенного типа. - -=head1 MEMBERS - -=head2 PROPERTIES - -=over - -=item C<[get,set] minOccur> - -C<default: 1>. - -Минимальное количество повторений узла. - -=item C<[get,set] maxOccur> - -C<default: 1>. - -Максимальное количество повторений узла - -=item C<[get,set] type> - -C<default: undef> - -Имя типа из схемы. - -=item C<[get,set] name> - -Имя узла. - -=back - -=cut
--- a/lib/IMPL/DOM/Schema/NodeList.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,114 +0,0 @@ -package IMPL::DOM::Schema::NodeList; -use strict; -use warnings; - - -use IMPL::declare { - require => { - ValidationError => 'IMPL::DOM::Schema::ValidationError', - AnyNode => '-IMPL::DOM::Schema::AnyNode', - Label => 'IMPL::DOM::Schema::Label' - }, - base => [ - 'IMPL::DOM::Node' => sub { nodeName => 'NodeList' } - ], - props => [ - messageUnexpected => { get => 1, set => 1, dom => 1 }, - messageNodesRequired => { get => 1, set => 1, dom => 1} - ] -}; - -sub CTOR { - my ($this,%args) = @_; - - $this->messageUnexpected($args{messageUnexpected} || 'A %node.nodeName% isn\'t allowed in %node.parentNode.path%'); - $this->messageNodesRequired($args{messageNodesRequired} || 'A %schemaNode.name% is required in the node %parent.path%'); -} - -sub Validate { - my ($this,$node,$ctx) = @_; - - my @nodes = map { - {nodeName => $_->name, anyNode => $_->isa(AnyNode) , schemaNode => $_, max => $_->maxOccur eq 'unbounded' ? undef : $_->maxOccur, min => $_->minOccur, seen => 0 } - } @{$this->childNodes}; - - my $info = shift @nodes; - - foreach my $child ( @{$node->childNodes} ) { - #skip schema elements - while ($info and not $info->{anyNode} and $info->{nodeName} ne $child->nodeName) { - # if possible of course :) - return ValidationError->new ( - message => $this->_MakeLabel( $this->messageUnexpected ), - node => $child, - parent => $node, - schemaNode => $info->{schemaNode} - ) if $info->{min} > $info->{seen}; # we trying to skip a schema node which has a quantifier - - $info = shift @nodes; - } - - # return error if no more children allowed - return ValidationError->new ( - message => $this->_MakeLabel( $this->messageUnexpected ), - node => $child, - parent => $node - ) unless $info; - - # it's ok, we found schema element for child - - # validate - while (my @errors = $info->{schemaNode}->Validate( $child ) ) { - if( $info->{anyNode} and $info->{seen} >= $info->{min} ) { - # in case of any or switch node, skip it if possible - next if $info = shift @nodes; - } - return @errors; - } - - $info->{seen}++; - - # check count limits - return ValidationError->new( - message => $this->_MakeLabel( $this->messageUnexpected ), - node => $child, - parent => $node, - schemaNode => $info->{schemaNode}, - ) if $info->{max} and $info->{seen} > $info->{max}; - } - - # no more children left (but may be should :) - while ($info) { - return ValidationError->new( - message => $this->_MakeLabel( $this->messageNodesRequired ), - parent => $node, - schemaNode => $info->{schemaNode} - ) if $info->{seen} < $info->{min}; - - $info = shift @nodes; - } - return; -} - -sub _MakeLabel { - my ($this,$label) = @_; - - if ($label =~ /^ID:(\w+)$/) { - return Label->new($this->document->stringMap, $1); - } else { - return $label; - } -} - -1; - -__END__ - -=pod - -=head1 DESCRIPTION - -Содержимое для сложного узла. Порядок важен. Дочерними элементами могут быть -только C<IMPL::DOM::Schema::ComplexNode> и C<IMPL::DOM::Schema::SimpleNode>. - -=cut
--- a/lib/IMPL/DOM/Schema/NodeSet.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,104 +0,0 @@ -package IMPL::DOM::Schema::NodeSet; -use strict; -use warnings; - -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - Label => 'IMPL::DOM::Schema::Label', - ValidationError => 'IMPL::DOM::Schema::ValidationError', - AnyNode => '-IMPL::DOM::Schema::AnyNode' - }, - base => [ - 'IMPL::DOM::Node' => sub { nodeName => 'NodeSet' } - ], - props => [ - messageUnexpected => { get => 1, set => 1, dom => 1}, - messageMax => { get => 1, set => 1, dom => 1}, - messageMin => { get => 1, set => 1, dom => 1} - ] -}; - -sub CTOR { - my ($this,%args) = @_; - - $this->messageMax( $args{messageMax} || 'Too many %node.nodeName% nodes'); - $this->messageMin( $args{messageMin} || '%schemaNode.name% nodes expected'); - $this->messageUnexpected( $args{messageUnexpected} || 'A %node.nodeName% isn\'t allowed in %node.parentNode.path%'); -} - -sub Validate { - my ($this,$node,$ctx) = @_; - - my @errors; - - my %nodes; - my $anyNode; - - foreach (@{$this->childNodes}) { - if ($_->isa(AnyNode)) { - $anyNode = {schemaNode => $_, min => $_->minOccur, max => $_->maxOccur eq 'unbounded' ? undef : $_->maxOccur , seen => 0 }; - } else { - $nodes{$_->name} = {schemaNode => $_, min => $_->minOccur, max => $_->maxOccur eq 'unbounded' ? undef : $_->maxOccur , seen => 0 }; - } - } - - foreach my $child ( @{$node->childNodes} ) { - if (my $info = $nodes{$child->nodeName} || $anyNode) { - $info->{seen}++; - push @errors,ValidationError->new( - schemaNode => $info->{schemaNode}, - node => $child, - parent => $node, - message => $this->_MakeLabel($this->messageMax) - ) if ($info->{max} and $info->{seen} > $info->{max}); - - if (my @localErrors = $info->{schemaNode}->Validate($child)) { - push @errors,@localErrors; - } - } else { - push @errors, ValidationError->new( - node => $child, - parent => $node, - message => $this->_MakeLabel($this->messageUnexpected) - ) - } - } - - foreach my $info (values %nodes) { - push @errors, ValidationError->new( - schemaNode => $info->{schemaNode}, - parent => $node, - message => $this->_MakeLabel($this->messageMin) - ) if $info->{min} > $info->{seen}; - } - - return @errors; -} - -sub _MakeLabel { - my ($this,$label) = @_; - - if ($label =~ /^ID:(\w+)$/) { - return Label->new($this->document->stringMap, $1); - } else { - return $label; - } -} - -1; - -__END__ - -=pod - -=head1 DESCRIPTION - -Содержимое для сложного узла. Порядок не важен. Дочерними элементами могут быть -только C<IMPL::DOM::Schema::ComplexNode> и C<IMPL::DOM::Schema::SimpleNode>. - -При проверке данного правила, проверяются имеющиеся элементы на соответсие схемы -и количества встречаемости, после чего проверяются количественные ограничения -для несуществующих элементов. - -=cut
--- a/lib/IMPL/DOM/Schema/Property.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,67 +0,0 @@ -package IMPL::DOM::Schema::Property; -use strict; -use warnings; - -use IMPL::declare { - require => { - Label => 'IMPL::DOM::Schema::Label', - DOMNode => 'IMPL::DOM::Node', - ValidationError => 'IMPL::DOM::Schema::ValidationError' - }, - base => [ - 'IMPL::DOM::Schema::SimpleNode' => sub { - my %args = @_; - - $args{maxOccur} = 1; - $args{minOccur} = delete $args{optional} ? 0 : 1; - $args{nodeName} ||= 'Property'; - - return %args; - } - ], - props => [ - messageRequired => { get => 1, set => 1, dom => 1 } - ] -}; - -sub CTOR { - my ($this,%args) = @_; - - $this->messageRequired($args{messageRequired} || 'A property %schemaNode.name% is required in the %node.qname%'); -} - -sub Validate { - my ($this,$node,$ctx) = @_; - - my $nodeValue = $node->nodeProperty($this->name); - - if (length $nodeValue) { - # we have a value so validate it - - # buld a pseudo node for the property value - my $nodeProp = DOMNode->new(nodeName => '::property', nodeValue => $nodeValue); - - return $this->SUPER::Validate($nodeProp); - - } elsif($this->minOccur) { - # we don't have a value but it's a mandatory property - return ValidationError->new( - message => $this->_MakeLabel($this->messageRequired), - node => $node, - schemaNode => $this - ); - } - return (); -} - -sub _MakeLabel { - my ($this,$label) = @_; - - if ($label =~ /^ID:(\w+)$/) { - return Label->new($this->document->stringMap, $1); - } else { - return $label; - } -} - -1;
--- a/lib/IMPL/DOM/Schema/SimpleNode.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,49 +0,0 @@ -package IMPL::DOM::Schema::SimpleNode; -use strict; -use warnings; - -use IMPL::declare { - base => [ - 'IMPL::DOM::Schema::Node' => sub { - my %args = @_; - $args{nodeName} ||= 'SimpleNode'; - %args - } - ] -}; - -sub Validate { - my ($this,$node,$ctx) = @_; - - $ctx->{schemaNode} ||= $this; # для безымянных типов - - $ctx->{schemaType} = $this; - - my @result; - - push @result, $_->Validate($node,$ctx) foreach $this->childNodes; - - return @result; -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::DOM::SimpleNode> - узел с текстом. - -=head1 DESCRIPTION - -Узел имеющий простое значение. Данный узел может содержать ограничения -на простое значение. - -Производит валидацию содержимого, при постоении DOM модели не имеет специального -типа и будет создан в виде C<IMPL::DOM::Node>. - -Также определяет как будет воссоздано значение узла в DOM модели. - -=cut
--- a/lib/IMPL/DOM/Schema/SimpleType.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,92 +0,0 @@ -package IMPL::DOM::Schema::SimpleType; -use strict; -use warnings; - -use IMPL::declare { - require => { - Label => 'IMPL::DOM::Schema::Label', - ValidationError => 'IMPL::DOM::Schema::ValidationError' - }, - base => [ - 'IMPL::DOM::Schema::SimpleNode' => sub { - my %args = @_; - $args{nodeName} = 'SimpleType'; - $args{minOccur} = 0; - $args{maxOccur} = 'unbounded'; - $args{name} ||= 'SimpleType'; - delete @args{qw(nativeType messageWrongType)}; - %args - } - ], - props => [ - nativeType => { get => 1, set => 1, direct => 1, dom => 1}, - messageWrongType => { get => 1, set => 1, direct => 1, dom => 1 } - ] -}; - -sub CTOR { - my ($this,%args) = @_; - - $this->{$nativeType} = $args{nativeType} if $args{nativeType}; - $this->{$messageWrongType} = $args{messageWrongType} || "A simple node '%node.path%' is expected to be %schemaType.nativeType%"; -} - -sub Validate { - my ($this, $node, $ctx) = @_; - - if ($this->{$nativeType}) { - return ValidationError->new( - node => $node, - schemaNode => $ctx->{schemaNode} || $this, - schemaType => $this, - message => $this->_MakeLabel($this->messageWrongType) - ) unless $node->isa($this->{$nativeType}); - } - return $this->SUPER::Validate($node,$ctx); -} - -sub qname { - $_[0]->nodeName.'[type='.$_[0]->type.']'; -} - -sub _MakeLabel { - my ($this,$label) = @_; - - if ($label =~ /^ID:(\w+)$/) { - return Label->new($this->document->stringMap, $1); - } else { - return $label; - } -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::DOM::Schema::SimpleType> - тип для простых узлов. - -=head1 DESCRIPTION - -Используется для описания простых узлов, которые можно отобразить в узлы -определенного типа при построении DOM документа. - -=head1 MEMBERS - -=over - -=item C<nativeType> - -Имя класса который будет представлять узел в DOM модели. - -=item C<messageWrongType> - -Формат сообщения которое будет выдано, если узел в дом модели не будет -соответствовать свойству C<nativeType>. - -=back - -=cut
--- a/lib/IMPL/DOM/Schema/SwitchNode.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,64 +0,0 @@ -package IMPL::DOM::Schema::SwitchNode; -use strict; -use warnings; - -use IMPL::declare { - require => { - Label => 'IMPL::DOM::Schema::Label', - ValidationError => 'IMPL::DOM::Schema::ValidationError' - }, - base => [ - 'IMPL::DOM::Schema::AnyNode' => sub { - my %args = @_; - - $args{nodeName} ||= 'SwitchNode'; - - %args; - } - ], - props => [ - messageNoMatch => { get => 1, set => 1, dom => 1 } - ] -}; - -sub CTOR { - my ($this,%args) = @_; - - $this->messageNoMatch($args{messageNoMatch} || 'A node %node.nodeName% isn\'t expected in the %parent.path%'); -} - -sub Validate { - my ($this,$node,$ctx) = @_; - - if ( my ($schema) = $this->selectNodes(sub {$_[0]->name eq $node->nodeName} ) ) { - return $schema->Validate($node,$ctx); - } else { - return ValidationError->new( - node => $node, - message => $this->_MakeLabel($this->messageNoMatch) - ); - } -} - -sub _MakeLabel { - my ($this,$label) = @_; - - if ($label =~ /^ID:(\w+)$/) { - return Label->new($this->document->stringMap, $1); - } else { - return $label; - } -} - -1; - -__END__ - -=pod - -=head1 DESCRIPTION - -Представляет узел, который может быть одним из узлов, которые лежат внутри него. -Это более строгий вариант C<IMPL::DOM::Schema::AnyNode>. - -=cut
--- a/lib/IMPL/DOM/Schema/ValidationError.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,138 +0,0 @@ -package IMPL::DOM::Schema::ValidationError; -use strict; -use warnings; - -use overload - '""' => \&toString, - 'fallback' => 1; - -use IMPL::lang qw(is); -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - Label => '-IMPL::DOM::Schema::Label' - }, - base => [ - 'IMPL::Object' => undef - ], - props => [ - node => PROP_RO | PROP_DIRECT, - schemaNode => PROP_RO | PROP_DIRECT, - schemaType => PROP_RO | PROP_DIRECT, - parent => PROP_RO | PROP_DIRECT, - message => PROP_RO | PROP_DIRECT - ] -}; -use IMPL::Resources::Format qw(FormatMessage); - -sub CTOR { - my ($this,%args) = @_; - - $this->{$node} = $args{node}; - $this->{$schemaNode} = $args{schemaNode} if $args{schemaNode}; - $this->{$schemaType} = $args{schemaType} if $args{schemaType}; - - if ($args{parent}) { - $this->{$parent} = $args{parent}; - } elsif ($args{node}) { - $this->{$parent} = $args{node}->parentNode; - } else { - die new IMPL::InvalidArgumentException("A 'parent' or a 'node' parameter is required"); - } - - if ($args{message}) { - $this->{$message} = is($args{message},Label) ? $args{message}->Format(\%args) : FormatMessage($args{message}, \%args) ; - } - -} - -sub toString { - (my $this) = @_; - return $this->message; -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::DOM::Schema::ValidationError> - Описывает ошибку в документе. - -=head1 DESCRIPTION - -При проверке документа на ошибки формирования возвращается массив с объектами -C<IMPL::DOM::Schema::ValidationError>, каждая из которых описывает одну ошибку -в документе. - -С помощью данного объекта осущетсвляется привязка элемента схемы, элемента документа -и сообщения о причине возникновения ошибки. - -Часть ошибок, таких как проверка содержимого на регулярные выражения, привязаны -непосредственно к элементу. Но есть ошибки которые привязываются к родительскому -контейнеру, например отсутсвие обязательного элемента. В таком случае ошибка -содержит свойство C<parent> и по свойству C<source> можно определить элемент -(например его имя), к которому относится ошибка. - -=head1 MEMBERS - -=over - -=item C<[get] node> - -Узел в документе который привел к ошибке. Как правило это либо простые узлы, либо -узлы, которые не могут присутствоать в данном месте по схеме. - -Данное свойство может быть C<undef>. - -=item C<[get] parent> - -Родительский узел в котором произошла ошибка. Используется в случаях, когда C<node> -не указан, например, если по схеме должен существовать дочерний узел с определенным -именем, а в реальном документе его нет. - -Также это свойство может использоваться при формировании сообщения. - -=item C<[get] schema> - -Схема для C<Node> или узла который должен присутсвовать если C<Node> не задан. - -=item C<[get] source> - -Схема, проверка которой привела к возникновению ошибки. Поскольку схемы могут -использовать ссылки, то данное свойство нужно для получения схемы узла, а не -схемы его типа. - -Тоесть проверка схемы узла C<IMPL::DOM::Schema::Node> приводит к проверке схемы -типа, например, C<IMPL::DOM::Schema::ComplexType>, а свойство C<Source> будет -указывать именно на C<IMPL::DOM::Schema::Node>. - -=item C<[get] message> - -Возвращает форматированное сообщение об ошибке. - -=item C<toString()> - -Преобразует ошибку к строке, возвращает значение свойства C<Message> - -=back - -=head1 REMARKS - -=begin code - -my $doc = IMPL::DOM::XMLReader->LoadDocument('data.xml'); -my $schema = IMPL::DOM::Schema->LoadSchema('schema.xml'); - -my @errors = $schema->Validate($doc); - -my $node = $doc->selectSingleNode('user','name'); - -# Получаем все ошибки относящиеся к данному узлу -my @nodeErrors = grep { ($_->node || $_->parent) == $node } @errors; - -=end code - -=cut
--- a/lib/IMPL/DOM/Schema/Validator.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,32 +0,0 @@ -package IMPL::DOM::Schema::Validator; -use strict; - -require IMPL::Exception; -use IMPL::declare { - base => [ - 'IMPL::DOM::Node' => '@_' - ] -}; - -sub Validate { - my ($this,$node) = @_; - - die new IMPL::NotImplementedException(); -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::DOM::Schema::Validator> - Базовый класс для ограничений на простые значения. - -=head1 DESCRIPTION - -От основных элементов схемы его отличает то, что в конечном документе он не соответсвует -никаким узлам и поэтому у него отсутствуют свойства C<minOcuur,maxOccur,name>. - -=cut
--- a/lib/IMPL/DOM/Schema/Validator/Compare.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,264 +0,0 @@ -package IMPL::DOM::Schema::Validator::Compare; -use strict; - -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - Label => 'IMPL::DOM::Schema::Label', - ValidationError => 'IMPL::DOM::Schema::ValidationError' - }, - base => [ - 'IMPL::DOM::Schema::Validator' => sub { - my %args = @_; - $args{nodeName} ||= 'Compare'; - delete @args{qw(targetProperty op nodePath optional message)}; - %args; - } - ], - props => [ - targetProperty => PROP_RW, - op => PROP_RW, - nodePath => PROP_RW, - optional => PROP_RW, - _pathTranslated => PROP_RW, - _targetNode => PROP_RW, - _schemaNode => PROP_RW, - message => PROP_RW - ] -}; -use IMPL::Resources::Format qw(FormatMessage); - -our %Ops = ( - '=' => \&_equals, - 'eq' => \&_equalsString, - '!=' => \&_notEquals, - 'ne' => \&_notEqualsString, - '=~' => \&_matchRx, - '!~' => \&_notMatchRx, - '<' => \&_less, - '>' => \&_greater, - 'lt' => \&_lessString, - 'gt' => \&_greaterString -); - -my $rxOps = map qr/$_/, join( '|', keys %Ops ); - -sub CTOR { - my ($this,%args) = @_; - - $this->targetProperty($args{targetProperty} || 'nodeValue'); - $this->op( $Ops{ $args{op} || '=' } ) or die new IMPL::InvalidArgumentException("Invalid parameter value",'op',$args{op},$this->path); - $this->nodePath($args{nodePath}) or die new IMPL::InvalidArgumentException("The argument is required", 'nodePath', $this->path); - $this->message($args{message} || 'The value of %node.path% %schemaNode.op% %value% (%schemaNode.nodePath%)' ); - $this->optional($args{optional}) if $args{optional}; -} - -sub TranslatePath { - my ($this,$path) = @_; - - $path ||= ''; - - my @selectQuery; - - my $i = 0; - - foreach my $chunk (split /\//,$path) { - $chunk = 'document:*' if $i == 0 and not length $chunk; - next if not length $chunk; - - my $query; - my ($axis,$filter) = ( $chunk =~ /^(?:(\w+):)?(.*)$/); - - if ($filter =~ /^\w+|\*$/ ) { - $query = $filter eq '*' ? undef : $filter; - } elsif ( $filter =~ /^(\w+|\*)\s*((?:\[\s*\w+\s*(?:=|!=|=~|!~|eq|ne|lt|gt)\s*["'](?:[^\\'"]|\\[\\"'])*["']\])+)$/) { - my ($nodeName,$filterArgs) = ($1,$2); - - - my @parsedFilters = map { - my ($prop,$op,$value) = ($_ =~ /\s*(\w+)\s*(=|!=|=~|!~|eq|ne|lt|gt)\s*(?:["']((?:[^\\'"]|\\[\\"'])*)["'])/); - - $value =~ s/\\[\\'"]/$1/g; - { - prop => $prop, - op => $Ops{$op}, - value => $value - } - } grep ( $_, split ( /[\]\[]+/,$filterArgs ) ); - - $query = sub { - my ($node) = shift; - - $node->nodeName eq $nodeName or return 0 if $nodeName ne '*'; - $_->{op}->( - _resovleProperty($node,$_->{prop}), - FormatMessage($_->{value},{ - Schema => $this->parentNode, - Node => $this->_targetNode, - schema => $this->parentNode, - schemaType => $this->parentNode, - node => $this->_targetNode, - source => $this->_schemaNode, - schemaNode => $this->_schemaNode - },\&_resovleProperty) - ) or return 0 foreach @parsedFilters; - return 1; - }; - } else { - die new IMPL::Exception("Invalid query syntax",$path,$chunk); - } - - push @selectQuery, $axis ? { $axis => $query } : $query; - - $i++; - } - - return \@selectQuery; -} - -sub Validate { - my ($this,$node,$ctx) = @_; - - my @result; - - my $schemaNode = $ctx->{schemaNode}; - my $schemaType = $ctx->{schemaType}; - - $this->_schemaNode($schemaNode); - - $this->_targetNode($node); - - my $query = $this->_pathTranslated() || $this->_pathTranslated($this->TranslatePath($this->nodePath)); - - my ($foreignNode) = $node->selectNodes(@$query); - - - - if ($foreignNode) { - my $value = $this->nodeValue; - - if ($value) { - $value = FormatMessage($value, { Schema => $this->parentNode, Node => $this->_targetNode, ForeignNode => $foreignNode },\&_resovleProperty); - } else { - $value = $foreignNode->nodeValue; - } - - push @result, ValidationError->new( - node => $node, - foreignNode => $foreignNode, - value => $value, - schemaNode => $schemaNode, - schemaType => $schemaType, - message => $this->_MakeLabel($this->message) - ) unless $this->op->(_resovleProperty($node,$this->targetProperty),$value); - } elsif (not $this->optional) { - push @result, ValidationError->new( - node => $node, - value => '', - schemaNode => $schemaNode, - schemaType => $schemaType, - message => $this->_MakeLabel( $this->message ) - ); - } - - $this->_targetNode(undef); - $this->_schemaNode(undef); - - return @result; -} - -sub _resovleProperty { - my ($node,$prop) = @_; - - return $node->can($prop) ? $node->$prop() : $node->nodeProperty($prop); -} - -sub _matchRx { - $_[0] =~ $_[1]; -} - -sub _notMatchRx { - $_[0] !~ $_[1]; -} - -sub _equals { - $_[0] == $_[1]; -} - -sub _notEquals { - $_[0] != $_[0]; -} - -sub _equalsString { - $_[0] eq $_[1]; -} - -sub _notEqualsString { - $_[0] ne $_[1]; -} - -sub _less { - $_[0] < $_[1]; -} - -sub _greater { - $_[0] > $_[1]; -} - -sub _lessString { - $_[0] lt $_[1]; -} - -sub _greaterString { - $_[0] gt $_[1]; -} - -sub _lessEq { - $_[0] <= $_[1]; -} - -sub _greaterEq { - $_[0] >= $_[1]; -} - -sub _MakeLabel { - my ($this,$label) = @_; - - if ($label =~ /^ID:(\w+)$/) { - return Label->new($this->document->stringMap, $1); - } else { - return $label; - } -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::DOM::Schema::Validator::Compare> - ограничение на содержимое текущего узла, -сравнивая его со значением другого узла. - -=head1 SYNOPSIS - -Пример типа описания поля с проверочным полем - -=begin code xml - -<schema> - <SimpleType type="retype_field"> - <Property name="linkedNode" message="Для узла %node.nodeName% необходимо задать свойство %schemaNode.name%"/> - <Compare op="eq" nodePath="sibling:*[nodeName eq '%node.linkedNode%']"/> - </SimpleType> -</schema> - -=begin code xml - -=head1 DESCRIPTION - -Позволяет сравнивать значение текущего узла со значением другого узла. - -=cut
--- a/lib/IMPL/DOM/Schema/Validator/RegExp.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,57 +0,0 @@ -package IMPL::DOM::Schema::Validator::RegExp; -use strict; - -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - Label => 'IMPL::DOM::Schema::Label', - ValidationError => 'IMPL::DOM::Schema::ValidationError' - }, - base => [ - 'IMPL::DOM::Schema::Validator' => sub { - my %args = @_; - $args{nodeName} ||= 'RegExp'; - %args; - } - ], - props => [ - message => { get => 1, set =>1, dom =>1 }, - launder => { get => 1, set =>1, dom =>1 }, - _rx => { get=> 1, set=> 1} - ] -}; - -sub CTOR { - my ($this,%args) = @_; - - $this->message($args{message} || "A %node.nodeName% doesn't match to the format %schemaNode.label%"); -} - -sub Validate { - my ($this,$node,$ctx) = @_; - - my $rx = $this->_rx() || $this->_rx( map qr{$_}, $this->nodeValue ); - - return ValidationError->new ( - node => $node, - schemaNode => $ctx->{schemaNode}, - schemaType => $ctx->{schemaType}, - message => $this->_MakeLabel($this->message) - ) unless (not $node->isComplex) and $node->nodeValue =~ /($rx)/; - - $node->nodeValue($1) if $this->launder; - - return (); -} - -sub _MakeLabel { - my ($this,$label) = @_; - - if ($label =~ /^ID:(\w+)$/) { - return Label->new($this->document->stringMap, $1); - } else { - return $label; - } -} - -1;
--- a/lib/IMPL/DOM/Transform.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,33 +0,0 @@ -package IMPL::DOM::Transform; -use strict; -use warnings; - -use parent qw(IMPL::Transform); - -__PACKAGE__->PassThroughArgs; - -sub GetClassForObject { - my ($this,$object) = @_; - - if (my $class = ref $object) { - if (UNIVERSAL::isa($object,'IMPL::DOM::Node')) { - return $object->nodeName; - } else { - return $class; - } - } else { - return undef; - } -} - -1; - -__END__ - -=pod - -=head1 DESCRIPTION - -Преобразование для DOM документа, использует имя узла для применения подходящего преобразования. - -=cut
--- a/lib/IMPL/DOM/Transform/ObjectToDOM.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,255 +0,0 @@ -package IMPL::DOM::Transform::ObjectToDOM; -use strict; - -use IMPL::Const qw(:prop :access); -use IMPL::declare { - require => { - PropertyInfo => 'IMPL::Class::PropertyInfo', - Builder => 'IMPL::DOM::Navigator::Builder', - Exception => 'IMPL::Exception', - ArgumentException => '-IMPL::InvalidArgumentException', - OperationException => '-IMPL::InvalidOperationException' - }, - base => [ - 'IMPL::Transform' => sub { - -plain => 'TransformPlain', - HASH => 'TransformHash', - -default => 'TransformDefault' - } - ], - props => [ - documentSchema => PROP_RO, - _schema => PROP_RW, - _navi => PROP_RW - ] -}; - -use constant { - SchemaNode => 'IMPL::DOM::Schema::Node', - ComplexNode => 'IMPL::DOM::Schema::ComplexNode' -}; - -sub CTOR { - my ($this,$docName,$docSchema,$transforms) = @_; - - my $docNodeSchema = $docSchema->selectSingleNode(sub { $_->isa(SchemaNode) and $_->name eq $docName } ) - or die OperationException->new("Can't find a node schema for the document '$docName'"); - - my $docClass = ($docNodeSchema->can('nativeType') ? $docNodeSchema->nativeType : undef) || 'IMPL::DOM::Document'; - - $this->documentSchema($docNodeSchema); - - $this->_navi( - Builder->new( - $docClass, - $docSchema, - ignoreUndefined => 1 - ) - ); - $this->_schema($docSchema); - - $this->_navi->NavigateCreate($docName); - $this->currentNode->nodeProperty(schemaDocument => $docSchema); -} - -sub TransformPlain { - my ($this,$data) = @_; - - $this->_navi->Current->nodeValue( $data ); - return $this->_navi->Current; -} - -sub currentNode { - shift->_navi->Current; -} - -sub TransformHash { - my ($this,$data) = @_; - - die ArgumentException->new(data => 'A HASH reference is required') - unless ref $data eq 'HASH'; - - return $this->StoreObject($this->currentNode,$data) - if !$this->currentNode->schemaType->isa(ComplexNode); - - KEYLOOP: foreach my $key (keys %$data) { - my $value = $data->{$key}; - - if (ref $value eq 'ARRAY') { - foreach my $subval (grep $_, @$value) { - - $this->_navi->saveState(); - - my $node = $this->_navi->NavigateCreate($key); - - unless(defined $node) { - #$this->_navi->Back(); - $this->_navi->restoreState(); - next KEYLOOP; - } - - $this->_navi->applyState(); - - $this->Transform($subval); - - $this->_navi->Back(); - } - } else { - $this->_navi->saveState(); - my $node = $this->_navi->NavigateCreate($key); - - unless(defined $node) { - #$this->_navi->Back(); - $this->_navi->restoreState(); - next KEYLOOP; - } - - $this->_navi->applyState(); - - $this->Transform($value); - - $this->_navi->Back(); - } - } - return $this->_navi->Current; -} - -# this method handles situatuions when a complex object must be stored in a -# simple node. -sub StoreObject { - my ($this,$node,$data) = @_; - - $node->nodeValue($data); - - return $node; -} - -sub TransformDefault { - my ($this,$data) = @_; - - return $this->StoreObject($this->currentNode,$data) - if !$this->currentNode->schemaType->isa(ComplexNode); - - if ( ref $data and eval { $data->can('GetMeta') } ) { - my %props = map { - $_->name, 1 - } $data->GetMeta(PropertyInfo, sub { $_->access == ACCESS_PUBLIC }, 1 ); - - - my %values = map { - $_, - scalar($data->$_()) - } keys %props; - - return $this->Transform(\%values); - } else { - die OperationException->new("Don't know how to transform $data"); - } - - return $this->_navi->Current; -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::DOM::Transform::ObjectToDOM> -преобразование объекта в DOM документ. - -=head1 SYNOPSIS - -=begin code - -use IMPL::require { - Schema => 'IMPL::DOM::Schema', - Config => 'IMPL::Config' -} - -my $data = { - id => '12313-232', - name => 'Peter', - age => 20 -}; - -my $schema = Schema->LoadSchema(Config->AppBase('schemas','person.xml')); -my $transorm = IMPL::DOM::Transform::ObjectToDOM->new('edit', $schema); - -my $form = $transform->Transform($data); - -my @errors; - -push @errors, $schema->Validate($doc); - -=end code - -=head1 DESCRIPTION - -Наследует C<IMPL::Transform>. Определяет базовые преобразования для хешей и -объектов, поддерживающих метаданные. - -Результатом выполнения преобразования является DOM документ. При построении -документа используется навигатор C<IMPL::DOM::Navigator::Builder> для -сопоставления схемы и свойств преобразуемого объекта. Элементы полученного -документа имеют ссылки на соответствующие им элементы схемы. - -После того, как документ построен и преобразование будет очищено, не останется -объектов, которые бы ссылались на документ со схемой, поскольку элементы схемы -имеют слабые ссылки на саму схему и не могут предотвратить ее удаление. -Для предотвращения очитски документа схемы, ссылка на него сохраняется в -атрибуте документа C<schemaDocument>, что обеспечит жизнь схемы на протяжении -жизни документа. - -Преобразование происходит рекурсивно, сначала используется метод -C<NavigateCreate> для создания элемента соответсвующего свойству объекта, -затем вызывается метод C<Transform> для преобразования значения свойства, при -этом C<currentNode> указывает на только что созданный элемент документа. - -Для изменения поведения преобразования можно добавлять новые обработчики, как -в случае со стандартным преобразованием, а также можно унаследовать текущий -класс для переопределения его некоторых методов. - -=head1 MEMBERS - -=head2 C<CTOR($docName,$schema)> - -Создает преобразование, при этом будет создан документ состоящий только из -корневого элемента с именем C<$docName> и будет найдена подходящий для него -элемент схемы C<$schema>. - -=over - -=item * C<$docName> - -Имя корневого узла документа, которое будет использовано для поиска -соответствующего элемента схемы C<$schema> - -=item * C<$schema> - -Схема, содержащая описание документа. Если в данной схеме нет описания корневого -элемента с именем C<$docName>, будет вызвано исключение. - -=back - -=head2 C<[get]documentSchema> - -Элемент схемы C<ComplexNode> соответствующий документу. Определяется в -конструкторе исходя из имени документа. - -=head2 C<[get]currentNode> - -Текущий элемент документа. После создания преобразования - это сам документ. -Данное свойство использется внутри преобразования для работы с текущим -элементом. - -=head2 C<[virtual]StoreObject($node,$data)> - -Метод, который вызывается преобразованием в случае если текущий узел документа -является простым, а значени которое ему соответсвует является объектом (ссылкой). - -По-умолчанию будет выполнено присваивание C<< $node->nodeValue($data) >>, однако -это можно заменить, например, на преобразование в строку. - -=cut \ No newline at end of file
--- a/lib/IMPL/DOM/Transform/PostToDOM.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,161 +0,0 @@ -package IMPL::DOM::Transform::PostToDOM; -use strict; -use warnings; - -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - Builder => 'IMPL::DOM::Navigator::Builder' - }, - base => [ - 'IMPL::Transform' => sub { - -plain => \&TransformPlain, - HASH => \&TransformContainer, - CGI => \&TransformCGI, - CGIWrapper => \&TransformCGI - } - ], - props => [ - documentClass => PROP_RO, - documentSchema => PROP_RO, - prefix => PROP_RO, - _navi => PROP_RW, - errors => PROP_RW | PROP_LIST, - _schema => PROP_RW - ] -}; - -sub CTOR { - my ($this,$docClass,$docSchema,$prefix) = @_; - $docClass ||= 'IMPL::DOM::Document'; - - $this->_navi( - IMPL::DOM::Navigator::Builder->new( - $docClass, - $docSchema - ) - ); - $this->_schema($docSchema); - $this->prefix($prefix) if $prefix; -} - -sub TransformContainer { - my ($this,$data) = @_; - - my $navi = $this->_navi; - - foreach my $key ( - sort { $a->[1] cmp $b->[1] || $a->[2] <=> $b->[2]} - map [$_,/(\w+)(?:\[(\d+)\])?/], keys %$data - ){ - my $value = $data->{$key->[0]}; - my $node = $navi->NavigateCreate($key->[1]); - - $node->nodeProperty(instanceId => $key->[2]) if defined $key->[2]; - - $this->Transform($value); - - $navi->Back(); - } - - return $navi->Current; -} - -sub TransformPlain { - my ($this,$data) = @_; - - $this->_navi->Current->nodeValue( $this->_navi->inflateValue($data) ); -} - -sub TransformCGI { - my ($this,$query) = @_; - - my $data={}; - - my $prefix = $this->prefix; - my $delim = $this->delimiter; - - foreach my $param (grep index($_,$prefix) >= 0 , $query->param()) { - length (my $value = $query->param($param)) or next; - - my @parts = split /\//,$param; - - my $node = $data; - while ( my $part = shift @parts ) { - if (@parts) { - $node = ($node->{$part} ||= {}); - } else { - $node->{$part} = $value; - } - } - } - - if (keys %$data > 1) { - $data = { document => $data }; - } - - my $doc = $this->Transform($data); - $doc->nodeProperty( query => $query ); - $this->errors->Append( $this->_navi->BuildErrors); - $this->errors->Append( $this->_schema->Validate($doc)); - return $doc; -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::DOM::Transform::PostToDOM> - Преобразование объекта C<CGI> в DOM документ. - -=head1 SINOPSYS - -=begin code - - my $schema = IMPL::DOM::Schema->LoadSchema('Data/user.add.schema.xml'); - - my $transform = IMPL::DOM::Transform::PostToDOM->new( - undef, # default class - $schema, - $schema->selectSingleNode('ComplexNode')->name - ); - - my $doc = $transform->Transform( - CGI->new({ - 'user/login' => 'bob', - 'user/fullName' => 'Bob Marley', - 'user/password' => 'secret', - 'user/password_retype' => 'secret', - 'user/birthday' => '1978-12-17', - 'user/email[1]' => 'bob@marley.com', - 'user/email[2]' => 'bob.marley@google.com', - process => 1 - }) - ); - -=end code - -=head1 DESCRIPTION - -Используется для преобразования CGI запроса в DOM документ. Для этого используются параметры запроса, имена которых -начинаются со значение из свойства C<prefix>. - -Имена параметров интерпретируются следующим образом - -=over - -=item 1 Имя параметра составляется из имени узла, имен всех его родителей и указанием номера экземпляра. - -=item 2 Имена узлов могут содержать только буквы, цифры и символ _ - -=item 3 В случае когда узел может повторяться несколько раз, в квадратных скобках указывается -послеовательный номер экземпляра. - -=item 4 Имена параметров объединяются через символ '/' - -=back - -=cut
--- a/lib/IMPL/DOM/Transform/QueryToDOM.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,185 +0,0 @@ -package IMPL::DOM::Transform::QueryToDOM; -use strict; - -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - OutOfRangeException => '-IMPL::OutOfRangeException' - }, - base => [ - 'IMPL::DOM::Transform::ObjectToDOM' => '@_' - ], - props => [ - prefix => PROP_RO, - delimiter => PROP_RO - ] -}; - -our $MAX_INDEX = 1024; - -sub CTOR { - my ($this) = @_; - - $this->templates->{'CGI'} = 'TransformCGI'; - $this->templates->{'IMPL::Web::Application::Action'} = 'TransformAction'; - - $this->delimiter('[.]'); - $this->prefix(''); -} - -# inflate simple properties -sub TransformPlain { - my ($this,$data) = @_; - - $this->currentNode->nodeProperty( rawValue => $data ); - $this->currentNode->nodeValue( $data ); - return $this->currentNode; -} - -# do not store complex data as node values -sub StoreObject { - my ($this,$node,$data) = @_; - - return $node; -} - -#TODO: support a.b[0][1].c[1] - -sub TransformCGI { - my ($this,$query) = @_; - - my $data={}; - - my $prefix = $this->prefix; - my $delim = $this->delimiter; - - foreach my $param (grep index($_,$prefix) >= 0 , $query->param()) { - - my @value = grep length($_), $query->param($param) or next; - - my @parts = split /$delim/,$param; - - my $node = $data; - while ( my $part = shift @parts ) { - if (my ($name,$index) = ($part =~ m/^(\w+)(?:\[(\d+)\])?$/) ) { - if (@parts) { - if(defined $index) { - $this->ValidateIndex($index); - $node = ($node->{$name}[$index] ||= {}); - } else { - $node = ($node->{$name} ||= {}); - } - } else { - if(defined $index) { - $this->ValidateIndex($index); - $node->{$name}[$index] = (@value == 1 ? $value[0] : \@value); - } else { - $node->{$name} = (@value == 1 ? $value[0] : \@value); - } - } - } - } - } - - return $this->Transform($data); -} - -sub ValidateIndex { - my ($this,$index) = @_; - - die OutOfRangeException->new() - unless $index >= 0 and $index <= $MAX_INDEX; -} - -sub TransformAction { - my ($this,$action) = @_; - - return $this->Transform($action->isJson ? $action->jsonData : $action->query); -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::DOM::Transform::QueryToDOM> - преобразование CGI запроса в DOM документ. - -=head1 SYNOPSIS - -=begin code - -use CGI(); -use IMPL::require { - Schema => 'IMPL::DOM::Schema', - Config => 'IMPL::Config', - QueryToDOM => 'IMPL::DOM::Transform::QueryToDOM' -} - -my $q = CGI->new(); - -my $schema = Schema->LoadSchema(Config->AppBase('schemas','person.xml')); -my $transorm = QueryToDOM->new('edit', $schema); - -my $form = $transform->Transform($q); - -my @errors; - -push @errors, $transform->buildErrors; -push @errors, $schema->Validate($doc); - - -=end code - -=head1 DESCRIPTION - -Наследует C<IMPL::DOM::Transform::ObjectToDOM>. Добавляет метод -C<TransformCGI> который применятеся к объектам типа C<CGI> (и производных). - -Запрос C<CGI> сначала приводится к хешу, затем полученный хеш преобразуется -в DOM документ при помощи вызова метода C<Transform>. - -Для этого выбираются параметры запроса, затем, имя каждого параметра -рассматривается в виде пути к свойству, создается структура из хешей и массивов -в которую по указанному пути кладется значение. - -Если параметр имеет несколько значений, значит свойство является массивом. - -Также изменено поведение некоторых методов преобразования. - -=over - -=item * C<TransformPlain($value)> - -Преобразование для простого значения свойства. Посокльку в запросе передаются -строковые значения, а схема документа может предполпгать другие типы, при -преобразовании значения параметра из запроса к значению узла используется -метод C<< $this->inflateNodeValue($value) >>, также помимо значения -C<< $this->currentNode->nodeValue >> задается атрибут -C<< $this->currentNode->nodeProperty( rawValue => $value) >>, для того, чтобы -была возможность получить оригинальное значение параметра запроса (например, -в случае когда его формат был не верным и C<nodeValue> будет C<undef>). - -=item * C<StoreObject($node,$object)> - -Данный метод вызывается если текущий узел (переданный в параметре C<$node>) -предполагает простое значение, однако в запросе для него было передано сложное -содержимое. Данная реализация просто игнорирует переданный объект C<$object> -и возвращает C<$node> без изменений. - -=back - -=head1 MEMBERS - -=head2 C<[get]delimiter> - -REGEX. Разделитель свойств в имени параметра, по-умолчанию C<'[.]'> - -=head2 C<[get]prefix> - -Строка, префикс имен параметров, которые участвуют в формировании документа. -По-умолчанию пусто. - -=cut \ No newline at end of file
--- a/lib/IMPL/DOM/XMLReader.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,153 +0,0 @@ -package IMPL::DOM::XMLReader; -use strict; -use warnings; - -use XML::Parser; - -use IMPL::declare { - require => { - Schema => 'IMPL::DOM::Schema', # IMPL::DOM::Schema references IMPL::DOM::XML::Reader - Builder => 'IMPL::DOM::Navigator::Builder', - SimpleBuilder => 'IMPL::DOM::Navigator::SimpleBuilder' - }, - base => [ - 'IMPL::Object' => undef - ], - props => [ - Navigator => '*r', - SkipWhitespace => '*r', - _current => '*rw', - _text => '*rw', - _textHistory => '*rw' - ] -}; - -use IMPL::require { - -}; - -sub CTOR { - my ($this, %params) = @_; - - $this->{$Navigator} = $params{Navigator} if $params{Navigator}; - $this->{$SkipWhitespace} = $params{SkipWhitespace} if $params{SkipWhitespace}; -} - -sub Parse { - my ($this,$in) = @_; - - my $parser = new XML::Parser( - Handlers => { - Start => sub {shift; goto &OnStart($this,@_)}, - End => sub {shift; goto &OnEnd($this,@_)}, - Char => sub {shift; goto &OnChar($this,@_)} - } - ); - - $parser->parse($in); -} - -sub ParseFile { - my ($this,$in) = @_; - - my $parser = new XML::Parser( - Handlers => { - Start => sub {shift; unshift @_, $this; goto &_OnBegin;}, - End => sub {shift; unshift @_, $this; goto &_OnEnd;}, - Char => sub {shift; unshift @_, $this; goto &_OnChar;} - } - ); - - $parser->parsefile($in); -} - -sub _OnBegin { - my ($this,$element,%attrs) = @_; - - push @{$this->{$_textHistory}},$this->{$_text}; - $this->{$_text} = ""; - $this->{$_current} = $this->Navigator->NavigateCreate($element,%attrs); -} - -sub _OnEnd { - my ($this,$element) = @_; - $this->{$_current}->nodeValue($this->{$_text}) if length $this->{$_text} and (not $this->{$SkipWhitespace} or $this->{$_text} =~ /\S/); - $this->{$_text} = pop @{$this->{$_textHistory}}; - $this->{$_current} = $this->Navigator->Back; -} - -sub _OnChar { - my ($this,$val) = @_; - $this->{$_text} .= $val; -} - -sub LoadDocument { - my ($self,$file,$schema) = @_; - - my $parser; - if ($schema) { - $schema = IMPL::DOM::Schema->LoadSchema($schema) if not ref $schema; - $parser = $self->new( - Navigator => IMPL::DOM::Navigator::Builder->new( - 'IMPL::DOM::Document', - $schema - ) - ); - } else { - $parser = $self->new( - Navigator => IMPL::DOM::Navigator::SimpleBuilder->new() - ); - } - - $parser->ParseFile($file); - my $doc = $parser->Navigator->Document; - my @errors; - if ($schema) { - push @errors, $schema->Validate($doc); - } - - if (wantarray) { - return $doc,\@errors; - } else { - die new IMPL::Exception("Loaded document doesn't match the schema", @errors) if @errors; - return $doc; - } -} - -1; - -__END__ - -=pod - -=head1 SYNOPSIS - -my $reader = new IMPL::DOM::XMLReader(Navigator => $DomBuilder); -my $obj = $reader->parsefile("data.xml"); - -=head1 DESCRIPTION - -Простой класс, использующий навигатор для постороения документа. В зависимости от -используемого навигатора может быть получен различный результат. - -Навигатор должен поодерживать методы C<NavigateCreate> и C<Back> - -=head1 METHODS - -=over - -=item C<CTOR(Naviagtor => $builder)> - -Создает новый экземпляр парсера, с указанным навигатором для построения документа - -=item C<$obj->Parse($in)> - -Строит документ. На вход получает либо xml строку, либо HANDLE. - -=item C<$obj->ParseFile($fileName)> - -Строит документ из файла с именем C<$fileName>. - -=back - -=cut
--- a/lib/IMPL/Mailer.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,69 +0,0 @@ -package IMPL::Mailer; -use strict; - -use Encode qw (encode); -use Encode::MIME::Header; -use MIME::Base64 qw(encode_base64); -use Email::Simple; - -our $SENDMAIL; - -sub DeliverMessage { - my $message = shift; - - $message = shift if $message eq __PACKAGE__ or ref $message eq __PACKAGE__; - - my $email = new Email::Simple($message); - - $email->header_set('Content-Transfer-Encoding' => 'base64'); - $email->header_set('MIME-Version' => '1.0') if !$email->header('MIME-Version'); - $email->header_set('Content-Type' => 'text/plain; charset="utf-8"'); - my $raw = $email->body(); - utf8::encode($raw) if utf8::is_utf8($raw); - $email->body_set(encode_base64($raw)); - - foreach my $field ($email->header_names()) { - $email->header_set($field, map { encode('MIME-Header', utf8::is_utf8($_) ? $_ : Encode::decode('utf-8',$_) ) } $email->header($field) ); - } - - return SendMail($email,@_); -} - -sub _find_sendmail { - return $SENDMAIL if defined $SENDMAIL; - - my @path = split (/:/, $ENV{PATH}); - my $sendmail; - for (@path) { - if ( -x "$_/sendmail" ) { - $sendmail = "$_/sendmail"; - last; - } - } - return $sendmail; -} - -sub SendMail { - my ($message, %args) = @_; - my $mailer = _find_sendmail; - - local *SENDMAIL; - if( $args{'TestFile'} ) { - open SENDMAIL, '>', $args{TestFile} or die "Failed to open $args{TestFile}: $!"; - binmode(SENDMAIL); - print SENDMAIL "X-SendMail-Cmd: sendmail ",join(' ',%args),"\n"; - } else { - my @args = %args; - die "sendmail not found" unless $mailer; - die "Found $mailer but cannot execute it" - unless -x $mailer; - open SENDMAIL, "| $mailer -t -oi @args" - or die "Error executing $mailer: $!"; - } - print SENDMAIL $message->as_string - or die "Error printing via pipe to $mailer: $!"; - close SENDMAIL; - return 1; -} - -1;
--- a/lib/IMPL/ORM.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,82 +0,0 @@ -package IMPL::ORM; -use strict; -use warnings; - -use parent qw(IMPL::Object); -use IMPL::Class::Property; -use Scalar::Util qw(weaken refaddr); - -use IMPL::Exception; - -our $Depth = 1; # загружать объект + 1 уровень детей -our $UseProxy = 1; - -BEGIN { - private property _ObjectCache => prop_all; - private property _MapInstances => prop_all; - private property _WorkUnit => prop_all; - public property Schema => prop_all; -} - -sub ObjectInfoById { - my ($this,$oid) = @_; - - return $this->_ObjectCache->{$oid}; -} - -sub ObjectInfo { - my ($this,$inst) = @_; - - die new IMPL::InvalidOperationException("This method can be used only for a reference") unless ref $inst; - - return $this->_MapInstances->{refaddr $inst}; -} - - -1; -__END__ - -=pod - -=head1 NAME - -C<IMPL::ORM> - Object Relational Mapping - -=head1 SYNOPSIS - -=begin code - -my $ds = IMPL::ORM::Storage::DBIC->new('My::Data',$dsn,$user,$pass,{Autocommit => 1}); - - -my $foo = $ds->Insert( - My::Data::Foo->new( - 'foo class' - ) -); - -my $bar = $ds->Insert( - My::Data::Bar->new( - 'bar class' - ) -) - -$bar->fooObject($foo); - -$ds->Save($bar); - -my $fooOther = $ds->Retrieve( - 'My::Data::Bar', - { - name => 'bar class', - fooObject => { - name => 'some foo' - } - } -) - -=end code - -=head1 DESCRIPTION - -=cut
--- a/lib/IMPL/ORM/Adapter/Generic.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,103 +0,0 @@ -package IMPL::ORM::Adapter::Generic; - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::ORM::Adapter::Generic> Адаптер для работы с данными объекта произвольного класса. - -=head1 DESCRIPTION - -Позволяет получать данные, изменения данных из объекта, а также записать данные в -объект и создать новый объект. - -=head1 MEMBERS - -=over - -=item C<CTOR($object,$hashOptions)> - -Создает новый адаптер к объекту C<$object> - -=item C<[get]object> - -Объект для которого создан данный адаптер, C<undef> если объект удален. - -=item C<[get]isChanged> - -Были ли обновления в объекте. - -=item C<[get]isDeleted> - -Является ли объект удаленным. - -=item C<[get]isNew> - -Является ли объект новым для БД. - -=item C<[get]initialState> - -Начальное состояние объекта, C<undef> если объект был создан. - -=item C<[get]currentState> - -Текущие состояние. C<undef> если объект удален. - -=item C<[get,list]history> - -История изменений. C<IMPL::Object::List> - -=item C<SaveChanges> - -Сохраняет изменения из объекта в текущее состояние, при этом изменения записываются в историю. - -B<returns> информацию об изменениях в объекте. - -=item C<Revert($version)> - -Возвращает объект в определенную версию. - -=item C<Delete> - -Удаляет объект, точнее помечает его для удаления до вызова C<Commit>. - -=item C<Commit> - -Сбрасывает историю изменений, и устанавливает соответсвующие свойства. - -=back - -=head1 Информация об изменениях объекта - -=begin code - -{ - version => 1, # object version - op => STORAGE_UPDATE, - data => { - entity1 => { - field1 => 'value 1' - }, - entity2 => { - field2 => 'value 2' - } - } -} - -=end code - -=head1 Информация об отображении объекта - -=begin code - -{ - prop_name => [ entity => 'field' ] -} - -=end code - -=cut
--- a/lib/IMPL/ORM/Entity.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,47 +0,0 @@ -package IMPL::ORM::Entity; -use strict; -use warnings; - -use parent qw(IMPL::Object); -use IMPL::Class::Property; - -BEGIN { - public _direct property Name => prop_get; - public _direct property Class => prop_get; - public _direct property Values => prop_get; - public _direct property Schema => prop_get; -} - -sub CTOR { - my ($this,$class,$schema) = @_; - - $this->{$Class} = $class; - (my $name = $class) =~ s/::/_/g; - $this->{$Name} = $name; - $this->Schema = $schema; - $this->{$Values} = { - map {$_->{name},{type => $_->{type}, virtual => $_->{virtual}}} @$schema - }; -} - -sub Store; -*Store = \&dbgStore; - -sub dbgStore { - my ($this,$prop,$value) = @_; - - if ( my $container = $this->{$Values}{$prop} ) { - $container->{oldValue} = $container->{value}; - $container->{value} = $value; - } else { - die new IMPL::InvalidOperationException("Property not found",$this->Name,$prop); - } -} - -sub Get { - my ($this,$prop) = @_; - - return $this->{$Values}{$prop}{value}; -} - -1;
--- a/lib/IMPL/ORM/Helpers.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,24 +0,0 @@ -package IMPL::ORM::Helpers; -use strict; -use warnings; - -require Exporter; -our @ISA = qw(Exporter); -our @EXPORT_OK = qw(&Map &Box); - -sub Map($$) { - my ($TKey,$TValue) = @_; - - $TKey =~ s/:://g; - $TValue =~ s/:://g; - - return "IMPL::ORM::Map::${TKey}${TValue}"; -} - -sub Box($) { - my ($TValue) = @_; - $TValue =~ s/:://g; - return "IMPL::ORM::Box::$TValue"; -} - -1;
--- a/lib/IMPL/ORM/Object.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,115 +0,0 @@ -package IMPL::ORM::Object; -use strict; -use warnings; - -use parent qw(IMPL::Object); -use IMPL::Class::Property; - -require IMPL::ORM::Entity; -require IMPL::ORM::Schema::Entity; -require IMPL::ORM::Schema::Field; -require IMPL::ORM::Schema::Relation::HasMany; -require IMPL::ORM::Schema::Relation::HasOne; -require IMPL::ORM::Schema::Relation::Subclass; - -BEGIN { - private _direct property _entities => prop_all; - public property objectType => prop_all, {type => 'String'}; - - sub _PropertyImplementor { - 'IMPL::ORM::PropertyImplementor' - } -} - -my %schemaCache; - -sub CTOR { - my ($this) = @_; - - while ( my ($class,$schema) = $this->ormGetSchema ) { - $this->{$_entities}{$class} = new IMPL::ORM::Entity($class,$schema); - } -} - -sub ormStore { - my ($this,$class,$prop,$value) = @_; - - die IMPL::InvalidOperationException("Cannot find entity for the specified class",$class) unless $this->{$_entities}{$class}; - - $this->{$_entities}{$class}->Store($prop,$value); -} - -sub ormGet { - my ($this,$class,$prop,$value) = @_; - - return $this->{$_entities}{$class} ? $this->{$_entities}{$class}->Get($prop,$value) : undef; -} - -sub entityName { - (my $self = ref $_[0] || $_[0]) =~ s/^.*?(\w+)$/$1/; - return $self; -} - -sub ormGetSchema { - my ($self,$dataSchema,$surrogate) = @_; - - my $schema = $surrogate || IMPL::ORM::Schema::Entity->new($self->entityName); - - # для текущего класса, проходим по всем свойствам - foreach my $ormProp ( - $self->get_meta( - 'IMPL::Class::PropertyInfo', - sub { - UNIVERSAL::isa($_->Implementor, 'IMPL::ORM::PropertyImplementor' ) - }, - 0 - ) - ){ - if ($ormProp->Mutators & prop_list) { - # отношение 1 ко многим - my $type = $dataSchema->resolveType($ormProp->Type) or die new IMPL::InvalidOperationException("Failed to resolve a reference type due building schema for a class", $ormProp->Class, $ormProp->Name); - $schema->appendChild( new IMPL::ORM::Schema::Relation::HasMany($ormProp->Name, $type->entityName) ); - } elsif (my $type = $dataSchema->isValueType($ormProp->Type)) { - # поле - $schema->appendChild( new IMPL::ORM::Schema::Field($ormProp->Name,$ormProp->Type) ); - } elsif (my $entity = $dataSchema->resolveType($ormProp->Type)) { - # отношение ссылка - $schema->appendChild( new IMPL::ORM::Schema::Relation::HasOne($ormProp->Name,$entity->entityName)); - } else { - # хз что. Скорее всего не удалось квалифицировать тип свойства не как ссылочный и как поле. - die new IMPL::Exception('Uexpected error due building schema for a class', $ormProp->Class, $ormProp->Name,$ormProp->Type); - } - } - - # Формируем отношения наследования - { - # локализуем прагму - no strict 'refs'; - - my $class = ref $self || $self; - - # по всем классам - foreach my $super (grep $_->isa(__PACKAGE__), @{"${class}::ISA"}) { - my $type = $dataSchema->resolveType($super) or die new IMPL::InvalidOperationException("Failed to resolve a super class due building schema for a class", $class, $super); - $schema->appendChild(new IMPL::ORM::Schema::Relation::Subclass($type)); - } - } - - return $schema; -} - -1; - -__END__ - -=pod - -=head1 DESCRIPTION - -Базовый объект для реляционного отображения, -содержит в себе реляционные записи представляющие данный объект. - -Каждый класс отображается в определенную сущность. Сущности хранят -состояние объектов в том виде в котором удобно записывать в реляционную базу. - -=cut
--- a/lib/IMPL/ORM/PropertyImplementor.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,7 +0,0 @@ -package IMPL::ORM::PropertyImplementor; -use strict; -use warnings; - - - -1;
--- a/lib/IMPL/ORM/Schema.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,153 +0,0 @@ -package IMPL::ORM::Schema; -use strict; -use warnings; - -use parent qw(IMPL::DOM::Document); -use IMPL::Class::Property; -require IMPL::ORM::Schema::Entity; -require IMPL::ORM::Schema::ValueType; - -our %CTOR = ( - 'IMPL::DOM::Document' => sub { nodeName => 'ORMSchema' } -); - -BEGIN { - public property mapValueTypes => prop_get | owner_set; - public property mapReferenceTypes => prop_get | owner_set; - public property mapPending => prop_get | owner_set; - public property prefix => prop_get | owner_set; -} - -sub CTOR { - my ($this ) = @_; - $this->mapValueTypes({}); - $this->mapReferenceTypes({}); - $this->mapPending({}); -} - -# return an entity for the specified typename -# makes forward declaration if nesessary -sub resolveType { - my ($this,$typeName) = @_; - - $this = ref $this ? $this : $this->instance; - - if (my $entity = $this->mapReferenceTypes->{$typeName}) { - return $entity; - } elsif (UNIVERSAL::isa($typeName,'IMPL::ORM::Object')) { - return $this->declareReferenceType($typeName); - } else { - return undef; - } -} - -sub declareReferenceType { - my ($this,$typeName) = @_; - - my $entity = new IMPL::ORM::Schema::Entity($typeName->entityName); - - $this->mapPending->{$typeName} = $entity; - - $this->appendChild($entity); - - return $this->mapReferenceTypes->{$typeName} = $entity; -} - -sub _addReferenceType { - my ($this,$className) = @_; - - if ( my $entity = delete $this->mapPending->{$className} ) { - $className->ormGetSchema($this,$entity); - } else { - return $this->appendChild( $this->mapReferenceTypes->{$className} = $className->ormGetSchema($this) ); - } - -} - -# returns valuetype name -sub isValueType { - my ($this,$typeName) = @_; - - $this = ref $this ? $this : $this->instance; - - return $this->mapValueTypes->{$typeName}; -} - -my %instances; -sub instance { - my ($class) = @_; - - return ($instances{$class} || ($instances{$class} = $class->new)); -} - -sub ValueTypes { - my ($this,%classes) = @_; - - $this = ref $this ? $this : $this->instance; - - while ( my ($typeName,$typeReflected) = each %classes ) { - $this->mapValueTypes->{$typeName} = $typeReflected; - $this->appendChild(IMPL::ORM::Schema::ValueType->new($typeName,$typeReflected)); - } -} - -sub Classes { - my ($this,@classNames) = @_; - - $this = ref $this ? $this : $this->instance; - - $this->_addReferenceType($this->prefix . $_) foreach @classNames; -} - -sub usePrefix { - my ($this,$prefix) = @_; - - $prefix .= '::' if $prefix and $prefix !~ /::$/; - - (ref $this ? $this : $this->instance)->prefix($prefix); -} - -sub CompleteSchema { - my ($this) = @_; - - $this = ref $this ? $this : $this->instance; - - $_->ormGetSchema($this,delete $this->mapPending->{$_}) foreach (keys %{$this->mapPending}); -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::ORM::Schema> Схема отображения классов в реляционную структуру. - -=head1 DESCRIPTION - -Схема данных, представляет собой DOM документ, элементами которой -являются сущности. - -Каждый узел - это описание сущности. - -=begin code xml - -<Schema> - <Entity entityName="My_Data_Foo"> - <Field fieldName="Doo" fieldType="String"/> - <HasMany name="Boxes" target="My_Data_Box"/> - </Entity> - <Entity entityName="My_Data_Bar"> - <Subclass base="My_Data_Foo"/> - <Field fieldName="Timestamp" fieldType="Integer"/> - </Entity> - <Entity entityName="My_Data_Box"> - <Field fieldName="Capacity" fieldType="Integer"/> - </Entity> -</Schema> - -=end code xml - -=cut
--- a/lib/IMPL/ORM/Schema/Entity.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,24 +0,0 @@ -package IMPL::ORM::Schema::Entity; -use strict; -use warnings; - -use parent qw(IMPL::DOM::Node); -use IMPL::Class::Property; - -BEGIN { - public property entityName => prop_get | owner_set; -} - -our %CTOR = ( - 'IMPL::DOM::Node' => sub { - nodeName => 'Entity' - } -); - -sub CTOR { - my ($this,$name) = @_; - - $this->entityName($name); -} - -1;
--- a/lib/IMPL/ORM/Schema/Field.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,30 +0,0 @@ -package IMPL::ORM::Schema::Field; -use strict; -use warnings; - -use parent qw(IMPL::DOM::Node); -use IMPL::Class::Property; - -BEGIN { - public property fieldName => prop_get | owner_set; - public property fieldType => prop_get | owner_set; - public property fieldNullbale => prop_get | owner_set; -} - -our %CTOR = ( - 'IMPL::DOM::Node' => sub { nodeName => 'Field' } -); - -sub CTOR { - my ($this,$name,$type,$nullable) = @_; - - $this->fieldName($name) or die new IMPL::InvalidArgumentException('A name is required for the field'); - $this->fieldType($type) or die new IMPL::InvalidArgumentException('A type is required for the field'); - $this->fieldNullbale(1) if $nullable; -} - -sub canHaveChildren { - 0; -} - -1;
--- a/lib/IMPL/ORM/Schema/GenericClass.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,17 +0,0 @@ -package IMPL::ORM::Schema::GenericClass; - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::ORM::Schema::GenericClass> Построение схемы из произвольного класса. - -=head1 DESCRIPTION - -Читает метаданные класса и строит на их основании элементы схемы данных. - -=cut
--- a/lib/IMPL/ORM/Schema/Relation.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,12 +0,0 @@ -package IMPL::ORM::Schema::Relation; -use strict; -use warnings; - -use parent qw(IMPL::DOM::Node); - -our %CTOR =( - 'IMPL::DOM::Node' => sub { nodeName => $_[0] } -); - - -1;
--- a/lib/IMPL/ORM/Schema/Relation/HasMany.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,27 +0,0 @@ -package IMPL::ORM::Schema::Relation::HasMany; -use strict; -use warnings; - -use parent qw(IMPL::ORM::Schema::Relation); -use IMPL::Class::Property; - -BEGIN { - public property target => prop_get | owner_set; - public property name => prop_get | owner_set; -} - -our %CTOR = ( - 'IMPL::ORM::Schema::Relation' => sub { 'HasMany' } -); - -sub CTOR { - my ($this,$name,$target) = @_; - $this->name($name) or die new IMPL::InvalidArgumentException('A name is required for this relation'); - $this->target($target) or die new IMPL::InvalidArgumentException('A target is required for this relation',$name); -} - -sub canHaveChildren { - 0; -} - -1;
--- a/lib/IMPL/ORM/Schema/Relation/HasOne.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,28 +0,0 @@ -package IMPL::ORM::Schema::Relation::HasOne; -use strict; -use warnings; - -use parent qw(IMPL::ORM::Schema::Relation); -use IMPL::Class::Property; - -BEGIN { - public property target => prop_get | owner_set; - public property name => prop_get | owner_set; -} - -our %CTOR = ( - 'IMPL::ORM::Schema::Relation' => sub { 'HasOne' } -); - -sub CTOR { - my ($this,$name,$target) = @_; - $this->name($name) or die new IMPL::InvalidArgumentException('A name is required for this relation'); - $this->target($target) or die new IMPL::InvalidArgumentException('A target is required for this relation',$name); -} - -sub canHaveChildren { - 0; -} - - -1;
--- a/lib/IMPL/ORM/Schema/Relation/Subclass.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -package IMPL::ORM::Schema::Relation::Subclass; -use strict; -use warnings; - -use parent qw(IMPL::ORM::Schema::Relation); -use IMPL::Class::Property; - -BEGIN { - public property base => prop_get | owner_set; -} - -our %CTOR = ( - 'IMPL::ORM::Schema::Relation' => sub { 'Subclass' } -); - -sub CTOR { - my ($this,$base) = @_; - - $this->base($base) or die new IMPL::InvalidArgumentException('A base is required for this relation'); -} - -sub canHaveChildren { - 0; -} - -1;
--- a/lib/IMPL/ORM/Schema/TransformToSQL.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,181 +0,0 @@ -package IMPL::ORM::Schema::TransformToSQL; -use strict; -use warnings; - -use parent qw(IMPL::DOM::Transform); -use IMPL::Class::Property; -use IMPL::SQL::Types qw(DateTime Varchar Integer Float Text Binary); - -require IMPL::SQL::Schema; - -BEGIN { - public property Types => prop_get | owner_set; -} - -our %CTOR = ( - 'IMPL::DOM::Transform' => sub { - ORMSchema => \&ORMSchemaTransform, - Entity => \&EntityTransform, - Field => \&FieldTransform, - HasOne => \&HasOneTransform, - HasMany => \&HasManyTransform, - Subclass => \&SubclassTransform, - ValueType => sub {} - } -); - -sub CTOR { - my ($this,$refTypeMap) = @_; - - $this->Types($refTypeMap) or die new IMPL::InvalidArgumentException("A reference to the type map hash is required"); -} - -sub ORMSchemaTransform { - my ($this,$node) = @_; - - my $schema = IMPL::SQL::Schema->new(Name => ref $node); - - my @constraints; - - my %ctx = (Schema => $schema); - - # all tables - foreach my $entity ($node->selectNodes('Entity')) { - $schema->AddTable($this->Transform($entity,\%ctx)); - push @constraints, $entity->selectNodes(sub {$_->isa('IMPL::ORM::Schema::Relation')}); - } - - # establish relations - $this->Transform($_,\%ctx) foreach @constraints; - - return $schema; -} - -sub EntityTransform { - my ($this,$node,$ctx) = @_; - - my $table = IMPL::SQL::Schema::Table->new(Name => $node->entityName, Schema => $ctx->{Schema}); - - $this->MakePrimaryKey($table); - - $table->InsertColumn( $this->Transform($_,$ctx)) foreach$node->selectNodes('Field'); - - return $table; -} - -sub FieldTransform { - my ($this,$field,$ctx) = @_; - - return { - Name => $field->fieldName, - Type => $this->MapType($field->fieldType) || die new IMPL::Exception("Can't get map a rom schema type to the SQL type",$field->fieldType), - CanBeNull => $field->fieldNullable - }; -} - -sub HasOneTransform { - my ($this,$relation,$ctx) = @_; - - my $sqlSchema = $ctx->{Schema}; - my $table = $sqlSchema->Tables->{$relation->parentNode->entityName}; - my $tableForeign = $sqlSchema->Tables->{$relation->target}; - my $prefix = $relation->name; - - my @fkColumns = $tableForeign->PrimaryKey->columns; - - if (@fkColumns > 1) { - @fkColumns = map - $table->InsertColumn({ - Name => $prefix . $_->Name, - Type => $_->Type, - CanBeNull => 1 - }), @fkColumns; - } else { - @fkColumns = $table->InsertColumn({ - Name => $prefix, - Type => $fkColumns[0]->Type, - CanBeNull => 1 - }); - } - - $table->LinkTo($tableForeign,@fkColumns); -} - -sub HasManyTransform { - my ($this,$relation,$ctx) = @_; - - #similar to HasOne - - my $sqlSchema = $ctx->{Schema}; - my $table = $sqlSchema->Tables->{$relation->parentNode->entityName}; - my $tableForeign = $sqlSchema->Tables->{$relation->target}; - my $prefix = $relation->name; - - my @fkColumns = $table->PrimaryKey->columns; - - if (@fkColumns > 1 ) { - @fkColumns = map $tableForeign->InsertColumn({ - Name => $prefix . $_->Name, - Type => $_->Type, - CanBeNull => 1 - }), @fkColumns; - } else { - @fkColumns = $tableForeign->InsertColumn({ - Name => $prefix, - Type => $fkColumns[0]->Type, - CanBeNull => 1 - }); - } - - $tableForeign->LinkTo($table,@fkColumns); -} - -sub SubclassTransform { - # actually this rlations has only logical implementation -} - -sub MapType { - my ($this,$typeName) = @_; - - $this->Types->{$typeName} || die new IMPL::Exception("Can't map a type",$typeName); -} - -sub MakePrimaryKey { - my ($this,$table) = @_; - - $table->InsertColumn( {Name => '_Id', Type => Integer } ); - $table->SetPrimaryKey('_Id'); -} - -{ - my $std; - sub Std { - $std ||= __PACKAGE__->new({ - String => Varchar(255), - DateTime => DateTime, - Integer => Integer, - Float => Float(24), - Decimal => Float(53), - Real => Float(24), - Binary => Binary, - Text => Text - }); - } -} - -1; - -__END__ - -=pod - -=head1 SYNOPSIS - -=begin code - -my $sqlSchema = IMPL::ORM::Schema::TransformToSQL->Default->Transform(Data::Schema->instance); - -=end code - -=cut -
--- a/lib/IMPL/ORM/Schema/ValueType.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,31 +0,0 @@ -package IMPL::ORM::Schema::ValueType; - -use strict; - -use parent qw(IMPL::DOM::Node); - -our %CTOR = ( - 'IMPL::DOM::Node' => sub { nodeName => 'ValueType' } -); - -use IMPL::Class::Property; - -BEGIN { - public property typeName => prop_all; - public property typeReflected => prop_all; -} - -sub CTOR { - my ($this,$typeName,$typeReflected) = @_; - - $this->typeName($typeName); - $this->typeReflected($typeReflected); -} - -1; - -__END__ - -=pod - -=cut
--- a/lib/IMPL/ORM/Store/DBIC.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,13 +0,0 @@ -package IMPL::ORM::DBIC; - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::ORM::DBIC> - Хранилище данных на основе C<DBIx::Class>. - -=cut
--- a/lib/IMPL/ORM/Store/SQL.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,30 +0,0 @@ -package IMPL::ORM::Store::SQL; -use strict; -use warnings; - -use parent qw(IMPL::Object); - -use IMPL::Class::Property; - -BEGIN { - public property Connection => prop_all; -} - -sub loadObjects { - my ($this,$rObjects) = @_; -} - -sub search { - my ($this,$query) = @_; -} - -1; - -__END__ - -=pod - -=head1 DESCRIPTION -Драйвер для SQL баз данных. - -=cut
--- a/lib/IMPL/ORM/Unit.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,20 +0,0 @@ -package IMPL::ORM::Unit; - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::ORM::Unit> Единица действий. - -=head1 DESCRIPTION - -C<[Infrastructure]> - -Позволяет записывать последовательность изменений. Используется C<IMPL::ORM> для реализации логических -транзакций. - -=cut
--- a/lib/IMPL/SQL/Schema.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,190 +0,0 @@ -use strict; -package IMPL::SQL::Schema; -use mro; - -use IMPL::lang qw(is); -use IMPL::Const qw(:prop); -use Scalar::Util qw(reftype); -use IMPL::declare { - require => { - Table => 'IMPL::SQL::Schema::Table' - }, - base => [ - 'IMPL::Object' => undef, - 'IMPL::Object::Disposable' => undef, - 'IMPL::Object::Clonable' => undef, - ], - props => [ - version => PROP_RO | PROP_DIRECT, - name => PROP_RO | PROP_DIRECT, - _tables => PROP_RO | PROP_DIRECT - ] -}; - -sub CTOR { - my ($this,%args) = @_; - - $this->$_($args{$_}) foreach grep exists $args{$_}, qw(name version); -} - -sub AddTable { - my ($this,$table) = @_; - - if (is($table,Table)) { - - $table->schema == $this or die new IMPL::InvalidOperationException('The specified table must belong to the database'); - not exists $this->{$_tables}->{$table->name} or die new IMPL::InvalidOperationException('a table with the same name already exists in the database'); - - } elsif (reftype($table) eq 'HASH') { - - not exists $this->{$_tables}->{$table->{'name'}} or die new IMPL::InvalidOperationException('a table with the same name already exists in the database'); - $table = { %$table }; - $table->{'schema'} = $this; - $table = Table->new(%{$table}); - } else { - die new IMPL::InvalidArgumentException('Either a table object or a hash with table parameters is required'); - } - - $this->{$_tables}{$table->name} = $table; -} - -sub RemoveTable { - my ($this,$table) = @_; - - my $tn = is($table,Table) ? $table->name : $table; - - $table = delete $this->{$_tables}{$tn} or die new IMPL::InvalidArgumentException('The table doesn\'t exists',$tn); - - # drop foreign keys - map { $_->table->RemoveConstraint($_) } values %{$table->primaryKey->connectedFK} if $table->primaryKey; - - # drop table contents - $table->Dispose(); - - return 1; -} - -sub ResolveTable { - my ($this,$table) = @_; - - is($table,Table) ? $table : $this->{$_tables}{$table}; -} - -sub GetTable { - my ($this,$tableName) = @_; - return $this->{$_tables}{$tableName}; -} - -sub GetTables { - my ($this) = @_; - - return wantarray ? values %{$this->{$_tables}} : [values %{$this->{$_tables}}]; -} - -sub RenameTable { - my ($this,$oldName,$newName) = @_; - - die new IMPL::InvalidOperationException("A source table doesn't exists", $oldName) unless exists $this->{$_tables}{$oldName}; - die new IMPL::InvalidOperationException("A target table already exists", $newName) if exists $this->{$_tables}{$newName}; - - my $table = delete $this->{$_tables}{$oldName}; - $table->_setName($newName); - $this->{$_tables}{$newName} = $table; -} - -sub Dispose { - my ($this) = @_; - - $_->Dispose foreach values %{$this->{$_tables}}; - - delete $this->{$_tables}; - - $this->next::method(); -} - -1; - -__END__ -=pod - -=head1 SYNOPSIS - -=begin code - -require IMPL::SQL::Schema; -use IMPL::SQL::Types qw(Varchar Integer); - -my $dbSchema = new IMPL::SQL::Schema; - -my $tbl = $dbSchema->AddTable({name => 'Person' }); -$tbl->AddColumn({ - name => 'FirstName', - canBeNull => 1, - type => Varchar(255) -}); -$tbl->AddColumn({ - name => 'Age', - type => Integer -}); - -# so on - -# and finally don't forget to - -$dbSchema->Dispose(); - -=end code - -=head1 DESCRIPTION - -Схема реляциоонной базы данных, орентированная на язык SQL, содержит описания таблиц -которые являются частью базы. Позволяет создавать и удалать таблицы. - -=head1 MEMBERS - -=over - -=item C<CTOR(%props)> - -Конструктор заполняет объект свойствами из C<props>. - -=item C<[get]name> - -Имя схемы. - -=item C<[get]version> - -Версия схемы. - -=item C<AddTable($table)> - -Доавляет таблицу в схему. C<$table> может быть либо таблице, либо хешем с набором -свойств для создания новой таблицы. Если таблица с таким именем уже существует в сехеме, -то вызывается исключение. - -=item C<GetTable($name)> - -Возвращает таблицу с именем C<$name> или C<undef>. - -=item C<GetTables()> - -Возвращает список таблиц. В скалярном контексте - ссылку на массив с таблицами. - -=item C<ResolveTable($table)> - -Если параметр C<$table> - таблица, то возвращается C<$table>, если C<$table> строка, то -ищется таблица с таким именем, если таблица не найдена, возвращается C<undef>. - -=item C<RenameTable($oldName,$newName)> - -Происходит переименование таблицы. Если C<$oldName> не существует, либо если C<$newName> -существует, вызывается исключение. - -=item C<RemoveTable($table)> - -Удаляется таблица C<$table> с удалением всех связей и ограничений. Если такой таблицы нет, -то вызывается исключение. C<$table> может быть либо именем таблицы, либо объектом. - -=back - -=cut
--- a/lib/IMPL/SQL/Schema/Column.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,78 +0,0 @@ -use strict; - -package IMPL::SQL::Schema::Column; - -use IMPL::lang qw( :base :compare :hash ); -use IMPL::Exception(); -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - SchemaType => '-IMPL::SQL::Schema::Type' - }, - base => [ - 'IMPL::Object' => undef, - ], - props => [ - name => PROP_RO | PROP_DIRECT, - type => PROP_RO | PROP_DIRECT, - isNullable => PROP_RO | PROP_DIRECT, - defaultValue => PROP_RO | PROP_DIRECT, - tag => PROP_RO | PROP_DIRECT - ] -}; - -sub CTOR { - my ( $this, %args ) = @_; - - $this->$_( $args{$_} ) - foreach grep exists $args{$_}, qw( name type isNullable defaultValue tag); - - $this->{$name} or - die new IMPL::InvalidArgumentException('A column name is required'); - - $this->{$isNullable} ||= 0; # if not exists $this->{$isNullable}; - - is( $this->{$type}, SchemaType ) - or die new IMPL::InvalidArgumentException( - 'a type is required for the column', - $this->{$name} ); -} - -sub SameValue { - my ( $this, $other ) = @_; - - return ( $this->{$name} eq $other->{$name} - and $this->{$isNullable} == $other->{$isNullable} - and equals_s( $this->{$defaultValue}, $other->{$defaultValue} ) - and $this->{$type}->SameValue( $other->{$type} ) ); -} - -sub SetType { - my ( $this, $newType ) = @_; - - $this->{$type} = $newType; -} - -sub SetDefaultValue { - my ( $this, $value ) = @_; - - $this->{$defaultValue} = $value; -} - -sub SetNullable { - my ( $this, $value ) = @_; - - $this->{$isNullable} = $value; -} - -sub SetOptions { - my ( $this, $diff ) = @_; - - return unless ref $diff eq 'HASH'; - - $this->tag( {} ) unless $this->tag; - - hashApply( $this->tag, $diff ); -} - -1;
--- a/lib/IMPL/SQL/Schema/Constraint.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,87 +0,0 @@ -package IMPL::SQL::Schema::Constraint; -use strict; -use warnings; - -use IMPL::lang; -use IMPL::Const qw(:prop); -use IMPL::declare { - base => [ - 'IMPL::Object' => undef, - 'IMPL::Object::Disposable' => undef - ], - props => [ - name => PROP_RO | PROP_DIRECT, - table => PROP_RO | PROP_DIRECT, - columns => PROP_RO | PROP_LIST - ] -}; - -my %aliases; - -sub CTOR { - my ($this,%args) = @_; - is( $args{table}, 'IMPL::SQL::Schema::Table' ) or - die new IMPL::InvalidArgumentException("table argument must be a table object"); - $this->{$name} = $args{'name'}; - $this->{$table} = $args{'table'}; - $this->columns( [map { ResolveColumn($this->table,$_) } @{$args{'columns'}}] ); -} - -sub ResolveColumn { - my ($Table,$Column) = @_; - - my $cn = is($Column,'IMPL::SQL::Schema::Column') ? $Column->name : $Column; - - my $resolved = $Table->GetColumn($cn); - die new IMPL::InvalidOperationException("The column is not found in the table", $cn, $Table->name) if not $resolved; - return $resolved; -} - -sub HasColumn { - my ($this,@Columns) = @_; - - my %Columns = map { $_, 1} @Columns; - - return scalar(grep { $Columns{$_->name} } $this->columns ) == scalar(@Columns); -} - -sub uniqName { - my ($this) = @_; - return $this->{$table}->name.'_'.$this->{$name}; -} - -sub Dispose { - my ($this) = @_; - - $this->columns([]); - - delete $$this{$table}; - - $this->SUPER::Dispose; -} - -sub SameValue { - my ($this,$other) = @_; - - return 0 unless $this->columns->Count == $other->columns->Count; - - for ( my $i=0; $i < $this->columns->Count; $i++ ) { - return 0 unless $this->columns->[$i]->name eq $other->columns->[$i]->name; - } - - return 1; -} - -sub ResolveAlias { - my ($self,$alias) = @_; - - return isclass($alias, 'IMPL::SQL::Schema::Constraint') ? $alias : $aliases{$alias}; -} - -sub RegisterAlias { - my ($self,$alias) = @_; - - $aliases{$alias} = ref $self ? typeof($self) : $self; -} - -1;
--- a/lib/IMPL/SQL/Schema/Constraint/ForeignKey.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,65 +0,0 @@ -package IMPL::SQL::Schema::Constraint::ForeignKey; -use strict; -use warnings; - -use IMPL::lang qw(:declare is); - -use parent qw(IMPL::SQL::Schema::Constraint); - - -BEGIN { - public _direct property referencedPrimaryKey => PROP_GET; - public _direct property onDelete => PROP_GET; - public _direct property onUpdate => PROP_GET; -} - -__PACKAGE__->PassThroughArgs; -__PACKAGE__->RegisterAlias('fk'); - -sub CTOR { - my ($this,%args) = @_; - - die new Exception("Referenced table must be an instance of a table object") if not is($args{'referencedTable'},'IMPL::SQL::Schema::Table'); - - die new Exception("Referenced columns must be a not empty list of columns") if not UNIVERSAL::isa($args{'referencedColumns'},'ARRAY') or not scalar(@{$args{'referencedColumns'}}); - - my @ReferencedColumns = map {IMPL::SQL::Schema::Constraint::ResolveColumn($args{'referencedTable'},$_)} @{$args{'referencedColumns'}}; - my $ForeingPK = $args{'referencedTable'}->primaryKey or die new Exception('The referenced table doesn\'t have a primary key'); - - scalar (@ReferencedColumns) == $this->columns->Count or die new Exception('A foreing key columns doesn\'t match refenced columns'); - my @ColumnsCopy = @ReferencedColumns; - - die new Exception('A foreing key columns doesn\'t match refenced columns') if grep { not $_->type->SameValue((shift @ColumnsCopy)->type)} @{$this->columns}; - - @ColumnsCopy = @ReferencedColumns; - die new Exception('The foreign key must match to the primary key of the referenced table',$this->name) if grep { not $_->type->SameValue(shift(@ColumnsCopy)->type)} @{$ForeingPK->columns}; - - $this->{$referencedPrimaryKey} = $ForeingPK; - - $ForeingPK->ConnectFK($this); - - $this->onUpdate($args{onUpdate}) if $args{onUpdate}; - $this->onDelete($args{onDelete}) if $args{onDelete}; -} - -sub Dispose { - my ($this) = @_; - - $this->{$referencedPrimaryKey}->DisconnectFK($this) if not $this->{$referencedPrimaryKey}->isDisposed; - delete $this->{$referencedPrimaryKey}; - - $this->SUPER::Dispose; -} - -sub SameValue { - my ($this,$other) = @_; - - uc($this->onDelete || '') eq uc($other->onDelete || '')or return 0; - uc($this->onUpdate || '') eq uc($other->onUpdate || '') or return 0; - - return $this->SUPER::SameValue($other); -} - - - -1;
--- a/lib/IMPL/SQL/Schema/Constraint/Index.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,15 +0,0 @@ -package IMPL::SQL::Schema::Constraint::Index; -use strict; -use parent qw(IMPL::SQL::Schema::Constraint); - -__PACKAGE__->PassThroughArgs; -__PACKAGE__->RegisterAlias('index'); - -sub CTOR { - my $this = shift; - - my %colnames; - not grep { $colnames{$_}++ } $this->columns or die new Exception('Each column in the index can occur only once'); -} - -1;
--- a/lib/IMPL/SQL/Schema/Constraint/PrimaryKey.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,42 +0,0 @@ -package IMPL::SQL::Schema::Constraint::PrimaryKey; -use strict; -use parent qw(IMPL::SQL::Schema::Constraint::Index); -use IMPL::Class::Property; - -__PACKAGE__->PassThroughArgs; -__PACKAGE__->RegisterAlias('pk'); - -BEGIN { - public _direct property connectedFK => prop_get; -} - -sub CTOR { - my ($this,%args) = @_; - - $this->{$connectedFK} = {}; -} - -sub ConnectFK { - my ($this,$FK) = @_; - - UNIVERSAL::isa($FK,'IMPL::SQL::Schema::Constraint::ForeignKey') or die new Exception('Aprimary key could be connected only to a foreign key'); - not exists $this->{$connectedFK}->{$FK->uniqName} or die new Exception('This primary key already conneted with the specified foreing key',$FK->name,$FK->table->name); - - $this->{$connectedFK}->{$FK->uniqName} = $FK; -} - -sub DisconnectFK { - my ($this,$FK) = @_; - - delete $this->{$connectedFK}->{$FK->uniqName}; -} - -sub Dispose { - my ($this) = @_; - - delete $this->{$connectedFK}; - - $this->SUPER::Dispose; -} - -1;
--- a/lib/IMPL/SQL/Schema/Constraint/Unique.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,8 +0,0 @@ -package IMPL::SQL::Schema::Constraint::Unique; -use strict; -use parent qw(IMPL::SQL::Schema::Constraint::Index); - -__PACKAGE__->PassThroughArgs; -__PACKAGE__->RegisterAlias('unique'); - -1;
--- a/lib/IMPL/SQL/Schema/Diff.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,192 +0,0 @@ -package IMPL::SQL::Schema::Diff; -use strict; -use warnings; -use IMPL::lang qw(:compare :hash is typeof); - -use IMPL::SQL::Schema::Traits(); - -use IMPL::require { - Schema => 'IMPL::SQL::Schema', - ForeignKey => '-IMPL::SQL::Schema::Constraint::ForeignKey', - PrimaryKey => '-IMPL::SQL::Schema::Constraint::PrimaryKey', - UniqueConstraint =>'-IMPL::SQL::Schema::Constraint::Unique', - Index => '-IMPL::SQL::Schema::Constraint::Index', - TraitsForeignKey => '-IMPL::SQL::Schema::Traits::ForeignKey', - TraitsPrimaryKey => '-IMPL::SQL::Schema::Traits::PrimaryKey', - TraitsUnique => '-IMPL::SQL::Schema::Traits::Unique', - TraitsIndex => '-IMPL::SQL::Schema::Traits::Index', - TraitsDropTable => '-IMPL::SQL::Schema::Traits::DropTable', - TraitsCreateTable => '-IMPL::SQL::Schema::Traits::CreateTable', - TraitsTable => '-IMPL::SQL::Schema::Traits::Table', - TraitsColumn => '-IMPL::SQL::Schema::Traits::Column', - TraitsAlterTableDropConstraint => '-IMPL::SQL::Schema::Traits::AlterTableDropConstraint', - TraitsAlterTableAddConstraint => '-IMPL::SQL::Schema::Traits::AlterTableAddConstraint', - TraitsAlterTableDropColumn => '-IMPL::SQL::Schema::Traits::AlterTableDropColumn', - TraitsAlterTableAddColumn => '-IMPL::SQL::Schema::Traits::AlterTableAddColumn', - TraitsAlterTableChangeColumn => '-IMPL::SQL::Schema::Traits::AlterTableChangeColumn', - Exception => 'IMPL::Exception', - ArgException => '-IMPL::InvalidArgumentException' -}; - -sub Diff { - my ($self,$src,$dst) = @_; - - die ArgException->new( src => "A valid source schema is required") unless is($src,Schema); - die ArgException->new( dst => "A valid desctination schema is requried" ) unless is($src,Schema); - - my %dstTables = map { $_->name, $_ } $dst->GetTables; - - my @operations; - - foreach my $srcTable ( $src->GetTables) { - my $dstTable = delete $dstTables{$srcTable->name}; - - if (not $dstTable) { - # if a source table doesn't have a corresponding destination table, it should be deleted - push @operations, TraitsDropTable->new($srcTable->name); - } else { - # a source table needs to be updated - push @operations, $self->_DiffTables($srcTable,$dstTable); - } - - } - - foreach my $tbl ( values %dstTables ) { - push @operations, TraitsCreateTable->new( - TraitsTable->new( - $tbl->name, - [ map _Column2Traits($_), @{$tbl->columns} ], - [ map _Constraint2Traits($_), $tbl->GetConstraints()], - $tbl->{tag} - ) - ) - } - - return \@operations; -} - -sub _DiffTables { - my ($self,$src,$dst) = @_; - - my @dropConstraints; - my @createConstraints; - - my %srcConstraints = map { $_->name, $_ } $src->GetConstraints(); - my %dstConstraints = map { $_->name, $_ } $dst->GetConstraints(); - - foreach my $cnSrcName (keys %srcConstraints) { - if ( my $cnDst = delete $dstConstraints{$cnSrcName} ) { - unless ( $srcConstraints{$cnSrcName}->SameValue($cnDst) ) { - push @dropConstraints, - TraitsAlterTableDropConstraint->new( $src->name, $cnSrcName ); - push @createConstraints, - TraitsAlterTableAddConstraint->new( $dst->name, _Constraint2Traits($cnDst) ); - } - } else { - push @dropConstraints,TraitsAlterTableDropConstraint->new( $src->name, $cnSrcName ); - } - } - - foreach my $cnDst (values %dstConstraints) { - push @createConstraints, - TraitsAlterTableAddConstraint->new( $dst->name, _Constraint2Traits($cnDst) ); - } - - my @deleteColumns; - my @addColumns; - my @updateColumns; - - my %dstColumnIndexes = map { - my $col = $dst->GetColumnAt($_); - ($col->name, { column => $col, index => $_ }) - } 0 .. $dst->ColumnsCount-1; - - my @columns; - - # remove old columns, mark for update changed columns - for( my $i=0; $i < $src->ColumnsCount; $i++) { - my $colSrc = $src->GetColumnAt($i); - - if ( my $infoDst = delete $dstColumnIndexes{$colSrc->name} ) { - $infoDst->{prevColumn} = $colSrc; - push @columns,$infoDst; - } else { - push @deleteColumns,TraitsAlterTableDropColumn->new($src->name,$colSrc->name); - } - } - - #insert new columns at specified positions - foreach ( sort { $a->{index} <=> $b->{index} } values %dstColumnIndexes ) { - splice(@columns,$_->{index},0,$_); - push @addColumns, TraitsAlterTableAddColumn->new($src->name, _Column2Traits( $_->{column}, position => $_->{index} )); - } - - # remember old indexes - for(my $i =0; $i< @columns; $i ++) { - $columns[$i]->{prevIndex} = $i; - } - - # reorder columns - @columns = sort { $a->{index} <=> $b->{index} } @columns; - - foreach my $info (@columns) { - if ($info->{prevColumn} && ( !$info->{column}->SameValue($info->{prevColumn}) or $info->{index}!= $info->{prevIndex} ) ) { - my $op = TraitsAlterTableChangeColumn->new($src->name,$info->{column}->name); - - $op->position( $info->{index} ) unless $info->{prevIndex} == $info->{index}; - $op->isNullable( $info->{column}->isNullable ) unless equals($info->{column}->isNullable,$info->{prevColumn}->isNullable); - $op->defaultValue( $info->{column}->defaultValue ) unless equals($info->{column}->defaultValue, $info->{prevColumn}->defaultValue); - - my $diff = hashDiff($info->{prevColumn}->tag,$info->{column}->tag); - $op->options($diff) if %$diff; - - push @updateColumns, $op; - } - } - - my @result = (@dropConstraints, @deleteColumns, @addColumns, @updateColumns, @createConstraints); - - return @result; -} - -sub _Column2Traits { - my ($column,%options) = @_; - - return TraitsColumn->new( - $column->name, - $column->type, - isNullable => $column->isNullable, - defaultValue => $column->defaultValue, - tag => $column->tag, - %options - ); -} - -sub _Constraint2Traits { - my ($constraint) = @_; - - my $map = { - ForeignKey , TraitsForeignKey, - PrimaryKey , TraitsPrimaryKey, - UniqueConstraint , TraitsUnique, - Index , TraitsIndex - }; - - my $class = $map->{typeof($constraint)} or die Exception->new("Can't map the constraint",typeof($constraint)); - - if ($class eq TraitsForeignKey) { - return $class->new( - $constraint->name, - [ map $_->name, $constraint->columns ], - $constraint->referencedPrimaryKey->table->name, - [ map $_->name, $constraint->referencedPrimaryKey->columns ] - ); - } else { - return $class->new( - $constraint->name, - [ map $_->name, $constraint->columns ] - ); - } -} - -1;
--- a/lib/IMPL/SQL/Schema/MySQL/CharType.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,27 +0,0 @@ -package IMPL::SQL::Schema::MySQL::CharType; -use strict; - -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - Exception => 'IMPL::Exception', - ArgException => '-IMPL::InvalidArgumentException' - }, - base => [ - 'IMPL::SQL::Schema::Type' => '@_' - ], - props => [ - encoding => PROP_RO - ] -}; - -my @CHAR_TYPES = qw(VARCHAR CHAR); - -sub CTOR { - my ($this) = @_; - - die ArgException->new(name => "The specified name is invalid", $this->name) - unless grep uc($this->name) eq $_, @CHAR_TYPES; -} - -1; \ No newline at end of file
--- a/lib/IMPL/SQL/Schema/MySQL/EnumType.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,23 +0,0 @@ -package IMPL::SQL::Schema::MySQL::EnumType; -use strict; - -use IMPL::Const qw(:prop); -use IMPL::declare { - base => [ - 'IMPL::SQL::Schema::Type' => '@_' - ], - props => [ - enumValues => PROP_RO | PROP_LIST - ] -}; - -our @ENUM_TYPES = qw(ENUM SET); - -sub CTOR { - my $this = shift; - - die ArgException->new(name => "The specified name is invalid", $this->name) - unless grep uc($this->name) eq $_, @ENUM_TYPES; -} - -1; \ No newline at end of file
--- a/lib/IMPL/SQL/Schema/MySQL/Formatter.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,561 +0,0 @@ -package IMPL::SQL::Schema::MySQL::Formatter; -use strict; - -use IMPL::lang qw(is); -use IMPL::require { - Exception => 'IMPL::Exception', - OpException => '-IMPL::InvalidOperationException', - ArgException => '-IMPL::InvalidArgumentException', - PrimaryKey => '-IMPL::SQL::Schema::Constraint::PrimaryKey', - UniqueIndex => '-IMPL::SQL::Schema::Constraint::Unique', - Index => '-IMPL::SQL::Schema::Constraint::Index', - ForeignKey => '-IMPL::SQL::Schema::Constraint::ForeignKey', - CharType => '-IMPL::SQL::Schema::MySQL::CharType', - EnumType => '-IMPL::SQL::Schema::MySQL::EnumType', - TraitsDropTable => '-IMPL::SQL::Schema::Traits::DropTable', - TraitsCreateTable => '-IMPL::SQL::Schema::Traits::CreateTable', - TraitsAlterTableDropConstraint => '-IMPL::SQL::Schema::Traits::AlterTableDropConstraint', - TraitsAlterTableAddConstraint => '-IMPL::SQL::Schema::Traits::AlterTableAddConstraint', - TraitsAlterTableDropColumn => '-IMPL::SQL::Schema::Traits::AlterTableDropColumn', - TraitsAlterTableAddColumn => '-IMPL::SQL::Schema::Traits::AlterTableAddColumn', - TraitsAlterTableChangeColumn => '-IMPL::SQL::Schema::Traits::AlterTableChangeColumn' -}; - -our %TRAITS_FORMATS = ( - TraitsDropTable, 'FormatDropTable', - TraitsCreateTable, 'FormatCreateTable', - TraitsAlterTableDropConstraint, 'FormatAlterTableDropConstraint', - TraitsAlterTableAddConstraint, 'FormatAlterTableAddConstraint', - TraitsAlterTableDropColumn, 'FormatAlterTableDropColumn', - TraitsAlterTableAddColumn, 'FormatAlterTableAddColumn', - TraitsAlterTableChangeColumn, 'FormatAlterTableChangeColumn' -); - -sub quote { - my $self = shift; - - if (wantarray) { - return map { my $str = $_; $str =~ s/'/''/g; "'$str'"; } @_; - } - else { - return join '', map { my $str = $_; $str =~ s/'/''/g; "'$str'"; } @_; - } -} - -sub quote_names { - my $self = shift; - - if (wantarray) { - return map { my $str = $_; $str =~ s/`/``/g; "`$str`"; } @_; - } - else { - return join '', map { my $str = $_; $str =~ s/`/``/g; "`$str`"; } @_; - } -} - -sub formatTypeNameInteger { - my ( $self, $type ) = @_; - - return - $type->name - . ( $type->maxLength ? '(' . $type->maxLength . ')' : '' ) - . ( $type->unsigned ? ' UNSIGNED' : '' ) - . ( $type->zerofill ? ' ZEROFILL' : '' ); -} - -sub formatTypeNameReal { - my ( $self, $type ) = @_; - - return $type->name - . ( $type->maxLength - ? '(' . $type->maxLength . ', ' . $type->scale . ')' - : '' ) - . ( $type->unsigned ? ' UNSIGNED' : '' ) - . ( $type->zerofill ? ' ZEROFILL' : '' ); -} - -sub formatTypeNameNumeric { - my ( $self, $type ) = @_; - $type->maxLength - or die ArgException->new( - type => 'The length and precission must be specified', - $type->name - ); - return $type->name - . ( $type->maxLength - ? '(' . $type->maxLength . ', ' . $type->scale . ')' - : '' ) - . ( $type->unsigned ? ' UNSIGNED' : '' ) - . ( $type->zerofill ? ' ZEROFILL' : '' ); -} - -sub formatTypeName { - my ( $self, $type ) = @_; - return $type->name; -} - -sub formatTypeNameChar { - my ( $self, $type ) = @_; - - return ($type->name . '(' - . $type->MaxLength . ')' - . ( is( $type, CharType ) ? $type->encoding : '' ) ); -} - -sub formatTypeNameVarChar { - my ( $self, $type ) = @_; - - return ($type->name . '(' - . $type->maxLength . ')' - . ( is( $type, CharType ) ? $type->encoding : '' ) ); -} - -sub formatTypeNameEnum { - my ( $self, $type ) = @_; - - die ArgException->new( type => 'Invalid enum type' ) - unless is( $type, EnumType ); - return ($type->name . '(' - . join( ',', map { $self->quote($_) } $type->enumValues ) - . ')' ); -} - -sub formatStringValue { - my ( $self, $value ) = @_; - - if ( ref $value eq 'SCALAR' ) { - return $$value; - } - else { - return $self->quote($value); - } -} - -sub formatNumberValue { - my ( $self, $value ) = @_; - - if ( ref $value eq 'SCALAR' ) { - return $$value; - } - else { - $value =~ /^((\+|-)\s*)?\d+(\.\d+)?(e(\+|-)?\d+)?$/ - or die ArgException->new( - value => 'The specified value isn\'t a valid number', - $value - ); - return $value; - } -} - -our %TYPES_FORMATS = ( - TINYINT => { - formatType => \&formatTypeNameInteger, - formatValue => \&formatNumberValue - }, - SMALLINT => { - formatType => \&formatTypeNameInteger, - formatValue => \&formatNumberValue - }, - MEDIUMINT => { - formatType => \&formatTypeNameInteger, - formatValue => \&formatNumberValue - }, - INT => { - formatType => \&formatTypeNameInteger, - formatValue => \&formatNumberValue - }, - INTEGER => { - formatType => \&formatTypeNameInteger, - formatValue => \&formatNumberValue - }, - BIGINT => { - formatType => \&formatTypeNameInteger, - formatValue => \&formatNumberValue - }, - REAL => { - formatType => \&formatTypeNameReal, - formatValue => \&formatNumberValue - }, - DOUBLE => { - formatType => \&formatTypeNameReal, - formatValue => \&formatNumberValue - }, - FLOAT => { - formatType => \&formatTypeNameReal, - formatValue => \&formatNumberValue - }, - DECIMAL => { - formatType => \&formatTypeNameNumeric, - formatValue => \&formatNumberValue - }, - NUMERIC => { - formatType => \&formatTypeNameNumeric, - formatValue => \&formatNumberValue - }, - DATE => { - formatType => \&formatTypeName, - formatValue => \&formatStringValue - }, - TIME => { - formatType => \&formatTypeName, - formatValue => \&formatStringValue - }, - TIMESTAMP => { - formatType => \&formatTypeName, - formatValue => \&formatStringValue - }, - DATETIME => { - formatType => \&formatTypeName, - formatValue => \&formatStringValue - }, - CHAR => { - formatType => \&formatTypeNameChar, - formatValue => \&formatStringValue - }, - VARCHAR => { - formatType => \&formatTypeNameVarChar, - formatValue => \&formatStringValue - }, - TINYBLOB => { - formatType => \&formatTypeName, - formatValue => \&formatStringValue - }, - BLOB => { - formatType => \&formatTypeName, - formatValue => \&formatStringValue - }, - MEDIUMBLOB => { - formatType => \&formatTypeName, - formatValue => \&formatStringValue - }, - LONGBLOB => { - formatType => \&formatTypeName, - formatValue => \&formatStringValue - }, - TINYTEXT => { - formatType => \&formatTypeName, - formatValue => \&formatStringValue - }, - TEXT => { - formatType => \&formatTypeName, - formatValue => \&formatStringValue - }, - MEDIUMTEXT => { - formatType => \&formatTypeName, - formatValue => \&formatStringValue - }, - LONGTEXT => { - formatType => \&formatTypeName, - formatValue => \&formatStringValue - }, - ENUM => { - formatType => \&formatTypeNameEnum, - formatValue => \&formatStringValue - }, - SET => { - formatType => \&formatTypeNameEnum, - formatValue => \&formatStringValue - } -); - -sub FormatTypeName { - my ( $self, $type ) = @_; - - my $fn = $TYPES_FORMATS{ $type->name }{formatType} - or die ArgException->new( type => "The specified type is unknown", - $type->name ); - - return $self->$fn($type); -} - -sub FormatValue { - my ( $self, $value, $type ) = @_; - - my $fn = $TYPES_FORMATS{ $type->name }{formatValue} - or die ArgException->new( type => "The specified type is unknown", - $type->name ); - - return $self->$fn( $value, $type ); -} - -sub FormatColumn { - my ( $self, $column ) = @_; - - my @parts = ( - $self->quote_names( $column->{name} ), - $self->FormatTypeName( $column->{type} ), - $column->{isNullable} ? 'NULL' : 'NOT NULL' - ); - - push @parts, $self->FormatValue( $column->{defaultValue}, $column->{type} ) - if $column->{defaultValue}; - - push @parts, 'AUTO_INCREMENT' - if $column->{tag} and $column->{tag}->{auto_increment}; - - return join ' ', @parts; -} - -sub FormatCreateTable { - my ( $self, $op ) = @_; - - my $table = $op->table; - - my @lines; - my @body; - - push @lines, "CREATE TABLE " . $self->quote_names($table->{name}) . "("; - - push @body, map { " " . $self->FormatColumn($_) } @{ $table->{columns} } - if $table->{columns}; - - push @body, map { " " . $self->FormatConstraint($_) } @{ $table->{constraints} } - if $table->{constraints}; - - push @lines, join(",\n", @body); - - push @lines, ");"; - - return join "\n", @lines; -} - -sub FormatDropTable { - my ( $self, $op ) = @_; - - return join ' ', 'DROP TABLE', $self->quote_names( $op->tableName ), ';'; -} - -sub FormatRenameTable { - my ( $self, $op ) = @_; - - return join ' ', - 'ALTER TABLE', - $self->quote_names( $op->tableName ), - 'RENAME TO', - $self->quote_names( $op->tableNewName ), - ';'; -} - -sub FormatAlterTableAddColumn { - my ( $self, $op, $schema ) = @_; - - my @parts = ( - 'ALTER TABLE',$self->quote_names($op->tableName), 'ADD COLUMN', - $self->FormatColumn( $op->column ) - ); - - if ( defined $op->position ) { - - # mysql supports column reordering - # the new location is specified relative to the previous column - # to determine the name of the previous column we need to ask the schema - - my $table = $schema->GetTable( $op->tableName ); - - if ( $op->position == 0 ) { - push @parts, 'FIRST'; - } - else { - push @parts, 'AFTER'; - - my $prevColumn = $table->GetColumnAt( $op->position - 1 ); - push @parts, $self->quote_names( $prevColumn->{name} ); - } - } - - push @parts, ';'; - - return join ' ', @parts; -} - -sub FormatAlterTableDropColumn { - my ( $self, $op ) = @_; - - return join ' ', - 'ALTER TABLE', - $self->quote_names( $op->tableName ), - 'DROP COLUMN', - $self->quote_names( $op->columnName ), - ';'; -} - -sub FormatAlterTableChangeColumn { - my ( $self, $op, $schema ) = @_; - - my $table = $schema->GetTable( $op->tableName ); - my $column = $table->GetColumn( $op->columnName ); - - my @parts = ( - 'ALTER TABLE', - $self->quote_names( $op->tableName ), - 'MODIFY COLUMN', - $self->quote_names( $op->columnName ), - $self->FormatColumn( $self->_Column2Traits($column) ) - ); - - if ( defined $op->position ) { - - # mysql supports column reordering - # the new location is specified relative to the previous column - # to determine the name of the previous column we need to ask the schema - - if ( $op->position == 0 ) { - push @parts, 'FIRST'; - } - else { - push @parts, 'AFTER'; - - my $prevColumn = $table->GetColumnAt( $op->position - 1 ); - push @parts, $self->quote_names( $prevColumn->{name} ); - } - } - - push @parts, ';'; - return join ' ', @parts; -} - -sub FormatConstraint { - my ($self,$constraint) = @_; - - my @fkRules = - ( 'RESTRICT', 'CASCADE', 'SET NULL', 'SET DEFAULT', 'NO ACTION' ); - - my @parts; - - if ( $constraint->constraintClass eq ForeignKey ) { - push @parts, - 'CONSTRAINT', - $self->quote_names( $constraint->{name} ), - 'FOREIGN KEY', - $self->quote_names( $constraint->{name} ), - '(', - join( ', ', $self->quote_names( @{ $constraint->{columns} || [] } ) ), - ')', - 'REFERENCES', $self->quote_names( $constraint->{foreignTable} ), '(', - join( ', ', - $self->quote_names( @{ $constraint->{foreignColumns} || [] } ) ), - ')'; - - if ( my $rule = $constraint->{onDelete} ) { - $rule = uc($rule); - grep $_ eq $rule, @fkRules - or die Exception->new( "Invalid onDelete rule specified", - $constraint->{name}, $rule ); - - push @parts, 'ON DELETE', $rule; - } - - if ( my $rule = $constraint->{onUpdate} ) { - $rule = uc($rule); - grep $_ eq $rule, @fkRules - or die Exception->new( "Invalid onUpdate rule specified", - $constraint->{name}, $rule ); - - push @parts, 'ON UPDATE', $rule; - } - - } - else { - if ( $constraint->constraintClass eq PrimaryKey ) { - push @parts, 'PRIMARY KEY'; - - } - elsif ( $constraint->constraintClass eq UniqueIndex ) { - push @parts, 'UNIQUE', $self->quote_names( $constraint->{name} ); - } - elsif ( $constraint->constraintClass eq Index ) { - push @parts, 'INDEX', $self->quote_names( $constraint->{name} ); - } - else { - die Exception->new( 'Invalid constraint type', - $constraint->constraintClass ); - } - - push @parts, - '(', - join( ', ', $self->quote_names( @{ $constraint->{columns} || [] } ) ), - ')'; - } - - - return join ' ', @parts; -} - -sub FormatAlterTableAddConstraint { - my ( $self, $op ) = @_; - - return join(' ', - 'ALTER TABLE', - $self->quote_names( $op->tableName ), - 'ADD', - $self->FormatConstraint($op->constraint), - ';' - ); -} - -sub FormatAlterTableDropConstraint { - my ( $self, $op, $constraintType ) = @_; - - my @parts = ( 'ALTER TABLE', $self->quote_names( $op->tableName ), 'DROP' ); - - if ( $constraintType eq PrimaryKey ) { - push @parts, 'PRIMARY KEY'; - } - elsif ( $constraintType eq ForeignKey ) { - push @parts, 'FOREIGN KEY', $self->quote_names( $op->constraintName ); - } - elsif ( $constraintType eq UniqueIndex or $constraintType eq Index ) { - push @parts, 'INDEX', $self->quote_names( $op->constraintName ); - } - else { - die Exception->new( - 'Invalid constraint type', $op->tableName, - $op->constraintName, $constraintType - ); - } - - push @parts, ';'; - - return join ' ', @parts; -} - -sub Format { - my $self = shift; - my ($op) = @_; - - my $formatter = $TRAITS_FORMATS{ref $op} - or die OpException->new("Don't know how to format the specified operation", $op); - - $self->$formatter(@_); -} - -sub _Column2Traits { - my ( $self, $column, %options ) = @_; - - return new IMPL::SQL::Schema::Traits::Column( - $column->name, - $column->type, - isNullable => $column->isNullable, - defaultValue => $column->defaultValue, - tag => $column->tag, - %options - ); -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::SQL::Traits::MysqlFormatter> - преобразует операции над схемой в C<SQL> -выражения. - -=head1 DESCRIPTION - -Используется для форматирования операций изменения схемы БД. Осуществляет -правильное экранирование имен, форматирование значений, имен типов данных. - -=cut
--- a/lib/IMPL/SQL/Schema/MySQL/Processor.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,150 +0,0 @@ -package IMPL::SQL::Schema::MySQL::Processor; -use strict; - -use mro; -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - MySQLFormatter => 'IMPL::SQL::Schema::MySQL::Formatter', - AlterTableDropConstraint => '-IMPL::SQL::Schema::Traits::AlterTableDropConstraint', - AlterTableAddConstraint => '-IMPL::SQL::Schema::Traits::AlterTableAddConstraint', - DropTable => '-IMPL::SQL::Schema::Traits::DropTable', - PrimitiveDropTable => '-IMPL::SQL::Schema::MySQL::Processor::PrimitiveDropTable', - CreateTable => '-IMPL::SQL::Schema::Traits::CreateTable', - Table => '-IMPL::SQL::Schema::Traits::Table', - ForeignKey => '-IMPL::SQL::Schema::Traits::ForeignKey', - - }, - base => [ - 'IMPL::SQL::Schema::Processor' => sub { $_[0] } - ], - props => [ - formatter => PROP_RO, - sqlBatch => PROP_RO - ] -}; -use IMPL::lang qw(is); - -sub CTOR { - my ( $this, $schema, %opts ) = @_; - - $this->formatter( $opts{formatter} || MySQLFormatter ); - $this->sqlBatch([]); -} - -sub AddSqlBatch { - my $this = shift; - - push @{$this->sqlBatch}, @_; -} - -sub ApplyOperation { - my ($this, $op, $iteration ) = @_; - - my @formatterParams; - - if ( is( $op, AlterTableDropConstraint ) ) { - my $constraint = $this - ->dbSchema - ->GetTable($op->tableName) - ->GetConstraint($op->constraintName); - - push @formatterParams, ref $constraint; - } else { - push @formatterParams, $this->dbSchema; - } - - if ( is( $op, CreateTable ) ) { - my @constraints; - my @fk; - my $table = $op->table; - - # отделяем создание внешних ключей от таблиц - - foreach my $c (@{$table->{constraints} || []}) { - if ( is($c,ForeignKey)) { - push @fk,$c; - } else { - push @constraints, $c; - } - } - - if (@fk) { - $op = CreateTable->new( - Table->new( - $table->{name}, - $table->{columns}, - \@constraints, - $table->{options} - ) - ); - - $this->AddPendingOperations( - map AlterTableAddConstraint->new($table->{name},$_), @fk - ); - } - } - - if (is($op, DropTable)) { - my $table = $this->dbSchema->GetTable($op->tableName); - - if(my $pk = $table->primaryKey) { - $this->ApplyOperation($_,$iteration) - foreach - map - AlterTableDropConstraint->new($_->table->name,$_->name), - values %{$pk->connectedFK || {}}; - } - } - - $this->next::method($op,$iteration); - - $this->AddSqlBatch( - $this->formatter->Format($op,@formatterParams) - ); -} - -package IMPL::SQL::Schema::MySQL::Processor::PrimitiveDropTable; -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - ArgException => '-IMPL::InvalidArgumentException' - }, - base => [ - 'IMPL::Object' => undef - ], - props => [ - tableName => PROP_RO, - ] -}; - -sub CTOR { - my ($this,$tableName) = @_; - - $this->tableName($tableName) or die ArgException->new("tableName is required"); -} - -sub CanApply { - my ($this,$schema) = @_; - - my $table = $schema->GetTable( $this->tableName ) - or return 0; - - my $pk = $table->primaryKey - or return 1; - - my $canDrop = keys(%{$pk->connectedFK || {}}) ? 0 : 1; - - warn "Can drop ", $this->tableName - if $canDrop; - - return $canDrop; -} - -sub Apply { - my ($this,$schema) = @_; - - $schema->RemoveTable($this->tableName); -} - -1;
--- a/lib/IMPL/SQL/Schema/Processor.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,99 +0,0 @@ -package IMPL::SQL::Schema::Processor; -use strict; - -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - Exception => 'IMPL::Exception', - ArgException => '-IMPL::InvalidArgumentException' - }, - base => [ - 'IMPL::Object' => undef - ], - props => [ - dbSchema => PROP_RO, - updateBatch => PROP_RO, - pendingOperations => PROP_RO - ] -}; - -sub CTOR { - my ($this,$schema) = @_; - - $this->dbSchema($schema) - or die ArgException->new(schema => 'A DB schema is required'); - - $this->updateBatch([]); - $this->pendingOperations([]); -} - -sub AddUpdateBatch { - my $this = shift; - - push @{$this->updateBatch}, @_; -} - -sub AddPendingOperations { - my $this = shift; - - push @{$this->pendingOperations}, @_; -} - -sub ProcessBatch { - my ($this,$batch) = @_; - - $this->pendingOperations($batch); - my $i = 1; - while(@{$this->pendingOperations}) { - $batch = $this->pendingOperations; - $this->pendingOperations([]); - - my $noChanges = 1; - - foreach my $op (@$batch) { - if ($this->CanApplyOperation($op,$i)) { - $noChanges = 0; - - $this->ApplyOperation($op,$i); - } else { - $this->AddPendingOperations($op); - } - } - - if ($noChanges && @{$this->pendingOperations}) { - die Exception->new("No changes were made (iteration $i), but some operations are pending",@{$this->pendingOperations}); - } - - $i++; - } -} - -sub CanApplyOperation { - my ($this,$op) = @_; - - return $op->CanApply($this->dbSchema); -} - -sub ApplyOperation { - my ($this,$op) = @_; - - $op->Apply($this->dbSchema); - $this->AddUpdateBatch($op); -} - -1; - -__END__ - -=pod - -=head1 NAME - -=head1 SYNOPSIS - -=head1 DESCRIPTION - -Позволяет применит набор примитивных операций C<IMPL::SQL::Schema::Traits> к -схеме. - -=cut \ No newline at end of file
--- a/lib/IMPL/SQL/Schema/Table.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,273 +0,0 @@ -package IMPL::SQL::Schema::Table; -use strict; - -use IMPL::lang qw(is); -use IMPL::Const qw(:prop); -use IMPL::declare { - base => [ - 'IMPL::Object' => undef, - 'IMPL::Object::Disposable' => undef - ], - props => [ - name => PROP_RO | PROP_DIRECT, - schema => PROP_RO | PROP_DIRECT, - columns => PROP_RO | PROP_DIRECT, - constraints => PROP_RO | PROP_DIRECT, - columnsByName => PROP_RO | PROP_DIRECT, - primaryKey => PROP_RO | PROP_DIRECT, - tag => PROP_RW | PROP_DIRECT, - ] -}; - -require IMPL::SQL::Schema::Column; -require IMPL::SQL::Schema::Constraint; -require IMPL::SQL::Schema::Constraint::PrimaryKey; -require IMPL::SQL::Schema::Constraint::ForeignKey; - -sub CTOR { - my ($this,%args) = @_; - - $this->{$name} = $args{'name'} or die new IMPL::InvalidArgumentException('a table name is required'); - $this->{$schema} = $args{'schema'} or die new IMPL::InvalidArgumentException('a parent schema is required'); - - if ($args{columns}) { - die new IMPL::InvalidOperationException('A columns property should be a reference to an array') unless ref $args{columns} eq 'ARRAY'; - - $this->InsertColumn($_) foreach @{$args{columns}}; - } -} - -sub InsertColumn { - my ($this,$column,$index) = @_; - - $index = ($this->{$columns} ? scalar(@{$this->{$columns}}) : 0) if not defined $index; - - die new IMPL::InvalidArgumentException("The index is out of range") if ($index < 0 || $index > ($this->{$columns} ? scalar(@{$this->{$columns}}) : 0)); - - if (UNIVERSAL::isa($column,'IMPL::SQL::Schema::Column')) { - - } elsif (UNIVERSAL::isa($column,'HASH')) { - $column = new IMPL::SQL::Schema::Column(%{$column}); - } else { - die new IMPL::InvalidArgumentException("The invalid column parameter"); - } - - if (exists $this->{$columnsByName}->{$column->name}) { - die new IMPL::InvalidOperationException("The column already exists",$column->name); - } else { - $this->{$columnsByName}->{$column->name} = $column; - splice @{$this->{$columns}},$index,0,$column; - } - - return $column; -} - -sub RemoveColumn { - my ($this,$NameOrColumn,$Force) = @_; - - my $ColName; - if (UNIVERSAL::isa($NameOrColumn,'IMPL::SQL::Schema::Column')) { - $ColName = $NameOrColumn->name; - } elsif (not ref $NameOrColumn) { - $ColName = $NameOrColumn; - } - - if (exists $this->{$columnsByName}->{$ColName}) { - my $index = 0; - foreach my $column(@{$this->{$columns}}) { - last if $column->name eq $ColName; - $index++; - } - - my $column = $this->{$columns}[$index]; - if (my @constraints = $this->GetColumnConstraints($column)){ - $Force or die new IMPL::InvalidOperationException('Can\'t remove column which is used in the constraints',@constraints); - $this->RemoveConstraint($_) foreach @constraints; - } - - my $removed = splice @{$this->{$columns}},$index,1; - delete $this->{$columnsByName}->{$ColName}; - return $removed; - } else { - die new IMPL::InvalidOperationException("The column not found",$NameOrColumn->name); - } -} - -sub GetColumn { - my ($this,$name) = @_; - - return $this->{$columnsByName}->{$name}; -} - -sub GetColumnAt { - my ($this,$index) = @_; - - die new IMPL::InvalidArgumentException("The index is out of range") - if $index < 0 || $index >= ($this->{$columns} ? scalar(@{$this->{$columns}}) : 0); - - return $this->{$columns}[$index]; -} - -sub SetColumnPosition { - my ($this,$nameOrColumn,$pos) = @_; - - my $colName; - if (is($nameOrColumn,'IMPL::SQL::Schema::Column')) { - $colName = $nameOrColumn->name; - } elsif (not ref $nameOrColumn) { - $colName = $nameOrColumn; - } else { - die IMPL::InvalidArgumentException->new(column => 'The specified column isn\'t found in the table'); - } - - die IMPL::InvalidArgumentException->new( 'pos' => 'The specified position is invalid') - if not defined $pos || $pos < 0 || $pos >= $this->columnsCount; - - my $index = 0; - foreach my $column(@{$this->{$columns}}) { - last if $column->name eq $colName; - $index++; - } - - if ($pos != $index) { - #position needs to be changed; - - my ($column) = splice @{$this->{$columns}}, $index, 1; - splice @{$this->{$columns}}, $pos, 0, $column; - } - - return; -} - -sub columnsCount { - my ($this) = @_; - - return scalar(@{$this->{$columns}}); -} - -sub ColumnsCount { - goto &columnsCount; -} - -sub AddConstraint { - my $this = shift; - if (@_ == 1) { - my ($Constraint) = @_; - - die new IMPL::InvalidArgumentException('The invalid parameter') if not is($Constraint,'IMPL::SQL::Schema::Constraint'); - - $Constraint->table == $this or die new IMPL::InvalidOperationException('The constaint must belong to the target table'); - - if (exists $this->{$constraints}->{$Constraint->name}) { - die new IMPL::InvalidOperationException('The table already has the specified constraint',$Constraint->name); - } else { - if (UNIVERSAL::isa($Constraint,'IMPL::SQL::Schema::Constraint::PrimaryKey')) { - not $this->{$primaryKey} or die new IMPL::InvalidOperationException('The table already has a primary key'); - $this->{$primaryKey} = $Constraint; - } - - $this->{$constraints}->{$Constraint->name} = $Constraint; - } - } elsif( @_ == 2) { - my ($type,$params) = @_; - - $type = IMPL::SQL::Schema::Constraint->ResolveAlias($type) or - die new IMPL::Exception("Can't resolve a constraint alias",$_[0]); - - $params = {%{$params}}; - - $params->{table} = $this; - - $this->AddConstraint($type->new(%$params)); - } else { - die new IMPL::Exception("Wrong arguments number",scalar(@_)); - } -} - -sub RemoveConstraint { - my ($this,$Constraint,$Force) = @_; - - my $cn = UNIVERSAL::isa($Constraint,'IMPL::SQL::Schema::Constraint') ? $Constraint->name : $Constraint; - $Constraint = $this->{$constraints}->{$cn} or die new IMPL::InvalidOperationException('The specified constraint doesn\'t exists',$cn); - - if (UNIVERSAL::isa($Constraint,'IMPL::SQL::Schema::Constraint::PrimaryKey')) { - not scalar keys %{$this->{$primaryKey}->ConnectedFK} or die new IMPL::InvalidOperationException('Can\'t remove Primary Key unless some foreign keys referenses it'); - - delete $this->{$primaryKey}; - } - $Constraint->Dispose; - delete $this->{$constraints}->{$cn}; - return $cn; -} - -sub GetConstraint { - my ($this,$name) = @_; - - return $this->{$constraints}{$name}; -} - -sub GetConstraints { - my ($this) = @_; - - return wantarray ? values %{$this->{$constraints}} : [values %{$this->{$constraints}}]; -} - -sub GetColumnConstraints { - my ($this,@Columns) = @_; - - my @cn = map { UNIVERSAL::isa($_ ,'IMPL::SQL::Schema::Column') ? $_ ->name : $_ } @Columns; - exists $this->{$columnsByName}->{$_} or die new IMPL::InvalidOperationException('The specified column isn\'t found',$_) foreach @cn; - - return grep {$_->HasColumn(@cn)} values %{$this->{$constraints}}; -} - -sub SetPrimaryKey { - my ($this,@ColumnList) = @_; - - $this->AddConstraint(new IMPL::SQL::Schema::Constraint::PrimaryKey(name => $this->{$name}.'_PK', table => $this, columns => \@ColumnList)); -} - -sub LinkTo { - my ($this,$table,@ColumnList) = @_; - $table->primaryKey or die new IMPL::InvalidOperationException('The referenced table must have a primary key'); - my $constraintName = $this->{$name}.'_'.$table->name.'_FK_'.join('_',map {ref $_ ? $_->name : $_} @ColumnList); - $this->AddConstraint(new IMPL::SQL::Schema::Constraint::ForeignKey(name => $constraintName, table => $this, columns => \@ColumnList, referencedTable => $table, referencedColumns => $table->primaryKey->columns->as_list)); -} - -sub Dispose { - my ($this) = @_; - - $_->Dispose() foreach values %{$this->{$constraints}}; - - undef %{$this}; - $this->SUPER::Dispose(); -} - -sub SameValue { - my ($this,$other) = @_; - - return 0 unless is($other, typeof($this)); - - return 0 unless $this->name eq $other->name; - return 0 unless $this->ColumnsCount eq $other->ColumnsCount; - - for (my $i = 0; $i < $this->ColumsCount; $i ++) { - return 0 unless $this->($i)->SameValue($other->GetColumnAt($i)); - } - - my %thisConstraints = map { $_->name, $_ } $this->GetConstraints(); - my %otherConstraints = map { $_->name, $_ } $other->GetConstraints(); - - foreach my $name ( keys %thisConstraints ) { - return 0 unless $otherConstraints{$name}; - return 0 unless $thisConstraints{$name}->SameValue(delete $otherConstraints{$name}); - } - - return 0 if %otherConstraints; - - return 1; -} - -1; - -
--- a/lib/IMPL/SQL/Schema/Traits.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,742 +0,0 @@ -package IMPL::SQL::Schema::Traits; -use strict; -use IMPL::_core::version; -use IMPL::Exception(); - -use parent qw(IMPL::Object); - -# required for use with typeof operator -use IMPL::SQL::Schema::Constraint::PrimaryKey(); -use IMPL::SQL::Schema::Constraint::Index(); -use IMPL::SQL::Schema::Constraint::Unique(); -use IMPL::SQL::Schema::Constraint::ForeignKey(); - -################################################### - -package IMPL::SQL::Schema::Traits::Table; -use base qw(IMPL::Object::Fields); - -use fields qw( - name - columns - constraints - options -); - -sub CTOR { - my ($this,$table,$columns,$constraints,$options) = @_; - - $this->{name} = $table or die new IMPL::InvalidArgumentException(table => "A table name is required"); - $this->{columns} = $columns if defined $columns; - $this->{constraints} = $constraints if defined $constraints; - $this->{options} = $options if defined $options; -} - -################################################### - -package IMPL::SQL::Schema::Traits::Column; -use base qw(IMPL::Object::Fields); - -use fields qw( - name - type - isNullable - defaultValue - tag -); - -sub CTOR { - my ($this, $name, $type, %args) = @_; - - $this->{name} = $name or die new IMPL::InvalidArgumentException("name"); - $this->{type} = $type or die new IMPL::InvalidArgumentException("type"); - $this->{isNullable} = $args{isNullable} if exists $args{isNullable}; - $this->{defaultValue} = $args{defaultValue} if exists $args{defaultValue}; - $this->{tag} = $args{tag} if exists $args{tag}; -} - -################################################## - -package IMPL::SQL::Schema::Traits::Constraint; -use base qw(IMPL::Object::Fields); - -use fields qw( - name - columns -); - -sub CTOR { - my ($this, $name, $columns) = @_; - - $this->{name} = $name; - $this->{columns} = $columns; # list of columnNames -} - -sub constraintClass { - die new IMPL::NotImplementedException(); -} - -################################################## - -package IMPL::SQL::Schema::Traits::PrimaryKey; - -use base qw(IMPL::SQL::Schema::Traits::Constraint); - -__PACKAGE__->PassThroughArgs; - -use constant { constraintClass => typeof IMPL::SQL::Schema::Constraint::PrimaryKey }; - -################################################## - -package IMPL::SQL::Schema::Traits::Index; - -use base qw(IMPL::SQL::Schema::Traits::Constraint); - -__PACKAGE__->PassThroughArgs; - -use constant { constraintClass => typeof IMPL::SQL::Schema::Constraint::Index }; - -################################################## - -package IMPL::SQL::Schema::Traits::Unique; - -use base qw(IMPL::SQL::Schema::Traits::Constraint); - -__PACKAGE__->PassThroughArgs; - -use constant { constraintClass => typeof IMPL::SQL::Schema::Constraint::Unique }; - -################################################## - -package IMPL::SQL::Schema::Traits::ForeignKey; - -use base qw(IMPL::SQL::Schema::Traits::Constraint); -use fields qw( - foreignTable - foreignColumns - onUpdate - onDelete -); - -use constant { constraintClass => typeof IMPL::SQL::Schema::Constraint::ForeignKey }; - -our %CTOR = ( - 'IMPL::SQL::Schema::Traits::Constraint' => sub { @_[0..1] } -); - -sub CTOR { - my ($this,$foreignTable,$foreignColumns,%args) = @_[0,3..$#_]; - - $this->{foreignTable} = $foreignTable; - $this->{foreignColumns} = $foreignColumns; - - $this->{onDelete} = $args{onDelete} if $args{onDelete}; - $this->{onUpdate} = $args{onUpdate} if $args{onUpdate}; -} - - -################################################## - -package IMPL::SQL::Schema::Traits::CreateTable; - -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - Table => '-IMPL::SQL::Schema::Traits::Table', - ArgException => '-IMPL::InvalidArgumentException', - OpException => '-IMPL::InvalidOperationException' - }, - base => [ - '-IMPL::SQL::Schema::Traits' => undef - ], - props => [ - table => PROP_RO, - ] -}; -use IMPL::lang; - -sub CTOR { - my ($this,$table) = @_; - - die ArgException->new("table", "An object of IMPL::SQL::Schema::Traits::Table type is required") - unless is($table, Table); - - $this->table($table); -} - -sub CanApply { - my ($this,$schema) = @_; - - return( $schema->GetTable( $this->table->{name} ) ? 0 : 1 ); -} - -sub Apply { - my ($this,$schema) = @_; - - my $args = {%{$this->table}}; - - my $constraints = delete $args->{constraints} || []; - - my $table = $schema->AddTable($args); - - $table->AddConstraint($_->constraintClass, $_) foreach @{$constraints}; -} - -################################################## - -package IMPL::SQL::Schema::Traits::DropTable; -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - ArgException => '-IMPL::InvalidArgumentException' - }, - base => [ - '-IMPL::SQL::Schema::Traits' => undef - ], - props => [ - tableName => PROP_RO, - ] -}; - -sub CTOR { - my ($this,$tableName) = @_; - - $this->tableName($tableName) or die ArgException->new("tableName is required"); -} - -sub CanApply { - my ($this,$schema) = @_; - - return $schema->GetTable( $this->tableName ) ? 1 : 0; -} - -sub Apply { - my ($this,$schema) = @_; - - $schema->RemoveTable($this->tableName); -} - -################################################## - -package IMPL::SQL::Schema::Traits::RenameTable; -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - ArgException => '-IMPL::InvalidArgumentException' - }, - base => [ - '-IMPL::SQL::Schema::Traits' => undef - ], - props => [ - tableName => PROP_RO, - tableNewName => PROP_RO, - ] -}; - -sub CTOR { - my ($this, $oldName, $newName) = @_; - - $this->tableName($oldName) or die ArgException->new("A table name is required"); - $this->tableNewName($newName) or die ArgException->new("A new table name is required"); -} - -sub CanApply { - my ($this, $schema) = @_; - - return ($schema->GetTable($this->tableName) and not $schema->GetTable($this->tableNewName) ? 1 : 0 ); -} - -sub Apply { - my ($this,$schema) = @_; - - $schema->RenameTable($this->tableName, $this->tableNewName); - -} - -################################################# - -package IMPL::SQL::Schema::Traits::AlterTableAddColumn; - -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - Column => '-IMPL::SQL::Schema::Traits::Column', - ArgException => '-IMPL::InvalidArgumentException', - OpException => '-IMPL::InvalidOperationException' - }, - base => [ - '-IMPL::SQL::Schema::Traits' => undef - ], - props => [ - tableName => PROP_RO, - column => PROP_RO, - position => PROP_RO - ] -}; -use IMPL::lang; - - -sub CTOR { - my ($this,$tableName,$column) = @_; - - $this->tableName($tableName) or die ArgException->new("A table name is required"); - - die ArgException->new("A column should be a IMPL::SQL::Schema::Traits::Column object") - unless is($column, Column); - - $this->column($column); -} - -sub CanApply { - my ($this,$schema) = @_; - - my $table = $schema->GetTable($this->tableName) - or return 0; - - return $table->GetColumn( $this->column->{name} ) ? 0 : 1; -} - -sub Apply { - my ($this,$schema) = @_; - - my $table = $schema->GetTable($this->tableName) - or die OpException->new("The specified table doesn't exists", $this->tableName); - - if ($this->position) { - $table->AddColumn($this->column); - } else { - $table->InsertColumn($this->column,$this->position); - } -} - -################################################# - -package IMPL::SQL::Schema::Traits::AlterTableDropColumn; - -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - FK => '-IMPL::SQL::Schema::Constraint::ForeignKey', - ArgException => '-IMPL::InvalidArgumentException', - OpException => '-IMPL::InvalidOperationException' - }, - base => [ - '-IMPL::SQL::Schema::Traits' => undef - ], - props => [ - tableName => PROP_RO, - columnName => PROP_RO, - ] -}; -use IMPL::lang; - - -sub CTOR { - my ($this,$table,$column) = @_; - - $this->tableName($table) or die ArgException->new(tableName => "A table name should be specified"); - $this->columnName($column) or die ArgException->new(columnName => "A column name should be specified"); -} - -sub CanApply { - my ($this,$schema) = @_; - - my $table = $schema->GetTable($this->tableName) - or return 0; - - $table->GetColumn($this->columnName) or - return 0; - - # столбец - return $table->GetColumnConstraints($this->columnName) - ? 0 - : 1 - ; -} - -sub Apply { - my ($this,$schema) = @_; - - my $table = $schema->GetTable($this->tableName) - or die OpException->new("The specified table doesn't exists", $this->tableName); - - $table->RemoveColumn($this->columnName); -} - -################################################# - -package IMPL::SQL::Schema::Traits::AlterTableChangeColumn; - -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - Constraint => '-IMPL::SQL::Schema::Traits::Constraint', - ArgException => '-IMPL::InvalidArgumentException', - OpException => '-IMPL::InvalidOperationException' - }, - base => [ - '-IMPL::SQL::Schema::Traits' => undef - ], - props => [ - tableName => PROP_RO, - columnName => PROP_RO, - columnType => PROP_RW, - defaultValue => PROP_RW, - isNullable => PROP_RW, - position => PROP_RW, - options => PROP_RW # hash diff format, (keys have a prefix '+' - add or update value, '-' remove value) - ] -}; -use IMPL::lang; - -sub CTOR { - my ($this, $table,$column,%args) = @_; - - $this->tableName($table) or die ArgException->new(tableName => "A table name is required"); - $this->columnName($column) or die ArgException->new(columnName => "A column name is required"); - - $this->$_($args{$_}) - for (grep exists $args{$_}, qw(columnType defaultValue isNullable options)); -} - -sub CanApply { - my ($this,$schema) = @_; - - my $table = $schema->GetTable($this->tableName) - or return 0; - - return $table->GetColumn($this->columnName) ? 1 : 0; -} - -sub Apply { - my ($this,$schema) = @_; - - my $table = $schema->GetTable($this->tableName) - or die OpException->new("The specified table doesn't exists", $this->tableName); - - my $column = $table->GetColumn($this->columnName) - or die OpException->new("The specified column doesn't exists", $this->tableName, $this->columnName); - - $column->SetType($this->columnType) if defined $this->columnType; - $column->SetNullable($this->isNullable) if defined $this->isNullable; - $column->SetDefaultValue($this->defaultValue) if defined $this->defaultValue; - $column->SetOptions($this->options) if defined $this->options; - - $table->SetColumnPosition($this->position) - if ($this->position); - -} - -################################################# - -package IMPL::SQL::Schema::Traits::AlterTableAddConstraint; - -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - Constraint => '-IMPL::SQL::Schema::Traits::Constraint', - ArgException => '-IMPL::InvalidArgumentException', - FK => '-IMPL::SQL::Schema::Traits::ForeignKey' - }, - base => [ - '-IMPL::SQL::Schema::Traits' => undef - ], - props => [ - tableName => PROP_RO, - constraint => PROP_RO - ] -}; -use IMPL::lang; - -sub CTOR { - my ($this,$table,$constraint) = @_; - - $this->tableName($table) or die ArgException->new( tableName => "A table name is required"); - - die ArgException->new(constaraint => "A valid " . Constraint . " is required") - unless is($constraint, Constraint); - - $this->constraint($constraint); -} - -sub CanApply { - my ($this, $schema) = @_; - - my $table = $schema->GetTable($this->tableName) - or return 0; - - my $constraint = $this->constraint; - - my @columns = map $table->GetColumn($_), @{$constraint->{columns} || []}; - - # проверяем, что в таблице есть все столбцы для создания ограничения - return 0 if grep not($_), @columns; - - if (is($constraint,FK)) { - my $foreignTable = $schema->GetTable($constraint->{foreignTable}) - or return 0; - - my @foreignColumns = map $foreignTable->GetColumn($_), @{$constraint->{foreignColumns}||[]}; - - # внешняя таблица имеет нужные столбцы - return 0 - if grep not($_), @foreignColumns; - - # типы столбцов во внешней таблице совпадают с типами столбцов ограничения - return 0 - if grep not($columns[$_]->type->SameValue($foreignColumns[$_]->type)), (0 .. $#columns); - } - - return 1; -} - -sub Apply { - my ($this,$schema) = @_; - - my $table = $schema->GetTable($this->tableName) - or die IMPL::InvalidOperationException->new("The specified table doesn't exists", $this->tableName); - - my $constraint = $this->constraint; - - if (is($constraint,FK)) { - my $args = { %$constraint }; - $args->{referencedTable} = $schema->GetTable(delete $args->{foreignTable}); - $args->{referencedColumns} = delete $args->{foreignColumns}; - $table->AddConstraint($constraint->constraintClass, $args); - } else { - $table->AddConstraint($constraint->constraintClass, $constraint); - } - -} - -################################################# - -package IMPL::SQL::Schema::Traits::AlterTableDropConstraint; -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - PK => '-IMPL::SQL::Schema::Constraint::PrimaryKey' - }, - base => [ - '-IMPL::SQL::Schema::Traits' => undef - ], - props => [ - tableName => PROP_RO, - constraintName => PROP_RO - ] -}; -use IMPL::lang qw(is); - -sub CTOR { - my ($this,$table,$constraint) = @_; - - die new IMPL::InvalidArgumentException( tableName => "A table name is required" ) unless $table; - die new IMPL::InvalidArgumentException( constraintName => "A constraint name is required" ) unless $constraint; - - $this->tableName($table); - $this->constraintName($constraint); -} - -sub CanApply { - my ($this,$schema) = @_; - - my $table = $schema->GetTable($this->tableName) - or return 0; - - my $constraint = $table->GetConstraint($this->constraintName) - or return 0; - - # есть ли внешние ключи на данную таблицу - return ( - is($constraint,PK) - && values( %{$constraint->connectedFK || {}} ) - ? 0 - : 1 - ); -} - -sub Apply { - my ($this,$schema) = @_; - - my $table = $schema->GetTable($this->tableName) - or die IMPL::InvalidOperationException->new("The specified table doesn't exists", $this->tableName); - - $table->RemoveConstraint($this->constraintName); -} - - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::SQL::Traits> - Операции над объектками SQL схемы. - -=head1 DESCRIPTION - -Изменения схемы могу быть представлены в виде последовательности примитивных операций. -Правила выполнения последовательности примитывных действий могут варьироваться -в зависимости от процессора, который их выполняет. Например C<IMPL::SQL::Schema::Traits::Processor>. - -Данные, которые содержаться в примитивных операциях не могут существовать независимо от схемы. - -=head1 OPERATIONS - -=head2 General - -Методы обще для всех примитивных операций. - -=head3 C<CanApply($schema)> - -Определяет возможность применения операции к указанной схеме. - -Возвращаемое значение: - -=over - -=item C<true> - -Операция приминима к схеме. - -=item C<false> - -Операция не может быть применена к схеме. - -=back - -=head3 C<Apply($schema)> - -Применяет операцию к указанной схеме. - -=head2 Primitive operations - -=head3 C<IMPL::SQL::Schema::Traits::CreateTable> - -Создает таблицу - -=head4 C<CTOR($table)> - -=head4 C<[get]table> - -C<IMPL::SQL::Schema::Traits::Table> - описание создаваемой таблицы - -=head3 C<IMPL::SQL::Schema::Traits::DropTable> - -Удалает таблицу по имени - -=head4 C<CTOR($tableName)> - -=head4 C<[get]tableName> - -Имя удаляемой таблицы - -=head3 C<IMPL::SQL::Schema::Traits::RenameTable> - -=head4 C<CTOR($tableName,$tableNewName)> - -=head4 C<[get]tableName> - -Имя таблицы, которую требуется переименовать - -=head4 C<[get]tableNewName> - -Новое имя таблицы - -=head3 C<IMPL::SQL::Schema::Traits::AlterTableAddColumn> - -Добавляет столбец в таблицу - -=head4 C<CTOR($tableName,$column,$position)> - -=head4 C<[get]tableName> - -Имя таблицы в которую нужно добавить столбец - -=head4 C<[get]column> - -C<IMPL::SQL::Schema::Traits::Column> - описание столбца который нужно добавить - -=head4 C<[get]position> - -Позиция на которую нужно вставить столбец - -=head3 C<IMPL::SQL::Schema::Traits::AlterTableDropColumn> - -Удаляет столбец из таблицы - -=head4 C<CTOR($tableName,$columnName)> - -=head4 C<[get]tableName> - -Имя таблицы в которой нужно удалить столбец - -=head4 C<[get]columnName> - -Имя столбца для удаления - -=head3 C<IMPL::SQL::Schema::Traits::AlterTableChangeColumn> - -Меняет описание столбца - -=head4 C<CTOR($tableName,$columnName,%args)> - -C<%args> - хеш, ключами которого являются оставшиеся свойства создаваемого объекта. - -=head4 C<[get]tableName> - -Имя таблицы в которой находится столбец. - -=head4 C<[get]columnName> - -Имя столбца для изменения - -=head4 C<[get]columnType> - -Новый тип столбца. Не задан, если тип не меняется - -=head4 C<[get]defaultValue> - -Значение по умолчанию. Не задано, если не меняется - -=head4 C<[get]isNullable> - -Может ли столбец содержать C<NULL>. Не задано, если не меняется. - -=head4 C<[get]options> - -Хеш опций, не задан, если опции не меняются. Данный хеш содержит разничу между -старыми и новыми значениями свойства C<tag> столбца. - - -=head3 C<IMPL::SQL::Schema::Traits::AlterTableAddConstraint> - -Базовый класс для операций по добавлению ограничений - -=head4 C<CTOR($tableName,$constraint)> - -=head4 C<[get]tableName> - -Имя таблицы в которую добавляется ограничение. - -=head4 C<[get]constraint> - -C<IMPL::SQL::Schema::Traits::Constraint> - описние ограничения, которое нужно добавить. - -=head3 C<IMPL::SQL::Schema::Traits::AlterTableDropConstraint> - -Удаляет ограничение на таблицу - -=head4 C<CTOR($tableName,$constraintName)> - -=head4 C<[get]tableName> - -Имя таблицы в которой требуется удалить ограничение. - -=head4 C<[get]constraintName> - -Имя ограничения для удаления. - -=cut
--- a/lib/IMPL/SQL/Schema/Traits/Diff.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,174 +0,0 @@ -package IMPL::SQL::Schema::Traits::Diff; -use strict; -use warnings; -use IMPL::lang qw(:compare :hash is typeof); - -use IMPL::SQL::Schema(); -use IMPL::SQL::Schema::Traits(); - -# defining a constant is a good style to enable compile checks -use constant { - schema_t => 'IMPL::SQL::Schema', - ConstraintForeignKey => 'IMPL::SQL::Schema::Constraint::ForeignKey', - TraitsForeignKey => 'IMPL::SQL::Schema::Traits::ForeignKey', - ConstraintPrimaryKey => 'IMPL::SQL::Schema::Constraint::PrimaryKey', - TraitsPrimaryKey => 'IMPL::SQL::Schema::Traits::PrimaryKey', - ConstraintUnique => 'IMPL::SQL::Schema::Constraint::Unique', - TraitsUnique => 'IMPL::SQL::Schema::Traits::Unique', - ConstraintIndex => 'IMPL::SQL::Schema::Constraint::Index', - TraitsIndex => 'IMPL::SQL::Schema::Traits::Index' -}; - -sub Diff { - my ($self,$src,$dst) = @_; - - die new IMPL::InvalidArgumentException( src => "A valid source schema is required") unless is($src,schema_t); - die new IMPL::InvalidArgumentException( dst => "A valid desctination schema is requried" ) unless is($src,schema_t); - - my %dstTables = map { $_->name, $_ } $dst->GetTables; - - my @operations; - - foreach my $srcTable ( $src->GetTables) { - my $dstTable = delete $dstTables{$srcTable->name}; - - if (not $dstTable) { - # if a source table doesn't have a corresponding destination table, it should be deleted - push @operations, new IMPL::SQL::Schema::Traits::DropTable($srcTable->name); - } else { - # a source table needs to be updated - push @operations, $self->_DiffTables($srcTable,$dstTable); - } - - } - - foreach my $tbl ( values %dstTables ) { - push @operations, new IMPL::SQL::Schema::Traits::CreateTable( - new IMPL::SQL::Schema::Traits::Table( - $tbl->name, - [ map _Column2Traits($_), @{$tbl->columns} ], - [ map _Constraint2Traits($_), $tbl->GetConstraints()], - $tbl->{tag} - ) - ) - } - - return \@operations; -} - -sub _DiffTables { - my ($self,$src,$dst) = @_; - - my @dropConstraints; - my @createConstraints; - - my %srcConstraints = map { $_->name, $_ } $src->GetConstraints(); - my %dstConstraints = map { $_->name, $_ } $dst->GetConstraints(); - - foreach my $cnSrcName (keys %srcConstraints) { - if ( my $cnDst = delete $dstConstraints{$cnSrcName} ) { - unless ( $srcConstraints{$cnSrcName}->SameValue($cnDst) ) { - push @dropConstraints, - new IMPL::SQL::Schema::Traits::AlterTableDropConstraint( $src->name, $cnSrcName ); - push @createConstraints, - new IMPL::SQL::Schema::Traits::AlterTableAddConstraint( $dst->name, _Constraint2Traits($cnDst) ); - } - } else { - push @dropConstraints,new IMPL::SQL::Schema::Traits::AlterTableDropConstraint( $src->name, $cnSrcName ); - } - } - - foreach my $cnDst (values %dstConstraints) { - push @createConstraints, - IMPL::SQL::Schema::Traits::AlterTableAddConstraint->new( $dst->name, _Constraint2Traits($cnDst) ); - } - - my @deleteColumns; - my @addColumns; - my @updateColumns; - - my %dstColumnIndexes = map { - my $col = $dst->GetColumnAt($_); - ($col->name, { column => $col, index => $_ }) - } 0 .. $dst->ColumnsCount-1; - - my @columns; - - # remove old columns, mark for update changed columns - for( my $i=0; $i < $src->ColumnsCount; $i++) { - my $colSrc = $src->GetColumnAt($i); - - if ( my $infoDst = delete $dstColumnIndexes{$colSrc->name} ) { - $infoDst->{prevColumn} = $colSrc; - push @columns,$infoDst; - } else { - push @deleteColumns,new IMPL::SQL::Schema::Traits::AlterTableDropColumn($src->name,$colSrc->name); - } - } - - #insert new columns at specified positions - foreach ( sort { $a->{index} <=> $b->{index} } values %dstColumnIndexes ) { - splice(@columns,$_->{index},0,$_); - push @addColumns, new IMPL::SQL::Schema::Traits::AlterTableAddColumn($src->name, _Column2Traits( $_->{column}, position => $_->{index} )); - } - - # remember old indexes - for(my $i =0; $i< @columns; $i ++) { - $columns[$i]->{prevIndex} = $i; - } - - # reorder columns - @columns = sort { $a->{index} <=> $b->{index} } @columns; - - foreach my $info (@columns) { - if ($info->{prevColumn} && ( !$info->{column}->SameValue($info->{prevColumn}) or $info->{index}!= $info->{prevIndex} ) ) { - my $op = new IMPL::SQL::Schema::Traits::AlterTableChangeColumn($src->name,$info->{column}->name); - - $op->position( $info->{index} ) unless $info->{prevIndex} == $info->{index}; - $op->isNullable( $info->{column}->isNullable ) unless equals($info->{column}->isNullable,$info->{prevColumn}->isNullable); - $op->defaultValue( $info->{column}->defaultValue ) unless equals($info->{column}->defaultValue, $info->{prevColumn}->defaultValue); - - my $diff = hashDiff($info->{prevColumn}->tag,$info->{column}->tag); - $op->options($diff) if %$diff; - - push @updateColumns, $op; - } - } - - my @result = (@dropConstraints, @deleteColumns, @addColumns, @updateColumns, @createConstraints); - - return @result; -} - -sub _Column2Traits { - my ($column,%options) = @_; - - return new IMPL::SQL::Schema::Traits::Column( - $column->name, - $column->type, - isNullable => $column->isNullable, - defaultValue => $column->defaultValue, - tag => $column->tag, - %options - ); -} - -sub _Constraint2Traits { - my ($constraint) = @_; - - my $map = { - ConstraintForeignKey , TraitsForeignKey, - ConstraintPrimaryKey , TraitsPrimaryKey, - ConstraintUnique , TraitsUnique, - ConstraintIndex , TraitsIndex - }; - - my $class = $map->{typeof($constraint)} or die new IMPL::Exception("Can't map the constraint",typeof($constraint)); - - return $class->new( - $constraint->name, - [ map $_->name, $constraint->columns ] - ) -} - -1;
--- a/lib/IMPL/SQL/Schema/Traits/mysql.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,550 +0,0 @@ -package IMPL::SQL::Schema::Traits::mysql::Handler; -use strict; -use parent qw(IMPL::Object); -use IMPL::Class::Property; - -BEGIN { - public _direct property SqlBatch => prop_all; -} - -sub formatTypeNameInteger { - my ($type) = @_; - - return $type->Name.($type->MaxLength ? '('.$type->MaxLength.')' : '').($type->Unsigned ? ' UNSIGNED': '').($type->Zerofill ? ' ZEROFILL' : ''); -} - -sub formatTypeNameReal { - my ($type) = @_; - - return $type->Name.($type->MaxLength ? '('.$type->MaxLength.', '.$type->Scale.')' : '').($type->Unsigned ? ' UNSIGNED': '').($type->Zerofill ? ' ZEROFILL' : ''); -} - -sub formatTypeNameNumeric { - my ($type) = @_; - $type->MaxLength or die new IMPL::InvalidArgumentException('The length and precission must be specified',$type->Name); - return $type->Name.($type->MaxLength ? '('.$type->MaxLength.', '.$type->Scale.')' : '').($type->Unsigned ? ' UNSIGNED': '').($type->Zerofill ? ' ZEROFILL' : ''); -} - -sub formatTypeName { - my ($type) = @_; - return $type->Name; -} - -sub formatTypeNameChar { - my ($type) = @_; - - return ( - $type->Name.'('.$type->MaxLength.')'. (UNIVERSAL::isa($type,'IMPL::SQL::Schema::Type::mysql::CHAR') ? $type->Encoding : '') - ); -} - -sub formatTypeNameVarChar { - my ($type) = @_; - - return ( - $type->Name.'('.$type->MaxLength.')'. (UNIVERSAL::isa($type,'IMPL::SQL::Schema::Type::mysql::VARCHAR') ? $type->Encoding : '') - ); -} - -sub formatTypeNameEnum { - my ($type) = @_; - die new Exception('Enum must be a type of either IMPL::SQL::Schema::Type::mysql::ENUM or IMPL::SQL::Schema::Type::mysql::SET') if not (UNIVERSAL::isa($type,'IMPL::SQL::Schema::Type::mysql::ENUM') or UNIVERSAL::isa($type,'IMPL::SQL::Schema::Type::mysql::SET')); - return ( - $type->Name.'('.join(',',map {quote($_)} $type->Values).')' - ); -} - -sub quote{ - if (wantarray) { - return map { my $str=$_; $str=~ s/'/''/g; "'$str'"; } @_; - } else { - return join '',map { my $str=$_; $str=~ s/'/''/g; "'$str'"; } @_; - } -} - -sub quote_names { - if (wantarray) { - return map { my $str=$_; $str=~ s/`/``/g; "`$str`"; } @_; - } else { - return join '',map { my $str=$_; $str=~ s/`/``/g; "`$str`"; } @_; - } -} - -sub formatStringValue { - my ($value) = @_; - - if (ref $value) { - if (UNIVERSAL::isa($value,'IMPL::SQL::Schema::mysql::Expression')) { - return $value->as_string; - } else { - die new Exception('Can\'t format the object as a value',ref $value); - } - } else { - return quote($value); - } -} - - -sub formatNumberValue { - my ($value) = @_; - - if (ref $value) { - if (UNIVERSAL::isa($value,'IMPL::SQL::Schema::mysql::Expression')) { - return $value->as_string; - } else { - die new Exception('Can\'t format the object as a value',ref $value); - } - } else { - $value =~ /^((\+|-)\s*)?\d+(\.\d+)?(e(\+|-)?\d+)?$/ or die new Exception('The specified value isn\'t a valid number',$value); - return $value; - } -} - - -my %TypesFormat = ( - TINYINT => { - formatType => \&formatTypeNameInteger, - formatValue => \&formatNumberValue - }, - SMALLINT => { - formatType => \&formatTypeNameInteger, - formatValue => \&formatNumberValue - }, - MEDIUMINT => { - formatType => \&formatTypeNameInteger, - formatValue => \&formatNumberValue - }, - INT => { - formatType => \&formatTypeNameInteger, - formatValue => \&formatNumberValue - }, - INTEGER => { - formatType => \&formatTypeNameInteger, - formatValue => \&formatNumberValue - }, - BIGINT => { - formatType => \&formatTypeNameInteger, - formatValue => \&formatNumberValue - }, - REAL => { - formatType => \&formatTypeNameReal, - formatValue => \&formatNumberValue - }, - DOUBLE => { - formatType => \&formatTypeNameReal, - formatValue => \&formatNumberValue - }, - FLOAT => { - formatType => \&formatTypeNameReal, - formatValue => \&formatNumberValue - }, - DECIMAL => { - formatType => \&formatTypeNameNumeric, - formatValue => \&formatNumberValue - }, - NUMERIC => { - formatType => \&formatTypeNameNumeric, - formatValue => \&formatNumberValue - }, - DATE => { - formatType => \&formatTypeName, - formatValue => \&formatStringValue - }, - TIME => { - formatType => \&formatTypeName, - formatValue => \&formatStringValue - }, - TIMESTAMP => { - formatType => \&formatTypeName, - formatValue => \&formatStringValue - }, - DATETIME => { - formatType => \&formatTypeName, - formatValue => \&formatStringValue - }, - CHAR => { - formatType => \&formatTypeNameChar, - formatValue => \&formatStringValue - }, - VARCHAR => { - formatType => \&formatTypeNameVarChar, - formatValue => \&formatStringValue - }, - TINYBLOB => { - formatType => \&formatTypeName, - formatValue => \&formatStringValue - }, - BLOB => { - formatType => \&formatTypeName, - formatValue => \&formatStringValue - }, - MEDIUMBLOB => { - formatType => \&formatTypeName, - formatValue => \&formatStringValue - }, - LONGBLOB => { - formatType => \&formatTypeName, - formatValue => \&formatStringValue - }, - TINYTEXT => { - formatType => \&formatTypeName, - formatValue => \&formatStringValue - }, - TEXT => { - formatType => \&formatTypeName, - formatValue => \&formatStringValue - }, - MEDIUMTEXT => { - formatType => \&formatTypeName, - formatValue => \&formatStringValue - }, - LONGTEXT => { - formatType => \&formatTypeName, - formatValue => \&formatStringValue - }, - ENUM => { - formatType => \&formatTypeNameEnum, - formatValue => \&formatStringValue - }, - SET => { - formatType => \&formatTypeNameEnum, - formatValue => \&formatStringValue - } -); - - -=pod -CREATE TABLE 'test'.'New Table' ( - 'dd' INTEGER UNSIGNED NOT NULL AUTO_INCREMENT, - `ff` VARCHAR(45) NOT NULL, - `ffg` VARCHAR(45) NOT NULL DEFAULT 'aaa', - `ddf` INTEGER UNSIGNED NOT NULL, - PRIMARY KEY(`dd`), - UNIQUE `Index_2`(`ffg`), - CONSTRAINT `FK_New Table_1` FOREIGN KEY `FK_New Table_1` (`ddf`) - REFERENCES `user` (`id`) - ON DELETE RESTRICT - ON UPDATE RESTRICT -) -ENGINE = InnoDB; -=cut -sub formatCreateTable { - my ($table,$level,%options) = @_; - - my @sql; - - # table body - push @sql, map { formatColumn($_,$level+1) } @{$table->Columns} ; - if ($options{'skip_foreign_keys'}) { - push @sql, map { formatConstraint($_,$level+1) } grep {not UNIVERSAL::isa($_,'IMPL::SQL::Schema::Constraint::ForeignKey')} values %{$table->Constraints}; - } else { - push @sql, map { formatConstraint($_,$level+1) } values %{$table->Constraints}; - } - - for(my $i = 0 ; $i < @sql -1; $i++) { - $sql[$i] .= ','; - } - - unshift @sql, "CREATE TABLE ".quote_names($table->Name)."("; - - if ($table->Tag) { - push @sql, ")"; - push @sql, formatTableTag($table->Tag,$level); - $sql[$#sql].=';'; - } else { - push @sql, ');'; - } - - return map { (" " x $level) . $_ } @sql; -} - -sub formatDropTable { - my ($tableName,$level) = @_; - - return " "x$level."DROP TABLE ".quote_names($tableName).";"; -} - -sub formatTableTag { - my ($tag,$level) = @_; - return map { " "x$level . "$_ = ".$tag->{$_} } grep {/^(ENGINE)$/i} keys %{$tag}; -} - -sub formatColumn { - my ($column,$level) = @_; - $level ||= 0; - return " "x$level.quote_names($column->Name)." ".formatType($column->Type)." ".($column->CanBeNull ? 'NULL' : 'NOT NULL').($column->DefaultValue ? formatValueToType($column->DefaultValue,$column->Type) : '' ).($column->Tag ? ' '.join(' ',$column->Tag) : ''); -} - -sub formatType { - my ($type) = @_; - my $format = $TypesFormat{uc $type->Name} or die new Exception('The unknown type name',$type->Name); - $format->{formatType}->($type); -} - -sub formatValueToType { - my ($value,$type) = @_; - - my $format = $TypesFormat{uc $type->Name} or die new Exception('The unknown type name',$type->Name); - $format->{formatValue}->($value); -} - -sub formatConstraint { - my ($constraint,$level) = @_; - - if (UNIVERSAL::isa($constraint,'IMPL::SQL::Schema::Constraint::ForeignKey')) { - return formatForeignKey($constraint,$level); - } else { - return formatIndex($constraint, $level); - } -} - -sub formatIndex { - my ($constraint,$level) = @_; - - my $name = quote_names($constraint->Name); - my $columns = join(',',map quote_names($_->Name),@{$constraint->Columns}); - - if (ref $constraint eq 'IMPL::SQL::Schema::Constraint::PrimaryKey') { - return " "x$level."PRIMARY KEY ($columns)"; - } elsif ($constraint eq 'IMPL::SQL::Schema::Constraint::Unique') { - return " "x$level."UNIQUE $name ($columns)"; - } elsif ($constraint eq 'IMPL::SQL::Schema::Constraint::Index') { - return " "x$level."INDEX $name ($columns)"; - } else { - die new IMPL::InvalidArgumentException('The unknown constraint', ref $constraint); - } - -} - -sub formatForeignKey { - my ($constraint,$level) = @_; - - my $name = quote_names($constraint->Name); - my $columns = join(',',map quote_names($_->Name),@{$constraint->Columns}); - - not $constraint->OnDelete or grep { uc $constraint->OnDelete eq $_ } ('RESTRICT','CASCADE','SET NULL','NO ACTION','SET DEFAULT') or die new IMPL::Exception('Invalid ON DELETE reference',$constraint->OnDelete); - not $constraint->OnUpdate or grep { uc $constraint->OnUpdate eq $_ } ('RESTRICT','CASCADE','SET NULL','NO ACTION','SET DEFAULT') or die new IMPL::Exception('Invalid ON UPDATE reference',$constraint->OnUpdate); - - my $refname = quote_names($constraint->ReferencedPrimaryKey->Table->Name); - my $refcolumns = join(',',map quote_names($_->Name),@{$constraint->ReferencedPrimaryKey->Columns}); - return ( - " "x$level. - "CONSTRAINT $name FOREIGN KEY $name ($columns) REFERENCES $refname ($refcolumns)". - ($constraint->OnUpdate ? 'ON UPDATE'.$constraint->OnUpdate : ''). - ($constraint->OnDelete ? 'ON DELETE'.$constraint->OnDelete : '') - ); -} - -sub formatAlterTableRename { - my ($oldName,$newName,$level) = @_; - - return " "x$level."ALTER TABLE ".quote_names($oldName)." RENAME TO ".quote_names($newName).";"; -} - -sub formatAlterTableDropColumn { - my ($tableName, $columnName,$level) = @_; - - return " "x$level."ALTER TABLE ".quote_names($tableName)." DROP COLUMN ".quote_names($columnName).";"; -} - -=pod -ALTER TABLE `test`.`user` ADD COLUMN `my_col` VARCHAR(45) NOT NULL AFTER `name2` -=cut -sub formatAlterTableAddColumn { - my ($tableName, $column, $table, $pos, $level) = @_; - - my $posSpec = $pos == 0 ? 'FIRST' : 'AFTER '.quote_names($table->ColumnAt($pos-1)->Name); - - return " "x$level."ALTER TABLE ".quote_names($tableName)." ADD COLUMN ".formatColumn($column) .' '. $posSpec.";"; -} - -=pod -ALTER TABLE `test`.`manager` MODIFY COLUMN `description` VARCHAR(256) NOT NULL DEFAULT NULL; -=cut -sub formatAlterTableChangeColumn { - my ($tableName,$column,$table,$pos,$level) = @_; - my $posSpec = $pos == 0 ? 'FIRST' : 'AFTER '.quote_names($table->ColumnAt($pos-1)->Name); - return " "x$level."ALTER TABLE ".quote_names($tableName)." MODIFY COLUMN ".formatColumn($column).' '. $posSpec.";"; -} - -=pod -ALTER TABLE `test`.`manager` DROP INDEX `Index_2`; -=cut -sub formatAlterTableDropConstraint { - my ($tableName,$constraint,$level) = @_; - my $constraintName; - if (ref $constraint eq 'IMPL::SQL::Schema::Constraint::PrimaryKey') { - $constraintName = 'PRIMARY KEY'; - } elsif (ref $constraint eq 'IMPL::SQL::Schema::Constraint::ForeignKey') { - $constraintName = 'FOREIGN KEY '.quote_names($constraint->Name); - } elsif (UNIVERSAL::isa($constraint,'IMPL::SQL::Schema::Constraint::Index')) { - $constraintName = 'INDEX '.quote_names($constraint->Name); - } else { - die new IMPL::Exception("The unknow type of the constraint",ref $constraint); - } - return " "x$level."ALTER TABLE ".quote_names($tableName)." DROP $constraintName;"; -} - -=pod -ALTER TABLE `test`.`session` ADD INDEX `Index_2`(`id`, `name`); -=cut -sub formatAlterTableAddConstraint { - my ($tableName,$constraint,$level) = @_; - - return " "x$level."ALTER TABLE ".quote_names($tableName)." ADD ".formatConstraint($constraint,0).';'; -} - -sub CreateTable { - my ($this,$tbl,%option) = @_; - - push @{$this->{$SqlBatch}},join("\n",formatCreateTable($tbl,0,%option)); - - return 1; -} - -sub DropTable { - my ($this,$tbl) = @_; - - push @{$this->{$SqlBatch}},join("\n",formatDropTable($tbl,0)); - - return 1; -} - -sub RenameTable { - my ($this,$oldName,$newName) = @_; - - push @{$this->{$SqlBatch}},join("\n",formatAlterTableRename($oldName,$newName,0)); - - return 1; -} - -sub AlterTableAddColumn { - my ($this,$tblName,$column,$table,$pos) = @_; - - push @{$this->{$SqlBatch}},join("\n",formatAlterTableAddColumn($tblName,$column,$table,$pos,0)); - - return 1; -} -sub AlterTableDropColumn { - my ($this,$tblName,$columnName) = @_; - - push @{$this->{$SqlBatch}},join("\n",formatAlterTableDropColumn($tblName,$columnName,0)); - - return 1; -} - -sub AlterTableChangeColumn { - my ($this,$tblName,$column,$table,$pos) = @_; - - push @{$this->{$SqlBatch}},join("\n",formatAlterTableChangeColumn($tblName,$column,$table,$pos,0)); - - return 1; -} - -sub AlterTableAddConstraint { - my ($this,$tblName,$constraint) = @_; - - push @{$this->{$SqlBatch}},join("\n",formatAlterTableAddConstraint($tblName,$constraint,0)); - - return 1; -} - -sub AlterTableDropConstraint { - my ($this,$tblName,$constraint) = @_; - - push @{$this->{$SqlBatch}},join("\n",formatAlterTableDropConstraint($tblName,$constraint,0)); - - return 1; -} - -sub Sql { - my ($this) = @_; - if (wantarray) { - @{$this->SqlBatch || []}; - } else { - return join("\n",$this->SqlBatch); - } -} - -package IMPL::SQL::Schema::Traits::mysql; -use parent qw(IMPL::SQL::Schema::Traits); -use IMPL::Class::Property; - -BEGIN { - public _direct property PendingConstraints => prop_none; -} - -our %CTOR = ( - 'IMPL::SQL::Schema::Traits' => sub { - my %args = @_; - $args{'Handler'} = new IMPL::SQL::Schema::Traits::mysql::Handler; - %args; - } -); - -sub DropConstraint { - my ($this,$constraint) = @_; - - if (UNIVERSAL::isa($constraint,'IMPL::SQL::Schema::Constraint::Index')) { - return 1 if not grep { $this->TableInfo->{$this->MapTableName($constraint->Table->Name)}->{'Columns'}->{$_->Name} != IMPL::SQL::Schema::Traits::STATE_REMOVED} $constraint->Columns; - my @constraints = grep {$_ != $constraint } $constraint->Table->GetColumnConstraints($constraint->Columns); - if (scalar @constraints == 1 and UNIVERSAL::isa($constraints[0],'IMPL::SQL::Schema::Constraint::ForeignKey')) { - my $fk = shift @constraints; - if ($this->TableInfo->{$this->MapTableName($fk->Table->Name)}->{'Constraints'}->{$fk->Name} != IMPL::SQL::Schema::Traits::STATE_REMOVED) { - push @{$this->PendingActions}, {Action => \&DropConstraint, Args => [$constraint]}; - $this->{$PendingConstraints}->{$constraint->UniqName}->{'attempts'} ++; - - die new IMPL::Exception('Can\'t drop the primary key becouse of the foreing key',$fk->UniqName) if $this->{$PendingConstraints}->{$constraint->UniqName}->{'attempts'} > 2; - return 2; - } - } - } - $this->SUPER::DropConstraint($constraint); -} - -sub GetMetaTable { - my ($class,$dbh) = @_; - - return IMPL::SQL::Schema::Traits::mysql::MetaTable->new( DBHandle => $dbh); -} - -package IMPL::SQL::Schema::Traits::mysql::MetaTable; -use parent qw(IMPL::Object); -use IMPL::Class::Property; - -BEGIN { - public _direct property DBHandle => prop_none; -} - -sub ReadProperty { - my ($this,$name) = @_; - - local $this->{$DBHandle}->{PrintError}; - $this->{$DBHandle}->{PrintError} = 0; - my ($val) = $this->{$DBHandle}->selectrow_array("SELECT value FROM _Meta WHERE name like ?", undef, $name); - return $val; -} - -sub SetProperty { - my ($this,$name,$val) = @_; - - if ( $this->{$DBHandle}->selectrow_arrayref("SELECT TABLE_NAME FROM information_schema.`TABLES` T where TABLE_SCHEMA like DATABASE() and TABLE_NAME like '_Meta'")) { - if ($this->{$DBHandle}->selectrow_arrayref("SELECT name FROM _Meta WHERE name like ?", undef, $name)) { - $this->{$DBHandle}->do("UPDATE _Meta SET value = ? WHERE name like ?",undef,$val,$name); - } else { - $this->{$DBHandle}->do("INSERT INTO _Meta(name,value) VALUES ('$name',?)",undef,$val); - } - } else { - $this->{$DBHandle}->do(q{ - CREATE TABLE `_Meta` ( - `name` VARCHAR(255) NOT NULL, - `value` LONGTEXT NULL, - PRIMARY KEY(`name`) - ); - }) or die new IMPL::Exception("Failed to create table","_Meta"); - - $this->{$DBHandle}->do("INSERT INTO _Meta(name,value) VALUES (?,?)",undef,$name,$val); - } -} - -1;
--- a/lib/IMPL/SQL/Schema/Type.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,103 +0,0 @@ -package IMPL::SQL::Schema::Type; -use strict; -use warnings; - -use IMPL::lang qw( :compare ); -use IMPL::Const qw(:prop :access); -use IMPL::declare{ - base => [ - 'IMPL::Object' => undef, - ], - props => [ - name => PROP_RO | PROP_DIRECT, - maxLength => PROP_RO | PROP_DIRECT, - scale => PROP_RO | PROP_DIRECT, - unsigned => PROP_RO | PROP_DIRECT, - zerofill => PROP_RO | PROP_DIRECT, - tag => PROP_RO | PROP_DIRECT - ] -}; - -sub CTOR { - my $this = shift; - - my $fields = ref($_[0]) eq 'HASH' ? $_[0] : { @_ }; - - while(my ($k,$v) = each %$fields) { - $this->$k($v); - } - - $this->{$scale} = 0 if not $this->{$scale}; -} - -sub SameValue { - my ($this,$other) = @_; - - return ( - $this->{$name} eq $other->name - and equals($this->{$maxLength},$other->{$maxLength}) - and equals($this->{$scale},$other->{$scale}) - ); -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::SQL::Schema::Type> Описывает SQL типы данных - -=head1 SYNOPSIS - -=begin code - -use IMPL::SQL::Schema::Type; - -my $varchar_t = new IMPL::SQL::Schema::Type( name => 'varchar', maxLength => 255 ); - -my $real_t = new IMPL::SQL::Schema::Type( name => 'float', maxLength=> 10, scale => 4); # mysql: float(10,4) - -=end - -Данный класс используется для стандатрного описания SQL типов данных. В зависимости -от движка БД эти объекты могут быть представлены различными строковыми представлениями. - -=head1 MEMBERS - -=over - -=item C<CTOR(%props)> - -Конструктор, заполняет объект значениями которые были переданы в конструкторе. - -=item C<[get]name> - -Имя типа. Обязательно. - -=item C<[get]maxLength> - -Максимальная длина, используется только для типов, имеющих длину (либо переменную, -либо постоянную). - -=item C<[get]scale> - -Точность, количество знаков после запятой. Используется вместе с C<maxLength>. - -=item C<[get]unsigned> - -Используется с числовыми данными, обозначает беззнаковые типы. - -=item C<[get]zerofill> - -Нестандартный атрибут дополняющий числа лидирующими нулями до C<maxLength>. - -=item C<[get]tag> - -Хеш с дополнительными опциями. - -=back - -=cut
--- a/lib/IMPL/SQL/Types.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,39 +0,0 @@ -package IMPL::SQL::Types; -use strict; -use warnings; - -require Exporter; -our @ISA = qw(Exporter); -our @EXPORT_OK = qw(&Integer &Varchar &Float &Real &Text &Binary &DateTime); - -require IMPL::SQL::Schema::Type; - -sub Integer() { - return IMPL::SQL::Schema::Type->new(name => 'INTEGER'); -} - -sub Varchar($) { - return IMPL::SQL::Schema::Type->new(name => 'VARCHAR', maxLength => shift); -} - -sub Float($) { - return IMPL::SQL::Schema::Type->new(name => 'FLOAT', scale => shift); -} - -sub Real() { - return IMPL::SQL::Schema::Type->new(name => 'REAL'); -} - -sub Text() { - return IMPL::SQL::Schema::Type->new(name => 'TEXT'); -} - -sub Binary() { - return IMPL::SQL::Schema::Type->new(name => 'BINARY'); -} - -sub DateTime() { - return IMPL::SQL::Schema::Type->new(name => 'DATETIME'); -} - -1;
--- a/lib/IMPL/Serialization.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,449 +0,0 @@ -package IMPL::Serialization; -use strict; - -package IMPL::Serialization::Context; - -use IMPL::Exception(); -use Scalar::Util qw(refaddr); - -use IMPL::Const qw(:prop); -use IMPL::declare { - base => [ 'IMPL::Object' => undef ], - props => [ - _objectWriter => PROP_RW | PROP_DIRECT, - _context => PROP_RW | PROP_DIRECT, - _nextId => PROP_RW | PROP_DIRECT, - serializer => PROP_RW | PROP_DIRECT, - _state => PROP_RW | PROP_DIRECT - ] -}; - -sub STATE_CLOSED () { 0 } -sub STATE_OPENED () { 1 } -sub STATE_COMPLEX () { 2 } -sub STATE_DATA () { 3 } - -sub CTOR { - my ( $this, %args ) = @_; - - $this->{$_objectWriter} = $args{'ObjectWriter'}; - $this->{$_nextId} = 1; - $this->{$serializer} = - ( $args{'Serializer'} ? $args{'Serializer'} : \&DefaultSerializer ); - $this->{$_state} = STATE_CLOSED; - - return 1; -} - -sub AddVar { - my ( $this, $sName, $Var ) = @_; - - die new Exception('Invalid operation') if $this->{$_state} == STATE_DATA; - - if ( not ref $Var ) { - my $prevState = $this->{$_state}; - - $this->{$_objectWriter}->BeginObject( name => $sName ); - $this->{$_state} = STATE_OPENED; - - $this->{$serializer}->( $this, \$Var ); - - $this->{$_objectWriter}->EndObject(); - - if ( $prevState == STATE_OPENED ) { - $this->{$_state} = STATE_COMPLEX; - } - else { - $this->{$_state} = $prevState; - } - return 0; - } - - my $PrevState = $this->{$_state}; - - my $ObjID = $this->{$_context}->{ refaddr $Var}; - if ($ObjID) { - $this->{$_objectWriter}->BeginObject( name => $sName, refid => $ObjID ); - $this->{$_objectWriter}->EndObject(); - return $ObjID; - } - - $ObjID = $this->{$_nextId}; - $this->{$_nextId} = $ObjID + 1; - - $this->{$_context}->{ refaddr $Var} = $ObjID; - - $this->{$_objectWriter} - ->BeginObject( name => $sName, type => ref($Var), id => $ObjID ); - - $this->{$_state} = STATE_OPENED; - $this->{$serializer}->( $this, $Var ); - - $this->{$_objectWriter}->EndObject(); - - if ( $PrevState == STATE_OPENED ) { - $this->{$_state} = STATE_COMPLEX; - } - else { - $this->{$_state} = $PrevState; - } - - return $ObjID; -} - -sub SetData { - my ( $this, $data, $type ) = @_; - - die new Exception('The object should be a scalar value') if ref $data; - die new Exception('Invalid operation') if $this->{$_state} != STATE_OPENED; - - $this->{$_objectWriter}->SetData( $data, $type ); - - $this->{$_state} = STATE_DATA; - - return 1; -} - -sub DefaultSerializer { - my ( $_context, $refObj ) = @_; - - if ( ref($refObj) eq 'SCALAR' ) { - $_context->SetData( $$refObj, 'SCALAR' ); - } - elsif ( ref($refObj) eq 'ARRAY' ) { - $_context->AddVar( 'item', $_ ) foreach @$refObj; - } - elsif ( ref($refObj) eq 'HASH' ) { - while ( my ( $key, $value ) = each %$refObj ) { - $_context->AddVar( $key, $value ); - } - } - elsif ( ref($refObj) eq 'REF' ) { - $_context->AddVar( 'ref', $$refObj ); - } - else { - if ( ref $refObj and $refObj->UNIVARSAL::can('save') ) { - $refObj->save($_context); - } - else { - die new Exception( - 'Cant serialize the object of the type: ' . ref($refObj) ); - } - } - - return 1; -} - -package IMPL::Deserialization::Context; - -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - Exception => 'IMPL::Exception', - Loader => 'IMPL::Code::Loader' - }, - base => [ 'IMPL::Object' => undef ], - props => [ - - # структура информации об объекте - # { - # Type => 'typename', - # Name => 'object_name', - # Data => $data, - # Id => 'object_id' - # } - _context => PROP_RW | PROP_DIRECT, - _currentObject => PROP_RW | PROP_DIRECT, - _objectsPath => PROP_RW | PROP_DIRECT, - root => PROP_RW | PROP_DIRECT - ] -}; - -sub CTOR { - my ( $this, %args ) = @_; - $this->{$_currentObject} = undef; - $this->{$root} = undef; -} - -sub OnObjectBegin { - my ( $this, $name, $rhProps ) = @_; - - die Exception->new( - "Invalid data from an ObjectReader", -"An object reader should pass a referense to a hash which contains attributes of an object" - ) if ( ref $rhProps ne 'HASH' ); - - die Exception->new("Trying to create second root object") - if not $this->{$_currentObject} and $this->{$root}; - - if ( $rhProps->{'refid'} ) { - - my $refObj = $this->{$_context}->{ $rhProps->{'refid'} }; - - die Exception->new("A reference to a not existing object found") - if not $refObj; - - my $rhCurrentObj = $this->{$_currentObject}; - - die Exception->new("The root object can't be a reference") - if not $rhCurrentObj; - - if ( $rhCurrentObj->{'Data'} ) { - - die Exception->new( "Invalid serializaed data", - "Plain deserialization data for an object already exist" ) - if not ref $rhCurrentObj->{'Data'}; - - push @{ $rhCurrentObj->{'Data'} }, $name, $refObj; - } else { - $rhCurrentObj->{'Data'} = [ $name, $refObj ]; - } - - push @{ $this->{$_objectsPath} }, $rhCurrentObj; - $this->{$_currentObject} = undef; - - } else { - push @{ $this->{$_objectsPath} }, $this->{$_currentObject} - if $this->{$_currentObject}; - - $this->{$_currentObject} = { - Name => $name, - Type => $rhProps->{'type'} || 'SCALAR', - Id => $rhProps->{'id'}, - refId => $rhProps->{'refid'} - }; - - if ( defined $rhProps->{'id'} ) { - die new IMPL::Exception( -"Trying to create a simple object instead of a reference, type is missing.", - $name, $rhProps->{id} - ) unless $rhProps->{'type'}; - - $this->{$_context}->{ $rhProps->{'id'} } = $this->CreateSurrogate( $rhProps->{'type'} ); - } - } - - return 1; -} - -sub OnObjectData { - my ( $this, $data ) = @_; - - my $rhObject = $this->{$_currentObject}; - - die Exception->new("Trying to set data for an object which not exists") - if not $rhObject; - - #die Exception->new( - # "Deserialization data already exists for a current object", - # "ObjectName= $rhObject->{'Name'}" ) - # if $rhObject->{'Data'}; - - $rhObject->{'Data'} .= $data; - - return 1; -} -{ - my $autoId = 0; - - sub OnObjectEnd { - my ( $this, $name ) = @_; - - my $rhObject = $this->{$_currentObject}; - my $rhPrevObject = pop @{ $this->{$_objectsPath} }; - - if ( ( not defined($rhObject) ) && $rhPrevObject ) { - $this->{$_currentObject} = $rhPrevObject; - return 1; - } - - my $refObj = $this->CreateObject( - $rhObject->{'Type'}, - $rhObject->{'Data'}, - $rhObject->{'Id'} - ? $this->{$_context}->{ $rhObject->{'Id'} } - : undef - ); - - die Exception->new("Trying to close a non existing oject") - if not $rhObject; - - my $data; - - if ( $rhObject->{'Id'} ) { - $this->{$_context}->{ $rhObject->{'Id'} } = $refObj; - $data = $refObj; - } - else { - if ( ref $refObj ne 'SCALAR' ) { - $rhObject->{Id} = "auto$autoId"; - $autoId++; - $this->{$_context}->{ $rhObject->{'Id'} } = $refObj; - $data = $refObj; - } - else { - $data = ${$refObj}; - } - } - - if ( not $rhPrevObject ) { - $this->{$root} = $data; - } - else { - if ( $rhPrevObject->{'Data'} ) { - die Exception->new( - "Trying append a reference to an object to the plain data") - if not ref $rhPrevObject->{'Data'}; - - push @{ $rhPrevObject->{'Data'} }, $rhObject->{'Name'}, $data; - } - else { - $rhPrevObject->{'Data'} = [ $rhObject->{'Name'}, $data ]; - } - } - - $this->{$_currentObject} = $rhPrevObject; - - return 1; - } -} - -sub CreateSurrogate { - my ($this,$type) = @_; - - if ( $type eq 'SCALAR' or $type eq 'REF' ) { - my $var; - return \$var; - } - elsif ( $type eq 'ARRAY' ) { - return []; - } - elsif ( $type eq 'HASH' ) { - return {}; - } - elsif ($type) { - Loader->safe->Require($type); - if ( eval { $type->can('surrogate') } ) { - return $type->surrogate(); - } - else { - return bless {}, $type; - } - } -} - -# deserialization context: -# [ -# 'var_name',value, -# .... -# ] - -sub CreateObject { - my ($this, $type, $data, $refSurogate ) = @_; - - if ( $type eq 'SCALAR' ) { - die Exception->new("SCALAR needs a plain data for a deserialization") - if ref $data; - if ($refSurogate) { - $$refSurogate = $data; - return $refSurogate; - } - else { - return \$data; - } - } - elsif ( $type eq 'ARRAY' ) { - $data ||= []; - die Exception->new( - "Invalid a deserialization context when deserializing ARRAY") - if not ref $data and defined $data; - if ( not ref $refSurogate ) { - my @Array; - $refSurogate = \@Array; - } - for ( my $i = 0 ; $i < scalar( @{$data} ) / 2 ; $i++ ) { - push @$refSurogate, $data->[ $i * 2 + 1 ]; - } - return $refSurogate; - } - elsif ( $type eq 'HASH' ) { - $data ||= []; - die Exception->new( - "Invalid a deserialization context when deserializing HASH") - if not ref $data and defined $data; - if ( not ref $refSurogate ) { - $refSurogate = {}; - } - for ( my $i = 0 ; $i < @$data ; $i += 2 ) { - $refSurogate->{ $data->[$i] } = $data->[ $i + 1 ]; - } - return $refSurogate; - } - elsif ( $type eq 'REF' ) { - $data ||= []; - die Exception->new( - "Invalid a deserialization context when deserializing REF") - if not ref $data and defined $data; - if ( not ref $refSurogate ) { - my $ref = $data->[1]; - return \$ref; - } - else { - $$refSurogate = $data->[1]; - return $refSurogate; - } - } - else { - Loader->safe->Require($type); - if ( eval { $type->can('restore') } ) { - return $type->restore( $data, $refSurogate ); - } - else { - die Exception->new("Don't know how to deserialize $type"); - } - } -} - -package IMPL::Serializer; - -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - Exception => 'IMPL::Exception', - SerializationContext => '-IMPL::Serialization::Context', - DeserializationContext => '-IMPL::Deserialization::Context' - }, - base => [ - 'IMPL::Object' => undef - ], - props => [ - _formatter => PROP_RW - ] -}; - -sub CTOR { - my ( $this, %args ) = @_; - $this->_formatter( $args{formatter} ) - or die Exception->new("Omitted mandatory parameter 'formatter'"); -} - -sub Serialize { - my $this = shift; - my ( $hStream, $Object ) = @_; - my $ObjWriter = $this->_formatter->CreateWriter($hStream); - my $context = - SerializationContext->new( objectWriter => $ObjWriter ); - $context->AddVar( 'root', $Object ); - return 1; -} - -sub Deserialize { - my $this = shift; - my ($hStream) = @_; - my $context = DeserializationContext->new(); - my $ObjReader = $this->_formatter->CreateReader( $hStream, $context ); - $ObjReader->Parse(); - return $context->root; -} - -1;
--- a/lib/IMPL/Serialization/XmlFormatter.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,200 +0,0 @@ -package IMPL::Serialization::XmlObjectWriter; -use strict; - -use parent qw(IMPL::Object); -use IMPL::Class::Property; - -use IMPL::Serialization; -use XML::Writer; -use IMPL::Exception; - -sub CONTAINER_EMPTY () { 1 } -sub CONTAINER_NORMAL () { 2 } - -BEGIN { - public _direct property Encoding => prop_all; - public _direct property hOutput => prop_all; - public _direct property IdentOutput => prop_all; - - private _direct property CurrentObject => prop_all; - private _direct property ObjectPath => prop_all; - private _direct property XmlWriter => prop_all; - private _direct property IdentLevel => prop_all; - private _direct property IdentNextTag => prop_all; -} - -sub new { - my $class = shift; - my $self = bless {}, ref($class) || $class; - $self->CTOR(@_); - return $self; -} - -sub CTOR { - my $this = shift; - my %args = @_; - $this->{$hOutput} = $args{'hOutput'}; - $this->{$Encoding} = $args{'Encoding'}; - $this->{$CurrentObject} = undef; - $this->{$IdentOutput} = $args{'IdentOutput'}; - $this->{$IdentLevel} = 0; - $this->{$IdentNextTag} = 0; - #$this->{$ObjectPath} = []; - return 1; -} - -sub BeginObject { - my $this = shift; - my %args = @_; - - if (not $this->{$CurrentObject}) { - my $xmlWriter = new XML::Writer(OUTPUT => $this->{$hOutput}, ENCODING => $this->{$Encoding}); - $this->{$XmlWriter} = $xmlWriter; - $xmlWriter->xmlDecl(); - } - - push @{$this->{$ObjectPath}},$this->{$CurrentObject} if $this->{$CurrentObject}; - - my %ObjectProperties = %args; - delete $ObjectProperties{'name'}; - delete $args{'container_type'}; - - $this->{$CurrentObject} = \%ObjectProperties; - - my $tagname; - if (_CheckName($args{'name'})) { - $tagname = $args{'name'}; - } else { - $tagname = 'element'; - $ObjectProperties{'extname'} = $args{'name'}; - } - - if ($args{'refid'}) { - $this->{$XmlWriter}->characters("\n" . (' ' x $$this{$IdentLevel}) ) if $$this{$IdentNextTag}; - $this->{$XmlWriter}->emptyTag($tagname,%ObjectProperties); - $ObjectProperties{'container_type'} = CONTAINER_EMPTY; - } else { - $this->{$XmlWriter}->characters("\n" . (' ' x $$this{$IdentLevel}) ) if $$this{$IdentNextTag}; - $this->{$XmlWriter}->startTag($tagname,%ObjectProperties); - $ObjectProperties{'container_type'} = CONTAINER_NORMAL; - } - - $this->{$IdentLevel} ++; - $this->{$IdentNextTag} = $this->{$IdentOutput}; - - return 1; -} - -sub EndObject { - my $this = shift; - - my $hCurrentObject = $this->{$CurrentObject} or return 0; - - $this->{$IdentLevel} --; - - if ( $hCurrentObject->{'container_type'} != CONTAINER_EMPTY ) { - $this->{$XmlWriter}->characters("\n" . (' ' x $$this{$IdentLevel}) ) if $$this{$IdentNextTag}; - $this->{$XmlWriter}->endTag(); - } - - $this->{$IdentNextTag} = $this->{$IdentOutput}; - - $this->{$CurrentObject} = pop @{$this->{$ObjectPath}} if exists $this->{$ObjectPath}; - $this->{$XmlWriter} = undef if (not $this->{$CurrentObject}); - - return 1; -} - -sub SetData { - my $this = shift; - #my $hCurrentObject = $this->{$CurrentObject} or return 0; - - if ($this->{$CurrentObject}->{'container_type'} == CONTAINER_NORMAL) { - $this->{$XmlWriter}->characters($_[0]) if defined $_[0]; - $this->{$IdentNextTag} = 0; - return 1; - } else { - return 0; - } -} - -sub _CheckName { - return 0 if not $_[0]; - return $_[0] =~ /^(_|\w|\d)+$/; -} - -package IMPL::Serialization::XmlObjectReader; -use parent qw(XML::Parser); - -sub new { - my $class = shift; - my %args = @_; - die new Exception("Handler parameter is reqired") if not $args{'Handler'}; - die new Exception("Handler parameter must be a reference") if not ref $args{'Handler'}; - - #my $this = $class->SUPER::new(Style => 'Stream', Pkg => 'Serialization::XmlObjectReader', 'Non-Expat-Options' => {hInput => $args{'hInput'} , Handler => $args{'Handler'}, SkipWhitespace => $args{'SkipWhitespace'} } ); - my $this = $class->SUPER::new(Handlers => { Start => \&StartTag, End => \&EndTag, Char => \&Text} , 'Non-Expat-Options' => {hInput => $args{'hInput'} , Handler => $args{'Handler'}, SkipWhitespace => $args{'SkipWhitespace'} } ); - return $this; -} - -sub Parse { - my $this = shift; - $this->parse($this->{'Non-Expat-Options'}->{'hInput'}); - return 1; -} - -sub StartTag { - my $this = shift; - my $name = shift; - my %Attr = @_; - $name = $Attr{'extname'} if defined $Attr{'extname'}; - $this->{'Non-Expat-Options'}->{'Handler'}->OnObjectBegin($name,\%Attr); - return 1; -} - -sub EndTag { - my ($this,$name) = @_; - $this->{'Non-Expat-Options'}->{'Handler'}->OnObjectEnd($name); - return 1; -} - -sub Text { - my ($this) = shift; - my $text = shift; - return 1 if $this->{'Non-Expat-Options'}->{'SkipWhitespace'} and $text =~ /^\n*\s*\n*$/; - $this->{'Non-Expat-Options'}->{'Handler'}->OnObjectData($text); - return 1; -} - -package IMPL::Serialization::XmlFormatter; -use parent qw(IMPL::Object); - -use IMPL::Class::Property; - -BEGIN { - public _direct property Encoding => prop_all; - public _direct property SkipWhitespace => prop_all; - public _direct property IdentOutput => prop_all; -} - -sub CTOR { - my ($this,%args) = @_; - - $this->Encoding($args{'Encoding'} || 'utf-8'); - $this->SkipWhitespace($args{'SkipWhitespace'}); - $this->IdentOutput($args{'IdentOutput'}); - - return 1; -} - -sub CreateWriter { - my ($this,$hStream) = @_; - return new IMPL::Serialization::XmlObjectWriter(Encoding =>$this->Encoding() , hOutput => $hStream, IdentOutput => $this->IdentOutput()); -} - -sub CreateReader { - my ($this,$hStream,$refHandler) = @_; - return new IMPL::Serialization::XmlObjectReader(hInput => $hStream, Handler => $refHandler, SkipWhitespace => $this->SkipWhitespace()); -} - -1;
--- a/lib/IMPL/TargetException.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,24 +0,0 @@ -package IMPL::TargetException; -use strict; - -use IMPL::Const qw(:prop); -use IMPL::declare { - base => [ - 'IMPL::AppException' => undef, - ], - props => [ - innerException => PROP_RO - ] -}; - -sub CTOR { - my ($this,%args) = @_; - - $this->innerException($args{innerException}); -} - -use IMPL::Resources::Strings { - message => "An invocation target throws an exception '%innerException.message%' \n%innerException.callStack%\n__END_OF_INNER_EXCEPTION__\n" -}; - -1; \ No newline at end of file
--- a/lib/IMPL/Test.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,104 +0,0 @@ -package IMPL::Test; -use strict; -use warnings; - -use IMPL::lang qw(equals_s); -use IMPL::Const qw(:access); -require IMPL::Test::SkipException; - -require Exporter; -our @ISA = qw(Exporter); -our @EXPORT_OK = qw(&test &shared &failed &cmparray &skip &run_plan &assert &assertarray &GetCallerSourceLine); - -require IMPL::Test::Unit; -require IMPL::Test::Plan; -require IMPL::Test::TAPListener; - -sub test($$) { - my ($name,$code) = @_; - my $class = caller; - - $class->set_meta( - new IMPL::Test::Unit::TestInfo( $name, $code ) - ); -} - -sub shared($) { - my ($propInfo) = @_; - - my $class = caller; - - die new IMPL::Exception("Only properties could be declared as shared",$propInfo->name) unless eval {$propInfo->isa('IMPL::Class::PropertyInfo')}; - die new IMPL::Exception("You can't mark the readonly property as shared",$propInfo->name) unless $propInfo->setter; - die new IMPL::Exception("Only public properties could be declared as shared",$propInfo->name) unless $propInfo->access == ACCESS_PUBLIC; - - $class->set_meta(new IMPL::Test::Unit::SharedData($propInfo->name)); -} - -sub failed($;@) { - die new IMPL::Test::FailException(@_); -} - -sub assert { - my ($condition,@params) = @_; - - die new IMPL::Test::FailException(@params ? @params : ("Assertion failed" , _GetSourceLine( (caller)[1,2] )) ) unless $condition; -} - -sub skip($;@) { - die new IMPL::Test::SkipException(@_); -} - -sub cmparray { - my ($a,$b) = @_; - - return 0 unless @$a == @$b; - - for (my $i=0; $i < @$a; $i++ ) { - return 0 unless - equals_s($a->[$i], $b->[$i]); - } - - return 1; -} - -sub assertarray { - my ($a,$b) = @_; - - - die IMPL::Test::FailException->new( - "Assert arrays failed", - _GetSourceLine( (caller)[1,2] ), - join(', ', map defined($_) ? $_ : '<undef>', @$a), - join(', ', map defined($_) ? $_ : '<undef>', @$b) - ) - unless cmparray($a,$b); -} - -sub _GetSourceLine { - my ($file,$line) = @_; - - open my $hFile, $file or return "failed to open file: $file: $!"; - - my $text; - $text = <$hFile> for ( 1 .. $line); - chomp $text; - $text =~ s/^\s+//; - return "line $line: $text"; -} - -sub GetCallerSourceLine { - my $line = shift || 0; - return _GetSourceLine( (caller($line + 1))[1,2] ) -} - -sub run_plan { - my (@units) = @_; - - my $plan = new IMPL::Test::Plan(@units); - - $plan->Prepare; - $plan->AddListener(new IMPL::Test::TAPListener); - $plan->Run; -} -1;
--- a/lib/IMPL/Test/BadUnit.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,65 +0,0 @@ -package IMPL::Test::BadUnit; -use strict; -use warnings; - -use parent qw(IMPL::Test::Unit); -use IMPL::Class::Property; - -BEGIN { - public property UnitName => prop_all; - public property Message => prop_all; - public property Error => prop_all; -} - -our %CTOR = ( - 'IMPL::Test::Unit' => sub { - if (@_>1) { - # Unit construction - my ($unit,$message,$error) = @_; - return new IMPL::Test::Unit::TestInfo( - BadUnitTest => sub { - die new IMPL::Test::FailException($message,$unit,eval {$error->isa('IMPL::Exception')} ? $error->toString(1) : $error) - } - ); - } else { - # test construction - return @_; - } - } -); - -sub CTOR { - my ($this,$name,$message,$error) = @_; - - $this->UnitName($name); - $this->Message($message); - $this->Error($error); -} - -sub save { - my ($this,$ctx) = @_; - - defined ($this->$_()) and $ctx->AddVar($_ => $this->$_()) foreach qw(UnitName Message); -} - -sub restore { - my ($class,$data,$inst) = @_; - - my %args = @$data; - - $inst ||= $class->surrogate; - $inst->callCTOR(@args{qw(UnitName Message)}); -} - -sub List { - my ($this) = @_; - my $error = $this->Error; - return new IMPL::Test::Unit::TestInfo( - BadUnitTest => sub { - die new IMPL::Test::FailException($this->Message,$this->UnitName,eval {$error->isa('IMPL::Exception')} ? $error->toString(1) : $error) - } - ); -} - - -1;
--- a/lib/IMPL/Test/FailException.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,22 +0,0 @@ -package IMPL::Test::FailException; -use strict; -use warnings; - -use parent qw(IMPL::Exception); - -__PACKAGE__->PassThroughArgs; - -sub toString { - my $this = shift; - - $this->Message . join("\n",'',map IMPL::Exception::indent($_,1), @{$this->Args} ); -} - -sub save { - my ($this,$ctx) = @_; - - $ctx->AddVar(Message => $this->Message); - $ctx->AddVar(Args => $this->Args) if @{$this->Args}; -} - -1;
--- a/lib/IMPL/Test/HarnessRunner.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,27 +0,0 @@ -package IMPL::Test::HarnessRunner; -use strict; -use warnings; - -use TAP::Parser; -use Test::Harness; - -use IMPL::declare { - base => [ - 'IMPL::Object' => undef, - 'IMPL::Object::Serializable' => undef - ] -}; - -sub RunTests { - my ($this,@files) = @_; - - return runtests(@files); -} - -sub ExecuteTests { - my ($this,%args) = @_; - - return Test::Harness::execute_tests(%args); -} - -1;
--- a/lib/IMPL/Test/Plan.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,238 +0,0 @@ -package IMPL::Test::Plan; -use strict; -use warnings; - -use parent qw(IMPL::Object); -use IMPL::Class::Property; - -use IMPL::Exception; -use IMPL::Test::Result; -use IMPL::Test::BadUnit; -use Error qw(:try); - -use IMPL::Serialization; -use IMPL::Serialization::XmlFormatter; - -BEGIN { - public property Units => prop_all | prop_list; - public property Results => prop_all | prop_list; - public property Listeners => prop_all | prop_list; - private property _Cache => prop_all | prop_list; - private property _Count => prop_all; -} - -sub CTOR { - my $this = shift; - $this->Units(\@_); -} - -sub restore { - my ($class,$data,$instance) = @_; - - $instance ||= $class->surrogate; - - $instance->callCTOR(); - - my %args = @$data; - - $instance->Units($args{Units}); - $instance->Results($args{Results}) if $args{Results}; - $instance->Listeners($args{Listeners}) if $args{Listeners}; -} - -sub save { - my ($this,$ctx) = @_; - - $ctx->AddVar(Units => [$this->Units]); - $ctx->AddVar(Results => [$this->Results]) if $this->Results; - $ctx->AddVar(Listeners => [$this->Listeners]) if $this->Listeners; -} - -sub AddListener { - my ($this,$listener) = @_; - - $this->Listeners($this->Listeners,$listener); -} - -sub Prepare { - my ($this) = @_; - - my $count = 0; - my @cache; - - foreach my $Unit ($this->Units){ - my %info; - - # preload module - undef $@; - - eval "require $Unit" unless (ref $Unit); - - # handle loading errors - $Unit = new IMPL::Test::BadUnit($Unit,"Failed to load unit",$@) if $@; - - $info{Unit} = $Unit; - try { - $info{Tests} = [$Unit->List]; - } otherwise { - my $err = $@; - $Unit = $info{Unit} = new IMPL::Test::BadUnit( - $Unit->can('UnitName') ? - $Unit->UnitName : - $Unit, - "Failed to extract tests", - $err - ); - $info{Tests} = [$Unit->List]; - }; - $count += @{$info{Tests}}; - push @cache, \%info if @{$info{Tests}}; - } - - $this->_Count($count); - $this->_Cache(\@cache); -} - -sub Count { - my ($this) = @_; - return $this->_Count; -} - -sub Run { - my $this = shift; - - die new IMPL::InvalidOperationException("You must call the prepare method before running the plan") unless $this->_Cache; - - $this->_Tell(RunPlan => $this); - - my @resultsTotal; - - foreach my $info ($this->_Cache) { - $this->_Tell(RunUnit => $info->{Unit}); - - my $data; - undef $@; - eval { - $data = $info->{Unit}->StartUnit; - }; - - my @results; - - if (not $@) { - - foreach my $test (@{$info->{Tests}}) { - my $name = $test->Name; - - #protected creation of the test - $test = eval { $info->{Unit}->new($test); } || new IMPL::Test::BadUnit( - $info->{Unit}->can('UnitName') ? - $info->{Unit}->UnitName : - $info->{Unit}, - "Failed to construct the test $name", - $@ - ); - - # invoke the test - $this->_Tell(RunTest => $test); - my $result = $test->Run($data); - $this->_Tell(EndTest => $test,$result); - - push @results,$result; - } - } else { - my $e = $@; - my $badTest = new IMPL::Test::BadUnit( - $info->{Unit}->can('UnitName') ? - $info->{Unit}->UnitName : - $info->{Unit}, - "Failed to initialize the unit", - $@ - ); - foreach my $test (@{$info->{Tests}}) { - - $this->_Tell(RunTest => $badTest); - my $result = new IMPL::Test::Result( - name => $test->Name, - state => IMPL::Test::Result::FAIL, - exception => $e - ); - $this->_Tell(EndTest => $badTest,$result); - push @results,$result; - } - } - - eval { - $info->{Unit}->FinishUnit($data); - }; - - undef $@; - - push @resultsTotal, { Unit => $info->{Unit}, Results => \@results}; - - $this->_Tell(EndUnit => $info->{Unit},\@results); - } - - $this->Results(\@resultsTotal); - $this->_Tell(EndPlan => $this); -} - -sub _Tell { - my ($this,$what,@args) = @_; - - $_->$what(@args) foreach $this->Listeners; -} - -sub SaveXML { - my ($this,$out) = @_; - - my $h; - - if (ref $out eq 'GLOB') { - $h = $out; - } elsif ($out and not ref $out) { - open $h, ">", $out or die new IMPL::Exception("Failed to open file",$out); - } else { - die new IMPL::InvalidOperationException("Invalid output specified"); - } - - my $s = new IMPL::Serializer(Formatter => new IMPL::Serialization::XmlFormatter( IdentOutput => 1, SkipWhitespace => 1) ); - $s->Serialize($h,$this); -} - -sub LoadXML { - my ($self,$in) = @_; - - my $h; - - if (ref $in eq 'GLOB') { - $h = $in; - } elsif ($in and not ref $in) { - open $h, ">", $in or die new IMPL::Exception("Failed to open file",$in); - } else { - die new IMPL::InvalidOperationException("Invalid input specified"); - } - - my $s = new IMPL::Serializer(Formatter => new IMPL::Serialization::XmlFormatter( IdentOutput => 1, SkipWhitespace => 1) ); - return $s->Deserialize($h); -} - -sub xml { - my $this = shift; - my $str = ''; - - open my $h,'>',\$str or die new IMPL::Exception("Failed to create stream"); - $this->SaveXML($h); - undef $h; - return $str; -} - -sub LoadXMLString { - my $self = shift; - my $str = shift; - - open my $h,'<',\$str or die new IMPL::Exception("Failed to create stream"); - return $self->LoadXML($h); -} - - -1;
--- a/lib/IMPL/Test/Result.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,42 +0,0 @@ -package IMPL::Test::Result; -use strict; -use warnings; - -use IMPL::Const qw(:prop); -use IMPL::declare { - base => [ - 'IMPL::Object' => undef, - 'IMPL::Object::Serializable' => '@_' - ], - props => [ - name => PROP_RW, - state => PROP_RW, - exception => PROP_RW, - timeExclusive => PROP_RW, - timeInclusive => PROP_RW - ] -}; - -__PACKAGE__->PassThroughArgs; - -use constant { - SUCCESS => 0, - FAIL => 1, - ERROR => 2 -}; - -sub CTOR { - my $this = shift; - - my $fields = @_ == 1 ? $_[0] : {@_}; - - $fields->{timeExclusive} ||= 0; - $fields->{timeInclusive} ||= 0; - - while (my ($k,$v) = each %$fields) { - $this->$k($v); - } -} - - -1;
--- a/lib/IMPL/Test/SkipException.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,8 +0,0 @@ -package IMPL::Test::SkipException; - -use parent qw(IMPL::Test::FailException); - -__PACKAGE__->PassThroughArgs; - -1; -
--- a/lib/IMPL/Test/Straps/ShellExecutor.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,32 +0,0 @@ -package IMPL::Test::Straps::ShellExecutor; -use strict; -use warnings; - -use parent qw(IMPL::Object IMPL::Object::Serializable); - -if ($^O =~ /win32/i) { - require Win32::Console; -} - -sub Execute { - my ($this,$file) = @_; - - my $h; - - if ($^O =~ /win32/i) { - Win32::Console::OutputCP(65001); - unless ( open $h,'-|',$file ) { - return undef; - } - binmode $h,':encoding(utf-8)'; - } else { - unless ( open $h,'-|',$file ) { - return undef; - } - } - - return $h; -} - - -1;
--- a/lib/IMPL/Test/TAPListener.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,70 +0,0 @@ -package IMPL::Test::TAPListener; -use strict; -use warnings; - -use parent qw(IMPL::Object IMPL::Object::Serializable); -use IMPL::Class::Property; -use IMPL::Test::Result; - -BEGIN { - private property _Output => prop_all; - private property _testNo => prop_all; -} - -sub CTOR { - my ($this,$out) = @_; - - $this->_Output($out || *STDOUT); - $this->_testNo(1); -} - -sub RunPlan { - my ($this,$plan) = @_; - - my $out = $this->_Output; - - print $out "1..",$plan->Count,"\n"; -} - -sub EndPlan { - -} - -sub RunUnit { - my ($this,$unit) = @_; - - my $out = $this->_Output; - - print $out "#\n",join("\n",map "# $_", split /\n/, "Running unit: " . $unit->UnitName, ),"\n#\n"; -} - -sub EndUnit { - -} - -sub RunTest { - -} - -sub EndTest { - my ($this,$test,$result) = @_; - - my $out = $this->_Output; - my $n = $this->_testNo; - - $this->_testNo($n+1); - - print $out ( - $result->state == IMPL::Test::Result::SUCCESS ? - "ok $n " . join("\n# ", split(/\n/, $result->name) ) - : - (eval { $result->exception->isa('IMPL::Test::SkipException') } ? "ok $n #SKIP: " : "not ok $n ") . join("\n# ", split(/\n/, $result->name.": ".$result->exception || '') ) - ),"\n"; - -} - -sub save { - -} - -1;
--- a/lib/IMPL/Test/Unit.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,158 +0,0 @@ -package IMPL::Test::Unit; -use strict; -use warnings; - -use parent qw(IMPL::Object); -use IMPL::Class::Property; - -use Time::HiRes qw(gettimeofday tv_interval); - -use Error qw(:try); -use Carp qw(carp); -use File::Spec(); -use IMPL::Test::Result(); -use IMPL::Test::FailException(); -use IMPL::Exception(); - -BEGIN { - public property Name => prop_all; - public property Code => prop_all; -} - -sub CTOR { - my ($this,$info) = @_; - - die new IMPL::InvalidArgumentException("TestInfo should be supplied as an argument") unless $info; - - $this->Name($info->Name || 'Annon'); - $this->Code($info->Code)or die new IMPL::InvalidOperationException("Can't create test without entry point"); -} - -sub UnitName { - my ($self) = @_; - $self->toString; -} - -sub Cleanup { - my ($this,$session) = @_; - - $session->{$_} = $this->$_() foreach map $_->DataList, $this->get_meta('IMPL::Test::Unit::SharedData',undef,1); - - 1; -} - -sub StartUnit { - my $class = shift; - - return {}; -} - -sub InitTest { - my ($this,$session) = @_; - - $this->$_($session->{$_}) foreach map $_->DataList, $this->get_meta('IMPL::Test::Unit::SharedData',undef,1); -} - -sub FinishUnit { - my ($class,$session) = @_; - - 1; -} - -sub List { - my $self = shift; - - return $self->get_meta('IMPL::Test::Unit::TestInfo',undef,1); # deep search with no criteria -} - -sub Run { - my ($this,$session) = @_; - - my $t = [gettimeofday]; - return try { - $this->InitTest($session); - my $code = $this->Code; - - - my $t0 = [gettimeofday]; - my $elapsed; - - try { - $this->$code(); - $elapsed = tv_interval ( $t0 ); - } finally { - # we need to call Cleanup anyway - $this->Cleanup($session); - }; - - return new IMPL::Test::Result( - name => $this->Name, - state => IMPL::Test::Result::SUCCESS, - timeExclusive => $elapsed, - timeInclusive => tv_interval ( $t ) - ); - } catch IMPL::Test::FailException with { - my $e = shift; - return new IMPL::Test::Result( - name => $this->Name, - state => IMPL::Test::Result::FAIL, - exception => $e, - timeInclusive => tv_interval ( $t ) - ); - } otherwise { - my $e = shift; - return new IMPL::Test::Result( - name => $this->Name, - state => IMPL::Test::Result::ERROR, - exception => $e, - timeInclusive => tv_interval ( $t ) - ); - } -} - -sub GetResourceFile { - my ($this,@path) = @_; - - my ($cwd) = map m/(.*)/, File::Spec->rel2abs(File::Spec->curdir()); - return File::Spec->catfile($cwd,@path); -} - -sub GetResourceDir { - my ($this,@path) = @_; - - my ($cwd) = map m/(.*)/, File::Spec->rel2abs(File::Spec->curdir()); - return File::Spec->catdir($cwd,@path); -} - -package IMPL::Test::Unit::TestInfo; -use parent qw(IMPL::Object::Meta); -use IMPL::Class::Property; - -require IMPL::Exception; - -BEGIN { - public property Name => prop_all; - public property Code => prop_all; -} - -sub CTOR { - my ($this,$name,$code) = @_; - - $this->Name($name); - $this->Code($code) or die new IMPL::InvalidArgumentException("The Code is a required parameter"); -} - -package IMPL::Test::Unit::SharedData; -use parent qw(IMPL::Object::Meta); -use IMPL::Class::Property; - -BEGIN { - public property DataList => prop_all | prop_list; -} - -sub CTOR { - my $this = shift; - - $this->DataList(\@_); -} -1;
--- a/lib/IMPL/Transform.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,134 +0,0 @@ -package IMPL::Transform; -use strict; - -use parent qw(IMPL::Object); - -use IMPL::lang qw(:declare); - - -BEGIN { - public _direct property templates => PROP_ALL; - public _direct property default => PROP_ALL; - public _direct property plain => PROP_ALL; - private _direct property _cache => PROP_ALL; -} - -sub CTOR { - my $this = shift; - my $args = @_ == 1 ? shift : { @_ }; - - $this->{$plain} = delete $args->{-plain}; - $this->{$default} = delete $args->{-default}; - - $this->{$templates} = $args; -} - -sub Transform { - my ($this,$object,@args) = @_; - - if (not ref $object) { - die new IMPL::Exception("There is no the template for a plain value in the transform") unless $this->{$plain}; - my $template = $this->{$plain}; - return $this->$template($object,@args); - } else { - - my $template = $this->MatchTemplate($object) || $this->default or die new IMPL::Transform::NoTransformException(ref $object); - - return $this->ProcessTemplate($template,$object,@args); - } -} - -sub MatchTemplate { - my ($this,$object) = @_; - my $class = $this->GetClassForObject( $object ); - - if (my $t = $this->{$_cache}->{$class} ) { - return $t; - } else { - $t = $this->{$templates}->{$class}; - - return $this->{$_cache}->{$class} = $t if $t; - - { - no strict 'refs'; - - my @isa = @{"${class}::ISA"}; - - while (@isa) { - my $sclass = shift @isa; - - $t = $this->{$templates}->{$sclass}; - - #cache and return - return $this->{$_cache}->{$class} = $t if $t; - - push @isa, @{"${sclass}::ISA"}; - } - ; - }; - } -} - -sub ProcessTemplate { - my ($this,$t,$obj,@args) = @_; - - return $this->$t($obj,@args); -} - -sub GetClassForObject { - my ($this,$object) = @_; - - return ref $object; -} - -package IMPL::Transform::NoTransformException; -use IMPL::declare { - base => { - 'IMPL::Exception' => sub { 'No transformation', @_ } - } -}; - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Transform> - преобразование объектной структуры - -=head1 SYNOPSIS - -=begin code - -my $obj = new AnyObject; - -my $t = new Transform ( - SomeClass => sub { - my ($this,$object) = @_; - return new NewClass({ Name => $object->name, Document => $this->Transform($object->Data) }) - }, - DocClass => sub { - my ($this,$object) = @_; - return new DocPreview(Author => $object->Author, Text => $object->Data); - }, - -default => sub { - my ($this,$object) = @_; - return $object; - }, - -plain => sub { - my ($this,$object) = @_; - return $object; - } -); - -my $result = $t->Transform($obj); - -=end code - -=head1 DESCRIPTION - -Преобразование одного объекта к другому, например даных к их представлению. - -=cut
--- a/lib/IMPL/Web/Application.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,149 +0,0 @@ -package IMPL::Web::Application; -use strict; -use warnings; - -use CGI; -use Carp qw(carp); -use IMPL::Const qw(:prop); - -use IMPL::declare { - require => { - Locator => 'IMPL::Web::AutoLocator', - TAction => 'IMPL::Web::Application::Action', - HttpResponse => 'IMPL::Web::HttpResponse', - TFactory => '-IMPL::Object::Factory', - Exception => 'IMPL::Exception', - ArgException => '-IMPL::InvalidArgumentException', - InvalidOperationException => '-IMPL::InvalidOperationException', - Loader => 'IMPL::Code::Loader' - }, - base => [ - 'IMPL::Config' => '@_', - 'IMPL::Object::Singleton' => undef - ], - props => [ - baseUrl => PROP_RW, - actionFactory => PROP_RW, - handlers => PROP_RW | PROP_LIST, - securityFactory => PROP_RW, - output => PROP_RW, - location => PROP_RO, - _handler => PROP_RW - ] -}; - -sub CTOR { - my ($this) = @_; - - die IMPL::InvalidArgumentException->new( "handlers", - "At least one handler should be supplied" ) - unless $this->handlers->Count; - - $this->baseUrl('/') unless $this->baseUrl; - - $this->actionFactory(TAction) unless $this->actionFactory; - $this->location(Locator->new(base => $this->baseUrl)); -} - -sub CreateSecurity { - my $factory = shift->securityFactory; - return $factory ? $factory->new() : undef; -} - -sub ProcessRequest { - my ($this,$q) = @_; - - die ArgException->new(q => 'A query is required') - unless $q; - - my $handler = $this->_handler; - unless ($handler) { - $handler = _ChainHandler( $_, $handler ) foreach $this->handlers; - $this->_handler($handler); - } - - my $action = $this->actionFactory->new( - query => $q, - application => $this, - ); - - eval { - my $result = $handler->($action); - - die InvalidOperationException->new("Invalid handlers result. A reference to IMPL::Web::HttpResponse is expexted.") - unless eval { $result->isa(HttpResponse) }; - - $result->PrintResponse( $this->output ); - }; - - $action->Dispose(); - - if ($@) { - my $e = $@; - - HttpResponse->InternalError( - type => 'text/plain', - charset => 'utf-8', - body => $e - )->PrintResponse( $this->output ); - - } -} - -sub _ChainHandler { - my ( $handler, $next ) = @_; - - if ( ref $handler eq 'CODE' ) { - return sub { - my ($action) = @_; - return $handler->( $action, $next ); - }; - } - elsif ( eval { $handler->can('Invoke') } ) { - return sub { - my ($action) = @_; - return $handler->Invoke( $action, $next ); - }; - } - elsif ( eval { $handler->isa(TFactory) } ) { - return sub { - my ($action) = @_; - my $inst = $handler->new(); - return $inst->Invoke( $action, $next ); - } - } - elsif ( $handler - and not ref $handler - and $handler =~ m/^(-)?(\w+(?:::\w+)*)$/ ) - { - my $class = $2; - if ( not $1 ) { - Loader->safe->Require($class); - die IMPL::InvalidArgumentException->( - "An invalid handler supplied", $handler - ) unless $class->can('Invoke'); - } - - return sub { - my ($action) = @_; - my $inst = $class->new(); - return $inst->Invoke( $action, $next ); - }; - } - else { - die new IMPL::InvalidArgumentException( "An invalid handler supplied", - $handler ); - } -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Web::Application> Базовай класс для веб-приложения - -=cut
--- a/lib/IMPL/Web/Application/Action.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,227 +0,0 @@ -package IMPL::Web::Application::Action; -use strict; - -use Carp qw(carp); -use URI; -use JSON; - -use IMPL::lang; -use IMPL::Const qw(:prop); -use IMPL::Web::CGIWrapper(); -use IMPL::declare { - require => { - Disposable => '-IMPL::Object::Disposable', - HttpResponse => 'IMPL::Web::HttpResponse' - }, - base => [ - 'IMPL::Object' => undef, - 'IMPL::Object::Autofill' => '@_', - 'IMPL::Object::Disposable' => undef - ], - props => [ - application => PROP_RW, - security => PROP_RW, - query => PROP_RO, - context => PROP_RW, - _jsonData => PROP_RW, - ] -}; - -sub CTOR { - my ($this) = @_; - - $this->context({}); - $this->security($this->application->CreateSecurity()); -} - -sub cookie { - my ($this,$name,$rx) = @_; - - $this->_launder(scalar( $this->query->cookie($name) ), $rx ); -} - -sub header { - my ($this,$header) = @_; - - $this->query->https ? $this->query->https($header) : $this->query->http($header); -} - -sub isSecure { - shift->query->https ? 1 : 0; -} - -sub isJson { - return shift->contentType =~ m{^application/json} ? 1 : 0; -} - -sub param { - my ($this,$name,$rx) = @_; - - my $value; - - if ( - $this->requestMethod eq 'GET' - or - $this->contentType eq 'multipart/form-data' - or - $this->contentType eq 'application/x-www-form-urlencoded' - ) { - $value = scalar( $this->query->param($name) ); - } else { - $value = scalar( $this->query->url_param($name) ); - } - - $this->_launder($value, $rx ); -} - -sub urlParam { - my ($this,$name,$rx) = @_; - - $this->_launder(scalar( $this->query->url_param($name) ), $rx); -} - -sub urlParams { - shift->query->url_param(); -} - -sub rawData { - my ($this, $decode) = @_; - - local $IMPL::Web::CGIWrapper::NO_DECODE = $decode ? 0 : 1; - if ($this->requestMethod eq 'POST') { - return $this->query->param('POSTDATA'); - } elsif($this->requestMethod eq 'PUT') { - return $this->query->param('PUTDATA'); - } -} - -sub jsonData { - my ($this) = @_; - - if ($this->isJson ) { - my $data = $this->_jsonData; - unless($data) { - $data = JSON->new()->decode($this->rawData('decode encoding')); - $this->_jsonData($data); - } - - return $data; - } - - return; -} - -sub requestMethod { - my ($this) = @_; - return $this->query->request_method; -} - -sub contentType { - return shift->query->content_type(); -} - -sub pathInfo { - my ($this) = @_; - return $this->query->path_info; -} - -sub baseUrl { - my ($this) = @_; - - return $this->query->url(-base => 1); -} - -sub applicationUrl { - shift->application->baseUrl; -} - -sub applicationFullUrl { - my ($this) = @_; - - return URI->new_abs($this->application->baseUrl, $this->query->url(-base => 1)); -} - -# creates an url that contains server, schema and path parts -sub CreateFullUrl { - my ($this,$path) = @_; - - return $path ? URI->new_abs($path,$this->applicationFullUrl) : $this->applicationFullUrl; -} - -# creates an url that contains only a path part -sub CreateAbsoluteUrl { - my ($this,$path) = @_; - - return $path ? URI->new_abs($path,$this->applicationUrl) : $this->applicationUrl; -} - -sub Redirect { - my ($this,$path) = @_; - return HttpResponse->Redirect( - location => $this->CreateFullUrl($path) - ); -} - -sub _launder { - my ($this,$value,$rx) = @_; - - if ( $value ) { - if ($rx) { - if ( my @result = ($value =~ m/$rx/) ) { - return @result > 1 ? \@result : $result[0]; - } else { - return; - } - } else { - return $value; - } - } else { - return; - } -} - -sub Dispose { - my ($this) = @_; - - $this->security->Dispose() - if $this->security and $this->security->can('Dispose'); - - $_->Dispose() foreach grep is($_,Disposable), values %{$this->context}; - - $this->next::method(); -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Web::Application::Action> - Обертка вокруг C<CGI> запроса. - -=head1 DESCRIPTION - -C<[Infrastructure]> -Свзяывет CGI запрос, приложение, орабатывающее его и ответ, который будет отправлен клиенту. - -=head1 MEMBERS - -=head2 C<CTOR(%args)> - -Инициализирует новый экземпляр. Именованными параметрами передаются значения -свойств. - -=head2 C< [get]application> - -Экземпляр приложения создавшего текущий объект - -=item C< [get] query > - -Экземпляр C<CGI> запроса - -=back - - -=cut
--- a/lib/IMPL/Web/Application/HttpResponseResource.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,32 +0,0 @@ -package IMPL::Web::Application::HttpResponseResource; -use strict; - -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - HttpResponse => 'IMPL::Web::HttpResponse' - }, - base => [ - 'IMPL::Object' => undef, - 'IMPL::Web::Application::ResourceInterface' => undef - ], - props => [ - response => PROP_RW - ] -}; - -sub CTOR { - my ($this,%args) = @_; - - $this->response($args{response} || HttpResponse->NoContent); -} - -sub FetchChildResource { - return shift; -} - -sub InvokeHttpVerb { - return shift->response; -} - -1; \ No newline at end of file
--- a/lib/IMPL/Web/Application/Resource.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,402 +0,0 @@ -package IMPL::Web::Application::Resource; -use strict; - -use constant { - ResourceClass => __PACKAGE__ -}; -use Scalar::Util qw(blessed); - -use IMPL::lang qw(:hash :base); -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - Exception => 'IMPL::Exception', - OpException => '-IMPL::InvalidOperationException', - NotFoundException => 'IMPL::Web::NotFoundException', - ResourceInterface => '-IMPL::Web::Application', - HttpResponse => 'IMPL::Web::HttpResponse', - HttpResponseResource => 'IMPL::Web::Application::HttpResponseResource', - Loader => 'IMPL::Code::Loader' - }, - base => [ - 'IMPL::Web::Application::ResourceBase' => '@_' - ], - props => [ - access => PROP_RW, - verbs => PROP_RW, - children => PROP_RW - ] -}; - -__PACKAGE__->static_accessor(verbNames => [qw(get post put delete options head)]); -__PACKAGE__->static_accessor(httpMethodPrefix => 'Http'); - -sub CTOR { - my ($this, %args) = @_; - - my %verbs; - my $httpPrefix = $this->httpMethodPrefix; - - foreach my $verb (@{$this->verbNames}) { - my $method = exists $args{$verb} ? $args{$verb} : $this->can($httpPrefix . ucfirst($verb)); - $verbs{$verb} = $method - if $method; - } - - hashApply(\%verbs,$args{verbs}) - if ref($args{verbs}) eq 'HASH' ; - - $this->children($args{children} || $this->GetChildResources()); - - $this->access($args{access}) - if $args{access}; - - $this->verbs(\%verbs); -} - -sub _isInvokable { - my ($this,$method) = @_; - - return - (blessed($method) and $method->can('Invoke')) || - ref($method) eq 'CODE' -} - -sub _invoke { - my ($this,$method,@args) = @_; - - if(blessed($method) and $method->can('Invoke')) { - return $method->Invoke($this,@args); - } elsif(ref($method) eq 'CODE' || (not(ref($method)) and $this->can($method))) { - return $this->$method(@args); - } else { - die OpException->new("Can't invoke the specified method: $method"); - } -} - -sub HttpGet { - shift->model; -} - -sub AccessCheck { - my ($this,$verb) = @_; - - $this->_invoke($this->access,$verb) - if $this->access; -} - -sub Fetch { - my ($this,$childId) = @_; - - my $children = $this->children - or die NotFoundException->new( $this->location->url, $childId ); - - if (ref($children) eq 'HASH') { - if(my $child = $children->{$childId}) { - return $this->_isInvokable($child) ? $this->_invoke($child, $childId) : $child; - } else { - die NotFoundException->new( $this->location->url, $childId ); - } - } elsif($this->_isInvokable($children)) { - return $this->_invoke($children,$childId); - } else { - die OpException->new("Invalid resource description", $childId, $children); - } -} - -sub FetchChildResource { - my ($this,$childId) = @_; - - my $info = $this->Fetch($childId); - - return $info - if (is($info,ResourceInterface)); - - $info = { - response => $info, - class => HttpResponseResource - } - if is($info,HttpResponse); - - return $this->CreateChildResource($info, $childId) - if ref($info) eq 'HASH'; - - die OpException->new("Invalid resource description", $childId, $info); -} - -sub CreateChildResource { - my ($this,$info, $childId) = @_; - - my $params = hashApply( - { - parent => $this, - id => $childId, - request => $this->request, - class => ResourceClass - }, - $info - ); - - $params->{model} = $this->_invoke($params->{model}) - if $this->_isInvokable($params->{model}); - - my $factory = Loader->default->Require($params->{class}); - - return $factory->new(%$params); -} - -sub GetChildResources { - return {}; -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Web::Application::Resource> - Ресурс C<REST> веб приложения - -=head1 SYNOPSIS - -=begin code - -use IMPL::require { - Resource => 'IMPL::Web::Application::Resource', - Security => 'IMPL::Security', - NotFoundException => 'IMPL::Web::NotFoundException', - ForbiddenException => 'IMPL::Web::ForbiddenException' -}; - -my $model = Resource->new( - get => sub { }, - verbs => { - # non-standart verbs placed here - myverb => sub { } - }, - #child resources can be a hash - children => { - user => { - # a resource class may be specified optionally - # class => Resource, - model => sub { - return Security->principal - }, - # the default get implementation is implied - # get => sub { shift->model }, - access => sub { - my ($this,$verb) = @_; - die ForbiddenException->new() - if Security->principal->isNobody - } - }, - catalog => { - get => sub { - my $ctx = shift->application->ConnectDb()->AutoPtr(); - - return $ctx->products->find_rs({ in_stock => 1 }); - }, - # chid resource may be created dynamically - children => sub { - # binds model against the parent reource and id - my ($this,$id) = @_; - - ($id) = ($id =~ /^(\w+)$/) - or die NotFoundException->new($id); - - my $ctx = shift->application->ConnectDb()->AutoPtr(); - - my $item = $ctx->products->fetch($id); - - die NotFoundException->new() - unless $item; - - # return parameters for the new resource - return { - model => $item, - get => sub { shift->model } - }; - } - }, - # dynamically binds whole child resource. The result of binding is - # the new resource or a hash with arguments to create one - posts => sub { - my ($this,$id) = @_; - - # this approach can be used to create a dynamic resource relaying - # on the type of the model - - return Resource->new( - id => $id, - parent => $this, - get => sub { shift->model } - ); - - # ditto - # parent and id will be mixed in automagically - # return { get => sub { shift->model} } - }, - post_only => { - get => undef, # remove GET verb implicitly - post => sub { - my ($this) = @_; - } - } - } -); - -=end code - -Альтернативный вариант для создания класса ресурса. - -=begin code - -package MyResource; - -use IMPL::declare { - require => { - ForbiddenException => 'IMPL::Web::ForbiddenException' - }, - base => [ - 'IMPL::Web::Application::Resource' => '@_' - ] -}; - -sub ds { - my ($this) = @_; - - $this->context->{ds} ||= $this->application->ConnectDb(); -} - -sub InvokeHttpVerb { - my $this = shift; - - $this->ds->Begin(); - - my $result = $this->next::method(@_); - - # in case of error the data context will be disposed and the transaction - # will be reverted - $this->ds->Commit(); - - return $result; -} - -# this method is inherited by default -# sub HttpGet { -# shift->model -# -# } - -sub HttpPost { - my ($this) = @_; - - my %data = map { - $_, - $this->request->param($_) - } qw(name description value); - - die ForbiddenException->new("The item with the scpecified name can't be created'") - if(not $data{name} or $this->ds->items->find({ name => $data{name})) - - $this->ds->items->insert(\%data); - - return $this->NoContent(); -} - -sub Fetch { - my ($this,$childId) = @_; - - my $item = $this->ds->items->find({name => $childId}) - or die NotFoundException->new(); - - # return parameters for the child resource - return { model => $item, role => "item food" }; -} - -=end code - -=head1 MEMBERS - -=head2 C<[get,set]verbs> - -Хеш с C<HTTP> методами. При попытке вызова C<HTTP> метода, которого нет в этом -хеше приводит к исключению C<IMPL::Web::NotAllowedException>. - -=head2 C<[get,set]access> - -Метод для проверки прав доступа. Если не задан, то доспуп возможен для всех. - -=head2 C<[get,set]children> - -Дочерние ресурсы. Дочерние ресурсы могут быть описаны либо в виде хеша, либо -в виде метода. - -=head3 C<HASH> - -Данный хещ содержит в себе таблицу идентификаторов дочерних ресурсов и их -описаний. - -Описание каждого ресурса представляет собой либо функцию, либо параметры для -создания ресурса C<CraeteChildResource>. Если описание в виде функции, то она -должна возвращать либо объект типа ресурс либо параметры для его создания. - -=head3 C<CODE> - -Если дочерние ресурсы описаны в виде функции (возможно использовать имя метода -класса текущего ресурса), то для получения дочернего ресурса будет вызвана -функция с параметрами C<($this,$childId)>, где C<$this> - текущий ресурс, -C<$childId> - идентификатор дочернего ресурса, который нужно вернуть. - -Данная функция должна возвратить либо объект типа ресурс, либо ссылку на хеш с -параметрами для создания оного при помощи метода -C<CreateChildResource($params,$childId)>. - -=head2 C<[virtual]Fetch($childId)> - -Метод для получения дочернего ресурса. - -Возвращает параметры для создания дочернего ресурса, либо уже созданный ресурс. -Создание дочернего ресурса происходит при помощи метода C<CreateChildResource()> -который добавляет недостающие параметры к возвращенным в данным методом и -создает новый ресурс - -=head2 C<CreateChildResource($params,$id)> - -Создает новый дочерний ресурс с указанным идентификатором и параметрами. -Автоматически заполняет параметры - -=over - -=item * C<parent> - -=item * C<id> - -=item * C<request> - -=back - -Тип создаваемого ресурса C<IMPL::Web::Application::Resource>, либо указывается -в параметре C<class>. - -=head2 C<[virtual]HttpGet()> - -Реализует C<HTTP> метод C<GET>. По-умолчанию возвращает модель. - -Данный метод нужен для того, чтобы ресурс по-умолчанию поддерживал метод C<GET>, -что является самым частым случаем, если нужно изменить данное поведение, нужно: - -=over - -=item * Передать в параметр конструктора C<get> значение undef - -=item * Переопределить метод C<HttpGet> - -=item * При проверке прав доступа выдать исключение - -=back - -=cut -
--- a/lib/IMPL/Web/Application/ResourceBase.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,262 +0,0 @@ -package IMPL::Web::Application::ResourceBase; -use strict; - -use URI; -use Carp qw(carp); -use IMPL::lang qw(:hash :base); -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - - Exception => 'IMPL::Exception', - ArgumentException => '-IMPL::InvalidArgumentException', - OperationException => '-IMPL::InvalidOperationException', - NotAllowedException => 'IMPL::Web::NotAllowedException', - - }, - base => [ - 'IMPL::Object' => undef, - 'IMPL::Web::Application::ResourceInterface' => undef - ], - props => [ - request => PROP_RO, - application => PROP_RO, - parent => PROP_RO, - model => PROP_RO, - id => PROP_RO, - location => PROP_RO, - role => PROP_RO | PROP_LIST - ] -}; - -sub CTOR { - my ( $this, %args ) = @_; - - die ArgumentException->new(request => 'A request object must be specified') - unless $args{request}; - - $this->request( $args{request} ); - $this->parent( $args{parent} ) if $args{parent}; - $this->model( $args{model} ) if $args{model}; - $this->id( $args{id} ) if $args{id}; - $this->application( $args{request}->application ); - -# если расположение явно не указано, то оно вычисляется автоматически, -# либо остается не заданным - $this->location( $args{location} - || eval { $this->parent->location->Child( $this->id ) } ); - - if (my $role = $args{role}) { - if (ref($role) eq 'ARRAY') { - $this->role($role); - } elsif (not ref($role)) { - $this->role(split(/\s+/, $role)); - } else { - die ArgumentException->new( role => 'A invalid value is provided, expected ARRAY or SCALAR'); - } - } -} - -sub InvokeHttpVerb { - my ( $this, $verb ) = @_; - - my $operation = $this->verbs->{ lc($verb) }; - - die NotAllowedException->new( - allow => join( ',', $this->GetAllowedMethods ) ) - unless $operation; - - $this->AccessCheck($verb); - my $request = $this->request; - -# в случае, когда один ресурс вызывает HTTP метод другого ресурса, нужно -# сохранить оригинальный resourceLocation - $request->context->{resourceLocation} ||= $this->location; - -# это свойство специфично только для REST приложений. -# сохранение текущего ресурса не повлечет за собой существенных расходов, -# т.к. они просто освободятся несколько позже. - if ( not $request->context->{resource} ) { - $request->context->{resource} = $this; - } - - return _InvokeDelegate( $operation, $this, $request ); -} - -sub security { - shift->request->security -} - -sub context { - shift->request->context -} - -sub verbs { - {} # возвращаем пстой список операций -} - -sub GetAllowedMethods { - map( uc, keys %{ shift->verbs } ); -} - -sub AccessCheck { - -} - -sub Seek { - my ($this, $role) = @_; - - my @roles; - - if (ref($role) eq 'ARRAY') { - @roles = @{$role}; - } elsif (not ref($role)) { - @roles = split(/\s+/, $role); - } else { - die ArgumentException->new( role => 'A invalid value is provided, expected ARRAY or SCALAR'); - } - - - for(my $r = $this; $r; $r = $r->parent) { - return $r if $r->HasRole(@roles); - } - return; -} - -sub HasRole { - my ($this, @roles) = @_; - my %cache = map { $_, 1 } @{$this->role}; - return scalar(grep not($cache{$_}), @roles) ? 0 : 1; -} - -sub _InvokeDelegate { - my $delegate = shift; - - return $delegate->(@_) if ref $delegate eq 'CODE'; - return $delegate->Invoke(@_) if eval { $delegate->can('Invoke') }; -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Web::Application::Resource> - Web-ресурс. - -=head1 SYNOPSIS - -Класс для внутреннего использования. Объединяет в себе контракт и модель данных. -Основная задача - обработать поступающий от контроллера запрос на вызов C<HTTP> -метода. - -Экземпляры данного класса передаются в качестве параметров делегатам -осуществляющим привязку к модели в C<IMPL::Web::Application::ResourceContract> -и C<IMPL::Web::Application::OperationContract>. - -=head1 DESCRIPTION - -Весь функционал ресурса, поддерживаемые им C<HTTP> методы определяются -контрактом. Однако можно реализовывать ресурсы, которые не имеют контракта -или он отличается от того, что предоставляется стандартно -C<IMPL::Web::Application::ResourceContract>. - -Каждый ресурс является контейнером, тоесть позволяет получить дочерний ресурс -по идентифифкатору, если таковой имеется, тоесть ресурс, у которого нет дочерних -ресурсов на самом деле рассматривается как пустой контейнер. - -С ресурсом непосредственно взаимодействует котроллер запросов -C<IMPL::Web::Handler::RestController>, вызывая два метода. - -=over - -=item * C<FetchChildResource($childId)> - -Данный метод возвращает дочерний ресурс, соответствующий C<$childId>. -Текущая реализация использует метод C<FindChildResourceInfo> контракта текущего -ресурса, после чего создает дочерний ресурс. - -Если дочерний ресурс не найден, вызывается исключение -C<IMPL::Web::NotFoundException>. - -=item * C<InvokeHttpVerb($verb,$action)> - -Обрабатывает запрос к ресурсу. Для этого используется контракт ресурса, в -нем выбирается соответсвующий C<IMPL::Web::Application::OperationContract>. -Затем найденный контракт для указанной операции используется для обработки -запроса. - -=back - -Если объект реализует два вышеуказанных метода, он является веб-ресурсом, а -детали его реализации, котнракт и прочее уже не важно, поэтому можно реализовать -собственный класс ресурса, например унаследованный от -C<IMPL::Web::Application::CustomResource>. - -=head1 MEMBERS - -=head2 C<[get]request> - -Объект C<IMPL::Web::Application::Action> представляющий запрос к серверу. - -=head2 C<[get]application> - -Ссылка на приложение, к которому относится данный ресурс. Получается -автоматически из объекта запроса. - -=head2 C<[get]contract> - -Обязательное свойство для ресурса, ссылается, на контракт, соответствующий -данному ресурсу, используется для выполнения C<HTTP> методов и получения -дочерних ресурсов. - -=head2 C<[get]id> - -Обязательное свойство ресурса, идентифицирует его в родительском контейнере, -для корневого ресурса может иметь произвольное значение. - -=head2 C<[get]parent> - -Ссылка на родительский ресурс, для корневого ресурса не определена. - -=head2 C<[get]model> - -Ссылка на объект предметной области, представляемый данным ресурсом. Данное -свойство не является обязательным и может быть не задано. - -=head2 C<[get]location> - -Объект типа C<IMPL::Web::AutoLocator> или аналогичный описывающий адрес текущего -ресурса, может быть как явно передан при создании ресурса, так и вычислен -автоматически (только для ресурсов имеющих родителя). Следует заметить, что -адрес ресурса не содержит параметров запроса, а только путь. - -=head2 C<[get,list]role> - -Список ролей ресурса. Роль это условный маркер, который позволяет определить -функции выполняемые ресурсом, например контейнер, профиль пользователя и т.п. - -Используется при построении цепочек навигации, а также при поиске с использованием -метода C<seek>. - -=head2 C<seek($role)> - -Ищет ресурс в цепочке родителей (включая сам ресурс) с подходящими ролями. - -Роли могут быть переданы в виде массива или строки, где роли разделены пробелами - -=head2 C<[get]FetchChildResource($id)> - -Возвращает дочерний ресурс, по его идентификатору. - -Данная реализация использует контракт текущего ресурса для поиска информации о -дочернем ресурсе C<< $this->contract->FindChildResourceInfo($id) >>. - -Затем осуществляется привязка к моделе, тоесть, выполняется делегат, для -получения модели дочернего ресурса, а затем осуществляется привязка к контракту, -при этом в делегат, который должен вернуть контракт дочернего ресурса передаются -текущий ресурc и модель дочернего ресурса. - -=cut
--- a/lib/IMPL/Web/Application/ResourceInterface.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,89 +0,0 @@ -package IMPL::Web::Application::ResourceInterface; -use strict; - -use IMPL::require { - Exception => 'IMPL::Exception', - NotImplException => '-IMPL::NotImplementedException' -}; - -sub InvokeHttpVerb { - die NotImplException->new(); -} - -sub FetchChildResource { - die NotImplException->new(); -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Web::Application::ResourceInterface> - Интерфейс для Web-ресурса. - -=head1 SYNOPSIS - -=begin code - -package MyApp::Web::Resource; -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - NotAllowedException => 'IMPL::Web::NotAllowedException' - }, - base => [ - 'IMPL::Object' => undef, - 'IMPL::Web::Application::ResourceInterface' => undef - ], - props => [ - model => PROP_ALL - ] -}; - -sub InvokeHttpVerb { - my ($this,$verb,$action) = @_; - - if($verb eq 'GET') { - return $this->model; - } else { - die NotAllowedException->new(allow => 'GET'); - } -} - -sub FetchChildResource { - # no child resources - return; -} - -=end code - -=head1 DESCRIPTION - -Данный модуль объявляет только интерфейс, тоесть в нем есть заглушки для функций -которые необходимо реализовать. - -Для создания класса, который может быть использоваться для создания Web-ресурсов -нужно унаследовать данный интерфейс и реализовать его методы. - -=head1 MEMBERS - -=head2 C<InvokeHttpVerb($verb,$action)> - -Выполняет операцию над ресурсом и возвращает результат ее выполнения. -Результатом может быть произвольный объект, который будет передан по цепочке -обработчиков приложения для формирования ответа вервера, либо -C<IMPL::Web::HttpResponse>, который описывает (не обязательно полностью) ответ. -В любом случае результат будет передан далее в цепочку обработчиков и может -быть изменен. - -=head2 C<FetchChildResource($childId)> - -Используется для получения дочернего ресурса (который содержится в данном -контейнере). Метод должен возвращать либо Web-ресурс -C<IMPL::Web::Application::ResourceInterface>, либо C<undef> если дочерний ресурс -не найден. - -=cut \ No newline at end of file
--- a/lib/IMPL/Web/AutoLocator.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,241 +0,0 @@ -package IMPL::Web::AutoLocator; -use strict; - -use overload '""' => 'toString'; - -use IMPL::Const qw(:prop); -use IMPL::lang qw(:hash); -use IMPL::clone qw(clone); -use URI; -use URI::Escape; -use IMPL::declare { - require => { - Exception => 'IMPL::Exception', - ArgumentException => '-IMPL::InvalidArgumentException' - }, - base => [ - 'IMPL::Object' => undef, - 'IMPL::Object::Autofill' => '@_', - 'IMPL::Object::Serializable' => '@_' - ], - props => [ - base => PROP_RO, - view => PROP_RW, - query => PROP_RW, - hash => PROP_RW - ] -}; - -sub Clone { - my $this = shift; - - return clone($this); -} - -sub Child { - my $this = shift; - my $child = shift or die ArgumentException->new("a child resource identifier is required"); - die ArgumentException->new("a child resource can't be a reference") if ref $child; - - # safe - #$child = uri_escape_utf8($child); - - my %args; - - $args{base} = $this->base =~ /\/$/ ? $this->base . $child : $this->base . '/' . $child; - $args{view} = $this->view if $this->view; - $args{hash} = $this->hash if $this->hash; - - if (@_) { - my $query = shift; - - $args{query} = ref $query eq 'HASH' ? hashMerge($this->query,$query) : $query; - } - - return $this->new(%args); -} - -sub Sibling { - my $this = shift; - my $child = shift or die ArgumentException->new("a child resource identifier is required"); - die ArgumentException->new("a child resource can't be a reference") if ref $child; - - # safe - #$child = uri_escape($child); - - my %args; - - if($this->base =~ /(.*?)(\/[^\/]*)?$/) { - $args{base} = join('/',$1,$child); - } else { - $args{base} = $child; - } - - $args{view} = $this->view if $this->view; - $args{hash} = $this->hash if $this->hash; - - if (@_) { - my $query = shift; - - $args{query} = ref $query eq 'HASH' ? hashMerge($this->query,$query) : $query; - } - - return $this->new(%args); - -} - -sub Query { - my ($this,$query) = @_; - - my %args; - - $args{base} = $this->base; - $args{view} = $this->view if $this->view; - $args{hash} = $this->hash if $this->hash; - $args{query} = ref $query eq 'HASH' ? hashMerge($this->query,$query) : $query; - - return $this->new(%args); -} - -sub SetView { - my ($this,$newView) = @_; - - $this->view($newView); - - return $this; -} - -sub url { - my ($this) = @_; - - my $url = URI->new($this->view ? $this->base . "." . $this->view : $this->base); - $url->query_form($this->query); - $url->fragment($this->hash); - - return $url; -} - -sub ToAbsolute { - my ($this,$baseUrl) = @_; - - return URI->new_abs( $this->url, $baseUrl ); -} - -sub toString { - shift->url->as_string(); -} - -sub AUTOLOAD { - our $AUTOLOAD; - - (my $method) = ($AUTOLOAD =~ m/(\w+)$/); - - return if $method eq 'DESTROY'; - - my $this = shift; - return $this->Child($method,@_); -} - - - -1; - -__END__ - -=head1 NAME - -C<IMPL::Web::AutoLocator> - Обертка вокруг адреса ресурса. - -=head1 SYNOPSIS - -=begin code - -use IMPL::require { - Locator => 'IMPL::Web::AutoLocator' -}; - -my $bugTracker = Locator->new(base => "http://myhost.org/bugzilla")->SetView("cgi"); - -my $bug = $bugTracker->show_bug({id = 1}); - -my $wikiPages = Locator->new(base => "http://myhost.org/wiki/bin/view"); - -my $page = $wiki->Main->HowTo; - -my $images = Locator->new(base => "http://static.myhost.org/images", view => "png"); - -my $editIco = $images->icons->small->edit; - -=end code - -=head1 DESCRIPTION - -Для удобстав навигации по ресурсам, полностью отражает классическую структуру -иерархически организованных ресурсов. позволяет гибко работать с параметрами -запроса и хешем. Для постоты чтения реализует метод C<AUTOLOAD> для доступа -к дочерним ресурсам. - -=head1 MEMBERS - -=head2 C<CTOR(%args)> - -Создает новый объект расположение. Позволяет задать путь, расширение, параметры -запроса и фрагмент ресурса. - -=over - -=item * C<base> - -Строка с базовым адресом для дочерних ресурсов. - -=item * C<view> - -Задает суфикс, обозначающий представление ресурса, аналогично расширению у -файлов. Данный суффикс может использоваться контроллером для выбора -представления ресурса. - -=item * C<query> - -Ссылка на хеш с параметрами запроса - -=item * C<hash> - -Часть C<uri> обозначающая фрагмент документа (все, что идет после символа C<#>). - -=back - -=head2 C<Child($child[,$query])> - -Получает расположение дочернего ресурса. При этом cоздается новый объект адреса ресурса. - -=head2 C<SetView($view)> - -Позволяет указать представление (расширение) у текущего адреса ресурса. Изменяет -представление и возвращает измененный адрес ресурса. - -=head2 C<[get]base> - -Базовый адрес, относительно которого будут получены дочерние ресурсы. - -=head2 C<[get,set]view> - -Представление для ресурсов, аналогично расширению у файлов. - -=head2 C<[get,set]query> - -Ссылка на хеш с параметрами для C<GET> запроса. - -=head2 C<[get,set]hash> - -Часть адреса ресурса, отвечающая за фрагмент. - -=head2 C<[get]url> - -Объект C<URI> для текущего адреса. - -=head2 C<AUTLOAD> - -Перенаправляет вызовы методов в метод C<Child> передавая первым параметром имя метода. - -=cut -
--- a/lib/IMPL/Web/BadRequestException.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,30 +0,0 @@ -package IMPL::Web::BadRequestException; -use strict; - -use IMPL::declare { - base => { - 'IMPL::Web::Exception' => '@_' - } -}; - -use IMPL::Resources::Strings { - message => "The request could not be understood due to malformed syntax" -}; - -sub status { - "400 Bad Request"; -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Web::BadRequestException> - 400 Bad Request - -=head1 DESCRIPTION - -=cut \ No newline at end of file
--- a/lib/IMPL/Web/CGIApplication.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,29 +0,0 @@ -package IMPL::Web::CGIApplication; -use strict; - -use IMPL::declare { - require => { - CGIWrapper => 'IMPL::Web::CGIWrapper' - }, - base => [ - 'IMPL::Web::Application' => '@_' - ] -}; - -sub CTOR { - my ($this) = @_; - - $this->output(\*STDOUT) unless $this->output; -} - -sub Run { - my ($this) = @_; - - my $query = CGIWrapper->new(); - - $query->charset('utf-8'); - - $this->ProcessRequest($query); -} - -1; \ No newline at end of file
--- a/lib/IMPL/Web/CGIWrapper.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,75 +0,0 @@ -package IMPL::Web::CGIWrapper; -use strict; - -use parent qw(CGI); -use Encode; - -our $NO_DECODE = 0; - -sub param { - my $this = shift; - - return $this->SUPER::param(@_) if $NO_DECODE; - - if (wantarray) { - my @result = $this->SUPER::param(@_); - - return map Encode::is_utf8($_) - ? $_ - : Encode::decode( $this->charset, $_, Encode::LEAVE_SRC ), @result; - } - else { - my $result = $this->SUPER::param(@_); - - return Encode::is_utf8($result) - ? $result - : Encode::decode( $this->charset, $result, Encode::LEAVE_SRC ); - } - -} - -sub upload { - my $this = shift; - - local $NO_DECODE = 1; - my $oldCharset = $this->charset(); - $this->charset('ISO-8859-1'); - - my $fh = $this->SUPER::upload(@_); - - $this->charset($oldCharset); - return $fh; -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Web::CGIWrapper> - обетрка вокруг стандартного объекта C<CGI> - -=head1 DESCRIPTION - -Наследуется от C<CGI>, и переопределяет метод C<param> для декодирования -строковых параметров. В остальном функциональность аналогична стандартному -модулю C<CGI>. - -=head1 MEMBERS - -=head2 C<$NO_DECODE> - -Глобальная переменная для отключения декодирования параметров. - -=begin code - -{ - local $IMPL::Web::CGIWrapper::NO_DECODE = 1; - my $raw = $q->param('binary'); -} - -=end code - -=cut \ No newline at end of file
--- a/lib/IMPL/Web/DOM/FileNode.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,193 +0,0 @@ -package IMPL::Web::DOM::FileNode; -use parent qw(IMPL::DOM::Node); - -__PACKAGE__->PassThroughArgs; - -use IMPL::Class::Property; -use File::Temp qw(tempfile); - -BEGIN { - public property parameterName => { - get => sub { - my ($this) = @_; - $this->_parameterName() or - $this->_parameterName( - join '/', ( map { - (defined $_->nodeProperty('instanceId')) ? - $_->nodeName . '['.$_->nodeProperty('instanceId').']': - $_->nodeName - } $this->_selectParents, $this ) - ); - } - }; - private property _parameterName => prop_all; - public property fileName => { - get => sub { - my ($this) = @_; - return $this->document->query->param($this->parameterName); - } - }; - public property fileHandle => { - get => sub { - my ($this) = @_; - return $this->document->query->upload($this->parameterName); - } - }; -} - -sub invokeTempFile { - my ($this,$sub,$target) = @_; - - die new IMPL::InvalidArgumentException("A reference to a function should be specified") unless $sub && ref $sub eq 'CODE'; - - $target ||= $this; - - my $query = $this->document->nodeProperty('query') or die new IMPL::InvalidOperationException("Failed to get a CGI query from the document"); - my $hFile = $query->upload($this->parameterName) or die new IMPL::IOException("Failed to open the uploaded file",$query->cgi_error,$this->parameterName,$this->nodeProperty('instanceId')); - - my ($hTemp,$tempFileName) = tempfile(); - binmode($hTemp); - - print $hTemp $_ while <$hFile>; - - $hTemp->flush(); - seek $hTemp, 0,0; - { - local $_ = $tempFileName; - $sub->($this,$tempFileName,$hTemp); - } -} - -sub _selectParents { - my ($node) = @_; - - my @result; - - unshift @result, $node while $node = $node->parentNode; - - return @result; -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Web::DOM::FileNode> - узел, использующийся для представления параметра запроса в котором передан файл. - -=head1 SINOPSYS - -=begin code xml - -<!-- input.schema.xml --> -<schema> - <SimpleType type="file" nativeType="IMPL::Web::DOM::FileNode"/> - <ComplexNode name="user"> - <Node type="file" name="avatar"/> - </ComplexNode> -</schema> - -=end code xml - -=begin code - -# handle.pl -use IMPL::DOM::Transform::PostToDOM (); -use IMPL::DOM::Schema; -use CGI; -use File::Copy qw(copy); - -my $t = new IMPL::DOM::Transform::PostToDOM( - undef, - IMPL::DOM::Schema->LoadSchema('input.schema.xml'), - 'user' -); - -my $doc = $t->Transform(CGI->new()); - -if ($t->Errors->Count) { - # handle errors -} - -$doc->selectSingleNode('avatar')->invokeTempFile( - sub { - my($node,$fname,$fhandle) = @_; - - # do smth with file - copy($_,'avatar.jpg'); - - # same thing - # copy($fname,'avatar.jpg'); - } -); - -=end code - -=head1 DESCRIPTION - -Данный класс используется для представлении параметров C<CGI> запросов при преобзаовании -запроса в ДОМ документ преобразованием C<IMPL::DOM::Transform::PostToDOM>. - -Узлы данного типа расширяют стандатрный C<IMPL::DOM::Node> несколькими свойствами и -методами для доступа к файлу, переданному в виде параметра запроса. - -=head1 MEMBERS - -=head2 PROPERTIES - -=over - -=item C<[get] parameterName> - -Имя параметра C<CGI> запроса соответствующего данному узлу. - -=item C<[get] fileName> - -Имя файла из параметра запроса - -=item C<[get] fileHandle> - -Указатель на файл из параметра запроса - -=back - -=head2 METHODS - -=over - -=item C<invokeTempFile($callback,$target)> - -Сохраняет файл, переданный в запросе во временный, вызывает C<$callback> для обработки временного файла. - -=over - -=item C<$callback> - -Ссылка на функцию которая будет вызвана для обработки временного файла. C<callback($target,$fname,$fhandle)> - -=over - -=item C<$fname> - -Имя временного файла - -=item C<$fhandle> - -Указатель на временный файл - -=back - -Также пременная C<$_> содержит имя временного файла. - -=item C<$target> - -Значение этого параметра будет передано первым параметром функции C<$callback>. - -=back - -=back - -=cut
--- a/lib/IMPL/Web/Exception.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,60 +0,0 @@ -package IMPL::Web::Exception; -use strict; -use warnings; - -use IMPL::Const qw(:prop); -use IMPL::declare { - base => [ - 'IMPL::AppException' => '@_' - ], - props => [ - headers => PROP_ALL - ] -}; - -sub status { - "500 Internal error"; -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Web::Exception> - Базовый класс для всех web-исключений, для ошибок вызванных -по вине клиента. - -=head1 SYNOPSIS - -Вызов исключения - -=begin code - -use IMPL::require { - WebException => 'IMPL::Web::Exception' -}; - -sub MyWebHandler { - # ... - - die WebException->new("something is wrong"); - - # ... -} - -=end code - -=head1 MEMBERS - -=head2 C<status()> - -Возвращает C<HTTP> код ошибки. Каждый класс иключений должен переопределить данный метод. - -=head2 C<[get,set]headers> - -Ссылка на хеш с параметрами заголовка. - -=cut \ No newline at end of file
--- a/lib/IMPL/Web/ForbiddenException.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,28 +0,0 @@ -package IMPL::Web::ForbiddenException; -use strict; - -use IMPL::declare { - base => { - 'IMPL::Web::Exception' => '@_' - } -}; - -use IMPL::Resources::Strings { - message => "You don't have access to this resource" -}; - -sub status { - "403 Forbidden" -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Web::ForbiddenException> - операция не разрешается. - -=cut \ No newline at end of file
--- a/lib/IMPL/Web/Handler/ErrorHandler.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,127 +0,0 @@ -package IMPL::Web::Handler::ErrorHandler; -use strict; - -use IMPL::Const qw(:prop); -use IMPL::Exception(); -use IMPL::declare { - require => { - WebException => 'IMPL::Web::Exception', - ArgumentException => '-IMPL::InvalidArgumentException', - IOException => '-IMPL::IOException', - HttpResponse => 'IMPL::Web::HttpResponse', - Security => 'IMPL::Security' - }, - base => { - 'IMPL::Object' => undef, - 'IMPL::Object::Autofill' => '@_', - 'IMPL::Object::Serializable' => undef - }, - props => [ - errors => PROP_RW, - view => PROP_RW, - fallback => PROP_RW, - contentType => PROP_RW - ] -}; - -sub CTOR { - my ($this) = @_; - - die ArgumentException->new("view") unless $this->view; - die ArgumentException->new("fallback") unless $this->fallback; - - $this->errors({}) unless $this->errors; - -} - -sub Invoke { - my ($this,$action,$next) = @_; - - undef $@; - my $result; - eval { - $result = $next ? $next->($action) : undef; - }; - - if (my $err = $@) { - - my $vars = { - error => $err, - result => $result, - request => sub { $action }, - app => $action->application, - location => $action->context->{resourceLocation}, - resource => $action->context->{resource}, - document => {}, - session => sub { Security->context }, - user => sub { Security->principal }, - security => sub { $action->security } - }; - - my $status = "500 Internal Server Error"; - - if (eval { $err->isa(WebException) }) { - $status = $err->status; - } - - my ($code) = ($status =~ m/^(\d+)/); - - my $text = $this->view->display( - $err, - $this->errors->{$code} || $this->fallback, - $vars - ); - - $result = HttpResponse->new( - status => $status, - type => $this->contentType, - charset => 'utf-8', - headers => eval{ $err->headers } || {}, - body => $text - ); - } - - return $result; -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Web::Handler::ErrorHandler> - обертка для обработки исключений. - -=head1 SYNOPSIS - -Используется в цеопчке обработчиков приложения. - -=begin code xml - - <handlers type="ARRAY"> - <item type="IMPL::Web::Handler::ErrorHandler"> - <contentType>text/html</contentType> - <loader refid="tt-loader"/> - <errors type="HASH"> - <error extname="500">errors/500</error> - <error extname="404">errors/404</error> - <error extname="403">errors/403</error> - </errors> - <fallback>errors/500</fallback> - </item> - </handlers> - -=end code xml - -=head1 DESCRIPTION - -Позволяет создать представление для ресурса в случае ошибки, для этого -используется соответствие представлений и кодов ошибок. - -В результате обработчик либо прозрачно передает результат вышестоящего -обработчика нижестоящему, либо создает C<IMPL::Web::HttpResponse> с -соответствующим статусом и содержанием. - -=cut \ No newline at end of file
--- a/lib/IMPL/Web/Handler/JSONView.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,70 +0,0 @@ -package IMPL::Web::Handler::JSONView; -use strict; -use JSON; - -use IMPL::lang qw(is); -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - HttpResponse => 'IMPL::Web::HttpResponse', - ViewResult => '-IMPL::Web::ViewResult', - Loader => 'IMPL::Code::Loader' - }, - base => [ - 'IMPL::Object' => undef, - 'IMPL::Object::Serializable' => undef, - 'IMPL::Object::Autofill' => '@_' - ], - props => [ - transform => PROP_RW - ] -}; - -sub contentType { - 'application/json' -} - -sub Invoke { - my ($this,$action,$next) = @_; - - my $result = $next ? $next->($action) : undef; - - - my $model = ( ref $result and is($result,ViewResult) ) - ? $result->model - : $result; - - $model = [$model] unless ref $model; - - if (my $factory = $this->transform) { - Loader->safe->Require($factory) unless ref $factory; - my $t = $this->transform->new(); - $model = $t->Transform($model); - } - - my %params = ( - type => $this->contentType, - charset => 'utf-8', - body => JSON->new->utf8->pretty->encode($model) - ); - - if(is($result,ViewResult)) { - $params{status} = $result->status if $result->status; - $params{headers} = $result->headers if $result->headers; - $params{cookies} = $result->cookies if $result->cookies; - } - - return HttpResponse->new( - %params - ); -} - -1; - -__END__ - -=pod - -=head1 - -=cut \ No newline at end of file
--- a/lib/IMPL/Web/Handler/LocaleHandler.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,96 +0,0 @@ -package IMPL::Web::Handler::LocaleHandler; -use strict; - -use IMPL::Const qw(:prop); -use DateTime; -use IMPL::declare { - require => { - Resources => 'IMPL::Resources' - }, - base => [ - 'IMPL::Object' => undef, - 'IMPL::Object::Autofill' => '@_', - 'IMPL::Object::Serializable' => undef - ], - props => [ - locales => PROP_RO | PROP_LIST, - default => PROP_RO, - cookie => PROP_RO - ] -}; - -sub Invoke { - my ($this,$action,$nextHandler) = @_; - - my $locale; - - if ($this->cookie and my $cookie = $action->cookie($this->cookie)) { - ($locale) = grep /^$cookie/i, $this->locales; - } - - unless($locale) { - my @matches; - - my $best = [$this->default,0]; - - if(my $header = $action->header('Accept-Language')) { - foreach my $part (split(/\s*,\s*/, $header)) { - my ($lang,$quality) = ($part =~ /([a-z]+(?:\-[a-z]+)*)(?:\s*;\s*q=(0\.[\d]+|1))?/i ); - - $quality ||=1; - - foreach my $tag ($this->locales) { - if ( $tag =~ m/^$lang/i ) { - push @matches, [$tag,$quality]; - } - } - } - - foreach my $match (@matches) { - if ($match->[1] > $best->[1]) { - $best = $match; - } - } - - } - - $locale = $best->[0]; - } - - if($locale) { - Resources->SetLocale($locale); - #$locale =~ tr/-/_/; - DateTime->DefaultLocale($locale); - } - - return $nextHandler->($action); -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Web::Handler::LocaleHandler> - handles locale for the request - -=head1 SYNOPSIS - -=begin code xml - - <handlers type="ARRAY"> - <item type="IMPL::Web::Handler::LocaleHandler"> - <locales type="ARRAY"> - <item>en-US</item> - <item>ru-RU</item> - </locales> - <default>en-US</default> - <cookie>lang</cookie> - </item> - </handlers> - -=end code xml - -=cut \ No newline at end of file
--- a/lib/IMPL/Web/Handler/RestController.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,148 +0,0 @@ -package IMPL::Web::Handler::RestController; -use strict; - -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - Locator => 'IMPL::Web::AutoLocator', - ResourceInterface => 'IMPL::Web::Application::ResourceInterface', - Exception => 'IMPL::Exception', - ArgumentExecption => '-IMPL::InvalidArgumentException', - NotFoundException => 'IMPL::Web::NotFoundException', - Loader => 'IMPL::Code::Loader' - }, - base => { - 'IMPL::Object' => undef, - 'IMPL::Object::Autofill' => '@_', - 'IMPL::Object::Serializable' => undef - }, - props => [ - resourceFactory => PROP_RO, - trailingSlash => PROP_RO - ] -}; - -sub CTOR { - my ($this) = @_; - - die ArgumentException->new(resourceFactory => "A web-resource is required") - unless $this->resourceFactory; - #unless eval { $this->resourceFacotry->isa(ResourceInterface) }; - -} - -sub GetResourcePath { - my ($this,$action) = @_; - - my $pathInfo = $action->pathInfo; - my @segments; - - if (length $pathInfo) { - - @segments = split(/\//, $pathInfo, $this->trailingSlash ? -1 : 0); - - # remove first segment if it is empty - shift @segments if @segments && length($segments[0]) == 0; - } - - return @segments; -} - - -sub Invoke { - my ($this,$request) = @_; - - my $method = $request->requestMethod; - - my @segments = $this->GetResourcePath($request); - - my $factory = $this->resourceFactory; - - $factory = Loader->default->Require($factory) - unless ref($factory) || eval { $factory->can('new') }; - - my $res = $factory->new( - id => 'root', - request => $request, - location => Locator->new(base => $request->application->baseUrl), - ); - - while(@segments) { - my $id = shift @segments; - $res = $res->FetchChildResource($id); - } - - $res = $res->InvokeHttpVerb($method); -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Web::Handler::RestController> - Обрабатывает C<HTTP> запрос передавая -его соответствующему ресурсу. - -=head1 SYNOPSIS - -Используется в конфигурации приложения как элемент цепочки обработчиков. -Как правило располагается на самом верхнем уровне. - -=begin code xml - - <handlers type="ARRAY"> - <item type="IMPL::Web::Handler::RestController"> - <resourceFactory>My::App::Web::RootResource</resourceFactory> - </item> - <item type="IMPL::Web::Handler::JSONView" /> - <item type="IMPL::Web::Handler::SecureCookie" /> - <item type="IMPL::Web::Handler::ErrorHandler" /> - </handlers> - -=end code xml - - -=head1 DESCRIPTION - -Использует C<PATH_INFO> для определения нужного ресурса, затем предает -найденному ресурсу управление для обработки запроса. - -Если ресурс не найден, то возникает исключение C<IMPL::Web::NotFoundException>. - -Для определения нужного ресурса контроллер разбивает C<PATH_INFO> на фрагменты -и использует каждый фрагмент для получения дочернего ресурса начиная с корневого. -Для чего используется метод -C<< IMPL::Web::Application::ResourceInterface->FetchChildResource($childId) >>. - -Дерево ресурсов сущестувет независимо от обрабатываемого запроса, однако оно -может полностью или частично загружаться в начале обработки запроса и -освобождаться по окончании обработки запроса. Поэтому при получении дочерних -ресурсов не участвует C<HTTP> запрос, он адресуется только последнему ресурсу. - -=begin text - -/music/audio.mp3 -> ['music','audio.mp3'] - -=end text - -=head1 MEMEBERS - -=head2 C<[get]resourceFactory> - -Фабрика для создания корневого ресурса приложения, полученный ресурс должен -реализовывать интерфейс C<IMPL::Web::Application::ResourceInterface>. - -Фабрика может сохранять ссылку на корневой ресурс и каждый раз не создавать -его, а возвращать уже существующий. Это вполне оправдано, если хранение -дерева ресурсов требует меньше ресурсов, чем его создание и при этом приложение -остается в памяти между C<HTTP> запросами. - -=head2 C<[get]trailingSlash> - -Если данная переменная имеет значение C<true>, то слеш в конце пути к ресурсу -будет интерпретироваться, как дочерний ресурс с пустым идентификатором. - -=cut \ No newline at end of file
--- a/lib/IMPL/Web/Handler/SecureCookie.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,201 +0,0 @@ -package IMPL::Web::Handler::SecureCookie; -use strict; - - -use Digest::MD5 qw(md5_hex); -use IMPL::Const qw(:prop); -use IMPL::Security::Auth qw(:Const GenSSID); -use IMPL::declare { - require => { - SecurityContext => 'IMPL::Security::Context', - User => 'IMPL::Security::Principal', - AuthSimple => 'IMPL::Security::Auth::Simple', - Exception => 'IMPL::Exception', - OperationException => '-IMPL::InvalidOperationException', - HttpResponse => '-IMPL::Web::HttpResponse' - }, - base => { - 'IMPL::Object' => undef, - 'IMPL::Object::Autofill' => '@_', - 'IMPL::Object::Serializable' => undef - }, - props => [ - salt => PROP_RO, - _security => PROP_RW, - _cookies => PROP_RW - ] -}; - -sub CTOR { - my ($this) = @_; - - $this->salt('DeadBeef') unless $this->salt; -} - -sub ValidateCookie { - my ($this,$sid,$cookie,$sign) = @_; - - return 1 if $sid and $cookie and $sign and $sign eq md5_hex($this->salt,$sid,$cookie,$this->salt); - - return 0; -} - -sub AuthCookie { - my ($this,$sid,$cookie,$sign, $context) = @_; - - if (eval { $context->auth->isa(AuthSimple) }) { - my ($result,$challenge) = $context->auth->DoAuth($cookie); - return $result; - } - - return AUTH_FAIL; -} - -sub Invoke { - my ($this,$action,$nextHandler) = @_; - - return unless $nextHandler; - - my $context; - $this->_security($action->security); - - - my $sid = $action->cookie('sid',qr/(\w+)/); - my $cookie = $action->cookie('sdata',qr/(\w+)/); - my $sign = $action->cookie('sign',qw/(\w+)/); - - if ( $this->ValidateCookie($sid,$cookie,$sign) ) { - # TODO: add a DeferredProxy to deffer a request to a data source - if ( $context = $this->_security->sessions->GetById($sid) ) { - if ( eval { $context->auth->isa(AuthSimple) } ) { - my ($result,$challenge) = $context->auth->DoAuth($cookie); - - $context->authority($this); - - if ($result == AUTH_FAIL) { - $context = undef; - } - } else { - undef $context; - } - } - - } - - $context ||= SecurityContext->new(principal => User->nobody, authority => $this); - - my $httpResponse = eval { $context->Impersonate($nextHandler,$action); }; - my $e = $@; - - die $e if $e; - - die OperationException->new("A HttpResponse instance is expected") - unless ref $httpResponse && eval { $httpResponse->isa(HttpResponse) }; - - return $this->_WriteResponse($httpResponse); -} - -sub InitSession { - my ($this,$user,$roles,$auth,$challenge) = @_; - - my ($status,$answer); - - if ($auth) { - ($status,$answer) = $auth->DoAuth($challenge); - } else { - $status = AUTH_SUCCESS; - } - - die OperationException->new("This provider doesn't support multiround auth") - if ($status == AUTH_INCOMPLETE || $answer); - - if ($status == AUTH_SUCCESS) { - my $sid = GenSSID(); - my $cookie = GenSSID(); - - $this->_cookies({ - sid => $sid, - sdata => $cookie - }); - - my $context = $this->_security->sessions->Create({ - sessionId => $sid, - principal => $user, - auth => AuthSimple->Create(password => $cookie), - authority => $this, - rolesAssigned => $roles - }); - - $context->Apply(); - - } - - return $status; -} - -sub CloseSession { - my ($this) = @_; - if(my $session = SecurityContext->current) { - $this->_cookies({ - sid => undef, - sdata => undef - }) - } -} - -sub _WriteResponse { - my ($this,$response) = @_; - - if (my $data = $this->_cookies) { - - my $sign = $data->{sid} && md5_hex( - $this->salt, - $data->{sid}, - $data->{sdata}, - $this->salt - ); - - $response->cookies->{sid} = $data->{sid}; - $response->cookies->{sdata} = $data->{sdata}; - $response->cookies->{sign} = $sign; - } - - return $response; -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Web::Handler::SecureCookie> - -=head1 DESCRIPTION - -Возобновляет сессию пользователя на основе информации переданной через Cookie. - -Использует механизм подписи информации для проверки верности входных данных перед -началом каких-либо действий. - -Данный обработчик возвращает результат выполнения следдующего обработчика. - - - -=head1 MEMBERS - -=head2 C<[get,set] salt> - -Скаляр, использующийся для подписи данных. - - -=head2 C<InitSession($user,$roles,$auth,$challenge)> - -Инициирует сессию, поскольку данный модуль отвечает за взаимодействие с клиентом -при проверки аутентификации, ему передаются данные аутентификации для -продолжения обмена данными с клиентом. Если создается новая сессия, по -инициативе веб-приложения, то C<$auth> должно быть пусто. - -=cut
--- a/lib/IMPL/Web/Handler/View.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,323 +0,0 @@ -package IMPL::Web::Handler::View; -use strict; - -use Carp qw(carp); -use List::Util qw(first); -use IMPL::lang; -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - Factory => 'IMPL::Web::View::ObjectFactory', - HttpResponse => 'IMPL::Web::HttpResponse', - Loader => 'IMPL::Code::Loader', - ViewResult => 'IMPL::Web::ViewResult', - Security => 'IMPL::Security' - }, - base => [ - 'IMPL::Object' => undef, - 'IMPL::Object::Autofill' => '@_', - 'IMPL::Object::Serializable' => undef - ], - - props => [ - contentType => PROP_RO, - contentCharset => PROP_RO, - view => PROP_RO, - layout => PROP_RO, - selectors => PROP_RO, - defaultDocument => PROP_RW, - _selectorsCache => PROP_RW - ] -}; - -sub CTOR { - my ($this) = @_; - - $this->_selectorsCache([ map $this->ParseRule($_), @{$this->selectors || []} ]); -} - -sub Invoke { - my ( $this, $action, $next ) = @_; - - my $result = $next ? $next->($action) : undef; - - my $model; - if( ref $result and eval { $result->isa(ViewResult) } ) { - $model = $result->model; - } else { - $model = $result; - $result = ViewResult->new(model => $model); - } - - my $vars = { - result => $result, - request => sub { $action }, - app => $action->application, - location => $action->context->{resourceLocation}, - resource => $action->context->{resource}, - layout => $this->layout, - document => {}, - session => sub { Security->context }, - user => sub { Security->principal }, - security => sub { $action->security } - }; - - my %responseParams = ( - type => $this->contentType, - charset => $this->contentCharset, - body => $this->view->display( - $model, - $this->SelectView( $action, ref $model ), - $vars - ) - ); - - $responseParams{status} = $result->status if $result->status; - $responseParams{cookies} = $result->cookies if ref $result->cookies eq 'HASH'; - $responseParams{headers} = $result->headers if ref $result->headers eq 'HASH'; - - return HttpResponse->new( - %responseParams - ); -} - -sub SelectView { - my ($this,$action) = @_; - - my @path; - - for(my $r = $action->context->{resource}; $r ; $r = $r->parent ) { - unshift @path, { - name => $r->id, - class => typeof($r->model) - }; - } - - @path = map { name => $_}, split /\/+/, $action->query->path_info() - unless (@path); - - return $this->MatchPath(\@path,$this->_selectorsCache) || $this->defaultDocument; -} - -sub ParseRule { - my ($this, $rule) = @_; - - my ($selector,$data) = split /\s+=>\s+/, $rule; - - my @parts; - my $first = 1; - my $weight = 0; - foreach my $part ( split /\//, $selector ) { - # если первым символом является / - # значит путь в селекторе абсолютный и не нужно - # добавлять "любой" элемент в начало - - if($part) { - $weight ++; - push @parts,{ any => 1 } if $first; - } else { - push @parts,{ any => 1 } unless $first; - next; - } - - my ($name,$class) = split /@/, $part; - - if ( my ( $varName, $rx ) = ( $name =~ m/^\{(?:(\w+)\:)?(.*)\}$/ ) ) { - #this is a regexp - - push @parts, { - rx => $rx, - var => $varName, - class => $class, - }; - } else { - push @parts, { - name => length($name) ? $name : undef, - class => $class, - }; - } - } continue { - $first = 0; - } - - return { selector => \@parts, data => $data, weight => $weight }; -} - -sub MatchPath { - my ($this,$path,$rules) = @_; - - $path ||= []; - $rules ||= []; - - my @next; - - foreach my $segment (@$path) { - foreach my $rule (@$rules) { - my @selector = @{$rule->{selector}}; - - my $part = shift @selector; - - # if this rule doesn't have a selector - next unless $part; - - if ($part->{any}) { - #keep the rule for the next try - push @next, $rule; - - $part = shift @selector while $part->{any}; - } - - my $newRule = { - selector => \@selector, - data => $rule->{data}, - weight => $rule->{weight}, - vars => { %{$rule->{vars} || {}} } - }; - - my $success = 1; - if (my $class = $part->{class}) { - $success = isclass($segment->{class},$class); - } - - if($success && (my $name = $part->{name})) { - $success = $segment->{name} eq $name; - } elsif ($success && (my $rx = $part->{rx})) { - if( my @captures = ($segment->{name} =~ m/($rx)/) ) { - $newRule->{vars}->{$part->{var}} = \@captures - if $part->{var}; - } else { - $success = 0; - } - } - - push @next, $newRule if $success; - - } - $rules = [@next]; - undef @next; - } - - my $result = ( - sort { - $b->{weight} <=> $a->{weight} - } - grep { - scalar(@{$_->{selector}}) == 0 - } - @$rules - )[0]; - - if($result) { - my $data = $result->{data}; - $data =~ s/{(\w+)(?:\:(\d+))?}/ - my ($name,$index) = ($1,$2 || 0); - - if ($result->{vars}{$name}) { - $result->{vars}{$name}[$index]; - } else { - ""; - } - /gex; - - return $data; - } else { - return; - } -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Web::Handler::TTView> - использует шаблоны для построения представления. - -=head1 SYNOPSIS - -=begin code xml - -<item id="html-view" type="IMPL::Web::Handler::View"> - <contentType>text/html</contentType> - <view id="tt-loader" type="IMPL::Web::View::TTView"> - <options type="HASH"> - <INCLUDE_PATH type="IMPL::Config::Reference"> - <target>IMPL::Config</target> - <AppBase>view</AppBase> - </INCLUDE_PATH> - <INTERPOLATE>1</INTERPOLATE> - <POST_CHOMP>1</POST_CHOMP> - <ENCODING>utf-8</ENCODING> - </options> - <ext>.tt</ext> - <initializer>global.tt</initializer> - <layoutBase>layouts</layoutBase> - </view> - <defaultDocument>default</defaultDocument> - <selectors type="ARRAY"> - <item>@HASH => dump</item> - <item>@My::Data::Product => product/info</item> - <item>{action:.*} @My::Data::Product => product/{action}</item> - </selectors> -</item> - -=end code xml - -=head1 DESCRIPTION - -Подбирает шаблон для представления результата, полученного при выполнении следующего обработчика. При -выборе используется принцип похожий на селекторы C<CSS>, основывающийся на именах ресурсов и их типах -данных. - -Данный обработчик понимает определенные свойства контекста: - -=over - -=item * C<resourceLocation> - -В данном свойстве может быть передана информация о текущем расположении ресурса, -для которого строится представление. Эта информация будет доступна в шаблоне -через свойство документа C<location>. - -=item * C<environment> - -В данном совойстве контекста передается дополнительная информация об окружении -ресурса, например, которую задали родительские ресурсы. Использование данного -свойства позволяет не загромождать ресурс реализацией функциональности по -поддержке окружения. Это свойство может быть ссылкой на функцию, что позволяет -формировать контекст только по необходимости, при этом указанная функция будет -выполнена только один раз, при первом обращении. - -=back - -=head1 SELECTORS - -=begin text - -syntax::= selector => template - -selector::= ([>]segment-template[@class-name]) - -segment-template::= {'{'name:regular-expr'}'|segment-name} - -name::= \w+ - -segment-name::= \S+ - -class-name::= name[(::name)] - -url-template@class => template - -shoes => product/list -/shop//{action:*.}@My::Data::Product => product/{action} - -stuff >list => product/list -details => product/details - -=end text - - -=cut -
--- a/lib/IMPL/Web/Handler/ViewSelector.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,100 +0,0 @@ -package IMPL::Web::Handler::ViewSelector; -use strict; - -use IMPL::Const qw(:prop); - -use IMPL::declare { - require => { - NotAcceptable => 'IMPL::Web::NotAcceptableException', - HttpResponse => 'IMPL::Web::HttpResponse' - }, - base => [ - 'IMPL::Object' => undef, - 'IMPL::Object::Autofill' => '@_', - 'IMPL::Object::Serializable' => undef - ], - props => [ - views => PROP_RW | PROP_LIST, - fallback => PROP_RW, - types => PROP_RW - ] -}; - -sub Invoke { - my ( $this, $action, $next ) = @_; - - my $result = $next ? $next->($action) : undef; - - my $model; - - return $result if eval { $result->isa(HttpResponse) }; - - my $handler; - my $path = $action->pathInfo; - - if ( $this->types and $path =~ m/\.(\w+)$/ ) { - my $forced; - if ( $forced = $this->types->{$1} and $action->query->Accept($forced) ) - { - ($handler) = - grep eval { $_->can('contentType') } - && $_->contentType eq $forced, $this->views; - } - } - - if ( not $handler ) { - - my @handlers = - sort { $b->{preference} <=> $a->{preference} } map { - { - handler => $_, - preference => eval { $_->can('contentType') } - ? $action->query->Accept( $_->contentType ) - : 0 - } - } $this->views; - - my $info = shift @handlers; - $handler = $info ? $info->{handler} : undef; - - } - - die NotAcceptable->new( - map { - eval { $_->can('contentType') } ? $_->contentType : () - } $this->views - ) unless $handler; - - return $handler->Invoke( $action, sub { $result } ); -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Web::Handler::ViewSelector> - Выбор нужного представления на основе заголовка C<Accept> - -=head1 DESCRIPTION - -Использует заголовок запроса C<Accept> для выбора подходящего представления, если задано свойство C<types>, -пытается в первую очередь по расширению определить, какое представление подходит. - -В случаях, когда не требуется строить представление для данных (например, при перенаправлении к другому -ресурсу или если нет данных), нужно, чтобы данному обработчику был возвращен -L<IMPL::Web::Application::ActionResult>, который будет просто передан далее. - -=head1 MEMBERS - -=head2 C<[get,set,list]views> - -Список представлений, которые могут быть возвращены. - -=head2 C<[get,set]types> - -Хеш с соотвествием между расширением и типом содержимого, для подсказки при выборе представления. - -=cut
--- a/lib/IMPL/Web/HttpResponse.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,174 +0,0 @@ -use strict; -package IMPL::Web::HttpResponse; - -use CGI(); -use IMPL::lang qw(:declare :hash); -use IMPL::declare { - require => { - Exception => 'IMPL::Exception', - ArgumentException => '-IMPL::InvalidArgumentException' - }, - base => [ - 'IMPL::Object' => undef, - 'IMPL::Object::Autofill' => '@_' - ], - props => [ - status => PROP_ALL, - type => PROP_ALL, - charset => PROP_ALL, - cookies => PROP_ALL, - headers => PROP_ALL, - body => PROP_ALL - ] -}; - -sub CTOR { - my ($this) = @_; - - $this->headers({}) unless $this->headers(); - $this->cookies({}) unless $this->cookies(); -} - -sub PrintResponse { - my ($this,$out) = @_; - - my $q = CGI->new({}); - - my %headers = %{$this->headers}; - - if(my $cookies = $this->cookies) { - $headers{-cookie} = [map _createCookie($_,$cookies->{$_}), keys %$cookies] if $cookies; - } - - $headers{'-status'} = $this->status || '200 OK'; - $headers{'-type'} = $this->type || 'text/html'; - - if(my $charset = $this->charset) { - $q->charset($charset); - binmode $out, ":encoding($charset)"; - } else { - $q->charset(''); - binmode $out; - } - - print $out $q->header(\%headers); - - if(my $body = $this->body) { - if(ref $body eq 'CODE') { - $body->($out); - } else { - print $out $body; - } - } -} - -#used to map a pair name valie to a valid cookie object -sub _createCookie { - return UNIVERSAL::isa($_[1], 'CGI::Cookie') - ? $_[1] - : ( defined $_[1] - ? CGI::Cookie->new(-name => $_[0], -value => $_[1] ) - : CGI::Cookie->new(-name => $_[0], -expires => '-1d', -value => '') - ); -} - -sub InternalError { - my ($self,%args) = @_; - - $args{status} ||= '500 Internal Server Error'; - - return $self->new(%args); -} - -sub Redirect { - my ($self,%args) = @_; - - return $self->new( - status => $args{status} || '303 See other', - headers => { - location => $args{location} - } - ); -} - -sub NoContent { - my ($self,%args) = @_; - - return $self->new( - status => $args{status} || '204 No Content' - ); -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Web::HttpResponse> - Результат обработки C<HTTP> запроса. - -=head1 SYNOPSIS - -=head1 DESCRIPTION - -Базовый класс для ответов приложения на C<HTTP> запрос. Каждый вид ответа, -например - -Данный объект используется для формирования и передачи данных C<HTTP> ответа -напрямую. Основными полями являются C<body> и C<status>. - -Кроме свойств относящихся непосредственно к самому C<HTTP> ответу, данный объект -может содержать свойства относящиеся к процессу обработки запроса, например -механизму формирования представления. - -=head1 MEMBERS - -=head2 C<[get,set]status> - -Статус который будет отправлен сервером клиенту, например, C<200 OK> или -C<204 No response>. Если не указан, то будет C<200 OK>. - -=head2 C<[get,set]type> - -Тип содержимого, которое будет передано клиенту, если не указано, будет -C<text/html>. - -=head2 C<[get,set]charset> - -Кодировка в которой будут переданны данные. Следует задавать если и только, если -передается текстовая информация. Если указана кодировка, то она будет -автоматически применена к потоку, который будет передан методу C<PrintResponse>. - -=head2 C<[get,set]cookies> - -Опционально. Ссылка на хеш с печеньками. - -=head2 C<[get,set]headers> - -Опционально. Ссылка на хеш с дополнительными полями заголовка ответа. Формат -имен полей как у модуля C<CGI>. - -=begin code - -$response->header->{custom_header} = "my value"; - -#will produce the following header - -Custom-header: my value - -=end code - -=head2 C<[get,set]body> - -Тело ответа. Может быть как простой скаляр, который будет приведен к строке и -выдан в поток вывода метода C<PrintResponse>. Также может быть ссылкой на -процедуру, в таком случае будет вызвана эта процедура и ей будет передан -первым параметром поток для вывода тела ответа. - -=head2 C<PrintResponse($outStream)> - -Формирует заголовок и выводит ответ сервера в указанный параметром поток. - -=cut \ No newline at end of file
--- a/lib/IMPL/Web/NotAcceptableException.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,25 +0,0 @@ -package IMPL::Web::NotAcceptableException; -use strict; - -use IMPL::declare { - base => { - 'IMPL::Web::Exception' => '@_' - } -}; - -sub status { - "406 Not acceptable" -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Web::NotAcceptableException> Исключение в случае, если запрошенный ресурс не может -быть выдан в указанном виде. - -=cut \ No newline at end of file
--- a/lib/IMPL/Web/NotAllowedException.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,30 +0,0 @@ -package IMPL::Web::NotAllowedException; -use strict; - -use IMPL::Const qw(:prop); -use IMPL::declare { - base => [ - 'IMPL::Web::Exception' => '@_' - ] -}; - -use IMPL::Resources::Strings { - message => "The requested method isn't allowed" -}; - -sub CTOR { - my $this = shift; - my %args = @_; - - $this->headers({ - allow => $args{allow} - }); -} - -sub status { - "405 Method Not Allowed" -} - -1; - -__END__ \ No newline at end of file
--- a/lib/IMPL/Web/NotFoundException.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,28 +0,0 @@ -package IMPL::Web::NotFoundException; -use strict; - -use IMPL::declare { - base => { - 'IMPL::Web::Exception' => '@_' - }, -}; - -use IMPL::Resources::Strings { - message => 'The specified resource isn\'t found.' -}; - -sub status { - "404 Not found" -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Web::NotFoundException> Исключение для несущесьвующего ресурса. - -=cut \ No newline at end of file
--- a/lib/IMPL/Web/OutOfRangeException.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,51 +0,0 @@ -package IMPL::Web::OutOfRangeException; -use strict; - -use IMPL::declare { - base => { - 'IMPL::Web::Exception' => '@_' - }, -}; - -sub CTOR { - my ($this,$range) = @_; - - #TODO: validate args - - $this->headers({ - content_range => { $range->{units} . ' */' . $range->{length} } - }); -} - -use IMPL::Resources::Strings { - message => 'The specified range is invalid' -}; - -sub status { - "416 Requested Range Not Satisfiable" -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Web::OutOfRangeException> A server SHOULD return a response with this -status code if a request included a Range request-header field (section 14.35), -and none of the range-specifier values in this field overlap the current extent -of the selected resource, and the request did not include an If-Range -request-header field. (For byte-ranges, this means that the first- byte-pos of -all of the byte-range-spec values were greater than the current length of the -selected resource.) - -=head1 DESCRIPTION - -When this status code is returned for a byte-range request, the response SHOULD -include a Content-Range entity-header field specifying the current length of the -selected resource (see section 14.16). This response MUST NOT use the -multipart/byteranges content- type. - -=cut \ No newline at end of file
--- a/lib/IMPL/Web/PreconditionException.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,33 +0,0 @@ -package IMPL::Web::PreconditionException; -use strict; - -use IMPL::declare { - base => { - 'IMPL::Web::Exception' => '@_' - } -}; - -use IMPL::Resources::Strings { - message => "Precondition Failed" -}; - -sub status { - "412 Precondition Failed" -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Web::PreconditionException> - The precondition given in one or more of -the request-header fields evaluated to false when it was tested on the server. - -This response code allows the client to place preconditions on the current -resource metainformation (header field data) and thus prevent the requested -method from being applied to a resource other than the one intended. - -=cut \ No newline at end of file
--- a/lib/IMPL/Web/Security.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,196 +0,0 @@ -package IMPL::Web::Security; -use strict; - -use IMPL::Security::Auth qw(:Const); -use IMPL::declare { - require => { - Exception => 'IMPL::Exception', - NotImplementedException => '-IMPL::NotImplementedException', - ArgException => '-IMPL::InvalidArgumentException', - SecurityContext => 'IMPL::Security::AbstractContext' - }, -}; - -use constant { - ERR_NO_SUCH_USER => -1, - ERR_NO_SEC_DATA => -2, - ERR_NO_AUTHORITY => -3, - ERR_NO_SEC_CONTEXT => -4, - ERR_AUTH_FAIL => -5 -}; - -sub interactiveAuthPackage { - die NotImplementedException->new(); -} - -sub users { - die NotImplementedException->new(); -} - -sub roles { - die die NotImplementedException->new(); -} - -sub sessions { - die NotImplementedException->new(); -} - -sub AuthUser { - my ($this,$name,$challenge,$roles,$package) = @_; - - $package ||= $this->interactiveAuthPackage; - $roles ||= []; - - my $user = $this->users->GetById($name) - or return { - status => AUTH_FAIL, - code => ERR_NO_SUCH_USER - }; - - my $auth; - if ( my $secData = $user->GetSecData($package) ) { - $auth = $package->new($secData); - } else { - return { - status => AUTH_FAIL, - code => ERR_NO_SEC_DATA, - user => $user - }; - } - - return { - status => AUTH_FAIL, - code => ERR_NO_SEC_CONTEXT - } unless SecurityContext->current; - - return { - status => AUTH_FAIL, - code => ERR_NO_AUTHORITY - } unless SecurityContext->current->authority; - - my $status = SecurityContext->current->authority->InitSession( - $user, - $roles, - $auth, - $challenge - ); - - return { - status => $status, - code => ($status == AUTH_FAIL ? ERR_AUTH_FAIL : 0), - user => $user - }; -} - -sub Logout { - my ($this) = @_; - - my $session = SecurityContext->current; - if($session && $session->authority) { - $session->authority->CloseSession($session); - - $this->sessions->Delete($session); - } -} - -sub CreateSecData { - my ($this,$package,$params) = @_; - - die ArgException->new(params => 'A hash reference is required') - unless ref($params) eq 'HASH'; - - return $package->CreateSecData(%$params); -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Web::Security> Модуль для аутентификации и авторизации веб запроса. - -=head1 DESCRIPTION - -Текущий модуль обеспечивает функции верхнего уровня для работы с системой -безопасности. Поскольку модуль является абстрактым, конкретные функции -хранения и реализацию объектов модели безопасности должно обеспечить само -приложение. - -Сама система безопасности в веб приложении состоит из двух частей - -=over - -=item Модель системы безопасности - -Предоставляет такие объкты безопасности, как пользователь, сессия роль, -определяет правила проверки прав доступа субъекта к объекту. - -=item Модуль безопасности - -Контекст безопасности создается именно этим модулем. - -Как правило встраивается в транспортный уровеь в виде обработчика -C<IMPL::Web::Handler> и реализует непосредственно протокол аутентификации и -обмена с пользователем. - -Также модуль безопасности использует модель для хранения сессий и данных -аутентификции. - -=back - -=head1 MEMBERS - -=head2 C<AuthUser($name,$package,$challenge)> - -Инициирует создание новой сессии используя провайдера безопасности текущего -контекста безопасности. - -=over - -=item C<$name> - -Имя пользователя, которое будет использоваться при поиске его в БД. - -=item C<$package> - -Имя модуля аутентификации, например, C<IMPL::Security::Auth::Simple>. - -=item C<$challenge> - -Данные, полученные от клиента, которые будут переданы модулю аутентификации для -начала процесса аутентификации и создания сессии. - -=back - -Функция возвращает хеш с элементами - -=over - -=item C<status> - -Статус аутентификации - отражает общее состояние процесса ацтентификации, - -=over - -=item C<AUTH_FAIL> - -Аутентификация неудачная, сессия не создана. - -=item C<AUTH_INCOMPLETE> - -Аутентификация требует дополнительных шагов, сессия создана, но еще не доверена. - -=item C<AUTH_SUCCESS> - -Аутентификация успешно проведена, сессия создана. - -=back - -=item C<code> - -=back - -=cut
--- a/lib/IMPL/Web/Security/Session.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,63 +0,0 @@ -package IMPL::Web::Security::Session; -use strict; -use parent qw(); - -use IMPL::Const qw(:prop); -use IMPL::declare { - base => [ - 'IMPL::Security::AbstractContext' => '@_' - ] -}; - -push @{__PACKAGE__->abstractProps}, sessionId => PROP_RW, security => PROP_RW; - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Web::Security::Session> - Сессия пользователя. - -=head1 SINOPSYS - -=begin code - -# define a custom session for the application - -package App::Session; -use parent qw(IMPL::Web::Security::Session); - -use IMPL::Class::Property; - -BEGIN { - public property transactionId => prop_all; -} - -=end code - -=head1 DESCRIPTION - -C<use parent qw(IMPL::Security::Context)> - -Представляет собой контекст безопасности, имеет идентификатор. Является базовым классом -для расширения дополнительными атрибутами. - -=head1 MEMBERS - -=over - -=item C<[get] sessionId> - -Идентификатор сессии - -=item C<[get] security> - -Экземпляр C<IMPL::Web::Security> в рамках которого создана сессия (откуда взят -пользователь и роли). - -=back - -=cut
--- a/lib/IMPL/Web/UnauthorizedException.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,24 +0,0 @@ -package IMPL::Web::UnauthorizedException; -use strict; - -use IMPL::declare { - base => { - 'IMPL::Web::Exception' => '@_' - } -}; - -sub status { - "401 Unauthorized" -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Web::UnauthorizedException> - запрос требует идентификации пользователя. - -=cut \ No newline at end of file
--- a/lib/IMPL/Web/UnsupportedMediaException.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,31 +0,0 @@ -package IMPL::Web::UnsupportedMediaException; -use strict; - -use IMPL::declare { - base => { - 'IMPL::Web::Exception' => '@_' - } -}; - -sub status { - "415 Unsupported Media Type" -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Web::UnsupportedMediaException> - 415 Unsupported Media Type - -=head1 DESCRIPTION - -The request entity has a media type which the server or resource does not -support. For example, the client uploads an image as C<image/svg+xml>, but the -server requires that images use a different format. -L<http://en.wikipedia.org/wiki/List_of_HTTP_status_codes> - -=cut \ No newline at end of file
--- a/lib/IMPL/Web/View/Metadata/BaseMeta.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,140 +0,0 @@ -package IMPL::Web::View::Metadata::BaseMeta; -use strict; - -use IMPL::lang; -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - Exception => 'IMPL::Exception', - ArgException => '-IMPL::InvalidArgumentException', - NotImplException => '-IMPL::NotImplementedException' - }, - base => [ - 'IMPL::Object' => undef - ], - props => [ - model => PROP_RO, - modelType => PROP_RO, - name => PROP_RO, - label => PROP_RO, - container => PROP_RO, - template => PROP_RO, - - _childMap => PROP_RO, - _childNames => PROP_RO - ] -}; - -sub CTOR { - my ($this,$model,$type,$args) = @_; - - $this->model($model); - $this->modelType($type); - $this->_childMap({}); - - #mixin other args - if ($args) { - $this->$_($args->{$_}) foreach grep $args->{$_}, qw(name label container template); - } -} - -sub GetProperty { - my ($this,$name) = @_; - - $this->GetProperties() - unless $this->_childNames; - - return $this->_childMap->{$name}; -} - -sub GetProperties { - my ($this) = @_; - - if ($this->_childNames) { - return [ map $this->_childMap->{$_}, @{$this->_childNames} ]; - } else { - my @childNames; - my %childMap; - my @result; - - foreach my $child (@{$this->PopulateProperties()}) { - $childMap{$child->name} = $child; - push @childNames, $child->name; - push @result, $child; - } - - $this->_childMap(\%childMap); - $this->_childNames(\@childNames); - return \@result; - } -} - -sub PopulateProperties { - my ($this) = @_; - - die NotImplException->new(); -} - -sub GetItems { - my ($this) = @_; - - die NotImplException->new(); -} - -sub GetItem { - my ($this,$index) = @_; - - die NotImplException->new(); -} - -1; - -__END__ - -=pod - -=head1 NAME - -=head1 SYNOPSIS - -=head1 DESCRIPTION - -Метаданные описывают модель, ее свойства, используются для построения -представления. - -=over - -=item * type - -Опционально. Тип модели. В случаях, когда модель не определена, данное свойство -позволяет определить ее тип. - -=item * label - -Опционально. Имя модели для отображения. - -=item * template - -Шаблон, который следует использовать для отображения модели. - -=item * fields - -Коллекция с информацией по свойствам (полям) модели. Данный хеш используется -для определения представления при использовании C<display_for('field')>. - -=back - -Метаданные публикуются провайдером, кроме того они могут быть расширены -дополнительными свойствами. - -=head1 MEMBERS - -=head2 C<GetChild($name)> - -Возвращает метаданные для дочернего элемента, например свойства объекта - -=head2 C<GetChildren()> - -Возвращает ссылку на массив с метаданными для дочерних элементов - -=cut \ No newline at end of file
--- a/lib/IMPL/Web/View/Metadata/FormMeta.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,319 +0,0 @@ -package IMPL::Web::View::Metadata::FormMeta; -use strict; - -use IMPL::lang; -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - Exception => 'IMPL::Exception', - ArgException => '-IMPL::InvalidArgumentException', - OpException => '-IMPL::InvalidOperationException', - SchemaNavigator => 'IMPL::DOM::Navigator::SchemaNavigator', - DOMNode => '-IMPL::DOM::Node' - }, - base => [ - 'IMPL::Web::View::Metadata::BaseMeta' => '@_' - ], - props => [ - nodes => PROP_RO, - decl => PROP_RO, - schema => PROP_RO, - errors => PROP_RO, - group => PROP_RO - ] -}; - -use constant { - Meta => __PACKAGE__ -}; - -sub CTOR { - my ($this,$model,$type,$args) = @_; - - if ($args) { - $this->$_($args->{$_}) foreach grep $args->{$_}, qw(decl schema nodes errors group); - } - - $this->$_() || die ArgException->new($_ => "The $_ is required") - foreach qw(schema); -} - -sub GetSchemaProperty { - my ($this,$name) = @_; - - return $this->decl ? $this->decl->nodeProperty($name) || $this->schema->nodeProperty($name) : $this->schema->nodeProperty($name); -} - -sub template { - shift->GetSchemaProperty('template'); -} - -sub label { - shift->GetSchemaProperty('label'); -} - -sub inputType { - shift->GetSchemaProperty('inputType'); -} - -sub inputValue { - my ($this) = @_; - - if($this->isMultiple) { - return [ - map { - $_ ? $_->nodeValue || $_->nodeProperty('rawValue') : undef - } - @{$this->model || []} - ] - } else { - return $this->model ? $this->model->nodeValue || $this->model->nodeProperty('rawValue') : undef; - } -} - -sub isMultiple { - my ($this) = @_; - $this->decl && $this->decl->isMultiple; -} - -sub isOptional { - my ($this) = @_; - not($this->decl) || $this->decl->isOptional; -} - -sub GetOwnErrors { - my ($this) = @_; - - my $nodes = $this->nodes; - - my $errors = [ - grep _IsOwnError($nodes,$this->decl,$_), @{$this->errors || []} - ]; - - return $errors; -} - -sub _IsOwnError { - my ($nodes,$source,$err) = @_; - - return 1 if ($err->node && grep($err->node == $_, @$nodes)) || (not(@$nodes) && $err->schemaNode && $err->schemaNode == $source ); - - return 0; -} - -sub _IsErrorRelates { - my ($nodes,$source,$err) = @_; - - # this is an own error - return 1 if _IsOwnError($nodes,$source,$err); - - # this error relates to the child control - - return 0 unless @$nodes; - - for (my $n = $err->parent; $n ; $n = $n->parentNode) { - return 1 if grep($n == $_, @$nodes); - } - - return 0; -} - -sub PopulateProperties { - my ($this) = @_; - - my @props; - - # return empty list of properties in case of multiple values - return \@props if $this->isMultiple; - - my $navi = SchemaNavigator->new($this->schema); - - foreach my $decl (@{$this->schema->content->childNodes}) { - - my $schema = $navi->NavigateName($decl->name); - $navi->SchemaBack(); - - my @nodes = $this->model && $this->model->selectNodes( sub { $_->schemaNode == $decl } ); - - my %args = ( - name => $decl->name, - decl => $decl, - schema => $schema, - nodes => [@nodes], - errors => [grep _IsErrorRelates(\@nodes,$decl,$_), @{$this->errors || []}] - ); - - my ($model,$type); - - if ($decl->isMultiple) { - $model = [@nodes]; - $type = 'ARRAY'; - $args{holdingType} = $schema->type; - } else { - $model = shift @nodes; - $type = $schema->type; - } - - push @props, Meta->new($model,$type,\%args); - } - - return \@props; -} - -sub GetItems { - my ($this) = @_; - - die OpException->new("The operation must be performed on the container") - unless $this->isMultiple; - - my $i = 0; - - return [ - map $this->_GetItemMeta($_,$i++), @{$this->nodes} - ]; -} - -sub GetItem { - my ($this,$index) = @_; - - die OpException->new("The operation must be performed on the container") - unless $this->isMultiple; - - my $node = $this->nodes->[$index]; - - return $this->_GetItemMeta($node,$index); -} - -sub _GetItemMeta { - my ($this,$node,$index) = @_; - - my @nodes; - push @nodes,$node if $node; - - return Meta->new( - $node, - $this->schema->type, - { - name => $index, - schema => $this->schema, - errors => [grep _IsErrorRelates([$node],$this->decl,$_), @{$this->errors ||[]} ], - group => $this, - nodes => \@nodes - } - ); -} - -sub GetMetadataForModel { - my ($self,$model,$args) = @_; - - $args ||= {}; - - my $modelType = delete $args->{modelType}; - - if($model) { - die ArgException->new(model => "A node is required") - unless is($model,DOMNode); - - $args->{decl} ||= $model->schemaNode; - $args->{schema} ||= $model->schemaType; - } - - return $self->new( - $model, - $modelType, - $args - ); -} - -1; - -__END__ - -=pod - -=head1 NAME - -=head1 SYNOPSIS - -=head1 DESCRIPTION - -Расширенные метаданные модели для элементов формы, помимо стандартных свойств -сожержит в себе информацию о схеме. - -=head1 MEMBERS - -=head2 C<[get]errors> - -Ссылка на массив с ошибками при проверке схемы. Ошибки относятся ко всем -узлам в текущей модели, включая вложенные и т.п. - -=head2 C<[get]model> - -Ссылка на элемент документа, либо на массив с элементами для множественных -значений (C<isMultiple = true>). В том случае, когда документ был не -корректен и для не множественного элемента было передено несколько значений, -данное свойство будет содержать только первое. - -=head2 C<[get]nodes> - -Ссылка на массив с узлами документа. В теории количество узлов может быть -произвольным, поскольку документ может быть некорректным, т.е. их может -быть более одного в то время, как C<isMultiple = false> или, напротив, ни -одного при C<isOptional = false>. - -Как правило для построения формы данное свойство не требуется. - -=head2 C<[get]modelType> - -Название типа данных из схемы документа (C<< schema->name >>), если тип не имеет название, то это -C<ComplexNode> для сложных узлов и C<SimpleNode> для простых. - -Для моделей с множественными значениями это свойство не задано. Тип элементов -храниться в свойстве C<holdingType> - -=head2 C<[get]decl> - -Объявление элемента формы, объявление может совпадать со схемой в случае, -когда это был C<SimpleNode> или C<ComplexNode>, иначе это C<Node> ссылающийся -на заранее обпределенный тип. - -=head2 C<[get]schema> - -Схема текущего элемента, C<СomlexType>, C<SimpleType>, C<ComplexNode> или -C<SimpleNode>. - -=head2 C<[get]isOptional> - -Данный элемент может не иметь ни одного значения - -=head2 C<[get]isMultiple> - -Данный элемент может иметь более одного значения. Модель с множественными -значениями является сложным элементом, в котором дочерними моделями являются -не свойства а сами элементы, в данном случае они их именами будут индексы. - -=begin code - -for(my $i=0; $i< 10; $i++) { - display_for($i,'template'); -} - -sub display_for { - my ($index,$tmpl) = @_; - - if ($index =~ /^\d+$/) { - return render($tmpl, metadata => { $meta->GetItem($index) }); - } else { - return render($tmpl, metadata => { $meta->GetProperty($index) }); - } -} - -=end code - -=head2 C<GetOwnErrors()> - -Возвращает ошибки относящиеся к самому элементу C<model>, это принципиально -для контейнеров и в случаях, когда модель не корректна и в ней присутствуют -лишние значения. - -=cut \ No newline at end of file
--- a/lib/IMPL/Web/View/Metadata/ObjectMeta.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,133 +0,0 @@ -package IMPL::Web::View::Metadata::ObjectMeta; -use strict; - -use IMPL::lang; -use IMPL::Const qw(:prop :access); -use IMPL::declare { - require => { - Exception => 'IMPL::Exception', - ArgException => '-IMPL::InvalidArgumentException', - OpException => '-IMPL::InvalidOperationException', - PropertyInfo => 'IMPL::Class::PropertyInfo', - AbstractObject => '-IMPL::Object::Abstract' - }, - base => [ - 'IMPL::Web::View::Metadata::BaseMeta' => sub { - my ($model,$type,$args) = @_; - $type ||= typeof($model); - return ($model,$type,$args); - } - ], - props => [ - isMultiple => PROP_RO, - holdingType => PROP_RO - ] -}; - -use constant { - Meta => __PACKAGE__ -}; - -sub CTOR { - my ($this,$model,$type,$args) = @_; - - $type = $this->modelType; - - $args->{isMultiple} ||= $type && $type eq 'ARRAY'; - - if ($args) { - $this->$_($args->{$_}) foreach grep $args->{$_}, qw(isMultiple holdingType); - } -} - -sub PopulateProperties { - my ($this) = @_; - - my %seen; - my @props; - - my $modelType = $this->modelType; - - if ( isclass($modelType,AbstractObject) ) { - foreach my $pi ( - $this->modelType->GetMeta( - PropertyInfo, - sub { not($seen{$_}++) and $_->access == ACCESS_PUBLIC }, - 1 - ) - ) { - my $pv = $this->model && $pi->getter->($this->model); - my $pt; - - my %args = (name => $pi->name); - if ($pi->isList) { - $pt = 'ARRAY'; - $args{isMultiple} = 1; - $args{holdingType} = $pi->type; - } else { - $pt = $pi->type; - } - - push @props, Meta->new($pv, $pt, \%args); - } - } elsif ( $modelType && $modelType eq 'HASH' ) { - while ( my ($k,$v) = each %{$this->model || {}} ) { - push @props, Meta->new($v,undef,{name => $k}); - } - } - - return \@props; -} - -sub GetItems { - my ($this) = @_; - - die OpException->new("The operation must be performed on the container") - unless $this->isMultiple; - - my $i = 0; - - return [ - map $this->_GetItemMeta($_,$i++), @{$this->model || []} - ]; -} - -sub GetItem { - my ($this,$index) = @_; - - die OpException->new("The operation must be performed on the container") - unless $this->isMultiple; - - my $item = @{$this->model || []}[$index]; - - return $this->_GetItemMeta($item,$index); -} - -sub _GetItemMeta { - my ($this,$item,$index) = @_; - - return Meta->new( - $item, - $this->holdingType, - { - name => $index, - container => $this - } - ); -} - -sub GetMetadataForModel { - my ($self,$model,$args) = @_; - - $args ||= {}; - - return $self->new( - $model, - delete $args->{modelType}, - $args - ) -} - -1; - -__END__
--- a/lib/IMPL/Web/View/ObjectFactory.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,33 +0,0 @@ -package IMPL::Web::View::ObjectFactory; -use strict; - -our $AUTOLOAD; - -use IMPL::declare { - require => { - Exception => 'IMPL::Exception', - OpException => '-IMPL::InvalidOperationException' - }, - base =>[ - 'IMPL::Object::Factory' => '@_' - ] -}; - -use IMPL::Resources::Strings { - MsgNoMethod => 'Method "%method%" isn\'t found in "%target%"' -}; - -sub AUTOLOAD { - my $this = shift; - my ($method) = ($AUTOLOAD =~ m/(\w+)$/); - - return if $method eq 'DESTROY'; - my $target = $this->factory; - if ( $target->can($method) ) { - return $target->$method(@_); - } else { - die OpException->new( MsgNoMethod( method => $method, target => $target ) ); - } -} - -1; \ No newline at end of file
--- a/lib/IMPL/Web/View/TTContext.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,519 +0,0 @@ -package IMPL::Web::View::TTContext; -use strict; -use Template::Base; -use Carp qw(carp); -use File::Spec(); -use IMPL::Resources::Format qw(FormatMessage); -use IMPL::Resources::Strings(); - -use IMPL::Exception(); -use IMPL::lang qw(is typeof hashApply hashMerge); -use IMPL::declare { - require => { - Document => '-Template::Document', - TypeKeyedCollection => 'IMPL::TypeKeyedCollection', - ArgException => '-IMPL::InvalidArgumentException', - Resources => 'IMPL::Resources', - Loader => 'IMPL::Code::Loader', - MetadataBase => '-IMPL::Web::View::Metadata::BaseMeta', - Metadata => 'IMPL::Web::View::Metadata::ObjectMeta', - StringMap => 'IMPL::Resources::StringLocaleMap' - }, - base => [ - 'Template::Context' => '@_' - ] -}; - -BEGIN { - no strict 'refs'; - # modules is a global (for the whole document) templates cache - # tt_cache is a local (for the current context only) templtes cache - foreach my $prop (qw( - root - base - tt_ext - tt_cache - parent - prefix - cache - includes - modules - aliases - id - metadata - model - templateInfo - )) { - my $t = $prop; - - *{__PACKAGE__ . '::' . $prop} = sub { - my $this = shift; - return @_ ? $this->stash->set($t, @_) : $this->stash->get($t); - } - } -} - -sub clone { - my $this = shift; - my $params = shift; - - $this->localise(); - - my $args = { %{$this} }; - - $this->delocalise(); - - my $class = ref($this); - - delete $args->{CONFIG}; - - my $clone = $class->new($args); - - $clone->stash->update($params) if $params; - - return $clone; -} - -sub get_next_id { - my ($this) = @_; - - my $id = $this->stash->get('document.nextId') || 0; - $this->stash->set('document.nextId', $id + 1); - return "w-$id"; -} - -sub find_template { - my ($this,$name, $nothrow) = @_; - - my $cache = $this->tt_cache; - - $this->tt_cache($cache = {}) unless $cache; - - if(my $tpl = $cache->{$name}) { - return $tpl; - } - - my @inc = ($this->base, @{$this->includes || []}); - #my @inc = @{$this->includes || []}; - - my $ext = $this->tt_ext || ""; - - #warn "find: $name"; - - my $file; - - foreach my $dir (@inc) { - $file = $dir ? "$dir/$name" : $name; - - my @parts = split(/\/+/,$file); - - my $templateName = pop @parts; - - my $base = join('/',@parts); - - $file = $ext ? "$file.$ext" : $file; - - #warn " file: $file"; - - if (exists($this->modules->{$file})) { - my $info = $this->modules->{$file}; - return $cache->{$name} = $info - if $info; - } else { - if( my $tt = eval { $this->template($file) } ) { - #warn " found: $file"; - my $class; - if ($class = $tt->class) { - $class = $this->aliases->{$class} || $class; - Loader->safe->Require($class); - } - my $info = { - base => $base, - name => $templateName, - template => $tt, - initialized => 0, - class => $class, - file => $file - }; - $this->modules->{$file} = $info; - return $cache->{$name} = $info; - } else { - my $err = $@; - - #warn " not found: $err"; - - for(my $t = $err; is($t,'Template::Exception'); $t = $t->info ) { - die $err unless $t->type eq Template::Constants::ERROR_FILE; - } - $this->modules->{$file} = undef; - } - } - } - - $this->throw(Template::Constants::ERROR_FILE, "$name: not found") - unless $nothrow; - return; -} - -sub display_for { - my $this = shift; - my $path = shift; - my ($template, $args); - - if (ref $_[0] eq 'HASH') { - $args = shift; - } else { - $template = shift; - $args = shift; - } - - my $prefix = $this->prefix; - - my $info; - my $meta = $this->resolve_model($path,$args) - or return "[not found '$path']"; - - $info->{prefix} = join('.', grep($_, $prefix, $path)); - $info->{model} = $meta->model; - $info->{metadata} = $meta; - - $template ||= $info->{template}; - $template = $template ? $this->find_template($template) : $this->find_template_for($info->{metadata}); - - return $this->render( - $template, - hashApply( - $info, - $args - ) - ); -} - -sub display_model { - my $this = shift; - my $model = shift; - my ($template, $args); - - if (ref $_[0] eq 'HASH') { - $args = shift; - } else { - $template = shift; - $args = shift; - } - - #copy - $args = { %{$args || {}} }; - - $args->{prefix} = join('.',grep($_,$this->prefix,$args->{path})) - unless defined $args->{prefix}; - - if (is($model,MetadataBase)) { - $args->{model} = $model->model; - $args->{metadata} = $model; - } else { - $args->{model} = $model; - $args->{metadata} = Metadata->GetMetadataForModel($model); - } - - $template = $template ? $this->find_template($template) : $this->find_template_for($args->{metadata}); - - return $this->render( - $template, - $args - ); -} - -# обеспечивает необходимый уровень изоляции между контекстами -# $code - код, который нужно выполнить в новом контексте -# $env - хеш с переменными, которые будут переданы в новый контекст -# в процессе будет создан клон корневого контекста, со всеми его свойствами -# затем новый контекст будет локализован и в него будут добавлены новые переменные из $env -# созданный контекст будет передан параметром в $code -sub invoke_environment { - my ($this,$code,$env) = @_; - - $env ||= {}; - - my $ctx = ($this->root || $this)->clone(); - - my @includes = @{$this->includes || []}; - - if ($this->base) { - unshift @includes, $this->base; - } - - my $out = eval { - $ctx->localise( - hashApply( - { - includes => \@includes, - aliases => $this->aliases || {}, - root => $this->root || $ctx, - modules => $this->modules || {}, - cache => TypeKeyedCollection->new(), - display_for => sub { - $ctx->display_for(@_); - }, - render => sub { - $ctx->render(@_); - }, - display_model => sub { - $ctx->display_model(@_); - }, - tt_cache => {}, - labels => sub { - $ctx->load_labels(@_); - } - }, - $env - ) - ); - - &$code($ctx); - }; - - my $e = $@; - $ctx->delocalise(); - - die $e if $e; - - return $out; -} - -# использует указанный шаблон для создания фрагмента документа -# шаблон может быть как именем, так и хешем, содержащим информацию -# о шаблоне. -# отдельно следует отметить, что данный метод создает новый контекст -# для выполнения шаблона в котором задает переменные base, parent, id -# а также создает переменные для строковых констант из labels -# хеш с переменными $args будет передан самому шаблону в момент выполнения -# если у шаблона указан класс элемента управления, то при выполнении шаблона -# будет создан экземпляр этого класса и процесс выполнения шаблона будет -# делегирован методу Render этого экземпляра. -sub render { - my ($this,$template,$args) = @_; - - $args ||= {}; - - my $info = ref $template ? $template : $this->find_template($template); - - if (ref($info) ne 'HASH') { - carp "got an invalid template object: $info (" . ref($info) . ")"; - $info = { - template => $info, - base => $this->base, - initialized => 1 - }; - } - - return $this->invoke_environment( - sub { - my $ctx = shift; - - unless($info->{initialized}) { - if(my $init = $info->{template}->blocks->{INIT}) { - $info->{initialized} = 1; - eval { - $ctx->visit($info->{template}->blocks); - $ctx->include($init); - }; - $ctx->leave(); - } - } - - if (my $class = $info->{class}) { - $class->new($ctx,$info->{template},$args)->Render({}); - } else { - return $ctx->include($info->{template},$args); - } - }, - { - base => $info->{base}, - parent => $this, - id => $this->get_next_id, - templateInfo => $info - } - ) -} - -sub resolve_model { - my ($this,$prefix) = @_; - - die ArgException->new(prefix => "the prefix must be specified") - unless defined $prefix; - - my $meta = $this->metadata; - unless($meta) { - $meta = Metadata->GetMetadataForModel($this->model); - $this->metadata($meta); - } - - foreach my $part (grep length($_), split(/\.|\[(\d+)\]/, $prefix)) { - last unless $meta; - if ($part =~ /^\d+$/) { - $meta = $meta->GetItem($part); - } else { - $meta = $meta->GetProperty($part); - } - } - - return $meta; -} - -sub find_template_for { - my ($this,$meta, $nothrow) = @_; - - die ArgException->new(meta => 'An invalid metadata is supplied') - unless is($meta,MetadataBase); - - return $this->find_template($meta->template) - if ($meta->template); - - my $type = $meta->modelType; - - return $this->find_template('templates/plain') unless $type; - - if (my $template = $this->cache->Get($type)) { - return $template; - } else { - - no strict 'refs'; - - my @isa = $type; - - while (@isa) { - my $sclass = shift @isa; - - (my $name = $sclass) =~ s/:+/_/g; - my ($shortName) = ($sclass =~ m/(\w+)$/); - - $template = $this->find_template("templates/$name",1) || $this->find_template("templates/$shortName",1); - - if ($template) { - $this->cache->Set($sclass,$template); - return $template; - } - - #todo $meta->GetISA to implement custom hierachy - push @isa, @{"${sclass}::ISA"}; - } - - } - $this->throw(Template::Constants::ERROR_FILE, "can't find a template for the model $type") - unless $nothrow; - - return; -} - -sub get_real_file { - my ($this,$fname) = @_; - - return unless length $fname; - - my @path = split(/\/+/,$fname); - - foreach my $provider (@{$this->load_templates || []}) { - foreach my $dir (@{$provider->paths || []}) { - my $realName = File::Spec->catfile($dir,@path); - return $realName if -f $realName; - } - } -} - -sub load_labels { - my ($this,$data) = @_; - - die ArgException->new("A hash reference is required") - unless ref($data) eq 'HASH'; - - my $stringMap = StringMap->new($data); - - $this->stash->update({ - map { - my $id = $_; - $id, - sub { - $stringMap->GetString($id,@_); - }; - } keys %$data - }); - - my $ti = $this->templateInfo || {}; - - if (my $fullName = $this->get_real_file($ti->{file})) { - my ($vol,$dir,$fname) = File::Spec->splitpath($fullName); - - my $name = $this->templateInfo->{name}; - - my $localePath = File::Spec->catpath($vol, File::Spec->catdir($dir,'locale'),''); - - $stringMap->name($name); - $stringMap->paths($localePath); - } - return; -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Web::View::TTContext> - доработанная версия контекста - -=head1 DESCRIPTION - -Расширяет функции C<Template::Context> - -=begin plantuml - -@startuml - -object RootContext { - document - globals -} - -object DocumentContext { - base - extends -} - -object ControlContext { - base - extends -} - -RootContext o-- DocumentContext -RootContext o-- ControlContext - -Document -- DocumentContext -Control - ControlContext - -Loader . RootContext: <<creates>> -Loader . Document: <<creates>> -Loader -up- Registry - -@enduml - -=end plantuml - -=head1 MEMBERS - -=head2 C<[get,set]base> - -Префикс пути для поиска шаблонов - -=head2 C<template($name)> - -Сначала пытается загрузить шаблон используя префикс C<base>, затем без префикса. - -=head2 C<clone()> - -Создает копию контекста, при этом C<stash> локализуется, таким образом -клонированный контекст имеет собственное пространство имен, вложенное в -пространство родительского контекста. - -=cut \ No newline at end of file
--- a/lib/IMPL/Web/View/TTControl.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,122 +0,0 @@ -package IMPL::Web::View::TTControl; -use strict; - -use IMPL::Const qw(:prop); -use IMPL::lang qw(:hash :base); -use IMPL::declare { - require => { - Exception => 'IMPL::Exception', - ArgException => '-IMPL::InvalidArgumentException' - }, - base => [ - 'IMPL::Object' => undef - ], - props => [ - context => PROP_RO, - template => PROP_RO - ] -}; - -our $AUTOLOAD_REGEX = qr/^[a-z]/; - -sub CTOR { - my ($this,$context,$template,$args) = @_; - - $this->context($context) - or die ArgException->new(context => 'A context is required'); - $this->template($template) - or die ArgException->new(template => 'A template is required'); - - if (ref $args eq 'HASH') { - while(my ($key, $value) = each %$args) { - next if grep $_ eq $key, qw(context template); - $this->$key($value); - } - } -} - -sub _PopulateMethods { - my ($this,@methods) = @_; - - $this->_stash->update({ - map { - my $name = $_; - $name, - sub { - $this->$name(@_); - } - } @methods - }); -} - -sub _stash { - $_[0]->context->stash; -} - -sub Render { - my ($this,$args) = @_; - return $this->context->include($this->template,$args); -} - -our $AUTOLOAD; -sub AUTOLOAD { - my ($prop) = ($AUTOLOAD =~ m/(\w+)$/); - - die Exception->new("Method not found: $AUTOLOAD") unless $prop=~/$AUTOLOAD_REGEX/ and $_[0]; - - no strict 'refs'; - - my $method = sub { - my $that = shift; - if (@_ == 0) { - return $that->_stash->get($prop); - } elsif (@_ == 1) { - return $that->_stash->set($prop,shift); - } else { - return $that->_stash->get([$prop,[@_]]); - } - }; - - *{$AUTOLOAD} = $method; - - goto &$method; -} - - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Web::View::TTControl> расширяет функциональность шаблонов - -=head1 SYNPOSIS - -=begin code - -package My::View::Menu; -use IMPL::declare { - base => [ - 'IMPL::Web::View::TTControl' => '@_' - ] -}; - -sub Render { - my ($this,$args) = @_; - - $this->PrepareItems($args); - - return $this->next::method($args); -} - -sub PrepareItems - -=end code - -=head1 DESCRIPTION - - -=cut \ No newline at end of file
--- a/lib/IMPL/Web/View/TTView.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,113 +0,0 @@ -package IMPL::Web::View::TTView; -use strict; - -use JSON; -use IMPL::lang qw(hashMerge is); -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - Context => 'IMPL::Web::View::TTContext', - Loader => 'IMPL::Code::Loader', - Factory => 'IMPL::Web::View::ObjectFactory' - }, - base => [ - 'IMPL::Object' => undef, - 'IMPL::Object::Autofill' => '@_', - 'IMPL::Object::Serializable' => undef - ], - props => [ - options => PROP_RW, - viewBase => PROP_RW, - layoutBase => PROP_RW, - layout => PROP_RW, - tt_ext => PROP_RW, - includes => PROP_RW | PROP_LIST, - globals => PROP_RW - ] -}; - -sub CTOR { - my ($this) = @_; - - $this->tt_ext('tt') unless defined $this->tt_ext; -} - -sub display { - my ($this,$model,$template,$args) = @_; - - my $context = Context->new($this->options); - eval { - $context->process('globals' . '.' . $this->tt_ext, $args); - }; - my $layout = delete $args->{layout} || $this->layout; - - return $context->invoke_environment( - sub { - my $ctx = shift; - if ($layout) { - return $ctx->invoke_environment( - sub { - return shift->render( - $layout, - hashMerge( - { - content => sub { - $ctx->invoke_environment( - sub { - return shift->display_model($model,$template); - }, - { - base => $this->viewBase - } - ) - }, - model => $model - } - ) - ); # render - }, - { - base => $this->layoutBase, - } - ); - } else { - return $ctx->invoke_environment( - sub { - return shift->display_model($model,$template); - }, - { - base => $this->viewBase - } - ); - } - },hashMerge( - $this->globals, - hashMerge( - $args, - { - includes => scalar($this->includes), - tt_ext => $this->tt_ext, - debug => sub { - warn @_; - }, - is => sub { - my ($obj,$class) = @_; - if (is($class,Factory)) { - return is($obj,$class->factory); - } else { - return is($obj,$class); - } - }, - import => sub { - return Factory->new(Loader->safe->Require(shift)); - }, - toJSON => sub { - return JSON->new()->utf8->pretty->encode(shift); - } - } - ) - ) - ); -} - -1; \ No newline at end of file
--- a/lib/IMPL/Web/View/TemplateView.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,20 +0,0 @@ -package IMPL::Web::View::TemplateView; -use strict; - -use Carp qw(carp); - -use IMPL::Const qw(:prop); -use IMPL::declare { - base => [ - 'IMPL::Web::ViewResult' => '@_' - ], - props => [ - template => PROP_RW, - ] -}; - -sub CTOR { - carp "deprecated"; -} - -1; \ No newline at end of file
--- a/lib/IMPL/Web/ViewResult.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,73 +0,0 @@ -package IMPL::Web::ViewResult; -use strict; - -use IMPL::Const qw(:prop); -use Carp qw(carp); - -use IMPL::declare { - base => [ - 'IMPL::Object' => undef, - 'IMPL::Object::Autofill' => '@_' - ], - props => [ - model => PROP_RW, - _location => PROP_RW, - cookies => PROP_RW, - headers => PROP_RW, - status => PROP_RW - ] -}; - -sub location { - carp "location property is absolute"; - return shift->_location(@_); -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Web::ViewResult> - описание представления результата. - -=head1 SYNOPSIS - -=begin code - -sub HttpGet { - my ($this, $action) = @_; - - return IMPL::Web::ViewResult->new( - model => $model - ); -} - -=end code - -=head1 DESCRIPTION - -Сожержит в себе информацию для представления модели. Также включает поля для -заголовков ответа C<cookies>, C<headers>, C<status>. - -=head1 MEMBERS - -=head2 C<[get,set]model> - -Модель ресурса, как правило это результат выполнения C<Http> метода. - -=head2 C<[get,set]cookies> - -Хеш с печеньками, которые будут добавлены в C<HTTP> ответ. - -=head2 C<[get,set]headers> - -Заголовки которые нужно добавить в заголовки C<HTTP> ответа. - -=head2 C<[get,set]status> - -Код C<HTTP> ответа. - -=cut