From 70eff5a00541024dc8a5454b8bb8ccd7be1f290a Mon Sep 17 00:00:00 2001 From: Fernando Correa de Oliveira Date: Mon, 31 Dec 2018 03:52:18 -0200 Subject: [PATCH] Adding exception mapper. t/10 is breaking on calling 'database'. Related to #69 --- META6.json | 3 ++- lib/MetamodelX/Red/Model.pm6 | 4 +-- lib/Red/Driver.pm6 | 5 ++++ lib/Red/Driver/Pg.pm6 | 9 +++++++ lib/Red/Driver/SQLite.pm6 | 9 +++++++ lib/Red/Statement.pm6 | 7 ++++- lib/X/Red/Exceptions.pm6 | 44 +++++++++++++++++++++++++++++++ lib/X/Red/InvalidTableName.pm6 | 6 ----- t/08-best-tree.t | 2 +- t/10-alternate-relation-modules.t | 2 +- 10 files changed, 79 insertions(+), 12 deletions(-) create mode 100644 lib/X/Red/Exceptions.pm6 delete mode 100644 lib/X/Red/InvalidTableName.pm6 diff --git a/META6.json b/META6.json index c068ec65..cb882001 100644 --- a/META6.json +++ b/META6.json @@ -77,7 +77,8 @@ "SameIfPresent" : "lib/Red/AST/Optimizer.pm6", "SameIfTheOtherIsTrue" : "lib/Red/AST/Optimizer.pm6", "Red::AST::Optimizer" : "lib/Red/AST/Optimizer.pm6", - "X::Red::InvalidTableName" : "lib/X/Red/InvalidTableName.pm6" + "X::Red::Exceptions" : "lib/X/Red/Exceptions.pm6", + "X::Red::InvalidTableName" : "lib/X/Red/Exceptions.pm6" }, "resources" : [ ], "source-url" : "", diff --git a/lib/MetamodelX/Red/Model.pm6 b/lib/MetamodelX/Red/Model.pm6 index 0d7aa1fa..8506996f 100644 --- a/lib/MetamodelX/Red/Model.pm6 +++ b/lib/MetamodelX/Red/Model.pm6 @@ -18,7 +18,7 @@ use Red::AST::LastInsertedRow; use MetamodelX::Red::Dirtable; use MetamodelX::Red::Comparate; use MetamodelX::Red::Relationship; -use X::Red::InvalidTableName; +use X::Red::Exceptions; unit class MetamodelX::Red::Model is Metamodel::ClassHOW; also does MetamodelX::Red::Dirtable; @@ -171,7 +171,7 @@ method rs($) { $.rs-class.new } method all($obj) { $obj.^rs } method create-table(\model) { - die X::Red::InvalidTableName.new: :table(model.^table), :driver($*RED-DB.^name) + die X::Red::InvalidTableName.new: :table(model.^table) unless $*RED-DB.is-valid-table-name: model.^table; $*RED-DB.execute: Red::AST::CreateTable.new: diff --git a/lib/Red/Driver.pm6 b/lib/Red/Driver.pm6 index 0e089f80..2cbfd974 100644 --- a/lib/Red/Driver.pm6 +++ b/lib/Red/Driver.pm6 @@ -1,5 +1,6 @@ use Red::AST; use Red::Column; +use X::Red::Exceptions; unit role Red::Driver; method translate(Red::AST, $?) { ... } @@ -12,6 +13,10 @@ multi method is-valid-table-name(Str --> Bool) { True } multi method type-by-name("string" --> "text") {} multi method type-by-name("int" --> "integer") {} +multi method map-exception($orig-exception) { + X::Red::Driver::Mapped::UnknownError.new: :$orig-exception +} + multi method prepare("") {class :: { method execute(|) {} }} multi method inflate(Any $value, Any :$to) { $value } diff --git a/lib/Red/Driver/Pg.pm6 b/lib/Red/Driver/Pg.pm6 index 26e1b99d..3435183b 100644 --- a/lib/Red/Driver/Pg.pm6 +++ b/lib/Red/Driver/Pg.pm6 @@ -3,6 +3,7 @@ use Red::Driver; use Red::Driver::CommonSQL; use Red::Statement; use Red::AST::Infixes; +use X::Red::Exceptions; unit class Red::Driver::Pg does Red::Driver::CommonSQL; has Str $!user; @@ -62,3 +63,11 @@ multi method default-type-for(Red::Column $ where .attr.type ~~ Bool multi method default-type-for(Red::Column $ --> Str:D) {"varchar(255)"} multi method inflate(Str $value, DateTime :$to!) { DateTime.new: $value } + +multi method map-exception(DB::Pg::Error::FatalError $x where /"duplicate key value violates unique constraint"/) { + $x.message ~~ /"DETAIL: Key (" \s* (\w+)+ % [\s* "," \s*] \s* ")=(" .*? ") already exists."/; + X::Red::Driver::Mapped::Unique.new: + :driver, + :orig-exception($x), + :fields($0>>.Str) +} diff --git a/lib/Red/Driver/SQLite.pm6 b/lib/Red/Driver/SQLite.pm6 index 5e3937e4..361a934b 100644 --- a/lib/Red/Driver/SQLite.pm6 +++ b/lib/Red/Driver/SQLite.pm6 @@ -8,6 +8,7 @@ use Red::AST::Infixes; use Red::AST::Function; use Red::Driver::CommonSQL; use Red::AST::LastInsertedRow; +use X::Red::Exceptions; unit class Red::Driver::SQLite does Red::Driver::CommonSQL; has $.database = q<:memory:>; @@ -72,3 +73,11 @@ multi method translate(Red::Column $_, "column-auto-increment") { "AUTOINCREMENT multi method default-type-for(Red::Column $ where .attr.type ~~ Bool --> Str:D) {"integer"} multi method default-type-for(Red::Column $ where .attr.type ~~ one(Int, Bool) --> Str:D) {"integer"} + +multi method map-exception(Exception $x where { .code == 19 and .native-message.starts-with: "UNIQUE constraint failed:" }) { + X::Red::Driver::Mapped::Unique.new: + :driver, + :orig-exception($x), + :fields($x.native-message.substr(26).split: /\s* "," \s*/) +} + diff --git a/lib/Red/Statement.pm6 b/lib/Red/Statement.pm6 index a634eb13..f57ad549 100644 --- a/lib/Red/Statement.pm6 +++ b/lib/Red/Statement.pm6 @@ -8,7 +8,12 @@ method stt-exec($, *@) { ... } method predefined-bind { $!predefined-bind = True } -method execute(*@binds) { +method execute(*@binds) is hidden-from-backtrace { + CATCH { + default { + $!driver.map-exception($_).throw + } + } $!statement = do if $!predefined-bind { self.stt-exec: $!statement, |@binds } else { diff --git a/lib/X/Red/Exceptions.pm6 b/lib/X/Red/Exceptions.pm6 new file mode 100644 index 00000000..6ded37d5 --- /dev/null +++ b/lib/X/Red/Exceptions.pm6 @@ -0,0 +1,44 @@ +class X::Red is Exception {} + +class X::Red::Driver is X::Red { + has Str $.driver = $*RED-DB.^name; +} + +class X::Red::InvalidTableName is X::Red::Driver { + has Str $.table; + + method message { "'$!table' is an invalid table name for driver { $.driver }" } +} + +class X::Red::Driver::Mapped is X::Red::Driver { + has Exception $.orig-exception is required; + has Str $!orig-message = $!orig-exception.message; + has Backtrace $!orig-backtrace = $!orig-exception.backtrace; + + method msg { !!! } + + method message { + "{self.msg}\nOriginal error:\n{$!orig-message}" + } + + method throw is hidden-from-backtrace { + nextwith $!orig-backtrace + } +} + +class X::Red::Driver::Mapped::UnknownError is X::Red::Driver::Mapped { + has Str @.fields; + method msg { + qq:to/END/ + Unknown Error!!! + Please, copy this backtrace and open an issue on https://github.com/FCO/Red/issues/new + Driver: { $.driver } + Original error: { $.orig-exception.perl } + END + } +} + +class X::Red::Driver::Mapped::Unique is X::Red::Driver::Mapped { + has Str @.fields; + method msg { "Unique constraint ({@!fields.join: ", "}) violated" } +} diff --git a/lib/X/Red/InvalidTableName.pm6 b/lib/X/Red/InvalidTableName.pm6 deleted file mode 100644 index a34641cd..00000000 --- a/lib/X/Red/InvalidTableName.pm6 +++ /dev/null @@ -1,6 +0,0 @@ -unit class X::Red::InvalidTableName is Exception; - -has Str $.table; -has Str $.driver; - -method message { "'$!table' is an invalid table name for driver $!driver" } diff --git a/t/08-best-tree.t b/t/08-best-tree.t index 844aa7bb..a1881798 100644 --- a/t/08-best-tree.t +++ b/t/08-best-tree.t @@ -26,7 +26,7 @@ model BestTree::Store is table { method suggest-tree(Rat() $longitude, Rat() $latitude, Rat() $height, Str $description) { CATCH { - when /"UNIQUE constraint failed"/ { + when X::Red::Driver::Mapped::Unique { die X::Tree::ExistsInTheSameArea.new: :$longitude, :$latitude } } diff --git a/t/10-alternate-relation-modules.t b/t/10-alternate-relation-modules.t index c519ce36..f3af3e20 100755 --- a/t/10-alternate-relation-modules.t +++ b/t/10-alternate-relation-modules.t @@ -30,7 +30,7 @@ ok $p.id.defined, "primary key is defined";; is $p.id, 1, "and it is the value we expected"; my $post; -lives-ok { +lives-ok { $post = $p.posts.create: :title("Red's commit"), :body("Merge branch 'master' of https://github.com/FCO/Red") ; }, "create a related post"; isa-ok $post, Post;