]>
Commit | Line | Data |
---|---|---|
6700b151 TL |
1 | package PVE::APIClient::Exception; |
2 | ||
2937fdf9 TL |
3 | # NOTE: derived from pve-common's PVE::Execption by copying and then: |
4 | # sed -i 's/PVE::/PVE::APIClient::/g' Exception.pm | |
5 | ||
6700b151 TL |
6 | # a way to add more information to exceptions (see man perlfunc (die)) |
7 | # use PVE::APIClient::Exception qw(raise); | |
8 | # raise ("my error message", code => 400, errors => { param1 => "err1", ...} ); | |
9 | ||
10 | use strict; | |
11 | use warnings; | |
d3e90048 DM |
12 | use vars qw(@ISA @EXPORT_OK); |
13 | require Exporter; | |
2401ab28 | 14 | use Storable qw(dclone); |
6700b151 TL |
15 | use HTTP::Status qw(:constants); |
16 | ||
d3e90048 DM |
17 | @ISA = qw(Exporter); |
18 | ||
6700b151 TL |
19 | use overload '""' => sub {local $@; shift->stringify}; |
20 | use overload 'cmp' => sub { | |
21 | my ($a, $b) = @_; | |
2401ab28 | 22 | local $@; |
6700b151 TL |
23 | return "$a" cmp "$b"; # compare as string |
24 | }; | |
25 | ||
d3e90048 | 26 | @EXPORT_OK = qw(raise raise_param_exc raise_perm_exc); |
6700b151 TL |
27 | |
28 | sub new { | |
29 | my ($class, $msg, %param) = @_; | |
30 | ||
31 | $class = ref($class) || $class; | |
32 | ||
33 | my $self = { | |
34 | msg => $msg, | |
35 | }; | |
36 | ||
37 | foreach my $p (keys %param) { | |
2401ab28 | 38 | next if defined($self->{$p}); |
6700b151 TL |
39 | my $v = $param{$p}; |
40 | $self->{$p} = ref($v) ? dclone($v) : $v; | |
41 | } | |
42 | ||
43 | return bless $self; | |
44 | } | |
45 | ||
46 | sub raise { | |
47 | ||
48 | my $exc = PVE::APIClient::Exception->new(@_); | |
2401ab28 | 49 | |
d3e90048 DM |
50 | my ($pkg, $filename, $line) = caller; |
51 | ||
52 | $exc->{filename} = $filename; | |
53 | $exc->{line} = $line; | |
54 | ||
55 | die $exc; | |
56 | } | |
57 | ||
58 | sub raise_perm_exc { | |
59 | my ($what) = @_; | |
60 | ||
61 | my $param = { code => HTTP_FORBIDDEN }; | |
6700b151 | 62 | |
d3e90048 | 63 | my $msg = "Permission check failed"; |
2401ab28 | 64 | |
d3e90048 DM |
65 | $msg .= " ($what)" if $what; |
66 | ||
67 | my $exc = PVE::APIClient::Exception->new("$msg\n", %$param); | |
2401ab28 | 68 | |
d3e90048 DM |
69 | my ($pkg, $filename, $line) = caller; |
70 | ||
71 | $exc->{filename} = $filename; | |
72 | $exc->{line} = $line; | |
73 | ||
74 | die $exc; | |
75 | } | |
76 | ||
77 | sub is_param_exc { | |
78 | my ($self) = @_; | |
79 | ||
80 | return $self->{code} && $self->{code} eq HTTP_BAD_REQUEST; | |
81 | } | |
82 | ||
83 | sub raise_param_exc { | |
84 | my ($errors, $usage) = @_; | |
85 | ||
86 | my $param = { | |
87 | code => HTTP_BAD_REQUEST, | |
88 | errors => $errors, | |
89 | }; | |
90 | ||
91 | $param->{usage} = $usage if $usage; | |
92 | ||
93 | my $exc = PVE::APIClient::Exception->new("Parameter verification failed.\n", %$param); | |
2401ab28 | 94 | |
6700b151 TL |
95 | my ($pkg, $filename, $line) = caller; |
96 | ||
97 | $exc->{filename} = $filename; | |
98 | $exc->{line} = $line; | |
99 | ||
100 | die $exc; | |
101 | } | |
102 | ||
103 | sub stringify { | |
104 | my $self = shift; | |
50f793b9 TL |
105 | |
106 | my $msg = $self->{msg}; | |
107 | if (my $code = $self->{code}) { | |
108 | if ($msg !~ /^\s*\Q$code\E[\s:,]/) { # avoid duplicating the error code heuristically | |
109 | $msg = "$code $msg"; | |
110 | } | |
111 | } | |
6700b151 TL |
112 | |
113 | if ($msg !~ m/\n$/) { | |
d3e90048 | 114 | |
6700b151 TL |
115 | if ($self->{filename} && $self->{line}) { |
116 | $msg .= " at $self->{filename} line $self->{line}"; | |
117 | } | |
d3e90048 | 118 | |
6700b151 TL |
119 | $msg .= "\n"; |
120 | } | |
121 | ||
122 | if ($self->{errors}) { | |
123 | foreach my $e (keys %{$self->{errors}}) { | |
124 | $msg .= "$e: $self->{errors}->{$e}\n"; | |
125 | } | |
126 | } | |
127 | ||
128 | if ($self->{propagate}) { | |
129 | foreach my $pi (@{$self->{propagate}}) { | |
130 | $msg .= "\t...propagated at $pi->[0] line $pi->[1]\n"; | |
131 | } | |
132 | } | |
133 | ||
134 | if ($self->{usage}) { | |
135 | $msg .= $self->{usage}; | |
136 | $msg .= "\n" if $msg !~ m/\n$/; | |
137 | } | |
138 | ||
139 | return $msg; | |
140 | } | |
141 | ||
142 | sub PROPAGATE { | |
143 | my ($self, $file, $line) = @_; | |
144 | ||
2401ab28 | 145 | push @{$self->{propagate}}, [$file, $line]; |
6700b151 TL |
146 | |
147 | return $self; | |
148 | } | |
149 | ||
150 | 1; |