line
stmt
bran
cond
sub
pod
time
code
1
=encoding utf8
2
3
=head1 NAME
4
5
SQL::Steno - Short hand for SQL and compact output
6
7
=head1 SYNOPSIS
8
9
Type some short-hand, see the corresponding SQL and its output:
10
11
steno> TABLE1;somecolumn > 2 -- ; after tables means where
12
select * from TABLE1 where somecolumn > 2;
13
prepare: 0.000s execute: 0.073s rows: 14
14
id|column1 |column2
15
| | |column3
16
| | | |somecolumn
17
----|-------------------------------------------|----|-|-|
18
27|foo | |a|7|
19
49|bar |abcd|a|3|
20
81|baz\nbazinga\nbazurka |jk |b|9|
21
1984|bla bla bla bla bla bla bla bla bla bla bla|xyz |c|5|
22
...
23
steno> /abc|foo/#TBL1;.socol > 2 -- /regexp/ grep, #tableabbrev, .columnabbrev
24
select * from TABLE1 where somecolumn > 2;
25
prepare: 0.000s execute: 0.039s rows: 14
26
id|column1
27
| |column2
28
| | |[column3=a]
29
| | |somecolumn
30
--|---|----|-|
31
27|foo| |7|
32
49|bar|abcd|3|
33
steno> .c1,.c2,.some;#TE1#:ob2d3 -- ; before tables means from, 2nd # alias, :macro
34
select column1,column2,somecolumn from TABLE1 TE1 order by 2 desc, 3;
35
...
36
steno> n(), yr(), cw(,1,2,3) -- functionabbrev before (, can have initial default arg
37
select count(*), year(now()), concat_ws(',',1,2,3);
38
...
39
steno> .col1,.clm2,.sn;#TBL1:jTBL2 u(id);mydate :b :m+3d and :d-w -- :jTABLEABBREV and :+/- family
40
select column1,column2,somecolumn from TABLE1 join TABLE2 using(id) where mydate
41
between date_format(now(),"%Y-%m-01")+interval 3 day and curdate()-interval 1 week;
42
...
43
44
=head1 DESCRIPTION
45
46
You're the command-line type, but are tired of typing C
47
where CONDITION>, always forgetting the final C<;>? Output always seems far
48
too wide and at least mysql cli messes up the format when it includes
49
newlines?
50
51
This module consists of the function C which implements a
52
configurable ultra-compact language that maps to SQL. Then there is C
53
which performs normal SQL queries but has various tricks for narrowing the
54
output. It can also grep on whole rows, rather than having to list all fields
55
that you expect to match. They get combined by the function C which
56
converts and runs in an endless loop.
57
58
This is work in progress, only recently isolated from a monolithic script.
59
Language elements and API may change as the need arises, e.g. C<:macro> used
60
to be C<@macro>, till the day I wanted to use an SQL-variable and noticed the
61
collision. In this early stage, you are more than welcome to propose
62
ammendments, especially if they make the language more powerful and/or more
63
consistent. Defaults are for MariaDB/MySQL, though the mechanism also works
64
with other DBs.
65
66
=cut
67
68
4
4
1974
use v5.14;
4
9
69
70
package SQL::Steno v0.3.2;
71
72
4
4
1905
use utf8;
4
32
4
15
73
4
4
100
use strict;
4
6
4
61
74
4
4
10
use warnings;
4
5
4
83
75
4
4
1728
use Time::HiRes qw(gettimeofday tv_interval);
4
3769
4
13
76
77
binmode $_, ':utf8' for *STDIN, *STDOUT, *STDERR;
78
79
our $dbh;
80
our $perl_re = qr/(\{(?:(?>[^{}]+)|(?-1))*\})/;
81
our( %Table_Columns, $table_re );
82
sub init {
83
0
0
0
0
0
die "\$dbh is undef\n" unless $dbh;
84
0
0
local @{$dbh}{qw(PrintWarn PrintError RaiseError)} = (0, 0, 0); # \todo is this right? views can barf because more restrictive.
0
0
85
0
0
for my $table ( @{$dbh->table_info->fetchall_arrayref} ) {
0
0
86
0
0
$Table_Columns{uc $table->[2]} = [];
87
0
0
splice @$table, 3, -1, '%';
88
0
0
0
my $info = $dbh->column_info( @$table ) or next;
89
0
0
for my $column ( @{$info->fetchall_arrayref} ) {
0
0
90
0
0
push @{$Table_Columns{$table->[2]}}, uc $column->[3];
0
0
91
}
92
}
93
0
0
undef $table_re; # (re)create below
94
}
95
our $init_from_query = <<\SQL;
96
select ucase(TABLE_NAME), ucase(COLUMN_NAME)
97
from information_schema.COLUMNS
98
where TABLE_SCHEMA = schema()
99
SQL
100
sub init_from_query {
101
0
0
0
0
0
die "\$dbh is undef\n" unless $dbh;
102
0
0
local @{$dbh}{qw(PrintWarn PrintError RaiseError)} = (0, 0, 0); # \todo is this right?
0
0
103
0
0
my $sth = $dbh->prepare( $init_from_query );
104
0
0
$sth->execute;
105
0
0
$sth->bind_columns( \my( $table, $column ));
106
0
0
push @{$Table_Columns{$table}}, $column while $sth->fetch;
0
0
107
0
0
undef $table_re; # (re)create below
108
}
109
110
111
112
my %render =
113
(csv => \&render_csv,
114
table => \&render_table,
115
yaml => \&render_yaml,
116
yml => \&render_yaml);
117
my( $render, %opt );
118
119
sub set_render($@) {
120
4
4
0
5
($render, %opt) = ();
121
4
5
for( @_ ) {
122
7
100
8
if( defined $render ) { # all further args are opts
123
3
3
tr/ \t//d;
124
3
7
undef $opt{$_}; # make it exist
125
} else {
126
4
8
$render = substr $_, 1;
127
}
128
}
129
4
6
$render = $render{$render};
130
4
23
''; # For use as a query
131
}
132
133
134
135
our( %Queries_help, %Queries );
136
sub Query {
137
74
74
0
97
$Queries_help{$_[0]} = $_[1];
138
74
74
$Queries{$_[0]} = $_[2];
139
74
123
undef;
140
}
141
Query ".$_", " output '&.$_() this' or next query as \U$_", \&set_render
142
for keys %render;
143
144
Query 'c'.substr( $_, 0, 1 ), "$_ show create (&- or similar for full display)",
145
'&{ $render ||= \&render__create; "" }=show create '.$_.' $1'
146
for qw(table function procedure view);
147
148
Query @$_
149
for
150
['-' => " output next query as YAML",
151
'&.yaml'],
152
153
154
[ps => ' show processlist (without Sleep)',
155
'{(${_}[7] // "") ne "Sleep"}=show processlist'],
156
157
[psf => ' show full processlist (without Sleep)',
158
'{(${_}[7] // "") ne "Sleep"}=show full processlist'],
159
160
161
[t => 'unquotedtablename[,unquotedcolumnpattern] show fields',
162
'COLUMN_NAME,COLUMN_TYPE,IS_NULLABLE NUL,COLUMN_KEY `KEY`,COLUMN_COMMENT;information_schema.`COLUMNS`;TABLE_SCHEMA=schema() and TABLE_NAME=$\1:ob ORDINAL_POSITION'],
163
# 'COLUMN_NAME,COLUMN_TYPE,IS_NULLABLE NUL,COLUMN_KEY `KEY`,COLUMN_COMMENT;information_schema.`COLUMNS`;TABLE_SCHEMA=schema() and TABLE_NAME=$\1$?>? and COLUMN_NAME like$\>??:ob ORDINAL_POSITION'],
164
165
166
[s => 'var;value set @var = value',
167
'set @$1=$2'],
168
169
[ss => "var;value set \@var = 'value'",
170
'set @$1=$\2'],
171
172
[sd => 'var;value set @var = cast("value" as date)',
173
'set @$1=cast($\2 as date)'],
174
175
[sdt => 'var;value set @var = cast("value" as datetime)',
176
'set @$1=cast($\2 as datetime)'],
177
178
[st => 'var;value set @var = cast("value" as time)',
179
'set @$1=cast($\2 as time)'],
180
181
[sy => ' set @a, @z yesterday is between @a and @z (see :baz)',
182
#'set @a=date(now())-interval 1 day, @z=date(now())-interval 1 second',
183
'select @a:=date(now()-interval 1 day)`@a`, @z:=date(now())-interval 1 second`@z`'];
184
185
186
187
our( %Quotes_help, %Quotes );
188
sub Quote {
189
10
10
0
259
$Quotes_help{$_[0]} = $_[1];
190
10
12
$Quotes{$_[0]} = $_[2];
191
10
24
undef;
192
}
193
Quote @$_
194
for
195
['a' => 'and: unquoted joined with &&',
196
'!%&&'],
197
198
['o' => 'or: unquoted joined with ||',
199
'!%||'];
200
201
202
our $weekstart = 1; # Monday is the first day of the week as per ISO 8601.
203
my $timespec_re = qr/[yqmwdhMs]?/;
204
our %Join_clause;
205
our %Macros =
206
(
207
b => ' between',
208
baz => ' between @a and @z',
209
d => ' distinct',
210
h => ' having',
211
j => ' join',
212
l => ' like',
213
lj => ' left join',
214
n => ' is null',
215
nb => ' not between',
216
nc => ' sql_no_cache',
217
nl => ' not like',
218
nn => ' is not null',
219
nr => ' not rlike',
220
od => ' on duplicate key update',
221
odku => ' on duplicate key update',
222
r => ' rlike',
223
u => ' union select',
224
ua => ' union all select',
225
wr => ' with rollup',
226
'' => sub {
227
my $join = 'for all #TBL matching TABLE';
228
my $int = 'see :+ :- :y-m :q+0 :d+2h';
229
my $gob = 'for 0 or more digits, optionally followed by a or d';
230
return ([jTBL => $join], ['jTBL#' => $join], [ljTBL => $join], [1 => 'for all numbers'],
231
[gb147 => $gob], [ob2d5a9 => $gob],
232
['+' => < $int], ['d+2h' => $int], ['y-m' => $int], ['q+0' => $int])
233
:B+/-NO this B(ase) +/- N(umber, 0 for none, default 1 if O given) O(ffset)
234
optional B, O is y(ear), q(uarter), m(onth), w(eek), d(ay), h(our), M(inute), s(econd)
235
INT
236
unless @_; # help
237
for( $_[0] ) {
238
return " limit $_" if /^\d+$/;
239
if( s/^([og])b(?=(?:\d[ad]?)*$)/ $1 eq 'g' ? ' group by ' : ' order by ' /e ) {
240
s/(?
241
s/a/ asc/g; s/(?
242
return $_;
243
}
244
if( s/^(l?)j/#/ ) { # (l)jtbl: j or lj with any #tbl
245
my $left = $1 ? ' left' : '';
246
&convert_table_column;
247
/^(\w+)/;
248
return "$left join $_" . ($Join_clause{$1} || $Join_clause{''} || '');
249
}
250
return $_ if
251
s(^($timespec_re)([+-])(\d*)($timespec_re)$) {
252
({ y => ' date_format(now(),"%Y-01-01")',
253
q => ' date_format(now()-interval mod(month(now())+11,3) month,"%Y-%m-01")',
254
m => ' date_format(now(),"%Y-%m-01")',
255
w => ' curdate()-interval weekday(now())' . ($weekstart ? ' day' : '+1 day'),
256
d => ' curdate()',
257
h => ' date_format(now(),"%F %H:00")',
258
M => ' date_format(now(),"%F %H:%M")',
259
s => ' now()' }->{$1} || '') .
260
($3 ne '0' &&
261
" $2interval" .
262
($3 ? " $3" : $4 ? ' 1' : '') .
263
({ y => ' year',
264
q => ' quarter',
265
m => ' month',
266
w => ' week',
267
d => ' day',
268
h => ' hour',
269
M => ' minute',
270
s => ' second' }->{$4} || ''))
271
}eo;
272
}
273
});
274
275
# \todo default arg n() -> n(*) time*(now())
276
our %Functions =
277
(
278
c => 'concat',
279
cw => 'concat_ws',
280
coa => 'coalesce',
281
gc => 'group_concat',
282
i => 'in', # not really fn, but ( follows
283
in => 'ifnull',
284
l => 'char_length',
285
lc => 'lcase',
286
m => 'min',
287
M => 'max',
288
n => 'count',
289
ni => 'not in', # -"-
290
s => 'substring',
291
u => 'using', # -"-
292
uc => 'ucase'
293
);
294
295
# functions where the 1st argument can be now()
296
my @nowFunctions = qw(
297
adddate addtime convert_tz date date_add date_format date_sub datediff day
298
dayname dayofmonth dayofweek dayofyear hour last_day minute month
299
monthname quarter second subdate subtime time time_format time_to_sec
300
timediff timestamp to_days to_seconds week weekday weekofyear year
301
yearweek
302
);
303
our @Functions = sort @nowFunctions, qw(
304
abs acos aes_decrypt aes_encrypt ascii asin atan avg benchmark bin bit_and
305
bit_count bit_length bit_or bit_xor cast ceiling char_length char
306
character_length charset coalesce coercibility collation compress
307
concat_ws concat connection_id conv cos cot count crc32 curdate
308
current_date current_time current_timestamp current_user curtime database
309
decode default degrees des_decrypt des_encrypt elt encode encrypt exp
310
export_set field find_in_set floor format found_rows from_days
311
from_unixtime get_format get_lock greatest group_concat hex if ifnull
312
inet_aton inet_ntoa insert instr interval is_free_lock is_used_lock isnull
313
last_insert_id lcase least left length ln load_file localtime
314
localtimestamp locate log10 log2 log lower lpad ltrim make_set makedate
315
maketime master_pos_wait max md5 microsecond mid min mod name_const now
316
nullif oct octet_length old_password ord password period_add period_diff
317
pi position power quote radians rand release_lock repeat replace reverse
318
right round row_count rpad rtrim schema sec_to_time session_user sha1 sign
319
sin sleep soundex space sqrt stddev stddev_pop stddev_samp str_to_date
320
strcmp substring_index substring sum sysdate system_user tan timestampadd
321
timestampdiff trim truncate ucase uncompress uncompressed_length unhex
322
unix_timestamp upper user utc_date utc_time utc_timestamp uuid values
323
var_pop var_samp variance
324
);
325
326
our %DefaultArguments = (
327
count => '*',
328
concat_ws => "','"
329
);
330
$DefaultArguments{$_} = 'now()' for @nowFunctions;
331
332
333
our %Tables;
334
our %Columns;
335
336
sub regexp($$) {
337
5
5
1
3
my( $str, $type ) = @_;
338
5
100
9
if( $type < 2 ) {
339
2
50
5
return if $str !~ /_/; # Otherwise same as find sprintf cases
340
0
0
0
return ($type ? '' : '^') . join '.*?_', split /_/, $str; # 0 & 1
341
}
342
3
7
my $expr = join '.*?', split //, $str; # 2, 3 & 4
343
3
100
7
if( $type < 4 ) {
344
2
5
substr $expr, 0, 0, '^'; # 2 & 3
345
2
100
3
$expr .= '$' if $type == 2; # 2
346
}
347
3
4
$expr;
348
}
349
350
my $error;
351
my @simple = qw(^%s$ ^%s_ ^%s _%s$ _%s %s$ %s_ %s);
352
sub find($$$\%;\@) {
353
55
55
0
69
my( $str, $prefix, $suffix, $hash, $list ) = @_;
354
55
61
my $ret = $hash->{$str};
355
55
100
162
return $ret if $ret;
356
357
13
12
$ret = $hash->{''};
358
13
100
19
$ret = &$ret( $str ) if $ret;
359
13
100
27
return $ret if $ret;
360
361
11
50
16
if( $list ) {
362
11
22
for my $type ( 0..@simple+4 ) { # Try to find a more and more fuzzy match.
363
23
100
55
my $expr = $type < @simple ?
364
sprintf $simple[$type], $str :
365
regexp $str, $type - @simple;
366
23
100
32
next unless defined $expr;
367
21
568
my @res = grep /$expr/i, @$list;
368
21
100
39
if( @res ) {
369
10
50
31
return $res[0] if @res == 1;
370
0
0
warn "$prefix$str$suffix matches @res\n";
371
0
0
$error = 1;
372
0
0
return '';
373
}
374
}
375
}
376
# no special syntax for fields or functions, so don't fail on real one
377
1
50
33
22
return $str if ord $prefix == ord '.' or ord $suffix == ord '(';
378
379
0
0
warn "$prefix$str$suffix doesn't match\n";
380
0
0
$error = 1;
381
}
382
383
my %rq = ('[', ']',
384
'{', '}');
385
my $quote_re = qr(\\([^\W\d_]*)([-,:;./ #?ω^\\\@!'"`[\]{}]*)(?:%(.+?))?); # $1: name, $2: spec, $3: join
386
sub quote($$$$) {
387
40
40
0
40
local $_ = $_[1];
388
40
58
my( $named, undef, $join, @args ) = @_;
389
40
59
while( $named ) {
390
5
6
my $quotes = $Quotes{$named};
391
5
50
33
76
if( !defined $quotes or "\\$quotes" !~ /^$quote_re$/o ) {
392
0
0
0
warn $quotes ? "\\$named is bad '$quotes' in \%Quotes\n" : "\\$named not found in \%Quotes\n";
393
0
0
$error = 1;
394
0
0
return '';
395
}
396
5
5
$named = $1;
397
5
6
substr $_, 0, 0, $2;
398
5
100
17
$join //= $3;
399
}
400
40
100
87
$join //= ',';
401
40
35
my $list = ref $args[0];
402
40
100
50
@args = @{$args[0]} if $list;
18
26
403
40
100
101
return join $join, @args unless defined;
404
30
31
/(['"`[{])/;
405
30
36
my( $lq ) = /(['"`[{])/;
406
30
100
59
$lq ||= "'";
407
30
66
65
my $rq = $rq{$lq} || $lq;
408
30
68
my( $noquote, $number, $boolean, $null, $space, $var ) =
409
4
4
7483
(tr/!//, tr/#//, tr/?//, tr/ω^//, tr/\\//, tr/@//);
4
8
4
35
410
30
50
41
my $split = tr/-// ? '-' : ''; # avoid range by putting - 1st
411
30
100
39
$split .= tr/ // ? '\s' : ''; # space means any whitespace
412
30
45
$split .= join '', /([,:;.\/])/g;
413
30
100
100
64
$split ||= ',' unless $list;
414
30
100
66
227
$split &&= $space ? qr/[$split]/ : qr/\s*[$split]\s*/;
415
join $join, map {
416
80
100
33
456
if( $noquote || $boolean && /^(?:true|false)$/i || $null && /^null$/i || $var && /^\@\w+$/ ) {
100
66
100
33
33
66
100
417
13
43
$_;
418
} elsif( $number && /^[-+]?(?:0b[01]+|0x[\da-f]+|(?=\.?\d)\d*\.?\d*(?:e[-+]?\d+)?)$/i ) {
419
9
17
$_;
420
} else {
421
58
131
s/$rq/$rq$rq/g;
422
58
200
"$lq$_$rq";
423
}
424
} map {
425
30
100
33
unless( $space ) {
50
61
426
49
87
s/\A\s*//;
427
49
111
s/\s*\Z//;
428
}
429
50
100
151
$split ? split $split, $_, -1 : $_;
430
} @args;
431
}
432
433
sub convert_Query($$) {
434
15
15
0
20
my $name = $_[0];
435
15
24
my $res = find $name, '&', '', %Queries;
436
15
15
my $ref = ref $res;
437
15
9
my @arg;
438
15
100
44
for( $ref ? $_[1] : "$res\cA$_[1]" ) {
439
15
14
&convert_table_column;
440
15
100
41
($res, $_) = split "\cA" unless $ref;
441
15
31
@arg = split ';';
442
}
443
15
100
50
22
return &$res( $name, @arg ) // '' if $ref;
444
445
11
8
my( @var, %seen, @rest );
446
11
128
$res =~ s(\$$quote_re?(?:(\d+\b)|([*>_]))) { # $4: numbered arg, $5: special arg
447
27
100
100
81
if( $4 && $4 > @arg ) {
448
2
6
'';
449
} else {
450
25
100
86
push @var, [$1, $2, $3, $5 ? (undef, $5) : $4-1];
451
25
100
52
undef $seen{$4-1} if $4; # make it exist
452
25
84
"\cV$#var\cZ";
453
}
454
}eg;
455
11
100
21
if( @arg > keys %seen ) {
456
2
5
@rest = @arg;
457
2
6
undef $rest[$_] for keys %seen;
458
2
7
@rest = grep defined(), @rest;
459
}
460
11
25
$res =~ s(\cV(\d+)\cZ) {
461
25
17
my @res = @{$var[$1]};
25
56
462
25
50
65
quote $res[0], $res[1], $res[2],
100
100
100
463
$res[4] ? ($res[4] eq '*' ? \@arg :
464
$res[4] eq '>' ? \@rest :
465
$_) :
466
$res[3] < 0 ? $name : $arg[$res[3]];
467
}eg;
468
11
75
$res;
469
}
470
471
my @keys_Table_Columns;
472
sub convert_table_column {
473
33
50
33
0
76
@keys_Table_Columns = keys %Table_Columns unless @keys_Table_Columns;
474
33
0
61
s&(?
0
0
0
50
475
476
33
100
51
unless( $table_re ) {
477
2
6
$table_re = join '|', keys %Table_Columns;
478
2
50
11
$table_re = $table_re ? qr/\b(?:$table_re)\b/ : qr/\s\b\s/;
479
}
480
33
50
45
unless( $error ) {
481
33
26
my %column;
482
33
227
for( grep /$table_re/io, split /\W+/ ) {
483
0
0
undef $column{$_} for @{$Table_Columns{$_}};
0
0
484
}
485
33
54
my @column = keys %column;
486
33
50
57
s/(^|.&|[-+\s(,;|])?(?
1
50
3
50
487
}
488
}
489
490
491
=head2 convert
492
493
This function takes a short-hand query in C<$_> and transforms it to SQL. See
494
L for more run time oriented features.
495
496
=head3 C<:\I(I)> E or E C<:\I%I(I)>
497
498
This is a special macro that transforms odd lists to SQL syntax. It takes a
499
list of unquoted strings and quotes each one of them in various ways. The
500
syntax is inspired by the Shell single character quote and Perl's C<\(...)>
501
syntax. The I is a combination of an optional I (set up with the
502
Perl function C), followed by an optional I that extends the named
503
spec. The I can get split on a variety of one or even simultaneously
504
various characters, which you can give in any order in the I:
505
506
=over
507
508
=item C<\> (backslash)
509
510
This one isn't a character to split on, but rather prevents trimming the
511
whitespace of both ends of the resulting strings.
512
513
=item C<,> (comma), the default
514
515
You only need to specify it, if you want to split on commas, as well as other
516
characters, at the same time. Where the C<\> (backslash) syntax is also used,
517
when given a list, there is no default splitting of list members:
518
L
519
code>}>|/Perl-code-or-:-namespec-Perl-code-or-:-namespec-join-Perl-code> and
520
L C<$\*> &
521
C<$\E>. In that case you must specify it, if needed, e.g. C<$\,*>.
522
523
=item C> (space)
524
525
This one stands for any single whitespace. Since strings are normally
526
trimmed, it's the equivalent of what the Shell does. But, if you combine it
527
with C<\>, which prevents trimming, you will get an empty string between each
528
of multiple whitespaces.
529
530
=item C<-> (minus)
531
532
=item C<:> (colon)
533
534
=item C<;> (semicolon)
535
536
=item C<.> (period)
537
538
=item C (slash)
539
540
=back
541
542
The I can also contain several of these characters to prevent certain
543
strings from being quoted:
544
545
=over
546
547
=item C<#> (hash)
548
549
All numbers, including signed, floats, binary and hexadecimal stay literal.
550
If you use C<-> as a separator, there can be no negative numbers.
551
552
=item C (question mark)
553
554
The boolean values C and C stay literal.
555
556
=item C<ω> (omega) E or E C<^> (caret)
557
558
The value C stays literal. Note that C<ω> is also a word character,
559
that would be part of a name at the beginning of I. It is only the
560
C-symbol following some non-word character, e.g. C<,> (comma).
561
562
=item C<@> (at sign)
563
564
Variables C<@name> stay literal.
565
566
=item C (exclamation mark)
567
568
Everything, presumed valid sql syntax, stays literal.
569
570
=back
571
572
And you can give at most one I for the quotes to use:
573
574
=over
575
576
=item C<'> (quote), the default
577
578
=item C<"> (double quote)
579
580
=item C<`> (backquote)
581
582
=item C<[]> (brackets)
583
584
=item C<{}> (braces)
585
586
In the latter two cases, the closing quotes are optional, for decoration only,
587
or if code completion adds them.
588
589
=back
590
591
The results are joined by comma, unless I is given. E.g. C<:\(a,b,
592
c,NULL,true,-1.2)> gives C<'a','b','c','NULL','true','-1.2'>, while
593
C<:\:"/\#?0(a:b/ c:NULL:true/-1.2)> gives C<"a","b"," c",NULL,true,-1.2> and
594
C<:\ !%&&(a b Ec)> gives C.
595
596
597
598
=head3 C<:I>
599
600
These are mostly simple text-replacements stored in C<%Macros>. Unlike
601
L|/namespec-strings-or-:-namespec-join-strings> these do not take arguments.
602
There are also some dynamic macros. Those starting with C<:j> (join) or
603
C<:lj> (left join) may continue into a L
604
without the leading C<#>. E.g. C<:ljtbl#t> might expand to C
605
t>.
606
607
Those starting with C<:gb> (group by) or C<:ob> (order by) may be followed by
608
result columns numbers from 1-9, each optionally followed by a or d for asc or
609
desc. E.g. C<:ob2d3> gives C.
610
611
=head3 C<:+I> E or E C<:I+I> E or E C<:-I> E or E C<:I-I>
612
613
These are time calculation macros, where an optional leading letter indicates
614
a base time, and an optional trailing letter with an optional count means the
615
offset. The letters are:
616
617
=over
618
619
=item y
620
621
(this) year(start). E.g. C<:y+2m> is march this year.
622
623
=item q
624
625
(this) quarter(start). E.g. C<:q+0> is this quarter, C<:q+q> is next quarter.
626
627
=item m
628
629
(this) month(start). E.g. C<:-3m> is whatever precedes, minus 3 months.
630
631
=item w
632
633
(this) week(start). E.g. C<:w+3d> is this week thursday (or wednesday if you
634
set C<$weekstart> to not follow ISO 8601 and the bible).
635
636
=item d
637
638
(this) day(start). E.g. C<:d-w> is midnight one week ago.
639
640
=item h
641
642
(this) hour(start). E.g. C<:h+30M> is half past current hour.
643
644
=item M
645
646
(this) minute(start). E.g. C<:+10M> is whatever precedes, plus 10min.
647
648
=item s
649
650
(this) second. E.g. C<:s-2h> is exactly 2h ago.
651
652
=back
653
654
655
=head3 C<:{I}> E or E C<:\I{I}> E or E C<:\I%I{I}>
656
657
This gets replaced by what it returns in list context. Undefined elements get
658
rendered as C and they all get joined by I or else C<,> (comma).
659
They can become quoted like
660
L|/namespec-strings-or-:-namespec-join-strings>. Since the result is
661
already a list, the elements don't get split by default. If you want that,
662
you must specify it as in C<:\,{I}>.
663
664
665
=head3 C<#I> E or E C<#I#> E or E C<#I#I>
666
667
Here I is a key of C<%Tables> or any abbreviation of known tables in
668
C<@Tables>. If followed by C<#>, the abbreviation is used as an alias, unless
669
an I directly follows, in which case that is used.
670
671
672
=head3 C<.I or E C<.I or E C<.I>
673
674
Here I
675
recognized in the query. If followed by C<.>, the abbreviation is used as an
676
alias, unless an I directly follows, in which case that is used. It tries
677
to be clever about whether the 1st C<.> needs to be preserved, i.e. following
678
a table name.
679
680
=head3 C(> E or E C\I(I)> E
681
or E C\I%I(I)>
682
683
Here I is a key of C<%Functions> or any
684
abbreviation of known functions in C<@Functions>, which includes words
685
typically followed by an opening parenthesis, such as C for C.
686
C becomes C, whereas C becomes C.
687
688
If the 2nd or 3rd form is used, the I inside of the parentheses are treated
689
just like C(I)|/namespec-strings-or-:-namespec-join-strings>>,
690
but in this case preserving the parentheses.
691
692
If the 1st argument of a function is empty and the abbrev or function is found
693
in C<%DefaultArguments> the value becomes the 1st argument.
694
E.g. C or C both become
695
C.
696
697
=head3 Abbreviated Keyword
698
699
Finally it picks on the structure of the statement: These keywords can be
700
abbreviated: C, C, C or C. If none of
701
these or C is present, C is assumed as default (more keywords
702
need to be recognized in the future).
703
704
For C, semicolons are alternately replaced by C (the 1st being
705
optional if it starts with a table name) and C. If no result columns
706
are given, they default to C<*>, see L. For C, semicolons
707
are frst replaced by C and then C.
708
709
=cut
710
711
sub convert {
712
18
18
1
2269
my @strings; # extract strings to prevent following replacements inside.
713
18
32
until( $error ) {
714
# Handle :\...{perl}
715
next if
716
28
100
100
464
s(:$quote_re?$perl_re){
717
7
100
278
my @ret = map $_ // 'NULL', eval substr $4, 1, -1; # strip {}
718
7
50
18
$error = 1, warn $@ if $@;
719
7
12
quote $1, $2, $3, \@ret;
720
}ego
721
722
# Handle function\...(str1, str2, str3) and :\...(str1, str2, str3)
723
or
724
s<(?:\b(\w+)|:)$quote_re\((.+?)\)> {
725
8
100
19
($1 ? "$1(" : '') .
100
726
quote( $2, $3, $4, $5 ) .
727
($1 ? ')' : '')
728
}ge;
729
730
# extract quoted strings
731
26
91
while( /\G.*?(['"`[{])/gc ) {
732
76
66
143
my $rq = $rq{$1}||$1;
733
76
73
my $pos = pos;
734
76
396
while( /\G.*?([$rq\\])/gc ) {
735
92
100
338
if( $1 eq '\\' ) {
100
736
5
18
++pos; # skip next
737
} elsif( ! /\G$rq/gc ) { # skip doubled quote
738
76
210
push @strings,
739
substr $_, $pos - 1, 1 - $pos + pos, # get string
740
"\cS".@strings."\cZ"; # and replace with counter
741
76
329
last;
742
}
743
}
744
}
745
746
# \todo (?(?<=\w)\b)
747
next if
748
26
100
110
s&:($timespec_re[+-]\d*$timespec_re(?(?<=\w)\b)|l?j\w+(?:#(\w*))|\w+)&find $1, ':', '', %Macros&ego;
23
33
749
18
17
last;
750
}
751
752
18
50
47
my $was_column = /^\./ or # Avoid next assumption when 1st column name is also a table name.
753
s&^(?=#)&;&; # Assume empty fieldlist before table name
754
18
22
&convert_table_column;
755
18
50
95
s&^(?=$table_re)&;& unless $was_column; # Assume empty fieldlist before table name
756
757
18
50
33
62
s&\b(\w+)\((?=\s*([,)])?)&my $fn = find $1, '', '(', %Functions, @Functions; ($fn || $1).'('.($2 and $DefaultArguments{$1} || $DefaultArguments{$fn} or '')&eg unless $error;
13
50
21
13
116
758
#s&\b(\w+)(?=\()&find $1, '', '(', %Functions, @Functions or $1&eg unless $error;
759
760
18
50
24
return if $error;
761
18
24
s/\A\s*;/*;/;
762
18
24
s/;\s*\Z//;
763
18
50
34
if( s/^upd(?:a(?:t(?:e)?)?)?\b/update/i ) {
764
0
0
0
s/(?
765
} else {
766
18
55
s/(?
767
18
50
33
112
s/^ins(?:e(?:r(?:t)?)?)?\b/insert/i ||
768
s/^del(?:e(?:t(?:e)?)?)?\b/delete/i ||
769
s/^(?!se(?:lec)?t)/select /i;
770
}
771
772
18
27
s/ $//mg;
773
18
34
s/ {2,}/ /g;
774
18
110
s/\cS(\d+)\cZ/$strings[$1]/g; # put back the strings
775
776
18
46
1;
777
}
778
779
780
# escape map for special replacement characters
781
my %esc = map { $_ eq 'v' ? "\013" : eval( qq!"\\$_"! ), "\\$_" } qw'0 a b e f n r t v \ "';
782
783
# With an argument of total number of rows, init output counting and return undef if it is to be skipped (not stdout).
784
# Without an argument, do the counting and return undef if no more rows wanted.
785
{
786
my( $total, $cnt, $i );
787
sub count(;$) {
788
16
100
16
0
27
if( @_ ) {
789
11
9
$total = $_[0];
790
11
9
$cnt = 0;
791
11
9
$i = 100;
792
11
100
38
return select eq 'main::STDOUT' ? 1 : undef;
793
}
794
5
4
++$cnt;
795
5
50
33
11
if( --$i <= 0 && $cnt < $total ) {
796
0
0
printf STDERR "How many more, * for all, or q to quit? (%d of %d) [default: 100] ",
797
$cnt, $total;
798
0
0
$i = <>;
799
0
0
0
if( defined $i ) {
800
0
0
$i =~ tr/qQxX \t\n\r/0000/d;
801
0
0
0
$i = (0 == length $i) ? 100 :
0
0
802
$i eq '*' ? ~0 :
803
$i == 0 ? return :
804
$i;
805
} else {
806
0
0
print "\n";
807
0
0
return;
808
}
809
}
810
5
15
1;
811
}
812
}
813
814
sub render_csv($;$$) {
815
6
6
0
1202
my( $sth, $filter ) = @_;
816
my( $semi, $tab ) =
817
(exists $_[2]{semi},
818
exists $_[2]{tab})
819
6
100
18
if $_[2];
820
6
6
my $name = $sth->{NAME};
821
6
14
my @row = @$name;
822
6
4
while() {
823
18
22
for( @row ) {
824
162
100
141
if( defined ) {
825
156
100
100
793
$_ = qq!"$_"! if
100
66
100
66
826
/\A\Z/ or
827
s/"/""/g or
828
$semi ? tr/;\n// : $tab ? tr/\t\n// : tr/,\n// or
829
/\A=/;
830
} else {
831
6
7
$_ = '';
832
}
833
162
190
utf8::decode $_;
834
}
835
18
100
57
print join( $semi ? ';' : $tab ? "\t" : ',', @row ) . "\n";
100
836
837
21
100
29
FETCH:
838
@row = $sth->fetchrow_array
839
or last;
840
15
100
100
241
$filter->( $name, @row ) or goto FETCH if $filter;
841
}
842
}
843
844
our $NULL = 'ω';
845
utf8::decode $NULL;
846
my( $r1, $r2, $r3, $r5 ) = ('[01]\d', '[0-2]\d', '[0-3]\d', '[0-5]\d');
847
sub render_table($;$$) {
848
17
17
0
3929
my( $sth, $filter ) = @_;
849
my( $null, $crlf, $date, $time ) =
850
exists $_[2]{all} ?
851
('NULL', 1, 1, 1) :
852
(exists $_[2]{NULL} ? 'NULL' : exists $_[2]{null} ? 'null' : 0,
853
exists $_[2]{crlf},
854
exists $_[2]{date},
855
exists $_[2]{time})
856
17
100
72
if $_[2];
50
100
100
857
17
66
48
$null ||= $NULL;
858
17
28
my @name = @{$sth->{NAME}};
17
39
859
17
34
my @len = (0) x @name;
860
17
14
my( @txt, @res, @comp );
861
17
27
while( my @res1 = $sth->fetchrow_array ) {
862
80
100
50
417
$filter->( \@name, @res1 ) or next if $filter;
863
80
93
for my $i ( 0..$#res1 ) {
864
580
100
1431
if( !defined $res1[$i] ) {
100
865
4
6
$res1[$i] = $null;
866
} elsif( $res1[$i] !~ /^\d+(?:\.\d+)?$/ ) {
867
537
329
$txt[$i] = 1;
868
537
100
642
$res1[$i] =~ s/\r\n/\\R/g unless $crlf;
869
537
433
$res1[$i] =~ s/([\t\n\r])/$esc{$1}/g;
870
4
4
22614
no warnings 'uninitialized';
4
7
4
12238
871
537
100
525
unless( $date ) {
872
215
100
633
if( $res1[$i] =~ s/^(\d{4}-)($r1)-0[01]([T ]$r2:$r5(?::$r5(?:[.,]\d{3})?)?(?:Z|[+-]$r2:$r5)?)?$/$1/o ) {
873
109
100
191
$res1[$i] .= "$2-" if $2 > 1;
874
109
100
193
$res1[$i] .= $3 if $3;
875
}
876
}
877
537
100
539
unless( $time ) {
878
215
100
847
if( $res1[$i] =~ s/^(\d{4}-(?:$r1-(?:$r3)?)?[T ])?($r2):($r5)(?::($r5)(?:([.,])(\d{3}))?)?(Z|[+-]$r2:$r5)?$/$1/o ) {
879
170
100
295
$res1[$i] = $1 || '';
880
170
100
66
750
if( $2 == 23 && $3 == 59 && ($4 // 59) == 59 && ($6 // 999) == 999 ) {
100
100
100
66
100
100
33
881
49
46
$res1[$i] .= "24:";
882
} elsif( $6 > 0 ) {
883
24
46
$res1[$i] .= "$2:$3:$4$5$6";
884
} elsif( $4 > 0 ) {
885
12
17
$res1[$i] .= "$2:$3:$4";
886
} elsif( $3 > 0 ) {
887
12
14
$res1[$i] .= "$2:$3";
888
} else {
889
73
78
$res1[$i] .= "$2:";
890
}
891
170
100
312
($res1[$i] .= $7) =~ s/:00$/:/
892
if $7;
893
}
894
}
895
537
611
utf8::decode $res1[$i];
896
}
897
580
100
681
$txt[$i] = 0 if @txt < $i;
898
580
392
my $len = length $res1[$i];
899
580
100
764
$len[$i] = $len if $len[$i] < $len;
900
}
901
80
100
86
if( @comp ) {
902
71
80
for my $i ( 0..$#comp ) {
903
509
100
100
791
undef $comp[$i] if defined $comp[$i] && $comp[$i] ne $res1[$i];
904
}
905
} else {
906
9
19
@comp = @res1;
907
}
908
80
176
push @res, \@res1;
909
}
910
17
100
87
if( @res ) {
911
9
100
19
@comp = () if @res == 1;
912
9
10
my $fmt = '';
913
9
17
for( my $i = 0; $i < @name; ++$i ) {
914
71
57
$name[$i] =~ s/\r\n/\\R/g;
915
71
65
$name[$i] =~ s/([\t\n\r])/$esc{$1}/g;
916
71
50
75
if( defined $comp[$i] ) {
917
0
0
my $more;
918
0
0
while( defined $comp[$i] ) {
919
0
0
0
printf $fmt, @name[0..$i-1] unless $more;
920
0
0
$more = 1;
921
0
0
printf "[%s=%s]", $name[$i], $comp[$i];
922
0
0
@name[0..$i] = ('') x ($i+1);
923
0
0
for my $row ( \@comp, \@name, \@len, \@txt, @res ) {
924
0
0
splice @$row, $i, 1;
925
}
926
}
927
0
0
print "\n";
928
0
0
--$i, next;
929
}
930
71
100
79
if( $len[$i] < length $name[$i] ) {
931
9
42
printf "$fmt%s\n", @name[0..$i];
932
9
25
@name[0..$i] = ('') x ($i+1);
933
}
934
71
100
145
$fmt .= '%' . ($txt[$i] ? -$len[$i] : $len[$i]) . 's|';
935
}
936
9
10
$fmt .= "\n";
937
9
100
44
printf $fmt, @name if $name[-1];
938
9
66
printf $fmt, map '-'x$_, @len;
939
9
21
my $count = count @res; # init
940
9
12
for my $row ( @res ) {
941
80
197
printf $fmt, @$row;
942
80
100
50
174
defined count or last if defined $count;
943
}
944
}
945
}
946
947
my $yaml_re = join '', sort keys %esc;
948
$yaml_re =~ s!\\!\\\\!;
949
my $tabsize = $ENV{TABSIZE} || 8;
950
sub render_yaml($;$$) {
951
2
2
0
396
my( $sth, $filter ) = @_;
952
2
2
my @label; # Fill on 0th round with same transformation as data (but \n inline)
953
2
100
4
my $count = count $DBI::rows || 1; # init \todo don't know how many unfiltered
954
2
3
my @row = @{$sth->{NAME}};
2
7
955
2
2
while() {
956
6
3
local $_;
957
6
6
my $i = 0;
958
6
9
for( @row ) {
959
54
100
66
216
if( !defined ) {
100
50
100
100
960
2
2
$_ = '~';
961
} elsif( /^(?:y(?:es)?|no?|true|false|o(?:n|ff)|-?\.inf|\.nan)$/s ) { # can only be string in Perl or DB
962
0
0
$_ = "'$_'";
963
} elsif( tr/][{},?:`'"|<>&*!%#@=~\0-\010\013-\037\177-\237-// or @label ? 0 : tr/\n// ) {
964
15
48
s/([$yaml_re])/$esc{$1}/go;
965
15
16
s/([\0-\010\013-\037\177-\237])/sprintf "\\x%02x", ord $1/ge;
0
0
966
15
18
$_ = qq!"$_"!;
967
} elsif( tr/\n// ) {
968
1
2
my $nl = chomp;
969
1
3
s/^/ /mg;
970
1
50
3
substr $_, 0, 0, $nl ? "|2\n" : "|2-\n";
971
}
972
54
100
117
print "$label[$i++]$_\n" if @label;
973
}
974
6
100
9
if( @label ) {
975
4
50
50
11
defined count or last if defined $count;
976
} else {
977
2
3
my $maxlen = 0;
978
2
3
for( @row ) {
979
18
100
25
substr $_, 0, 0, $maxlen ? ' ' : '- '; # 1st field if no maxlen yet
980
18
12
my $length = 0;
981
18
100
73
$length += $1 ? $tabsize - $length % $tabsize : length $2
982
while /\G(?:(\t)|([^\t]+))/gc;
983
18
22
$_ .= ": $length";
984
18
100
28
$maxlen = $length if $maxlen < $length;
985
}
986
18
57
s/(\d+)\Z/' ' x ($maxlen - $1)/e
987
2
13
for @label = @row;
988
}
989
7
100
17
FETCH:
990
@row = $sth->fetchrow_array
991
or last;
992
5
100
100
72
$filter->( $sth->{NAME}, @row ) or goto FETCH if $filter;
993
}
994
}
995
996
sub render__create($;$$) {
997
0
0
0
0
0
my @row = $_[0]->fetchrow_array
998
or return;
999
0
0
0
my $col = $_[0]{NAME}[0] =~ /Function|Procedure/i ? 2 : 1;
1000
0
0
0
if( @row > $col ) {
1001
0
0
$col = $row[$col];
1002
0
0
0
$col =~ s/,/,\n/g if $_[0]{NAME}[0] =~ /View/i;
1003
0
0
say $col;
1004
}
1005
}
1006
1007
1008
1009
my $lasttime = time;
1010
sub run($;$\%) {
1011
13
13
0
16
my( $sql, $filter, $opt ) = @_;
1012
13
35
my $t0 = [gettimeofday];
1013
13
50
33
55
if( $DBI::err || $t0->[0] - $lasttime > 3600 and !$dbh->ping ) {
33
1014
0
0
printf STDOUT "Inactive for %ds, ping failed after %.03fs, your session variables are lost.\n",
1015
$t0->[0] - $lasttime, tv_interval $t0;
1016
#$dbh->disconnect;
1017
0
0
$dbh = $dbh->clone; # reconnect
1018
0
0
$t0 = [gettimeofday];
1019
}
1020
13
9
$lasttime = $t0->[0];
1021
13
50
70
if( my $sth = UNIVERSAL::isa( $sql, 'DBI::st' ) ? $sql : $dbh->prepare( $sql )) {
50
1022
13
143
my $t1 = [gettimeofday];
1023
13
24
$sth->execute;
1024
13
33
printf STDOUT "prepare: %.03fs execute: %.03fs rows: %d\n",
1025
tv_interval( $t0, $t1 ), tv_interval( $t1 ), $DBI::rows;
1026
13
50
297
if( $sth->{Active} ) {
1027
13
100
16
if( $render ) {
1028
4
8
&$render( $sth, $filter, $opt );
1029
} else {
1030
9
17
render_table $sth, $filter, $opt;
1031
}
1032
}
1033
}
1034
}
1035
1036
1037
=head2 shell
1038
1039
This function reads, converts and (if C<$dbh> is set) runs in an end-less loop
1040
(i.e. till end of file or C<^D>). Reading is a single line affair, unless you
1041
request otherwise. This can happen either, as in Unix Shell, by using
1042
continuation lines as long as you put a backslash at the end of your lines.
1043
Or there is a special case, if the 1st line starts with C<\\>, then everything
1044
up to C<\\> at the end of one of the next lines, constitutes one entry.
1045
1046
In addition to converting, it offers a few extra features, performed in this
1047
order (i.e. C<&I> can return C/=I> etc.):
1048
1049
=head3 C<&{I} I>
1050
1051
Run I. It sees the optional I in C<$_> and may
1052
modify it. If it returns C, this statement is skipped. If it returns
1053
a DBI statement handle, run that instead of this statement. Else replace with
1054
what it returns.
1055
1056
Reprocess result as a shell entry (i.e. it may return another C<&I>).
1057
1058
=head3 C<&I; ...> E or E C<&I( I; ... ) I>
1059
1060
These allow canned entries and are more complex than macros, in that they take
1061
arguments and replacement can depend on the argument.
1062
1063
Reprocess result as a shell entry (i.e. it may return another C<&I>).
1064
1065
You can define your own canned queries with:
1066
1067
C< &{ Query I =E 'I', 'I' }>
1068
1069
Here C becomes the replacement string for C<&name>. It may contain
1070
arguments a bit like the Shell: C<$0> (I), C<$*> (all arguments), C<$1,
1071
$2, ..., $10, ...> (individual arguments) and C<$E> (all arguments not
1072
adressed individually). They can become quoted like
1073
L|/namespec-strings-or-:-namespec-join-strings> as
1074
C<$\II> or C<$\I%II>. Here I is
1075
C<*>, C> or a number directly tacked on to I or I. E.g.:
1076
C<$\-"1> splits the 1st (semi-colon separated from the 2nd) argument itself on
1077
C<-> (minus), quotes the pieces with C<"> (double quote) and joins them with
1078
C<,> (comma). The two list variables C<$\*> & C<$\E> don't get split
1079
individually unless explicitly specified, e.g. C<$\,*>. Putting the quotes
1080
inside the argument like this, eliminates them, if no argument is given.
1081
1082
=head3 C/ I> E or E C/i I> E or E C/ I> E or E C/i I>
1083
1084
This will treat the I normally, but will join each output row into
1085
a C<~> (tilde) separated string for matching. NULL fields are rendered as
1086
that string. E.g. to return only rows starting with a number 1-5, followed by
1087
a NULL field, you could write: C.
1088
1089
With a suffix C, matching becomes case insensitive. This is why the mostly
1090
optional space before I is shown above. Without an C, but if
1091
the statement starts with the word C (e.g. your first column name), you
1092
must separate it with a space. With an C, if the statement starts with an
1093
alphanumeric caracter, you must separate it with a space.
1094
1095
Only matching rows are considered unless there is a preceding C
1096
(exclamation mark), in which case only non-matching rows are considered.
1097
1098
You can provide your own formatting of the row by setting C<$regexp_fail> to a
1099
Perl sub that returns a Perl expression as a string. That expression takes
1100
the row in C<@_> and shall be true if the row fails to match.
1101
1102
Caveat: the whole result set of the I gets generated and
1103
transferred to the client. This is definitely much more expensive than doing
1104
the equivalent filtering in the where clause. But it is not a big deal for
1105
tens or maybe hundreds of thousands or rows, probably still faster than
1106
writing the corresponding SQL. And Perl's regexps are so much more powerful.
1107
1108
=head3 C<{I}I>
1109
1110
Call I for every output row returned by the I with the
1111
array of column names as zeroth argument and the values after that (i.e.
1112
numbered from 1 like in SQL). It may modify individual values. If it returns
1113
false, the row is skipped.
1114
1115
You may combine S/{I}>> in any order and as many of them as
1116
you want.
1117
1118
The same caveat as for regexps applies here. But again Perl is far more
1119
powerful than any SQL functions.
1120
1121
=head3 C<=I>
1122
1123
A preceding C<=> prevents conversion, useful for hitherto untreated keywords
1124
or where the conversion doesn't play well with your intention.
1125
1126
=head3 C
1127
1128
Help prefix. Alone it will give an overview. You can follow up with any of
1129
the special syntaxes, with or without an abbreviation. E.g. C will show
1130
all function abbreviations, whereas C(> will show only those functions
1131
matching I or C> only those tables matching I.
1132
1133
=head3 C>
1134
1135
Will convert and show, but not perform I. If C<$dbh> is not set, this
1136
is the default behaviour.
1137
1138
=head3 C>
1139
1140
Run I.
1141
1142
=head3 CI> E or E CEI>
1143
1144
Redirect or append next statement's output to I. For known
1145
suffixes and options, see the L.
1146
1147
=head3 C<|I>
1148
1149
Pipe next statement's output through I.
1150
1151
=head2 Output Formats
1152
1153
The output format for the next SQL statement that is run, is chosen from the
1154
suffix of a redirection or a special suffix query. In both cases
1155
comma-separated options may be passed:
1156
1157
=over
1158
1159
=item >I.I
1160
1161
=item >I.I( I; ... )
1162
1163
=item >>I.I
1164
1165
=item >>I.I( I; ... )
1166
1167
=item &.I; ...
1168
1169
=item &.I( I; ... ) following text
1170
1171
=back
1172
1173
The known suffixes and their respective options are:
1174
1175
=over
1176
1177
=item C<.csv>
1178
1179
This writes Comma Separated Values with one subtle trick: NULL and empty
1180
strings are distinguished by quoting the latter. Some tools like Perl's file
1181
DB L or rather its underlying L can pick that up. CSV
1182
can take one of these options:
1183
1184
=over
1185
1186
=item semi
1187
1188
Use a semicolon as a separator. This is a common format in environments where
1189
the comma is the decimal separator. However if you want decimal commas, you must
1190
provide such formatting yourself.
1191
1192
=item tab
1193
1194
Use tabulators as column separators. Apart from that you get the full CSV
1195
formatting, so this is not the primitive F<.tsv> format some tools may have.
1196
1197
=back
1198
1199
1200
=item C<.table>
1201
1202
This is the default table format. But you need to name it, if you want to set
1203
options.
1204
1205
=over
1206
1207
=item all
1208
1209
This is a shorthand for outputting everything in the long form, equivalent to
1210
C<( NULL, crlf, date )>.
1211
1212
=item crlf
1213
1214
Do not shorten C<\r\n> to C<\R>.
1215
1216
=item date
1217
1218
Output ISO dates fully instead of shortening 0000-00-00 to 0000- and
1219
yyyy-01-01 to yyyy- or yyyy-mm-01 to yyyy-mm-.
1220
1221
=item time
1222
1223
Output times fully instead of shortening 23:59(:59) to 24: and hh:00(:00) to
1224
hh: or hh:mm(:00) to hh:mm.
1225
1226
=item NULL
1227
1228
=item null
1229
1230
Output this keyword instead of the shorter C<ω> from DB theory (or whatever
1231
you assigned to C<$NULL>).
1232
1233
=back
1234
1235
1236
=item C<.yaml>
1237
1238
=item C<.yml>
1239
1240
Format output as YAML. This format has no options. Because its every value
1241
on a new line format can be more readable, there is a shorthand query C<&->
1242
for it.
1243
1244
=back
1245
1246
=cut
1247
1248
our $prompt = 'steno> ';
1249
our $contprompt = '...> ';
1250
our $echo;
1251
# Called for every leading re, 1st arg is the optional '!', 2nd arg '/re/' or '/re/i'. Expression shall be true for non-matching lines.
1252
our $regexp_fail = sub($$) { 'join( "~", map ref() ? () : $_ // q!NULL!, @_ )' . ($_[0] ? '=~' : '!~') . $_[1] };
1253
sub shell() {
1254
1
1
1
815
print STDERR $prompt;
1255
1
2
my $fh;
1256
1
18
while( <> ) {
1257
22
17
undef $error;
1258
22
100
64
goto NEXT unless /\S/;
1259
20
100
43
if( s/^\s*\\\\\s*// ) {
1260
1
6
s/\s*\Z/\n/s;
1261
1
5
local $/ = "\\\\\n"; # leading \n gets chopped below
1262
1
2
$_ .= <>;
1263
1
3
chomp;
1264
} else {
1265
19
57
while( s/(?
1266
1
1
print STDERR $contprompt;
1267
1
4
$_ .= <>;
1268
}
1269
19
27
s/\A\s+//;
1270
}
1271
20
72
s/\s+\Z//;
1272
20
50
58
say if $echo;
1273
20
25
until( $error ) {
1274
36
100
134
if( s!^&$perl_re!! ) {
1275
3
191
my $perl = eval $1;
1276
3
12
local $| = 1; # flush to avoid stderr prompt overtaking last output line.
1277
3
50
8
warn $@ if $@;
1278
3
50
15
if( UNIVERSAL::isa $perl, 'DBI::st' ) {
100
1279
0
0
$_ = $perl;
1280
0
0
goto RUN;
1281
} elsif( defined $perl ) {
1282
1
7
substr $_, 0, 0, $perl;
1283
} else {
1284
2
13
goto NEXT;
1285
}
1286
} else {
1287
last unless
1288
33
100
100
136
s!^&(\.?\w+|-)(\(((?:(?>[^()]+)|(?2))*)\))!convert_Query $1, $3!e
3
7
1289
12
20
or s!^&(\.?\w+|-) *(.*)!convert_Query $1, $2!e;
1290
}
1291
}
1292
1293
18
19
my $filter = '';
1294
18
100
134
while( s/^\s*$perl_re// || s%^\s*(!?)(/.+?/(?:i\b)?)\s*%% ) {
1295
9
100
15
if( defined $2 ) {
1296
3
6
$filter .= 'return if ' . $regexp_fail->( $1, $2 ) . ";\n";
1297
} else {
1298
6
39
$filter .= "return unless eval $1;\n";
1299
}
1300
}
1301
18
100
25
if( $filter ) {
1302
7
631
$filter = eval "sub {\n$filter 1; }";
1303
7
50
15
warn $@ if $@;
1304
}
1305
18
100
60
goto RUN if s/^\s*=//; # run literally
1306
1307
13
13
my $skip = 0;
1308
13
100
24
if( /^\s*\?\s*(?:([?&#.:\\])(\w*)|(\w*)\()?/ ) { # help
1309
3
50
33
15
if( $1 && $1 eq '?' ) {
1310
0
0
s/^\s*\?\s*\?//;
1311
0
0
$skip = 1;
1312
} else {
1313
3
9
help( $1, $2, $3 );
1314
3
13
goto NEXT;
1315
}
1316
}
1317
10
50
16
if( s/^\s*!// ) {
1318
0
0
system $_;
1319
0
0
0
if( $? == -1 ) {
0
1320
0
0
print STDERR "failed to execute: $!\n";
1321
} elsif( my $exit = $? & 0b111_1111 ) {
1322
0
0
0
printf STDERR "child died with signal %d, with%s coredump\n",
1323
$exit, ($? & 0b1000_0000) ? '' : 'out';
1324
} else {
1325
0
0
printf STDERR "child exited with value %d\n", $? >> 8;
1326
}
1327
0
0
goto NEXT;
1328
}
1329
10
29
s/^\s*()//; # dummy because $1 survives loop iterations :-o
1330
10
50
31
if( /\A(>{1,2})\s*(.+?(\.\w+)?)(?:\((.*)\))?\s*\Z/ ) { # redirect output
50
1331
0
0
0
set_render $3, $4 ? split ';', $4 : () if $3;
0
1332
0
0
open $fh, "$1:utf8", (glob $2)[0];
1333
0
0
select $fh;
1334
0
0
goto NEXT;
1335
} elsif( /\A\|(.+)\Z/ ) { # pipe output
1336
0
0
open $fh, '|-:utf8', $1;
1337
0
0
select $fh;
1338
0
0
goto NEXT;
1339
}
1340
1341
10
8
undef $error;
1342
1343
10
100
66
21
goto NEXT unless $_ && &convert;
1344
1345
8
28
print STDOUT "$_;\n";
1346
8
50
14
goto NEXT if $skip;
1347
1348
13
50
38
RUN:
1349
run $_, $filter, %opt if $dbh;
1350
13
55
($render, %opt) = ();
1351
13
50
20
if( $fh ) {
1352
0
0
close;
1353
0
0
select STDOUT;
1354
0
0
undef $fh;
1355
}
1356
NEXT:
1357
22
157
print STDERR $prompt;
1358
}
1359
1
99
print STDERR "\n";
1360
}
1361
1362
1363
1364
sub helphashalt(\%@) {
1365
0
0
0
0
my $hash = shift;
1366
0
0
0
if( @_ ) {
1367
0
0
my $ret = $hash->{''};
1368
0
0
print "for *ptr, *cr, *cp, ...:\n";
1369
printf "%-5s %s\n", $_, &$ret( $_ )
1370
0
0
for @_;
1371
0
0
print "\n";
1372
}
1373
$_ eq '' or printf "%-5s %s\n", $_, $hash->{$_}
1374
0
0
0
for sort keys %$hash;
1375
}
1376
sub helphash($$$\%;\@) {
1377
#my( $str, $prefix, $suffix, $hash, $list ) = @_;
1378
3
50
3
0
6
if( $_[0] ) {
1379
3
4
undef $error;
1380
3
50
33
4
$error or printf "%-7s %s\n", "$_[1]$_[0]$_[2]", $_ if $_ = &find;
1381
} else {
1382
0
0
my %hash = %{$_[3]};
0
0
1383
0
0
0
if( my $sub = delete $hash{''} ) {
1384
0
0
my @list = $sub->();
1385
0
0
for my $elt ( @list ) {
1386
0
0
$hash{$elt->[0]} = $sub->( my $name = $elt->[0] ) . ' ' . $elt->[1];
1387
}
1388
}
1389
0
0
chomp %hash;
1390
printf "%-7s %s\n", "$_[1]$_$_[2]", $hash{$_}
1391
0
0
0
for sort { lc( $a ) cmp lc( $b ) or $a cmp $b } keys %hash;
0
0
1392
0
0
0
return unless $_[4];
1393
0
0
my $i = 0;
1394
0
0
0
my @list = sort { lc( $a ) cmp lc( $b ) or $a cmp $b } @{$_[4]};
0
0
0
0
1395
0
0
while( @list ) {
1396
0
0
0
if( ($i += length $list[0]) < 80 ) {
1397
0
0
print ' ', shift @list;
1398
} else {
1399
0
0
$i = 0;
1400
0
0
print "\n";
1401
}
1402
}
1403
0
0
0
print "\n" if $i;
1404
}
1405
}
1406
1407
sub help {
1408
3
50
3
0
19
if( defined $_[2] ) {
50
50
50
100
50
1409
0
0
helphash $_[2], '', '(', %Functions, @Functions;
1410
} elsif( !$_[0] ) {
1411
0
0
print <<\HELP;
1412
All entries are single line unless \\wrapped at 1st bol and last eol\\ or continued.\
1413
Queries have the form: {{!}/regexp/{i}}{=}query
1414
The query has lots of short-hands expanded, unless it is prefixed by the optional =.
1415
The fields joined with '~' are grepped if regexp is given, case-insensitively if i is given.
1416
1417
??query Only shows massaged query.
1418
!perl-code Runs perl-code.
1419
>file Next query's output to file. In csv or yaml format if filename has that suffix.
1420
1421
Query has the form {select|update|insert|delete}{fieldlist};tablelist{;clause} or set ...
1422
'select' is prepended if none of these initial keywords.
1423
fieldlist defaults to '*', also if Query starts with '#'.
1424
';' is alternately replaced by 'from' and 'where'.
1425
1426
Abbreviations, more help with ?&{abbrev}, ?:{abbrev}, ?\{abbrev}, ?#{abbrev}, ?.{abbrev}, ?{abbrev}(
1427
&{Perl code}... # only at bol, if it returns undef then skip, else prepend to ...
1428
&query $1;$2;... # only at bol
1429
&query($1;$2;...)... # only at bol, only replace upto )
1430
:macro
1431
:\quote(arg,...) # split, quote & join (?\ alone needs trailing space, because \ at end continues)
1432
:{Perl code} # dynamic macro
1433
#table #table#t
1434
.column .column.c # for any table recognized in statement
1435
function(
1436
1437
Characters \t\n\r get masked in output, \r\n as \R.
1438
Date or time 0000-00-00 -> 0000- 1970-01-01 -> 1970- 00:00:00 -> 00: 23:59:59 -> 24:
1439
HELP
1440
} elsif( $_[0] eq '#' ) {
1441
0
0
0
@keys_Table_Columns = keys %Table_Columns unless @keys_Table_Columns;
1442
0
0
helphash $_[1], '#', '', %Tables, @keys_Table_Columns;
1443
} elsif( $_[0] eq '.' ) {
1444
0
0
0
helphashalt %Columns, 'ptr' unless $_[1]; # \todo WIN@
1445
0
0
0
0
$error or print "$_\n" if
0
1446
$_[1] and $_ = find $_[1], '.', '', %Columns; # \todo, @column;
1447
} elsif( $_[0] eq '&' ) {
1448
2
50
5
print <<\HELP unless $_[1];
1449
&{ Query name => 'doc', 'query' } define query &name on the fly
1450
query may contain arguments a bit like the Shell: $1, $2, ..., $*
1451
they can become quoted: $\1, $\"2, $\`*, $\[3, $\{}>
1452
$* means all args; $> the remaining args after using up the numbered ones
1453
if it is quoted, each arg gets quoted, separated by a comma
1454
$?arg?arg-replacement?no-arg-replacement? 1st if $arg has a value
1455
HELP
1456
2
6
helphash $_[1], '&', '', %Queries_help;
1457
} elsif( $_[0] eq '\\' ) {
1458
1
50
3
print <<\HELP unless $_[1];
1459
:\namespec(arg,...) or func\namespec(arg,...) quotes args for you.
1460
&{ Quote name => 'doc', 'namespec' } define quote \name on the fly
1461
namespec may another name and/or any splitter chars (-,:;./ ),
1462
preventer chars (#?ω^\@!), quoting chars ('"`[]{}) and/or
1463
a string to join the results with after a %.
1464
HELP
1465
1
4
helphash $_[1], '\\', '', %Quotes_help;
1466
} else {
1467
0
0
print <<\HELP unless $_[1];
1468
:\(...) split arguments and quote in many ways
1469
HELP
1470
0
local $Tables{TBL} = 'TABLE';
1471
0
helphash $_[1], ':', '', %Macros;
1472
}
1473
}
1474
1475
1;
1476
1477
=head1 YOUR SCRIPT
1478
1479
package SQL::Steno; # doesn't export yet, so get the functions easily
1480
use SQL::Steno;
1481
use DBI;
1482
our $dbh = DBI->connect( ... ); # preferably mysql, but other DBs should work (with limitations).
1483
# If you want #tbl and .col to work, (only) one of:
1484
init_from_query; # fast, defaults to mysql information_schema, for which you need read permission
1485
init; # slow, using DBI dbh methods.
1486
# Set any of the variables mentioned above to get you favourite abbreviations.
1487
shell;
1488
1489
=head1 LICENSE
1490
1491
This program is free software; you may redistribute it and/or modify it under
1492
the same terms as Perl itself.
1493
1494
=head1 SEE ALSO
1495
1496
L, L, L, L, L
1497
1498
=head1 AUTHOR
1499
1500
(C) 2015, 2016 by Daniel Pfeiffer .