| line | stmt | bran | cond | sub | pod | time | code | 
| 1 |  |  |  |  |  |  | package ArangoDB2::Base; | 
| 2 |  |  |  |  |  |  |  | 
| 3 | 21 |  |  | 21 |  | 108 | use strict; | 
|  | 21 |  |  |  |  | 49 |  | 
|  | 21 |  |  |  |  | 629 |  | 
| 4 | 21 |  |  | 21 |  | 90 | use warnings; | 
|  | 21 |  |  |  |  | 24 |  | 
|  | 21 |  |  |  |  | 450 |  | 
| 5 |  |  |  |  |  |  |  | 
| 6 | 21 |  |  | 21 |  | 75 | use Carp qw(croak); | 
|  | 21 |  |  |  |  | 22 |  | 
|  | 21 |  |  |  |  | 1101 |  | 
| 7 | 21 |  |  | 21 |  | 1205 | use Data::Dumper; | 
|  | 21 |  |  |  |  | 12062 |  | 
|  | 21 |  |  |  |  | 832 |  | 
| 8 | 21 |  |  | 21 |  | 13582 | use JSON::XS; | 
|  | 21 |  |  |  |  | 92576 |  | 
|  | 21 |  |  |  |  | 1366 |  | 
| 9 | 21 |  |  | 21 |  | 129 | use Scalar::Util qw(blessed weaken); | 
|  | 21 |  |  |  |  | 27 |  | 
|  | 21 |  |  |  |  | 18051 |  | 
| 10 |  |  |  |  |  |  |  | 
| 11 |  |  |  |  |  |  |  | 
| 12 |  |  |  |  |  |  |  | 
| 13 |  |  |  |  |  |  | # new | 
| 14 |  |  |  |  |  |  | # | 
| 15 |  |  |  |  |  |  | # Arango organizes data hierarchically: Databases > Collections > Documents | 
| 16 |  |  |  |  |  |  | # | 
| 17 |  |  |  |  |  |  | # This constructor can build ArangoDB2::Database, Collection, Document, Edge, | 
| 18 |  |  |  |  |  |  | # etc. objects which all follow the same pattern | 
| 19 |  |  |  |  |  |  | sub new | 
| 20 |  |  |  |  |  |  | { | 
| 21 | 53 |  |  | 53 | 1 | 474 | my $class = shift; | 
| 22 |  |  |  |  |  |  | # new instance | 
| 23 | 53 |  |  |  |  | 78 | my $self = {}; | 
| 24 | 53 |  |  |  |  | 91 | bless($self, $class); | 
| 25 |  |  |  |  |  |  | # process args | 
| 26 | 53 |  |  |  |  | 136 | while (my $arg = shift) { | 
| 27 |  |  |  |  |  |  | # if arg is a ref it should be another | 
| 28 |  |  |  |  |  |  | # ArangoDB::* object | 
| 29 | 124 | 100 |  |  |  | 195 | if (ref $arg) { | 
| 30 |  |  |  |  |  |  | # prevent circular ref | 
| 31 | 99 |  |  |  |  | 195 | weaken $arg; | 
| 32 |  |  |  |  |  |  | # create reference to parent object | 
| 33 | 99 |  |  |  |  | 412 | $self->{$arg->_class} = $arg; | 
| 34 |  |  |  |  |  |  | } | 
| 35 |  |  |  |  |  |  | # if arg is a string then it is the "name" | 
| 36 |  |  |  |  |  |  | # of this object | 
| 37 |  |  |  |  |  |  | else { | 
| 38 | 25 |  |  |  |  | 136 | $self->name($arg); | 
| 39 |  |  |  |  |  |  | } | 
| 40 |  |  |  |  |  |  | } | 
| 41 |  |  |  |  |  |  | # if we have a name and can get then try it | 
| 42 | 53 | 50 | 66 |  |  | 148 | $self->get if defined $self->name | 
| 43 |  |  |  |  |  |  | and $self->can('get'); | 
| 44 |  |  |  |  |  |  |  | 
| 45 | 53 |  |  |  |  | 179 | return $self; | 
| 46 |  |  |  |  |  |  | } | 
| 47 |  |  |  |  |  |  |  | 
| 48 |  |  |  |  |  |  | # api_path | 
| 49 |  |  |  |  |  |  | # | 
| 50 |  |  |  |  |  |  | # return /_db//_api | 
| 51 |  |  |  |  |  |  | sub api_path | 
| 52 |  |  |  |  |  |  | { | 
| 53 | 0 |  |  | 0 | 1 | 0 | my $self = shift; | 
| 54 |  |  |  |  |  |  |  | 
| 55 | 0 | 0 |  |  |  | 0 | my $db_name | 
| 56 |  |  |  |  |  |  | = $self->database | 
| 57 |  |  |  |  |  |  | ? $self->database->name | 
| 58 |  |  |  |  |  |  | : $self->name; | 
| 59 |  |  |  |  |  |  |  | 
| 60 | 0 |  |  |  |  | 0 | return '/' . join('/', '_db', $db_name, '_api', @_); | 
| 61 |  |  |  |  |  |  | } | 
| 62 |  |  |  |  |  |  |  | 
| 63 |  |  |  |  |  |  | # arango | 
| 64 |  |  |  |  |  |  | # | 
| 65 |  |  |  |  |  |  | # ArangoDB2 instance | 
| 66 | 31 |  |  | 31 | 1 | 230 | sub arango { $_[0]->{arango} } | 
| 67 |  |  |  |  |  |  |  | 
| 68 |  |  |  |  |  |  | # collection | 
| 69 |  |  |  |  |  |  | # | 
| 70 |  |  |  |  |  |  | # parent ArangoDB2::Collection instance | 
| 71 |  |  |  |  |  |  | sub collection { | 
| 72 | 0 |  |  | 0 | 1 | 0 | my($self, $value) = @_; | 
| 73 |  |  |  |  |  |  |  | 
| 74 | 0 | 0 |  |  |  | 0 | if (defined $value) { | 
| 75 |  |  |  |  |  |  | # if value is already an object then set it | 
| 76 | 0 | 0 |  |  |  | 0 | if (ref $value) { | 
| 77 | 0 |  |  |  |  | 0 | $self->{collection} = $value; | 
| 78 |  |  |  |  |  |  | } | 
| 79 |  |  |  |  |  |  | # otherwise treat as name and get collection object | 
| 80 |  |  |  |  |  |  | else { | 
| 81 | 0 |  |  |  |  | 0 | $self->{collection} = $self->database->collection($value); | 
| 82 |  |  |  |  |  |  | } | 
| 83 |  |  |  |  |  |  | } | 
| 84 |  |  |  |  |  |  |  | 
| 85 | 0 |  |  |  |  | 0 | return $self->{collection}; | 
| 86 |  |  |  |  |  |  | } | 
| 87 |  |  |  |  |  |  |  | 
| 88 |  |  |  |  |  |  | # data | 
| 89 |  |  |  |  |  |  | # | 
| 90 |  |  |  |  |  |  | # ref to hash containing document data | 
| 91 | 0 |  |  | 0 | 1 | 0 | sub data { shift->_get_set('data', @_) } | 
| 92 |  |  |  |  |  |  |  | 
| 93 |  |  |  |  |  |  | # database | 
| 94 |  |  |  |  |  |  | # | 
| 95 |  |  |  |  |  |  | # parent ArangoDB2::Database instance | 
| 96 | 12 |  |  | 12 | 1 | 95 | sub database { $_[0]->{database} } | 
| 97 |  |  |  |  |  |  |  | 
| 98 |  |  |  |  |  |  | # graph | 
| 99 |  |  |  |  |  |  | # | 
| 100 |  |  |  |  |  |  | # parent ArangoDB2::Graph instance | 
| 101 | 2 |  |  | 2 | 1 | 21 | sub graph { $_[0]->{graph} } | 
| 102 |  |  |  |  |  |  |  | 
| 103 |  |  |  |  |  |  | # id | 
| 104 |  |  |  |  |  |  | # | 
| 105 |  |  |  |  |  |  | # ArangoDB _id | 
| 106 | 0 |  |  | 0 | 1 | 0 | sub id { $_[0]->{id} } | 
| 107 |  |  |  |  |  |  |  | 
| 108 |  |  |  |  |  |  | # name | 
| 109 |  |  |  |  |  |  | # | 
| 110 |  |  |  |  |  |  | # name/handle of object | 
| 111 | 78 |  |  | 78 | 1 | 265 | sub name { shift->_get_set_name('name', @_) } | 
| 112 |  |  |  |  |  |  |  | 
| 113 |  |  |  |  |  |  | # rev | 
| 114 |  |  |  |  |  |  | # | 
| 115 |  |  |  |  |  |  | # ArangoDB _rev | 
| 116 | 0 |  |  | 0 | 1 | 0 | sub rev { $_[0]->{rev} } | 
| 117 |  |  |  |  |  |  |  | 
| 118 |  |  |  |  |  |  | # _build_args | 
| 119 |  |  |  |  |  |  | # | 
| 120 |  |  |  |  |  |  | # process args for requests | 
| 121 |  |  |  |  |  |  | sub _build_args | 
| 122 |  |  |  |  |  |  | { | 
| 123 | 0 |  |  | 0 |  | 0 | my($self, $args, $params) = @_; | 
| 124 |  |  |  |  |  |  | # require hash ref for args | 
| 125 | 0 | 0 | 0 |  |  | 0 | $args = {} unless defined $args | 
|  |  |  | 0 |  |  |  |  | 
| 126 |  |  |  |  |  |  | and ref $args and ref $args eq 'HASH'; | 
| 127 |  |  |  |  |  |  | # if an explicit list is not passed for this call | 
| 128 |  |  |  |  |  |  | # then use global list for class | 
| 129 | 0 |  | 0 |  |  | 0 | $params ||= $self->_params; | 
| 130 |  |  |  |  |  |  | # for each of the allowed parameters use the | 
| 131 |  |  |  |  |  |  | # setter to set the value if it is passed and | 
| 132 |  |  |  |  |  |  | # and the value to the request args if it is | 
| 133 |  |  |  |  |  |  | # defined | 
| 134 | 0 |  |  |  |  | 0 | for my $param (@$params) { | 
| 135 |  |  |  |  |  |  | # if params is pased in args then it supersedes | 
| 136 |  |  |  |  |  |  | # any value set as a property of the object | 
| 137 | 0 | 0 |  |  |  | 0 | if (exists $args->{$param}) { | 
|  |  | 0 |  |  |  |  |  | 
| 138 |  |  |  |  |  |  | # run arg through setter with validate only | 
| 139 |  |  |  |  |  |  | # flag which will return the validated arg | 
| 140 | 0 |  |  |  |  | 0 | $args->{$param} = $self->$param($args->{$param}, 1); | 
| 141 |  |  |  |  |  |  | } | 
| 142 |  |  |  |  |  |  | # otherwise if the param is set then add to args | 
| 143 |  |  |  |  |  |  | elsif (defined $self->$param) { | 
| 144 | 0 |  |  |  |  | 0 | $args->{$param} = $self->$param; | 
| 145 |  |  |  |  |  |  | } | 
| 146 |  |  |  |  |  |  | } | 
| 147 |  |  |  |  |  |  |  | 
| 148 | 0 |  |  |  |  | 0 | return $args; | 
| 149 |  |  |  |  |  |  | } | 
| 150 |  |  |  |  |  |  |  | 
| 151 |  |  |  |  |  |  | # _build_self | 
| 152 |  |  |  |  |  |  | # | 
| 153 |  |  |  |  |  |  | # copy param values from passed data to self | 
| 154 |  |  |  |  |  |  | sub _build_self | 
| 155 |  |  |  |  |  |  | { | 
| 156 | 0 |  |  | 0 |  | 0 | my($self, $data, $params) = @_; | 
| 157 |  |  |  |  |  |  | # require data | 
| 158 | 0 | 0 |  |  |  | 0 | croak "Invalid Args" | 
| 159 |  |  |  |  |  |  | unless ref $data eq 'HASH'; | 
| 160 |  |  |  |  |  |  | # if an explicit list is not passed for this call | 
| 161 |  |  |  |  |  |  | # then use global list for class | 
| 162 | 0 |  | 0 |  |  | 0 | $params ||= $self->_params; | 
| 163 |  |  |  |  |  |  | # copy params | 
| 164 | 0 |  |  |  |  | 0 | for my $param (@$params) { | 
| 165 | 0 | 0 |  |  |  | 0 | $self->{$param} = delete $data->{$param} | 
| 166 |  |  |  |  |  |  | if exists $data->{$param}; | 
| 167 |  |  |  |  |  |  | } | 
| 168 |  |  |  |  |  |  | # copy _id and _rev to id/rev | 
| 169 | 0 | 0 |  |  |  | 0 | $self->{id} = delete $data->{_id} | 
| 170 |  |  |  |  |  |  | if exists $data->{_id}; | 
| 171 | 0 | 0 |  |  |  | 0 | $self->{rev} = delete $data->{_rev} | 
| 172 |  |  |  |  |  |  | if exists $data->{_rev}; | 
| 173 |  |  |  |  |  |  | # if user is set then use it as name | 
| 174 | 0 | 0 |  |  |  | 0 | if (exists $data->{user}) { | 
|  |  | 0 |  |  |  |  |  | 
| 175 | 0 |  |  |  |  | 0 | $self->{name} = delete $data->{user}; | 
| 176 |  |  |  |  |  |  | } | 
| 177 |  |  |  |  |  |  | # otherwise try _key | 
| 178 |  |  |  |  |  |  | elsif (exists $data->{_key}) { | 
| 179 | 0 |  |  |  |  | 0 | $self->{name} = delete $data->{_key} | 
| 180 |  |  |  |  |  |  | } | 
| 181 |  |  |  |  |  |  | # copy to and from | 
| 182 | 0 | 0 |  |  |  | 0 | $self->{from} = delete $data->{_from} | 
| 183 |  |  |  |  |  |  | if exists $data->{_from}; | 
| 184 | 0 | 0 |  |  |  | 0 | $self->{to} = delete $data->{_to} | 
| 185 |  |  |  |  |  |  | if exists $data->{_to}; | 
| 186 |  |  |  |  |  |  |  | 
| 187 | 0 |  |  |  |  | 0 | return $self; | 
| 188 |  |  |  |  |  |  | } | 
| 189 |  |  |  |  |  |  |  | 
| 190 |  |  |  |  |  |  | # _get_set | 
| 191 |  |  |  |  |  |  | # | 
| 192 |  |  |  |  |  |  | # either get or set value. | 
| 193 |  |  |  |  |  |  | # setting value returns self. | 
| 194 |  |  |  |  |  |  | sub _get_set | 
| 195 |  |  |  |  |  |  | { | 
| 196 | 42 |  |  | 42 |  | 78 | my($self, $param, $value, $validate) = @_; | 
| 197 |  |  |  |  |  |  |  | 
| 198 | 42 | 50 |  |  |  | 113 | if (defined $value) { | 
| 199 |  |  |  |  |  |  | # if we are only validating then return valid value | 
| 200 | 0 | 0 |  |  |  | 0 | return $value if $validate; | 
| 201 |  |  |  |  |  |  | # set value and return self | 
| 202 | 0 |  |  |  |  | 0 | $self->{$param} = $value; | 
| 203 | 0 |  |  |  |  | 0 | return $self; | 
| 204 |  |  |  |  |  |  | } | 
| 205 |  |  |  |  |  |  | else { | 
| 206 |  |  |  |  |  |  | # return currently set value | 
| 207 | 42 |  |  |  |  | 115 | return $self->{$param}; | 
| 208 |  |  |  |  |  |  | } | 
| 209 |  |  |  |  |  |  | } | 
| 210 |  |  |  |  |  |  |  | 
| 211 |  |  |  |  |  |  | # _get_set_bool | 
| 212 |  |  |  |  |  |  | # | 
| 213 |  |  |  |  |  |  | # either get value  or set JSON bool value. | 
| 214 |  |  |  |  |  |  | # setting value returns self. | 
| 215 |  |  |  |  |  |  | sub _get_set_bool | 
| 216 |  |  |  |  |  |  | { | 
| 217 | 0 |  |  | 0 |  | 0 | my($self, $param, $value, $validate) = @_; | 
| 218 |  |  |  |  |  |  |  | 
| 219 | 0 | 0 |  |  |  | 0 | if (defined $value) { | 
| 220 |  |  |  |  |  |  | # accept "true" as JSON bool false | 
| 221 | 0 | 0 |  |  |  | 0 | if ($value eq "true") { | 
|  |  | 0 |  |  |  |  |  | 
| 222 | 0 |  |  |  |  | 0 | $value = JSON::XS::true; | 
| 223 |  |  |  |  |  |  | } | 
| 224 |  |  |  |  |  |  | # accept "false" as JSON bool false | 
| 225 |  |  |  |  |  |  | elsif ($value eq "false") { | 
| 226 | 0 |  |  |  |  | 0 | $value = JSON::XS::false; | 
| 227 |  |  |  |  |  |  | } | 
| 228 |  |  |  |  |  |  | # use the true/false of value to determine JSON bool | 
| 229 |  |  |  |  |  |  | else { | 
| 230 | 0 | 0 |  |  |  | 0 | $value = $value ? JSON::XS::true : JSON::XS::false; | 
| 231 |  |  |  |  |  |  | } | 
| 232 |  |  |  |  |  |  | # if we are only validating then return valid value | 
| 233 | 0 | 0 |  |  |  | 0 | return $value if $validate; | 
| 234 |  |  |  |  |  |  | # set value and return self | 
| 235 | 0 |  |  |  |  | 0 | $self->{$param} = $value; | 
| 236 | 0 |  |  |  |  | 0 | return $self; | 
| 237 |  |  |  |  |  |  | } | 
| 238 |  |  |  |  |  |  | else { | 
| 239 |  |  |  |  |  |  | # return currently set value | 
| 240 | 0 |  |  |  |  | 0 | return $self->{$param}; | 
| 241 |  |  |  |  |  |  | } | 
| 242 |  |  |  |  |  |  | } | 
| 243 |  |  |  |  |  |  |  | 
| 244 |  |  |  |  |  |  | # _get_set_id | 
| 245 |  |  |  |  |  |  | # | 
| 246 |  |  |  |  |  |  | # get/set id with either string or object | 
| 247 |  |  |  |  |  |  | # setting a value returns self | 
| 248 |  |  |  |  |  |  | sub _get_set_id | 
| 249 |  |  |  |  |  |  | { | 
| 250 | 0 |  |  | 0 |  | 0 | my($self, $param, $value, $validate) = @_; | 
| 251 |  |  |  |  |  |  |  | 
| 252 | 0 | 0 |  |  |  | 0 | if (defined $value) { | 
| 253 |  |  |  |  |  |  | # get value from an ArangoDB2 object | 
| 254 | 0 | 0 | 0 |  |  | 0 | if ( blessed $value && $value->can('id') ) { | 
| 255 | 0 |  |  |  |  | 0 | $value = $value->id | 
| 256 |  |  |  |  |  |  | } | 
| 257 |  |  |  |  |  |  | # if we are only validating then return valid value | 
| 258 | 0 | 0 |  |  |  | 0 | return $value if $validate; | 
| 259 |  |  |  |  |  |  | # set value and return self | 
| 260 | 0 |  |  |  |  | 0 | $self->{$param} = $value; | 
| 261 | 0 |  |  |  |  | 0 | return $self; | 
| 262 |  |  |  |  |  |  | } | 
| 263 |  |  |  |  |  |  | else { | 
| 264 |  |  |  |  |  |  | # return currently set value | 
| 265 | 0 |  |  |  |  | 0 | return $self->{$param}; | 
| 266 |  |  |  |  |  |  | } | 
| 267 |  |  |  |  |  |  | } | 
| 268 |  |  |  |  |  |  |  | 
| 269 |  |  |  |  |  |  | # _get_set_name | 
| 270 |  |  |  |  |  |  | # | 
| 271 |  |  |  |  |  |  | # get/set name with either name or object | 
| 272 |  |  |  |  |  |  | # setting a value returns self | 
| 273 |  |  |  |  |  |  | sub _get_set_name | 
| 274 |  |  |  |  |  |  | { | 
| 275 | 78 |  |  | 78 |  | 117 | my($self, $param, $value, $validate) = @_; | 
| 276 |  |  |  |  |  |  |  | 
| 277 | 78 | 100 |  |  |  | 139 | if (defined $value) { | 
| 278 |  |  |  |  |  |  | # get value from an ArangoDB2 object | 
| 279 | 25 | 50 | 33 |  |  | 118 | if ( blessed $value && $value->can('name') ) { | 
| 280 | 0 |  |  |  |  | 0 | $value = $value->name | 
| 281 |  |  |  |  |  |  | } | 
| 282 |  |  |  |  |  |  | # if we are only validating then return valid value | 
| 283 | 25 | 50 |  |  |  | 62 | return $value if $validate; | 
| 284 |  |  |  |  |  |  | # set value and return self | 
| 285 | 25 |  |  |  |  | 47 | $self->{$param} = $value; | 
| 286 | 25 |  |  |  |  | 84 | return $self; | 
| 287 |  |  |  |  |  |  | } | 
| 288 |  |  |  |  |  |  | else { | 
| 289 |  |  |  |  |  |  | # return currently set value | 
| 290 | 53 |  |  |  |  | 395 | return $self->{$param}; | 
| 291 |  |  |  |  |  |  | } | 
| 292 |  |  |  |  |  |  | } | 
| 293 |  |  |  |  |  |  |  | 
| 294 |  |  |  |  |  |  | 1; | 
| 295 |  |  |  |  |  |  |  | 
| 296 |  |  |  |  |  |  | __END__ |