File Coverage

File:lib/OpenAPI/Handler/Model.pm
Coverage:80.9%

linestmtbrancondsubpodtimecode
1package OpenAPI;
2
3
22
22
22
22
173
68
191
use strict;
4
22
22
22
22
231
66
162
use warnings;
5#use Smart::Comments;
6
22
22
22
22
250
88
199
use vars qw($Dumper %OpMap);
7
22
22
22
22
252
178
345
use Clone 'clone';
8
9sub check_type {
10
64
64
0
355
    my $type = shift;
11
64
100
801
    if ($type !~ m{^ \s*
12                (
13                    text |
14                    integer |
15                    serial |
16                    real |
17                    double precision |
18                    date |
19                    (?:timestamp|time) (?: \s* \( \s* \d+ \s* \) )?
20                        (?: \s* with(?:out)? \s+ time \s+ zone)? |
21                    interval (?: \s* \( \s* \d+ \s* \) )?
22                ) \s* $
23            }x) {
24
2
8
        die "Bad column type: $type\n";
25    }
26
62
558
    $1;
27}
28
29sub DELETE_model_list {
30
27
27
0
235
    my ($self, $bits) = @_;
31
27
215
    my $res = $self->get_tables();
32
27
50
1322
    if (!$res) {
33
0
0
        return { success => 1 };
34    }; # no-op
35
27
27
242
232
    my @tables = map { @$_ } @$res;
36    #$tables = $tables->[0];
37
38
27
211
    for my $table (@tables) {
39
27
297
        $self->drop_table($table);
40    }
41
27
581
    return { success => 1 };
42}
43
44sub GET_model_list {
45
17
17
0
130
    my ($self, $bits) = @_;
46
17
142
    my $models = $self->get_models;
47
17
50
448
    $models ||= [];
48
49
17
16
111
232
    map { $_->{src} = "/=/model/$_->{name}" } @$models;
50
17
181
    $models;
51}
52
53sub GET_model {
54
19
19
0
145
    my ($self, $bits) = @_;
55
19
116
    my $model = $bits->[1];
56    #
57    # TODO: need to deal with '~'
58    #
59
19
157
    return $self->get_model_cols($model);
60}
61
62sub POST_model {
63
50
50
0
311
    my ($self, $bits) = @_;
64
50
100
489
    my $data = _HASH($self->{_req_data}) or
65        die "The model schema must be a HASH.\n";
66
48
1676
    my $model = $bits->[1];
67
68
48
139
    my $name;
69
48
100
288
    if ($model eq '~') {
70
2
16
        $model = $data->{name};
71    }
72
73
48
100
100
522
    if ($name = delete $data->{name} and $name ne $model) {
74
1
12
        $self->warning("name \"$name\" in POST content ignored.");
75    }
76
48
310
    $data->{name} = $model;
77
48
379
    return $self->new_model($data);
78}
79
80sub DELETE_model {
81
6
6
0
49
    my ($self, $bits) = @_;
82
6
39
    my $model = $bits->[1];
83
6
26
    my $table = $model;
84
6
100
48
    if ($model eq '~') {
85
1
8
        return $self->DELETE_model_list();
86    }
87
5
50
35
    if (!$self->has_model($model)) {
88
0
0
        die "Model \"$model\" not found.\n";
89    }
90    #$tables = $tables->[0];
91
5
117
    $self->drop_table($table);
92
5
116
    return { success => 1 };
93}
94
95sub GET_model_column {
96
11
11
0
79
    my ($self, $bits) = @_;
97
11
70
    my $model = $bits->[1];
98
11
143
    my $col = $bits->[2];
99
100
11
46
    my $table_name = $model;
101
102
11
195
    my $select = SQL::Select->new(qw< name type label >, '"default"')
103            ->from('_columns')
104            ->where(table_name => Q($table_name))
105            ->order_by('id');
106
11
100
96
    if ($col eq '~') {
107
4
14
        my $list = $self->select("$select", { use_hash => 1 });
108
4
0
50
33
128
0
        if (!$list or !ref $list) { $list = []; }
109
4
61
        unshift @$list, { name => 'id', type => 'serial', label => 'ID' };
110
4
15
        return $list;
111    } else {
112
7
48
        $select->where( name => Q($col) );
113
7
18
        my $res = $self->select("$select", { use_hash => 1 });
114
7
50
33
203
        if (!$res or !@$res) {
115
0
0
            die "Column '$col' not found.\n";
116        }
117
118
7
21
        return $res->[0];
119    }
120}
121
122sub POST_model_column {
123
17
17
0
146
    my ($self, $bits) = @_;
124
17
118
    my $model = $bits->[1];
125
17
98
    my $col = $bits->[2];
126
17
112
    my $data = $self->{_req_data};
127
17
73
    my $table_name = $model;
128
129
17
129
    my $num = $self->column_count;
130
131
17
50
11311
    if ($num >= $COLUMN_LIMIT) {
132
0
0
        die "Exceeded model column count limit: $COLUMN_LIMIT.\n";
133    }
134
135
17
50
164
    $data = _HASH($data) or die "column spec must be a HASH.\n";
136
17
50
643
    if ($col eq 'id') {
137
0
0
        die "Column id is reserved.";
138    }
139
17
100
117
    if ($col eq '~') {
140
4
50
42
         $col = $data->{name} || die "you must provide the new the column with a name!";
141    }
142
143
17
104
    my $alias = $data->{name};
144
17
134
    my $cols = $self->get_model_col_names($model);
145
17
52
52
85
218
    my $fst = first { $col eq $_ } @$cols;
146
17
100
267
    if (defined $fst) {
147
2
6
        die "Column '$col' already exists in model '$model'.\n";
148    }
149    # type defaults to 'text' if not specified.
150
15
50
162
    my $type = $data->{type} || 'text';
151
15
50
123
    my $label = $data->{label} or
152        die "No 'label' specified for column \"$col\" in model \"$model\".\n";
153
15
102
    $type = check_type($type);
154
13
154
    my $insert = SQL::Insert->new('_columns')
155        ->cols(qw< name label type table_name >)
156        ->values( Q($col, $label, $type, $table_name) );
157
158
13
108
    my $default = delete $data->{default};
159
13
100
86
    if (defined $default) {
160
2
23
        $default = $self->process_default($default);
161
2
17
        $insert->cols('"default"')->values(Q($default));
162    }
163
13
100
98
    $default ||= 'null';
164
165
13
181
    my $sql = "alter table \"$table_name\" add column \"$col\" $type default ($default);\n";
166
13
36
    $sql .= "$insert";
167
168
13
158
    my $res = $self->do($sql);
169
170
13
100
100
195
    return { success => 1,
171             src => "/=/model/$model/$col",
172             warning => "Column name \"$alias\" Ignored."
173     } if $alias && $alias ne $col;
174
12
43
    return { success => 1, src => "/=/model/$model/$col" };
175}
176
177sub PUT_model_column {
178
8
8
0
64
    my ($self, $bits) = @_;
179
8
53
    my $model = $bits->[1];
180
8
43
    my $col = $bits->[2];
181
8
100
246
    my $data = _HASH($self->{_req_data}) or
182        die "column spec must be a non-empty HASH.\n";
183
7
243
    my $table_name = $model;
184
185    # discard 'id' column
186
7
50
57
    if (lc($col) eq 'id') {
187
0
0
        die "Column id is reserved.";
188    }
189    # type defaults to 'text' if not specified.
190
7
22
    my $sql;
191
7
47
    my $new_col = delete $data->{name};
192
7
72
    my $update_meta = SQL::Update->new('_columns');
193
7
100
54
    if ($new_col) {
194
3
50
20
        _IDENT($new_col) or die "Bad column name: ",
195                $Dumper->($new_col), "\n";
196
197        #$new_col = $new_col);
198
3
29
        $update_meta->set(name => Q($new_col));
199
3
45
        $sql .= "alter table \"$table_name\" rename column \"$col\" to \"$new_col\";\n";
200        #$col = $new_col;
201    } else {
202
4
19
        $new_col = $col;
203    }
204
7
46
    my $type = delete $data->{type};
205
7
100
48
    if ($type) {
206        #die "Changing column type is not supported.\n";
207
3
21
        $type = check_type($type);
208
3
29
        $update_meta->set(type => Q($type));
209
3
43
        $sql .= "alter table \"$table_name\" alter column \"$new_col\" type $type;\n",
210    }
211
212
7
42
    my $label = delete $data->{label};
213
7
100
48
    if (defined $label) {
214
1
50
8
        _STRING($label) or die "Lable must be a non-empty string: ",
215            $Dumper->($label);
216
1
24
        $update_meta->set(label => Q($label));
217    }
218
219
7
53
    my $default = delete $data->{default};
220
7
100
55
    if (defined $default) {
221
2
16
        $default = $self->process_default($default);
222
223
2
19
        $update_meta->set(QI('default') => Q($default));
224
2
28
        $sql .= "alter table \"$table_name\" alter column \"$new_col\" set default ($default);\n",
225    }
226
227
7
53
    $update_meta->where(table_name => Q($table_name))
228        ->where(name => Q($col));
229
230
7
20
    $sql .= $update_meta;
231
232
7
83
    my $res = $self->do($sql);
233
234
7
50
24
    return { success => $res ? 1 : 0 };
235}
236
237sub DELETE_model_column {
238
3
3
0
26
    my ($self, $bits) = @_;
239
3
19
    my $model = $bits->[1];
240
3
17
    my $col = $bits->[2];
241
3
13
    my $table_name = $model;
242
243    # discard 'id' column
244
3
100
27
    if (lc($col) eq 'id') {
245
1
4
        die "Column \"id\" is reserved.\n";
246    }
247
2
9
    my $sql = '';
248
249
2
100
15
    if($col eq '~') {
250
1
12
         $self->warning("Column \"id\" is reserved.");
251
1
9
     my $columns = $self->get_model_col_names($model);
252
1
24
     for my $c (@$columns) {
253
3
59
              $sql .= "delete from _columns where table_name = '$table_name' and name='$c';" .
254                      "alter table \"$table_name\" drop column \"$c\" restrict;";
255         }
256    } else {
257
1
15
        $sql = "delete from _columns where table_name='$table_name' and name='$col'; alter table \"$table_name\" drop column \"$col\" restrict;";
258    }
259
2
19
    my $res = $self->do($sql);
260
2
50
53
    return { success => $res > -1? 1:0 };
261}
262
263# alter table $table_name rename column $col TO city;
264sub POST_model_row {
265
33
33
0
245
    my ($self, $bits) = @_;
266
33
205
    my $data = $self->{_req_data};
267
33
179
    my $model = $bits->[1];
268
269
33
268
    return $self->insert_records($model, $data);
270}
271
272sub GET_model_row {
273
79
79
0
560
    my ($self, $bits) = @_;
274
79
470
    my $model = $bits->[1];
275
79
466
    my $column = $bits->[2];
276
79
423
    my $value = $bits->[3];
277
278
79
100
100
1060
    if ($column ne '~' and $value ne '~') {
279
39
383
        return $self->select_records($model, $column, $value);
280    }
281
40
100
67
373
    if ($column ne '~' and $value eq '~') {
282
2
17
        return $self->select_records($model, $column);
283    }
284
38
100
67
635
    if ($column eq '~' and $value eq '~') {
285
37
501
        return $self->select_all_records($model);
286    }
287
1
50
7
    if ($column eq '~') {
288
1
8
        return $self->select_records($model, $column, $value);
289    } else {
290
0
0
        return { success => 0, error => "Unsupported operation." };
291    }
292}
293
294sub DELETE_model_row {
295
9
9
0
68
    my ($self, $bits) = @_;
296
9
56
    my $model = $bits->[1];
297
9
50
    my $column = $bits->[2];
298
9
44
    my $value = $bits->[3];
299
9
100
69
    if ($value eq '~') {
300
3
27
        return $self->delete_all_records($model);
301    }
302
303
6
55
    return $self->delete_records($model, $column, $value);
304}
305
306sub PUT_model_row {
307
8
8
0
57
    my ($self, $bits) = @_;
308
8
48
    my $model = $bits->[1];
309
8
42
    my $column = $bits->[2];
310
8
41
    my $value = $bits->[3];
311
8
49
    my $data = $self->{_req_data};
312
8
75
    return $self->update_records($model, $column, $value, $data);
313}
314
315sub PUT_model {
316
3
3
0
27
    my ($self, $bits) = @_;
317
3
22
    my $model = $bits->[1];
318
3
18
    my $data = $self->{_req_data};
319    #warn "Model: $model";
320
3
26
    return $self->alter_model($model, $data);
321}
322
323sub new_model {
324
48
48
0
276
    my ($self, $data) = @_;
325
48
284
    my $nmodels = $self->model_count;
326
48
50
29331
    if ($nmodels >= $MODEL_LIMIT) {
327        #warn "===================================> $num\n";
328
0
0
        die "Exceeded model count limit $MODEL_LIMIT.\n";
329    }
330
48
50
540
    my $model = delete $data->{name} or
331        die "No 'name' field found for the new model\n";
332
48
213
    my $table = $model;
333
334
48
100
389
    my $description = delete $data->{description} or
335        die "No 'description' specified for model \"$model\".\n";
336
46
100
356
    die "Bad 'description' value: ", $Dumper->($description), "\n"
337        unless _STRING($description);
338
339    # XXX Should we allow 0 column table here?
340
45
50
1283
    if (!ref $data) {
341
0
0
        die "Malformed data. Hash or Array expected.\n";
342    }
343
344
45
289
    my $columns = delete $data->{columns};
345
45
3
100
273
112
    if (_HASH($columns)) { $columns = [$columns] }
346
45
100
100
100
100
1153
    if ($columns && !_ARRAY0($columns)) {
347
1
4
        die "Invalid 'columns' value: ", $Dumper->($columns), "\n";
348    } elsif (!$columns) {
349
4
45
        $self->warning("No 'columns' specified for model \"$model\".");
350
4
25
        $columns = [];
351    } elsif (!@$columns) {
352
1
35
        $self->warning("'columns' empty for model \"$model\".");
353    }
354
44
50
1301
    if (@$columns > $COLUMN_LIMIT) {
355
0
0
        die "Exceeded model column count limit: $COLUMN_LIMIT.\n";
356    }
357
358
44
100
275
    if (%$data) {
359
2
28
    my @key = sort(keys %$data);
360
2
7
        die "Unrecognized keys in model schema 'TTT': ",
361            join(", ", @key),"\n";
362    }
363
42
171
    my $i = 1;
364
42
100
307
    if ($self->has_model($model)) {
365
1
4
        die "Model \"$model\" already exists.\n";
366    }
367
41
1080
    my $insert = SQL::Insert->new('_models')
368        ->cols(qw< name table_name description >)
369        ->values( Q($model, $table, $description) );
370
371
41
128
    my $sql = "$insert";
372
41
673
    $insert->reset('_columns')
373        ->cols(QI( qw<name type label table_name> ));
374
41
366
    $sql .=
375        "create table \"$table\" (\n\t\"id\" serial primary key";
376
41
151
    my $sql2;
377
41
180
    my $found_id = undef;
378
41
272
    for my $col (@$columns) {
379
60
100
561
        _HASH($col) or die "Column definition must be a hash: ", $Dumper->($col), "\n";
380
59
50
2025
        my $name = delete $col->{name} or
381            die "No 'name' specified for the column $i.\n";
382
59
100
386
        _STRING($name) or die "Bad column name: ", $Dumper->($name), "\n";
383
58
100
1438
        _IDENT($name) or die "Bad column name: $name\n";
384
54
100
470
        if (length($name) >= 32) {
385
1
4
            die "Column name too long: $name\n";
386        }
387        #$name = $name;
388        # discard 'id' column
389
53
100
402
        if (lc($name) eq 'id') {
390
5
23
            $found_id = 1;
391
5
33
            next;
392        }
393        # type defaults to 'text' if not specified.
394
48
100
721
        my $type = delete $col->{type} || 'text';
395
48
100
381
        my $label = $col->{label} or
396            die "No 'label' specified for column \"$name\" in model \"$model\".\n";
397
398
46
243
        my $default = delete $col->{default};
399
46
284
        $type = check_type($type);
400
46
408
        $sql .= ",\n\t\"$name\" $type";
401
46
4924
        my $ins = $insert->clone
402            ->values(Q($name, $type, $label, $table));
403
46
100
387
        if (defined $default) {
404
3
28
            $default = $self->process_default($default);
405            # XXX
406
3
165
            $sql .= " default ($default)";
407
3
29
            $ins->cols(QI('default'))
408                ->values(Q($default));
409        }
410
46
120
        $sql2 .= $ins;
411
46
122
        $i++;
412    }
413
32
587
    $sql .= "\n);\ngrant select on table \"$table\" to anonymous;\n";
414   #warn $sql, "\n";
415
416    #register_table($table);
417    #register_columns
418
32
118
    eval {
419
32
456
        $self->do($sql2 . $sql);
420    };
421
32
50
501
    if ($@) {
422
0
0
        die "Failed to create model \"$model\": $@\n";
423    }
424    return {
425
32
100
143
        success => 1,
426        $found_id ? (warning => "Column \"id\" reserved. Ignored.") : ()
427    };
428}
429
430sub check_default_expr {
431
3
3
0
18
    my $expr = shift;
432
3
50
52
    if ($expr !~ m{^ \s*
433                (
434                    now \s* \( \s* \)
435                        (?: \s+ at \s+ time \s+ zone \s+ '[^']+' )?
436                ) \s* $
437            }x) {
438
0
0
        die "Bad default expression: $expr\n";
439    }
440
3
17
    $1;
441}
442
443sub process_default {
444
7
7
0
53
    my ($self, $default) = @_;
445
7
100
50
67
93
    if (_STRING($default or $default eq '0')) {
446
4
110
        return Q($default);
447    } elsif (_ARRAY($default)) {
448
3
28
        my $expr = join ' ', @$default;
449
3
22
        check_default_expr($expr);
450
3
28
        return $expr;
451    } else {
452
0
0
        die "Invalid \"default\" value: ", $Dumper->($default), "\n";
453    }
454}
455
456sub has_model {
457
447
447
0
2915
    my ($self, $model) = @_;
458
447
50
2537
    _IDENT($model) or die "Bad model name: $model\n";
459
447
1650
    my $retval;
460
447
4453
    my $select = SQL::Select->new('count(name)')
461        ->from('_models')
462        ->where(name => Q($model))
463        ->limit(1);
464
447
2111
    eval {
465
447
1141
        $retval = $self->select("$select")->[0][0];
466    };
467
447
1618
    return $retval + 0;
468}
469
470sub global_model_check {
471
311
311
0
2499
    my ($self, $rbits, $meth) = @_;
472         #warn "$meth: {@$rbits}\n";
473
474
311
1403
    my ($model, $col);
475
311
100
2424
    if (@$rbits >= 2) {
476
268
1501
        $model = $rbits->[1];
477
268
100
100
1793
        _IDENT($model) or $model eq '~' or die "Bad model name: ", $Dumper->($model), "\n";
478
263
100
2340
        if (length($model) >= 32) {
479
1
4
            die "Model name too long: $model\n";
480        }
481    }
482
305
100
2614
    if (@$rbits >= 3) {
483        # XXX check column name here...
484
180
1100
        $col = $rbits->[2];
485
180
100
100
1191
        (_IDENT($col) || $col eq '~') or die "Bad column name: ", $Dumper->($col), "\n";
486    }
487
488
300
100
2026
    if ($meth eq 'POST') {
489            #warn "hello {@$rbits}";
490
101
100
67
1428
        if (@$rbits >= 3 and $model ne '~') {
491
51
100
932
            if (!$self->has_model($model)) {
492
1
4
                die "Model \"$model\" not found.\n";
493            }
494 #(_IDENT($col) || $col eq '~') or die "Column '$col' not found.\n";
495        }
496    } else {
497
498
199
100
100
2769
        if ($model and $model ne '~') {
499
155
100
1275
            if (!$self->has_model($model)) {
500
5
18
                die "Model \"$model\" not found.\n";
501            }
502        }
503        #
504
194
100
100
5471
        if ($col and $col ne '~') {
505
77
100
67
1387
            if ($model ne '~' and ! $self->has_model_col($model, $col)) {
506
5
20
                die "Column '$col' not found.\n";
507            }
508        }
509    }
510}
511
512sub get_tables {
513    #my ($self, $user) = @_;
514
27
27
0
160
    my $self = shift;
515
27
278
    my $select = SQL::Select->new('name')->from('_models');
516
27
86
    return $self->select("$select");
517}
518
519sub model_count {
520
48
48
0
209
    my $self = shift;
521
48
306
    return $self->select("select count(*) from _models")->[0][0];
522}
523
524sub column_count {
525
17
17
0
90
    my $self = shift;
526
17
131
    return $self->select("select count(*) from _columns")->[0][0];
527}
528
529sub row_count {
530
33
33
0
260
    my ($self, $table) = @_;
531
33
313
    return $self->select("select count(*) from \"$table\"")->[0][0];
532}
533
534sub get_models {
535
17
17
0
102
    my $self = shift;
536
17
190
    my $select = SQL::Select->new('name','description')->from('_models')->order_by('id');
537
17
49
    return $self->select("$select", { use_hash => 1 });
538}
539
540sub get_model_cols {
541
19
19
0
122
    my ($self, $model) = @_;
542
19
50
114
    if (!$self->has_model($model)) {
543
0
0
        die "Model \"$model\" not found.\n";
544    }
545
19
412
    my $table = $model;
546
19
185
    my $select = SQL::Select->new('description')
547        ->from('_models')
548        ->where(name => Q($model));
549
19
59
    my $list = $self->select("$select");
550
19
12881
    my $desc = $list->[0][0];
551
19
238
    $select->reset( QI(qw< name type label default >) )
552           ->from('_columns')
553           ->where(table_name => Q($table))
554           ->order_by('id');
555
19
51
    $list = $self->select("$select", { use_hash => 1 });
556
19
0
50
33
576
0
    if (!$list or !ref $list) { $list = []; }
557
19
258
    unshift @$list, { name => 'id', type => 'serial', label => 'ID' };
558
19
62
    return { description => $desc, name => $model, columns => $list };
559}
560
561sub get_model_col_names {
562
107
107
0
755
    my ($self, $model) = @_;
563
564
107
50
684
    if (!$self->has_model($model)) {
565
0
0
        die "Model \"$model\" not found.\n";
566    }
567
107
2098
    my $table = $model;
568
107
959
    my $select = SQL::Select->new('name')
569        ->from('_columns')
570        ->where(table_name => Q($table));
571
572
107
302
    my $list = $self->select("$select");
573
107
0
50
33
70987
0
    if (!$list or !ref $list) { return []; }
574
107
237
793
1104
    return [map { @$_ } @$list];
575}
576
577sub has_model_col {
578
95
95
0
764
    my ($self, $model, $col) = @_;
579
95
50
782
    _IDENT($model) or die "Bad model name: $model\n";
580
95
100
659
    _IDENT($col) or die "Bad model column name: $col\n";
581
94
478
    my $table_name = $model;
582
583
94
100
1042
    return 1 if $col eq 'id';
584
60
199
    my $res;
585
60
608
    my $select = SQL::Select->new('count(name)')
586        ->from('_columns')
587        ->where(table_name => Q($table_name))
588        ->where(name => Q($col))
589        ->limit(1);
590
60
329
    eval {
591
60
172
        $res = $self->select("$select")->[0][0];
592    };
593
60
229
    return $res + 0;
594}
595
596sub drop_table {
597
32
32
0
262
    my ($self, $table) = @_;
598
32
575
    $self->do(<<_EOC_);
599drop table if exists "$table";
600delete from _models where table_name='$table';
601delete from _columns where table_name='$table';
602_EOC_
603}
604
605sub insert_records {
606
33
33
0
218
    my ($self, $model, $data) = @_;
607
33
50
245
    if (!ref $data) {
608
0
0
        die "Malformed data: Hash or Array expected\n";
609    }
610    ## Data: $data
611
33
128
    my $table = $model;
612
33
50
226
    if ($self->row_count($table) >= $RECORD_LIMIT) {
613
0
0
        die "Exceeded model row count limit: $RECORD_LIMIT.\n";
614    }
615
616
33
23435
    my $cols = $self->get_model_col_names($model);
617
33
495
    my $sql;
618
33
543
    my $insert = SQL::Insert->new(QI($table));
619
620
33
297
    my $user = $self->current_user;
621
33
154
    my $special_account = 'carrie';
622
33
50
227
    if ($user eq $special_account) {
623
22
22
22
22
335
102
328
        use lib "$FindBin::Bin/../../../openapi-filter-qp/trunk/lib";
624
0
0
        require OpenAPI::Filter::QP;
625
0
0
        my $str = JSON::Syck::Dump(clone($data));
626        #die $val;
627        #die "aaaa";
628
0
0
        OpenAPI::Filter::QP->filter($str);
629    }
630
631
33
100
50
310
    if (ref $data eq 'HASH') { # record found
632
633
24
223
        my $num = $self->insert_record($insert, $data, $cols, 1);
634
635
23
495
        my $last_id = $self->last_insert_id($table);
636
637
23
50
70
        return { rows_affected => $num, last_row => "/=/model/$model/id/$last_id", success => $num?1:0 };
638    } elsif (ref $data eq 'ARRAY') {
639
9
38
        my $i = 0;
640
9
36
        my $rows_affected = 0;
641
9
50
71
        if (@$data > $INSERT_LIMIT) {
642
0
0
            die "You can only insert $INSERT_LIMIT rows at a time.\n";
643        }
644
9
58
        for my $row_data (@$data) {
645
44
50
278
            _HASH($row_data) or
646                die "Bad data in row $i: ", $Dumper->($row_data), "\n";
647
44
1598
            $rows_affected += $self->insert_record($insert, $row_data, $cols, $i);
648
44
737
            $i++;
649        }
650
9
89
        my $last_id = $self->last_insert_id($table);
651
9
50
29
        return { rows_affected => $rows_affected, last_row => "/=/model/$model/id/$last_id", success => $rows_affected?1:0 };
652    } else {
653
0
0
        die "Malformed data: Hash or Array expected.\n";
654    }
655}
656
657sub insert_record {
658
68
68
0
473
    my ($self, $insert, $row_data, $cols, $row_num) = @_;
659
68
1360
    $insert = $insert->clone;
660    #die $user;
661
68
588
    my $found = 0;
662
68
769
    while (my ($col, $val) = each %$row_data) {
663
115
50
706
        _IDENT($col) or
664            die "Bad column name in row $row_num: ", $Dumper->($col), "\n";
665        # XXX croak on column "id"
666
115
825
        $insert->cols(QI($col));
667
115
748
        $insert->values(Q($val));
668
115
1234
        $found = 1;
669    }
670
68
100
431
    if (!$found) {
671
1
3
        die "No column specified in row $row_num.\n";
672    }
673
67
157
    my $sql = "$insert";
674
675
67
726
    return $Backend->do($sql);
676}
677
678sub process_order_by {
679
79
79
0
535
    my ($self, $select, $model) = @_;
680
79
731
    my $order_by = $self->{_cgi}->url_param('order_by');
681
79
100
600
    return unless defined $order_by;
682
16
100
118
    die "No column found in order_by.\n" if $order_by eq '';
683
15
157
    my @sub_order_by = split ',', $order_by;
684
15
100
67
158
    if (!@sub_order_by and $order_by) {
685
1
4
        die "Invalid order_by value: $order_by\n";
686    }
687
14
92
    foreach my $item (@sub_order_by){
688
689
18
160
        my ($col, $dir) = split ':', $item, 2;
690
18
100
156
        die "No column \"$col\" found in order_by.\n"
691            unless $self->has_model_col($model, $col);
692
16
100
385
        $dir = lc($dir) if $dir;
693
16
100
100
263
        die "Invalid order_by direction: $dir\n"
694            if $dir and $dir ne 'asc' and $dir ne 'desc';
695
13
67
203
        $select->order_by($col => $dir || ());
696    }
697}
698
699sub process_offset {
700
72
72
0
428
    my ($self, $select) = @_;
701
72
545
    my $offset = $self->{_offset};
702
72
100
469
    if ($offset) {
703
8
64
        $select->offset($offset);
704    }
705}
706
707sub process_limit {
708
72
72
0
429
    my ($self, $select) = @_;
709
72
389
    my $limit = $self->{_limit};
710
72
50
434
    if (defined $limit) {
711
72
458
        $select->limit($limit);
712    }
713}
714
715sub select_records {
716
42
42
0
350
    my ($self, $model, $user_col, $val) = @_;
717
42
177
    my $table = $model;
718
42
479
    my $cols = $self->get_model_col_names($model);
719
720
42
100
100
1210
    if (lc($user_col) ne 'id' and $user_col ne '~') {
721
23
104
        my $found = 0;
722
23
163
        for my $col (@$cols) {
723
39
23
23
100
266
108
113
            if ($col eq $user_col) { $found = 1; last; }
724        }
725
23
0
50
177
0
        if (!$found) { die "Column $user_col not available.\n"; }
726    }
727
42
498
    my $select = SQL::Select->new;
728
42
541
    $select->from(QI($table));
729
42
100
67
834
    if (defined $val and $val ne '~') {
730
40
100
752
        my $op = $self->{_cgi}->url_param('op') || 'eq';
731
40
287
        $op = $OpMap{$op};
732
40
100
261
        if ($op eq 'like') {
733
1
9
            $val = "%$val%";
734        }
735
40
323
        $select->select('id', QI(@$cols));
736
40
100
325
        if ($user_col eq '~') {
737            # XXX
738
1
8
            $select->op('or');
739
1
5
            for my $col (@$cols) {
740
2
12
                $select->where($col => $op => Q($val));
741            }
742        } else {
743
39
667
            $select->where(QI($user_col) => $op => Q($val));
744        }
745    } else {
746
2
14
        $select->select($user_col);
747    }
748
42
383
    $self->process_order_by($select, $model, $user_col);
749
37
244
    $self->process_offset($select);
750
37
242
    $self->process_limit($select);
751
752
37
96
    my $res = $self->select("$select", { use_hash => 1 });
753
37
0
50
33
747
0
    if (!$res and !ref $res) { return []; }
754
37
103
    return $res;
755}
756
757sub select_all_records {
758
37
37
0
243
    my ($self, $model) = @_;
759
37
224
    my $order_by = $self->{'_order_by'};
760
761
37
50
220
    if (!$self->has_model($model)) {
762
0
0
        die "Model \"$model\" not found.\n";
763    }
764
765
37
743
    my $table = $model;
766
37
316
    my $select = SQL::Select->new('*')->from(QI($table));
767
768
37
338
    $self->process_order_by($select, $model);
769
35
239
    $self->process_offset($select);
770
35
231
    $self->process_limit($select);
771
772
35
94
    my $list = $self->select("$select", { use_hash => 1 });
773
35
0
50
33
962
0
    if (!$list or !ref $list) { return []; }
774
35
95
    return $list;
775}
776
777sub delete_all_records {
778
3
3
0
19
    my ($self, $model) = @_;
779
3
50
20
    if (!$self->has_model($model)) {
780
0
0
        die "Model \"$model\" not found.\n";
781    }
782
3
58
    my $table = $model;
783
3
34
    my $retval = $Backend->do("delete from \"$table\"");
784
3
58
    return {success => 1,rows_affected => $retval+0};
785}
786
787sub delete_records {
788
6
6
0
49
    my ($self, $model, $user_col, $val) = @_;
789
6
50
37
    if (!$self->has_model($model)) {
790
0
0
        die "Model \"$model\" not found.\n";
791    }
792
6
131
    my $table = $model;
793
6
54
    my $cols = $self->get_model_col_names($model);
794
6
50
131
    if (lc($user_col) ne 'id') {
795
0
0
        my $found = 0;
796
0
0
        for my $col (@$cols) {
797
0
0
0
0
0
0
0
            if ($col eq $user_col) { $found = 1; last; }
798        }
799
0
0
0
0
0
        if (!$found) { die "Column $user_col not available.\n"; }
800    }
801    #my $flds = join(",", @$cols);
802
6
21
    my $sql;
803
6
50
42
    if (defined $val) {
804
6
80
        $sql = "delete from \"$table\" where \"$user_col\"=" . Q($val);
805    } else {
806
0
0
        $sql = "delete from \"$table\"";
807    }
808
809
6
49
    my $retval = $Backend->do($sql);
810
6
135
    return {success => 1,rows_affected => $retval+0};
811}
812
813sub update_records {
814
8
8
0
61
    my ($self, $model, $user_col, $val, $data) = @_;
815
8
30
    my $table = $model;
816
8
53
    my $cols = $self->get_model_col_names($model);
817
8
50
67
178
    if ($user_col ne 'id' && $user_col ne '~') {
818
0
0
        my $found = 0;
819
0
0
        for my $col (@$cols) {
820
0
0
0
0
0
0
0
            if ($col eq $user_col) { $found = 1; last; }
821        }
822        #my $flds = join(",", @$cols);
823
0
0
0
0
0
        if (!$found) { die "Column $user_col not available.\n"; }
824    }
825
8
50
33
134
    if (!ref $data || ref $data ne 'HASH') {
826
0
0
        die "HASH data expected in the content body.\n";
827    }
828
8
74
    my $update = SQL::Update->new(QI($table));
829
8
113
    while (my ($key, $val) = each %$data) {
830
8
38
        my $col = $key;
831
8
100
60
        if (lc($col) eq 'id') {
832
1
4
            die "Column \"id\" reserved.\n";
833        }
834
7
46
        $update->set(QI($col) => Q($val));
835    }
836
837
7
100
67
115
    if (defined $val and $val ne '~') {
838
6
42
        $update->where(QI($user_col) => $val);
839    }
840    ### SQL: "$update"
841
7
18
    my $retval = $Backend->do("$update") + 0;
842
7
100
23
    return {success => $retval ? 1 : 0,rows_affected => $retval};
843}
844
845sub alter_model {
846
3
3
0
14
    my $self = $_[0];
847
3
50
23
    my $model = _IDENT($_[1]) or die "Invalid model name \"$_[1]\".\n";
848
3
50
32
    my $data = _HASH($_[2]) or die "HASH expected in the PUT content.\n";
849
3
98
    my $table = $model;
850
3
50
22
    if (!$self->has_model($model)) {
851
0
0
        die "Model \"$model\" not found.\n";
852    }
853
854
3
63
    my $sql;
855
3
16
    my $new_model = $model;
856
3
100
36
    if ($new_model = delete $data->{name}) {
857
2
50
14
        _IDENT($new_model) or
858            die "Bad model name: ", $Dumper->($new_model), "\n";
859
2
50
21
        if ($self->has_model($new_model)) {
860
0
0
            die "Model \"$new_model\" already exists.\n";
861        }
862
2
50
        my $new_table = $new_model;
863
2
64
        $sql .=
864            "update _models set table_name='$new_table', name='$new_model' where name='$model';\n" .
865            "update _columns set table_name='$new_table' where table_name='$table';\n" .
866            "alter table \"$table\" rename to \"$new_table\";\n";
867    }
868
3
50
22
    $new_model ||= $model;
869
3
50
35
    if (my $desc = delete $data->{description}) {
870
3
50
25
        _STRING($desc) or die "Model descriptons must be strings.\n";
871
3
89
        $sql .= "update _models set description=".Q($desc)." where name='$new_model';\n"
872    }
873
3
50
28
    if (%$data) {
874
0
0
        die "Unknown fields ", join(", ", keys %$data), "\n";
875    }
876
877    #warn "SQL: $sql";
878
3
27
    my $retval = $self->do($sql);
879
880
3
76
    return {success => $retval+0 >= 0};
881}
882
8831;
884