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