X-Git-Url: https://git.dogcows.com/gitweb?a=blobdiff_plain;f=lib%2FFile%2FKDBX%2FError.pm;fp=lib%2FFile%2FKDBX%2FError.pm;h=f80155796f4ae40e8d17afcda9dd8b0c8bdfce39;hb=f63182fc62b25269b1c38588dca2b3535ed1a1a2;hp=0000000000000000000000000000000000000000;hpb=e2deca75a6040911441e0d7c4430aeae9be69e40;p=chaz%2Fp5-File-KDBX diff --git a/lib/File/KDBX/Error.pm b/lib/File/KDBX/Error.pm new file mode 100644 index 0000000..f801557 --- /dev/null +++ b/lib/File/KDBX/Error.pm @@ -0,0 +1,221 @@ +package File::KDBX::Error; +# ABSTRACT: Represents something bad that happened + +use warnings; +use strict; + +use Exporter qw(import); +use Scalar::Util qw(blessed); +use namespace::clean -except => 'import'; + +our $VERSION = '999.999'; # VERSION + +our @EXPORT = qw(alert error throw); + +my $WARNINGS_CATEGORY; +BEGIN { + $WARNINGS_CATEGORY = 'File::KDBX'; + warnings::register_categories($WARNINGS_CATEGORY) if warnings->can('register_categories'); +} + +use overload '""' => 'to_string', cmp => '_cmp'; + +=method new + + $error = File::KDBX::Error->new($message, %details); + +Construct a new error. + +=cut + +sub new { + my $class = shift; + my %args = @_ % 2 == 0 ? @_ : (_error => shift, @_); + + my $error = delete $args{_error}; + my $e = $error; + # $e =~ s/ at \H+ line \d+.*//g; + + my $self = bless { + details => \%args, + error => $e // 'Something happened', + errno => $!, + previous => $@, + trace => do { + require Carp; + local $Carp::CarpInternal{''.__PACKAGE__} = 1; + my $mess = $error =~ /at \H+ line \d+/ ? $error : Carp::longmess($error); + [map { /^\h*(.*?)\.?$/ ? $1 : $_ } split(/\n/, $mess)]; + }, + }, $class; + chomp $self->{error}; + return $self; +} + +=method error + + $error = error($error); + $error = error($message, %details); + $error = File::KDBX::Error->error($error); + $error = File::KDBX::Error->error($message, %details); + +Wrap a thing to make it an error object. If the thing is already an error, it gets returned. Otherwise what is +passed will be forwarded to L to create a new error object. + +This can be convenient for error handling when you're not sure what the exception is but you want to treat it +as a B. Example: + + eval { .... }; + if (my $error = error(@_)) { + if ($error->type eq 'key.missing') { + handle_missing_key($error); + } + else { + handle_other_error($error); + } + } + +=cut + +sub error { + my $self = (blessed($_[0]) && $_[0]->isa('File::KDBX::Error')) + ? shift + : (@_ && $_[0] eq __PACKAGE__) + ? shift->new(@_) + : __PACKAGE__->new(@_); + return $self; +} + +=attr details + + \%details = $error->details; + +Get the error details. + +=cut + +sub details { + my $self = shift; + my %args = @_; + my $details = $self->{details} //= {}; + @$details{keys %args} = values %args; + return $details; +} + +sub errno { $_[0]->{errno} } + +sub previous { $_[0]->{previous} } + +sub trace { $_[0]->{trace} // [] } + +sub type { $_[0]->details->{type} // '' } + +=method to_string + + $message = $error->to_string; + $message = "$error"; + +Stringify an error. + +This does not contain a stack trace, but you can set the C environment +variable to truthy to stringify the whole error object. + +=cut + +sub _cmp { "$_[0]" cmp "$_[1]" } + +sub PROPAGATE { + 'wat'; +} + +sub to_string { + my $self = shift; + # return "uh oh\n"; + my $msg = "$self->{trace}[0]"; + $msg .= '.' if $msg !~ /[\.\!\?]$/; # Why does this cause infinite recursion on some perls? + # $msg .= '.' if $msg !~ /(?:\.|!|\?)$/; + if ($ENV{DEBUG}) { + require Data::Dumper; + local $Data::Dumper::Indent = 1; + local $Data::Dumper::Quotekeys = 0; + local $Data::Dumper::Sortkeys = 1; + local $Data::Dumper::Terse = 1; + local $Data::Dumper::Trailingcomma = 1; + local $Data::Dumper::Useqq = 1; + $msg .= "\n" . Data::Dumper::Dumper $self; + } + $msg .= "\n" if $msg !~ /\n$/; + return $msg; +} + +=method throw + + File::KDBX::Error::throw($message, %details); + $error->throw; + +Throw an error. + +=cut + +sub throw { + my $self = error(@_); + die $self; +} + +=method warn + + File::KDBX::Error::warn($message, %details); + $error->warn; + +Log a warning. + +=cut + +sub warn { + return if !($File::KDBX::WARNINGS // 1); + + my $self = error(@_); + + # Use die and warn directly instead of warnings::warnif because the latter only provides the stringified + # error to the warning signal handler (perl 5.34). Maybe that's a warnings.pm bug? + + if (my $fatal = warnings->can('fatal_enabled_at_level')) { + my $blame = _find_blame_frame(); + die $self if $fatal->($WARNINGS_CATEGORY, $blame); + } + + if (my $enabled = warnings->can('enabled_at_level')) { + my $blame = _find_blame_frame(); + warn $self if $enabled->($WARNINGS_CATEGORY, $blame); + } + elsif ($enabled = warnings->can('enabled')) { + warn $self if $enabled->($WARNINGS_CATEGORY); + } + else { + warn $self; + } + return $self; +} + +=method alert + + alert $error; + +Importable alias for L. + +=cut + +sub alert { goto &warn } + +sub _find_blame_frame { + my $frame = 1; + while (1) { + my ($package) = caller($frame); + last if !$package; + return $frame - 1 if $package !~ /^\Q$WARNINGS_CATEGORY\E/; + $frame++; + } + return 0; +} + +1;