File Coverage

blib/lib/SQL/Steno.pm

Criterion	Covered	Total	%
statement	319	432	73.8
branch	232	336	69.0
condition	77	132	58.3
subroutine	22	25	88.0
pod	3	19	15.7
total	653	944	69.1

=encoding utf8

=head1 NAME

SQL::Steno - Short hand for SQL and compact output

=head1 SYNOPSIS

Type some short-hand, see the corresponding SQL and its output:

 steno> TABLE1;somecolumn > 2    -- ; after tables means where
 select * from TABLE1 where somecolumn > 2;
 prepare: 0.000s   execute: 0.073s   rows: 14
   id|column1                                    |column2
     |                                           |    |column3
     |                                           |    | |somecolumn
 ----|-------------------------------------------|----|-|-|
   27|foo                                        |    |a|7|
   49|bar                                        |abcd|a|3|
   81|baz\nbazinga\nbazurka                      |jk  |b|9|
 1984|bla bla bla bla bla bla bla bla bla bla bla|xyz |c|5|
 ...
 steno> /abc|foo/#TBL1;.socol > 2    -- /regexp/ grep, #tableabbrev, .columnabbrev
 select * from TABLE1 where somecolumn > 2;
 prepare: 0.000s   execute: 0.039s   rows: 14
 id|column1
   |   |column2
   |   |    |[column3=a]
   |   |    |somecolumn
 --|---|----|-|
 27|foo|    |7|
 49|bar|abcd|3|
 steno> .c1,.c2,.some;#TE1#:ob2d3    -- ; before tables means from, 2nd # alias, :macro
 select column1,column2,somecolumn from TABLE1 TE1 order by 2 desc, 3;
 ...
 steno> n(), yr(), cw(,1,2,3)    -- functionabbrev before (, can have initial default arg
 select count(*), year(now()), concat_ws(',',1,2,3);
 ...
 steno> .col1,.clm2,.sn;#TBL1:jTBL2 u(id);mydate :b :m+3d and :d-w    -- :jTABLEABBREV and :+/- family
 select column1,column2,somecolumn from TABLE1 join TABLE2 using(id) where mydate
 between date_format(now(),"%Y-%m-01")+interval 3 day and curdate()-interval 1 week;
 ...

=head1 DESCRIPTION

You're the command-line type, but are tired of typing C
where CONDITION>, always forgetting the final C<;>?  Output always seems far
too wide and at least mysql cli messes up the format when it includes
newlines?

This module consists of the function C which implements a
configurable ultra-compact language that maps to SQL.  Then there is C
which performs normal SQL queries but has various tricks for narrowing the
output.  It can also grep on whole rows, rather than having to list all fields
that you expect to match.  They get combined by the function C which
converts and runs in an endless loop.

This is work in progress, only recently isolated from a monolithic script.
Language elements and API may change as the need arises, e.g. C<:macro> used
to be C<@macro>, till the day I wanted to use an SQL-variable and noticed the
collision.  In this early stage, you are more than welcome to propose
ammendments, especially if they make the language more powerful and/or more
consistent.  Defaults are for MariaDB/MySQL, though the mechanism also works
with other DBs.

=cut

use v5.16;

package SQL::Steno v0.3.0;

use strict;
use warnings;
use Time::HiRes qw(gettimeofday tv_interval);

binmode STDIN, ':utf8';
binmode STDOUT, ':utf8';

our $dbh;
our $perl_re = qr/(\{(?:(?>[^{}]+)|(?-1))*\})/;
our( %Table_Columns, $table_re );
sub init {
    die "\$dbh is undef\n" unless $dbh;
    local @{$dbh}{qw(PrintWarn PrintError RaiseError)} = (0, 0, 0); # \todo is this right? views can barf because more restrictive.
    for my $table ( @{$dbh->table_info->fetchall_arrayref} ) {
	$Table_Columns{uc $table->[2]} = [];
	splice @$table, 3, -1, '%';
	my $info = $dbh->column_info( @$table ) or next;
	for my $column ( @{$info->fetchall_arrayref} ) {
	    push @{$Table_Columns{$table->[2]}}, uc $column->[3];
	}
    }
    undef $table_re;		# (re)create below
}
our $init_from_query = <<\SQL;
	select ucase(TABLE_NAME), ucase(COLUMN_NAME)
	from information_schema.COLUMNS
	where TABLE_SCHEMA = schema()
SQL
sub init_from_query {
    die "\$dbh is undef\n" unless $dbh;
    local @{$dbh}{qw(PrintWarn PrintError RaiseError)} = (0, 0, 0); # \todo is this right?
    my $sth = $dbh->prepare( $init_from_query );
    $sth->execute;
    $sth->bind_columns( \my( $table, $column ));
    push @{$Table_Columns{$table}}, $column while $sth->fetch;
    undef $table_re;		# (re)create below
}



my %render =
    (csv => \&render_csv,
     table => \&render_table,
     yaml => \&render_yaml,
     yml => \&render_yaml);
my( $render, %opt );

sub set_render($@) {
    ($render, %opt) = ();
    for( @_ ) {
	if( defined $render ) {	# all further args are opts
	    tr/ \t//d;
	    undef $opt{$_};	# make it exist
	} else {
	    $render = substr $_, 1;
	}
    }
    $render = $render{$render};
    '';				# For use as a query
}
our( %Queries_help, %Queries );

for my $fmt ( keys %render ) {
    $Queries_help{".$fmt"} = "   output '&.$fmt() this' or next query as \U$fmt";
    $Queries{".$fmt"} = \&set_render;
}
sub Query {
    $Queries_help{$_[0]} = $_[1];
    $Queries{$_[0]} = $_[2];
    undef;
}
Query @$_ for
    ['-' => "   output next query as YAML",
      '&.yaml'],


    [ps => '   show processlist (without Sleep)',
      '{(${_}[7] // "") ne "Sleep"}=show processlist'],

    [psf => '   show full processlist (without Sleep)',
      '{(${_}[7] // "") ne "Sleep"}=show full processlist'],


    [t => 'unquotedtablename[,unquotedcolumnpattern]   show fields',
      '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'],


    [s => 'var;value   set @var = value',
      'set @$1=$2'],

    [ss => "var;value   set \@var = 'value'",
      'set @$1=$\2'],

    [sd => 'var;value   set @var = cast("value" as date)',
      'set @$1=cast($\2 as date)'],

    [sdt => 'var;value   set @var = cast("value" as datetime)',
      'set @$1=cast($\2 as datetime)'],

    [st => 'var;value   set @var = cast("value" as time)',
      'set @$1=cast($\2 as time)'],

    [sy => '            set @a, @z   yesterday is between @a and @z  (see :baz)',
      #'set @a=date(now())-interval 1 day, @z=date(now())-interval 1 second',
     'select @a:=date(now()-interval 1 day)`@a`, @z:=date(now())-interval 1 second`@z`'];


our $weekstart = 1;		# Monday is the first day of the week as per ISO 8601.
my $timespec_re = qr/[yqmwdhMs]?/;
our %Join_clause;
our %Macros =
   (
    b => ' between',
    baz => ' between @a and @z',
    d => ' distinct',
    h => ' having',
    j => ' join',
    l => ' like',
    lj => ' left join',
    n => ' is null',
    nb => ' not between',
    nc => ' sql_no_cache',
    nl => ' not like',
    nn => ' is not null',
    nr => ' not rlike',
    od => ' on duplicate key update',
    odku => ' on duplicate key update',
    r => ' rlike',
    u => ' union select',
    ua => ' union all select',
    wr => ' with rollup',
    '' => sub {
	my $join = 'for all #TBL matching TABLE';
	my $int = 'see :+  :-  :y-m  :q+0  :d+2h';
	my $gob = 'for 0 or more digits, optionally followed by a or d';
	return ([jTBL => $join], ['jTBL#' => $join], [ljTBL => $join], [1 => 'for all numbers'],
		[gb147 => $gob], [ob2d5a9 => $gob],
		['+' => < $int], ['d+2h' => $int], ['y-m' => $int], ['q+0' => $int])
:B+/-NO this B(ase) +/- N(umber, 0 for none, default 1 if O given) O(ffset)
	 optional B, O is y(ear), q(uarter), m(onth), w(eek), d(ay), h(our), M(inute), s(econd)
INT
	    unless @_;		# help
	for( $_[0] ) {
	    return " limit $_" if /^\d+$/;
	    if( s/^([og])b(?=(?:\d[ad]?)*$)/ $1 eq 'g' ? ' group by ' : ' order by ' /e ) {
		s/(?
		s/a/ asc/g; s/(?
		return $_;
	    }
	    if( s/^(l?)j/#/ ) {	# (l)jtbl: j or lj with any #tbl
		my $left = $1 ? ' left' : '';
		&convert_table_column;
		/^(\w+)/;
		return "$left join $_" . ($Join_clause{$1} || $Join_clause{''} || '');
	    }
	    return $_ if
		s(^($timespec_re)([+-])(\d*)($timespec_re)$) {
		    ({ y => ' date_format(now(),"%Y-01-01")',
		       q => ' date_format(now()-interval mod(month(now())+11,3) month,"%Y-%m-01")',
		       m => ' date_format(now(),"%Y-%m-01")',
		       w => ' curdate()-interval weekday(now())' . ($weekstart ? ' day' : '+1 day'),
		       d => ' curdate()',
		       h => ' date_format(now(),"%F %H:00")',
		       M => ' date_format(now(),"%F %H:%M")',
		       s => ' now()' }->{$1} || '') .
		    ($3 ne '0' &&
		     " $2interval" .
		     ($3 ? " $3" : $4 ? ' 1' : '') .
		     ({ y => ' year',
			q => ' quarter',
			m => ' month',
			w => ' week',
			d => ' day',
			h => ' hour',
			M => ' minute',
			s => ' second' }->{$4} || ''))
		}eo;
	}
    });

# \todo default arg n() -> n(*) time*(now())
our %Functions =
   (
    c => 'concat',
    cw => 'concat_ws',
    coa => 'coalesce',
    gc => 'group_concat',
    i => 'in',			# not really fn, but ( follows
    in => 'ifnull',
    l => 'char_length',
    lc => 'lcase',
    m => 'min',
    M => 'max',
    n => 'count',
    ni => 'not in',		# -"-
    s => 'substring',
    u => 'using',		# -"-
    uc => 'ucase'
   );

# functions where the 1st argument can be now()
my @nowFunctions = qw(
    adddate addtime convert_tz date date_add date_format date_sub datediff day
    dayname dayofmonth dayofweek dayofyear hour last_day minute month
    monthname quarter second subdate subtime time time_format time_to_sec
    timediff timestamp to_days to_seconds week weekday weekofyear year
    yearweek
);
our @Functions = sort @nowFunctions, qw(
    abs acos aes_decrypt aes_encrypt ascii asin atan avg benchmark bin bit_and
    bit_count bit_length bit_or bit_xor cast ceiling char_length char
    character_length charset coalesce coercibility collation compress
    concat_ws concat connection_id conv cos cot count crc32 curdate
    current_date current_time current_timestamp current_user curtime database
    decode default degrees des_decrypt des_encrypt elt encode encrypt exp
    export_set field find_in_set floor format found_rows from_days
    from_unixtime get_format get_lock greatest group_concat hex if ifnull
    inet_aton inet_ntoa insert instr interval is_free_lock is_used_lock isnull
    last_insert_id lcase least left length ln load_file localtime
    localtimestamp locate log10 log2 log lower lpad ltrim make_set makedate
    maketime master_pos_wait max md5 microsecond mid min mod name_const now
    nullif oct octet_length old_password ord password period_add period_diff
    pi position power quote radians rand release_lock repeat replace reverse
    right round row_count rpad rtrim schema sec_to_time session_user sha1 sign
    sin sleep soundex space sqrt stddev stddev_pop stddev_samp str_to_date
    strcmp substring_index substring sum sysdate system_user tan timestampadd
    timestampdiff trim truncate ucase uncompress uncompressed_length unhex
    unix_timestamp upper user utc_date utc_time utc_timestamp uuid values
    var_pop var_samp variance
);

our %DefaultArguments = (
    count => '*',
    concat_ws => "','"
);
$DefaultArguments{$_} = 'now()' for @nowFunctions;


our %Tables;
our %Columns;

sub regexp($$) {
    my( $str, $type ) = @_;
    if( $type < 2 ) {
	return if $str !~ /_/; # Otherwise same as find sprintf cases
	return ($type ? '' : '^') . join '.*?_', split /_/, $str; # 0 & 1
    }
    my $expr = join '.*?', split //, $str; # 2, 3 & 4
    if( $type < 4 ) {
	substr $expr, 0, 0, '^'; # 2 & 3
	$expr .= '$' if $type == 2; # 2
    }
    $expr;
}

my $error;
my @simple = qw(^%s$ ^%s_ ^%s _%s$ _%s %s$ %s_ %s);
sub find($$$\%;\@) {
    my( $str, $prefix, $suffix, $hash, $list ) = @_;
    my $ret = $hash->{$str};
    return $ret if $ret;

    $ret = $hash->{''};
    $ret = &$ret( $str ) if $ret;
    return $ret if $ret;

    if( $list ) {
	for my $type ( 0..@simple+4 ) { # Try to find a more and more fuzzy match.
	    my $expr = $type < @simple ?
		sprintf $simple[$type], $str :
		regexp $str, $type - @simple;
	    next unless defined $expr;
	    my @res = grep /$expr/i, @$list;
	    if( @res ) {
		return $res[0] if @res == 1;
		warn "$prefix$str$suffix matches @res\n";
		$error = 1;
		return '';
	    }
	}
    }
    # no special syntax for fields or functions, so don't fail on real one
    return $str if ord $prefix == ord '.' or ord $suffix == ord '(';

    warn "$prefix$str$suffix doesn't match\n";
    $error = 1;
}

my %rq = ('[', ']',
	  '{', '}');
my $quote_re = qr(\\([-,:;./ #?\N{GREEK SMALL LETTER OMEGA}^\\\@!'"`[\]{}]*)(?:%(.+?))?);
sub quote($$@) {
    (local $_, my $join) = splice @_, 0, 2;
    $join //= ',';
    return join $join, @_ unless defined;
    my @args = @_;
    /(['"`[{])/;
    my( $lq ) = /(['"`[{])/;
    $lq ||= "'";
    my $rq = $rq{$lq} || $lq;
    my( $noquote, $number, $boolean, $null, $space, $var ) =
	(tr/!//, tr/#//, tr/?//, tr/\N{GREEK SMALL LETTER OMEGA}^//, tr/\\//, tr/@//);
    my $split = tr/-// ? '-' : ''; # avoid range by putting - 1st
    $split .= tr/ // ? '\s' : '';  # space means any whitespace
    $split .= join '', /([,:;.\/])/g;
    $split ||= ',';
    $split = $space ? qr/[$split]/ : qr/\s*[$split]\s*/;
    join $join, map {
	if( $noquote || $boolean && /^(?:true|false)$/i || $null && /^null$/i || $var && /^\@\w+$/ ) {
	    $_;
	} elsif( $number && /^[-+]?(?:0b[01]+|0x[\da-f]+|(?=\.?\d)\d*\.?\d*(?:e[-+]?\d+)?)$/i ) {
	    $_;
	} else {
	    s/$rq/$rq$rq/g;
	    "$lq$_$rq";
	}
    } map {
	unless( $space ) {
	    s/\A\s*//;
	    s/\s*\Z//;
	}
	split $split, $_, -1;
    } @args;
}

sub convert_Query($$) {
    my $name = $_[0];
    my $res = find $name, '&', '', %Queries;
    my $ref = ref $res;
    my @arg;
    for( $ref ? $_[1] : "$res\cA$_[1]" ) {
	&convert_table_column;
	($res, $_) = split "\cA" unless $ref;
	@arg = split ';';
    }
    return &$res( $name, @arg ) // '' if $ref;

    my( @var, %seen, @rest );
    $res =~ s(\$$quote_re?(?:(\d+\b)|([*>_]))) {
	if( $3 && $3 > @arg ) {
	    '';
	} else {
	    push @var, [$1, $2, $4 ? (undef, $4) : $3-1];
	    undef $seen{$3-1} if $3;	# make it exist
	    "\cV$#var\cZ";
	}
    }eg;
    if( @arg > keys %seen ) {
	@rest = @arg;
	undef $rest[$_] for keys %seen;
	@rest = grep defined(), @rest;
    }
    $res =~ s(\cV(\d+)\cZ) {
	my @res = @{$var[$1]};
	quote $res[0], $res[1],
	    $res[3] ? ($res[3] eq '*' ? @arg :
		       $res[3] eq '>' ? @rest :
		       $_) :
	    $res[2] < 0 ? $name : $arg[$res[2]];
    }eg;
    $res;
}

my @keys_Table_Columns;
sub convert_table_column {
    @keys_Table_Columns = keys %Table_Columns unless @keys_Table_Columns;
    s&(?

    unless( $table_re ) {
	$table_re = join '|', keys %Table_Columns;
	$table_re = $table_re ? qr/\b(?:$table_re)\b/ : qr/\s\b\s/;
    }
    unless( $error ) {
	my %column;
	for( grep /$table_re/io, split /\W+/ ) {
	    undef $column{$_} for @{$Table_Columns{$_}};
	}
	my @column = keys %column;
	s/(^|.&|[-+\s(,;|])?(?
    }
}


=head2 convert

This function takes a short-hand query in C<$_> and transforms it to SQL.  See
L for more run time oriented features.

=head3 C<:\I(I)> E or E C<:\I%I(I)>

This is a special macro that transforms odd lists to SQL syntax.  It takes a
list of unquoted strings and quotes each one of them in various ways.  The
syntax is inspired by the Shell single character quote and Perl's C<\(...)>
syntax.  The I can get split on a variety of one or even
simultaneously various characters, which you can give in any order in the
I:

=over

=item C<\> (backslash)

This one isn't a character to split on, but rather prevents trimming the
whitespace of both ends of the resulting strings.

=item C<,> (comma), the default

You only need to specify it, if you want to split on commas, as well as other
characters, at the same time.

=item C> (space)

This one stands for any single whitespace.  Since strings are normally
trimmed, it's the equivalent of what the Shell does.  But, if you combine it
with C<\>, which prevents trimming, you will get an empty string between each
of multiple whitespaces.

=item C<-> (minus)

=item C<:> (colon)

=item C<;> (semicolon)

=item C<.> (period)

=item C (slash)

=back

The I can also contain several of these characters to prevent certain
strings from being quoted:

=over

=item C<#> (hash)

All numbers, including signed, floats, binary and hexadecimal stay literal.
If you use C<-> as a separator, there can be no negative numbers.

=item C (question mark)

The boolean values C and C stay literal.

=item C<ω> (omega) E or E C<^> (caret)

The value C stays literal.

=item C<@> (at sign)

Variables C<@name> stay literal.

=item C (exclamation mark)

Everything, presumably column names, stays literal.

=back

And you can give at most one I for the quotes to use:

=over

=item C<'> (quote), the default

=item C<"> (double quote)

=item C<`> (backquote)

=item C<[]> (brackets)

=item C<{}> (braces)

In the latter two cases, the closing quotes are optional, for decoration only,
or if code completion adds them.

=back

The results are joined by comma, unless I is given.  E.g. C<:\(a,b,
c,NULL,true,-1.2)> gives C<'a','b','c','NULL','true','-1.2'>, while
C<:\:"/\#?0(a:b/ c:NULL:true/-1.2)> gives C<"a","b"," c",NULL,true,-1.2> and
C<:\ !%&&(a b Ec)> gives C.



=head3 C<:I>

These are mostly simple text-replacements stored in C<%Macros>.  Unlike
L|/spec-strings-or-:-spec-join-strings> these do not take arguments.
There are also some dynamic macros.  Those starting with C<:j> (join) or
C<:lj> (left join) may continue into a L> E or E C<.I.> E or E C<.I.I> 


is a key of C<%Columns> or any abbreviation of columns of any table  




560




 





 





 





 





 





 



 without the leading C<#>.  E.g. C<:ljtbl#t> might expand to C




561




 





 





 





 





 





 



 t>. 




562




 





 





 





 





 





 



   




563




 





 





 





 





 





 



 Those starting with C<:gb> (group by) or C<:ob> (order by) may be followed by 




564




 





 





 





 





 





 



 result columns numbers from 1-9, each optionally followed by a or d for asc or 




565




 





 





 





 





 





 



 desc.  E.g. C<:ob2d3> gives C. 




566




 





 





 





 





 





 



   




567




 





 





 





 





 





 



 =head3 C<:+I> E or E C<:I+I> E or E C<:-I> E or E C<:I-I> 




568




 





 





 





 





 





 



   




569




 





 





 





 





 





 



 These are time calculation macros, where an optional leading letter indicates 




570




 





 





 





 





 





 



 a base time, and an optional trailing letter with an optional count means the 




571




 





 





 





 





 





 



 offset.  The letters are: 




572




 





 





 





 





 





 



   




573




 





 





 





 





 





 



 =over 




574




 





 





 





 





 





 



   




575




 





 





 





 





 





 



 =item y 




576




 





 





 





 





 





 



   




577




 





 





 





 





 





 



 (this) year(start).  E.g. C<:y+2m> is march this year. 




578




 





 





 





 





 





 



   




579




 





 





 





 





 





 



 =item q 




580




 





 





 





 





 





 



   




581




 





 





 





 





 





 



 (this) quarter(start).  E.g. C<:q+0> is this quarter, C<:q+q> is next quarter. 




582




 





 





 





 





 





 



   




583




 





 





 





 





 





 



 =item m 




584




 





 





 





 





 





 



   




585




 





 





 





 





 





 



 (this) month(start).  E.g. C<:-3m> is whatever precedes, minus 3 months. 




586




 





 





 





 





 





 



   




587




 





 





 





 





 





 



 =item w 




588




 





 





 





 





 





 



   




589




 





 





 





 





 





 



 (this) week(start).  E.g. C<:w+3d> is this week thursday (or wednesday if you 




590




 





 





 





 





 





 



 set C<$weekstart> to not follow ISO 8601 and the bible). 




591




 





 





 





 





 





 



   




592




 





 





 





 





 





 



 =item d 




593




 





 





 





 





 





 



   




594




 





 





 





 





 





 



 (this) day(start).  E.g. C<:d-w> is midnight one week ago. 




595




 





 





 





 





 





 



   




596




 





 





 





 





 





 



 =item h 




597




 





 





 





 





 





 



   




598




 





 





 





 





 





 



 (this) hour(start).  E.g. C<:h+30M> is half past current hour. 




599




 





 





 





 





 





 



   




600




 





 





 





 





 





 



 =item M 




601




 





 





 





 





 





 



   




602




 





 





 





 





 





 



 (this) minute(start).  E.g. C<:+10M> is whatever precedes, plus 10min. 




603




 





 





 





 





 





 



   




604




 





 





 





 





 





 



 =item s 




605




 





 





 





 





 





 



   




606




 





 





 





 





 





 



 (this) second.  E.g. C<:s-2h> is exactly 2h ago. 




607




 





 





 





 





 





 



   




608




 





 





 





 





 





 



 =back 




609




 





 





 





 





 





 



   




610




 





 





 





 





 





 



   




611




 





 





 





 





 





 



 =head3 C<:{I}> 




612




 





 





 





 





 





 



   




613




 





 





 





 





 





 



 This gets replaced by what it returns. 




614




 





 





 





 





 





 



   




615




 





 





 





 





 





 



   




616




 





 





 





 





 





 



 =head3 C<#I> E or E C<#I#> E or E C<#I#I> 




617




 





 





 





 





 





 



   




618




 





 





 





 





 





 



 Here I is a key of C<%Tables> or any abbreviation of known tables in 




619




 





 





 





 





 





 



 C<@Tables>.  If followed by C<#>, the abbreviation is used as an alias, unless 




620




 





 





 





 





 





 



 an I directly follows, in which case that is used. 




621




 





 





 





 





 





 



   




622




 





 





 





 





 





 



   




623




 





 





 





 





 





 



 =head3 C<.I

624




 





 





 





 





 





 



   




625




 





 





 





 





 





 



 Here I 




626




 





 





 





 





 





 



 recognized in the query.  If followed by C<.>, the abbreviation is used as an 




627




 





 





 





 





 





 



 alias, unless an I directly follows, in which case that is used.  It tries 




628




 





 





 





 





 





 



 to be clever about whether the 1st C<.> needs to be preserved, i.e. following 




629




 





 





 





 





 





 



 a table name. 




630




 





 





 





 





 





 



   




631




 





 





 





 





 





 



 =head3 C(> E or E C\I(I)> E 




632




 





 





 





 





 





 



 or E C\I%I(I)> 




633




 





 





 





 





 





 



   




634




 





 





 





 





 





 



 Here I is a key of C<%Functions> or any 




635




 





 





 





 





 





 



 abbreviation of known functions in C<@Functions>, which includes words 




636




 





 





 





 





 





 



 typically followed by an opening parenthesis, such as C for C. 




637




 





 





 





 





 





 



 C becomes C, whereas C becomes C. 




638




 





 





 





 





 





 



   




639




 





 





 





 





 





 



 If the 2nd or 3rd form is used, the I inside of the parentheses are treated 




640




 





 





 





 





 





 



 just like C(I)|/spec-strings-or-:-spec-join-strings>>, 




641




 





 





 





 





 





 



 but in this case preserving the parentheses. 




642




 





 





 





 





 





 



   




643




 





 





 





 





 





 



 If the 1st argument of a function is empty and the abbrev or function is found 




644




 





 





 





 





 





 



 in C<%DefaultArguments> the value becomes the 1st argument. 




645




 





 





 





 





 





 



 E.g. C or C both become 




646




 





 





 





 





 





 



 C. 




647




 





 





 





 





 





 



   




648




 





 





 





 





 





 



 =head3 Abbreviated Keyword 




649




 





 





 





 





 





 



   




650




 





 





 





 





 





 



 Finally it picks on the structure of the statement: These keywords can be 




651




 





 





 





 





 





 



 abbreviated: C, C, C or C.  If none of 




652




 





 





 





 





 





 



 these or C is present, C is assumed as default (more keywords 




653




 





 





 





 





 





 



 need to be recognized in the future). 




654




 





 





 





 





 





 



   




655




 





 





 





 





 





 



 For C, semicolons are alternately replaced by C (the 1st being 




656




 





 





 





 





 





 



 optional if it starts with a table name) and C.  If no result columns 




657




 





 





 





 





 





 



 are given, they default to C<*>, see L.  For C, semicolons 




658




 





 





 





 





 





 



 are frst replaced by C and then C. 




659




 





 





 





 





 





 



   




660




 





 





 





 





 





 



 =cut 




661




 





 





 





 





 





 



   




662




 





 





 





 





 





 



 sub convert { 




663




 





 





 





 





 





 



     # Handle :\...(str1, str2, str3) 




664




16





 





 




  
16
  



  
1
  




2381



     s<(?:\b(\w+)|:)$quote_re\((.+?)\)> { 




665




5




  
100
  




 





 





 





15



 	($1 ? "$1(" : '') . 




 




 




  
100
  




 





 





 





 



   




666




 





 





 





 





 





 



  	quote($2, $3, $4 ) . 




667




 





 





 





 





 





 



 	($1 ? ')' : '') 




668




 





 





 





 





 





 



     }ge; 




669




16





 





 





 





 





19



     my @strings;		# extract strings to prevent following replacements inside. 




670




16





 





 





 





 





71



     while( /\G.*?(['"`[{])/gc ) { 




671




44





 




  
 66
  




 





 





100



 	my $rq = $rq{$1}||$1; 




672




44





 





 





 





 





38



 	my $pos = pos; 




673




44





 





 





 





 





309



 	while( /\G.*?([$rq\\])/gc ) { 




674




60




  
100
  




 





 





 





262



 	    if( $1 eq '\\' ) { 




 




 




  
100
  




 





 





 





 



   




675




5





 





 





 





 





20



 		++pos;		# skip next 




676




 





 





 





 





 





 



 	    } elsif( ! /\G$rq/gc ) { # skip doubled quote 




677




44





 





 





 





 





137



 		push @strings, 




678




 





 





 





 





 





 



 		    substr $_, $pos - 1, 1 - $pos + pos, # get string 




679




 





 





 





 





 





 



 		    "\cS".@strings."\cZ"; # and replace with counter 




680




44





 





 





 





 





163



 		last; 




681




 





 





 





 





 





 



 	    } 




682




 





 





 





 





 





 



 	} 




683




 





 





 





 





 





 



     } 




684




 





 





 





 





 





 



   




685




16





 





 





 





 





20



     until( $error ) { 




686




24




  
  0
  



  
  0
  




 





 





212



 	s&:$perl_re&my $ret = eval $1; warn $@ if $@; $ret // ' NULL '&ego or 




 



  
0
  



  
100
  



  
 66
  




 





 





0



   




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




687




 





 





 





 





 





 



 	    # \todo (?(?<=\w)\b) 




688




23





 





 





 





 





36



 	    s&:($timespec_re[+-]\d*$timespec_re(?(?<=\w)\b)|l?j\w+(?:#(\w*))|\w+)&find $1, ':', '', %Macros&ego or 




689




 





 





 





 





 





 



 		last; 




690




 





 





 





 





 





 



     } 




691




 





 





 





 





 





 



   




692




16





 





 





 





 





24



     s&^(?=#)&;&;		# Assume empty fieldlist before table name 




693




16





 





 





 





 





21



     &convert_table_column; 




694




16





 





 





 





 





59



     s&^(?=$table_re)&;&;	# Assume empty fieldlist before table name 




695




 





 





 





 





 





 



   




696




16




  
 50
  



  
 33
  




 





 





44



     s&\b(\w+)\((?=\s*([,)])?)&my $fn = find $1, '', '(', %Functions, @Functions; ($fn || $1).'('.($2 and $DefaultArguments{$1} || $DefaultArguments{$fn} or '')&eg unless $error; 




 




13





 




  
 50
  




 





 





22



   




 




13





 





 





 





 





116



   




697




 





 





 





 





 





 



     #s&\b(\w+)(?=\()&find $1, '', '(', %Functions, @Functions or $1&eg unless $error; 




698




 





 





 





 





 





 



   




699




16




  
 50
  




 





 





 





24



     return if $error; 




700




16





 





 





 





 





25



     s/\A\s*;/*;/; 




701




16





 





 





 





 





24



     s/;\s*\Z//; 




702




16




  
 50
  




 





 





 





31



     if( s/^upd(?:a(?:t(?:e)?)?)?\b/update/i ) { 




703



  
0
  



  
  0
  




 





 





 





0



 	s/(?




704




 





 





 





 





 





 



     } else { 




705




16





 





 





 





 





51



 	s/(?




706




16




  
 50
  



  
 33
  




 





 





84



 	s/^ins(?:e(?:r(?:t)?)?)?\b/insert/i || 




707




 





 





 





 





 





 



 	    s/^del(?:e(?:t(?:e)?)?)?\b/delete/i || 




708




 





 





 





 





 





 



 	    s/^(?!se(?:lec)?t)/select /i; 




709




 





 





 





 





 





 



     } 




710




 





 





 





 





 





 



   




711




16





 





 





 





 





26



     s/ $//mg; 




712




16





 





 





 





 





34



     s/ {2,}/ /g; 




713




16





 





 





 





 





83



     s/\cS(\d+)\cZ/$strings[$1]/g; # put back the strings 




714




 





 





 





 





 





 



   




715




16





 





 





 





 





39



     1; 




716




 





 





 





 





 





 



 } 




717




 





 





 





 





 





 



   




718




 





 





 





 





 





 



   




719




 





 





 





 





 





 



 # escape map for special replacement characters 




720




 





 





 





 





 





 



 my %esc = map { $_ eq 'v' ? "\013" : eval( qq!"\\$_"! ), "\\$_" } qw'0 a b e f n r t v \ "'; 




721




 





 





 





 





 





 



   




722




 





 





 





 





 





 



 # With an argument of total number of rows, init output counting and return undef if it is to be skipped (not stdout). 




723




 





 





 





 





 





 



 # Without an argument, do the counting and return undef if no more rows wanted. 




724




 





 





 





 





 





 



 { 




725




 





 





 





 





 





 



     my( $total, $cnt, $i ); 




726




 





 





 





 





 





 



     sub count(;$) { 




727




16




  
100
  




 




  
16
  



  
0
  




25



 	if( @_ ) { 




728




11





 





 





 





 





12



 	    $total = $_[0]; 




729




11





 





 





 





 





8



 	    $cnt = 0; 




730




11





 





 





 





 





7



 	    $i = 100; 




731




11




  
100
  




 





 





 





46



 	    return select eq 'main::STDOUT' ? 1 : undef; 




732




 





 





 





 





 





 



 	} 




733




5





 





 





 





 





4



 	++$cnt; 




734




5




  
 50
  



  
 33
  




 





 





12



 	if( --$i <= 0 && $cnt < $total ) { 




735



  
0
  




 





 





 





 





0



 	    printf STDERR "How many more, * for all, or q to quit? (%d of %d) [default: 100] ", 




736




 





 





 





 





 





 



 		$cnt, $total; 




737



  
0
  




 





 





 





 





0



 	    $i = <>; 




738



  
0
  



  
  0
  




 





 





 





0



 	    if( defined $i ) { 




739



  
0
  




 





 





 





 





0



 		$i =~ tr/qQxX \t\n\r/0000/d; 




740



  
0
  



  
  0
  




 





 





 





0



 		$i = (0 == length $i) ? 100 : 




 




 




  
  0
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




741




 





 





 





 





 





 



 		    $i eq '*' ? ~0 : 




742




 





 





 





 





 





 



 			$i == 0 ? return : 




743




 





 





 





 





 





 



 			    $i; 




744




 





 





 





 





 





 



 	    } else { 




745



  
0
  




 





 





 





 





0



 		print "\n"; 




746



  
0
  




 





 





 





 





0



 		return; 




747




 





 





 





 





 





 



 	    } 




748




 





 





 





 





 





 



 	} 




749




5





 





 





 





 





17



 	1; 




750




 





 





 





 





 





 



     } 




751




 





 





 





 





 





 



 } 




752




 





 





 





 





 





 



   




753




 





 





 





 





 





 



 sub render_csv($;$$) { 




754




6





 





 




  
6
  



  
0
  




930



     my( $sth, $filter ) = @_; 




755




 





 





 





 





 





 



     my( $semi, $tab ) = 




756




 





 





 





 





 





 



 	(exists $_[2]{semi}, 




757




 





 





 





 





 





 



 	 exists $_[2]{tab}) 




758




6




  
100
  




 





 





 





19



 	if $_[2]; 




759




6





 





 





 





 





7



     my $name = $sth->{NAME}; 




760




6





 





 





 





 





14



     my @row = @$name; 




761




6





 





 





 





 





5



     while() { 




762




18





 





 





 





 





19



 	for( @row ) { 




763




162




  
100
  




 





 





 





138



 	    if( defined ) { 




764




156




  
100
  



  
100
  




 





 





793



 		$_ = qq!"$_"! if 




 




 




  
100
  



  
 66
  




 





 





 



   




 




 




  
100
  



  
 66
  




 





 





 



   




765




 





 





 





 





 





 



 		    /\A\Z/ or 




766




 





 





 





 





 





 



 		    s/"/""/g or 




767




 





 





 





 





 





 



 		    $semi ? tr/;\n// : $tab ? tr/\t\n// : tr/,\n// or 




768




 





 





 





 





 





 



 		    /\A=/; 




769




 





 





 





 





 





 



 	    } else { 




770




6





 





 





 





 





8



 		$_ = ''; 




771




 





 





 





 





 





 



 	    } 




772




162





 





 





 





 





186



 	    utf8::decode $_; 




773




 





 





 





 





 





 



 	} 




774




18




  
100
  




 





 





 





61



 	print join( $semi ? ';' : $tab ? "\t" : ',', @row ) . "\n"; 




 




 




  
100
  




 





 





 





 



   




775




 





 





 





 





 





 



   




776




21




  
100
  




 





 





 





30



       FETCH: 




777




 





 





 





 





 





 



 	@row = $sth->fetchrow_array 




778




 





 





 





 





 





 



 	    or last; 




779




15




  
100
  



  
100
  




 





 





194



 	$filter->( $name, @row ) or goto FETCH if $filter; 




780




 





 





 





 





 





 



     } 




781




 





 





 





 





 





 



 } 




782




 





 





 





 





 





 



   




783




 





 





 





 





 





 



 our $NULL = 'ω'; 




784




 





 





 





 





 





 



 utf8::decode $NULL; 




785




 





 





 





 





 





 



 my( $r1, $r2, $r3, $r5 ) = ('[01]\d', '[0-2]\d', '[0-3]\d', '[0-5]\d'); 




786




 





 





 





 





 





 



 sub render_table($;$$) { 




787




16





 





 




  
16
  



  
0
  




3360



     my( $sth, $filter ) = @_; 




788




 





 





 





 





 





 



     my( $null, $crlf, $date, $time ) = 




789




 





 





 





 





 





 



 	exists $_[2]{all} ? 




790




 





 





 





 





 





 



 	('NULL', 1, 1, 1) : 




791




 





 





 





 





 





 



 	(exists $_[2]{NULL} ? 'NULL' : exists $_[2]{null} ? 'null' : 0, 




792




 





 





 





 





 





 



 	 exists $_[2]{crlf}, 




793




 





 





 





 





 





 



 	 exists $_[2]{date}, 




794




 





 





 





 





 





 



 	 exists $_[2]{time}) 




795




16




  
100
  




 





 





 





76



 	if $_[2]; 




 




 




  
 50
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




796




16





 




  
 66
  




 





 





50



     $null ||= $NULL; 




797




16





 





 





 





 





12



     my @name = @{$sth->{NAME}}; 




 




16





 





 





 





 





39



   




798




16





 





 





 





 





33



     my @len = (0) x @name; 




799




16





 





 





 





 





13



     my( @txt, @res, @comp ); 




800




16





 





 





 





 





29



     while( my @res1 = $sth->fetchrow_array ) { 




801




80




  
100
  



  
 50
  




 





 





414



 	$filter->( \@name, @res1 ) or next if $filter; 




802




80





 





 





 





 





96



 	for my $i ( 0..$#res1 ) { 




803




580




  
100
  




 





 





 





1496



 	    if( !defined $res1[$i] ) { 




 




 




  
100
  




 





 





 





 



   




804




4





 





 





 





 





4



 		$res1[$i] = $null; 




805




 





 





 





 





 





 



 	    } elsif( $res1[$i] !~ /^\d+(?:\.\d+)?$/ ) { 




806




537





 





 





 





 





343



 		$txt[$i] = 1; 




807




537




  
100
  




 





 





 





665



 		$res1[$i] =~ s/\r\n/\\R/g unless $crlf; 




808




537





 





 





 





 





487



 		$res1[$i] =~ s/([\t\n\r])/$esc{$1}/g; 




809




4





 





 




  
4
  




 





50011



 		no warnings 'uninitialized'; 




 




4





 





 





 





 





8



   




 




4





 





 





 





 





14529



   




810




537




  
100
  




 





 





 





558



 		unless( $date ) { 




811




215




  
100
  




 





 





 





711



 		    if( $res1[$i] =~ s/^(\d{4}-)($r1)-0[01]([T ]$r2:$r5(?::$r5(?:[.,]\d{3})?)?(?:Z|[+-]$r2:$r5)?)?$/$1/o ) { 




812




109




  
100
  




 





 





 





179



 			$res1[$i] .= "$2-" if $2 > 1; 




813




109




  
100
  




 





 





 





208



 			$res1[$i] .= $3 if $3; 




814




 





 





 





 





 





 



 		    } 




815




 





 





 





 





 





 



 		} 




816




537




  
100
  




 





 





 





594



 		unless( $time ) { 




817




215




  
100
  




 





 





 





962



 		    if( $res1[$i] =~ s/^(\d{4}-(?:$r1-(?:$r3)?)?[T ])?($r2):($r5)(?::($r5)(?:([.,])(\d{3}))?)?(Z|[+-]$r2:$r5)?$/$1/o ) { 




818




170





 




  
100
  




 





 





311



 			$res1[$i] = $1 || ''; 




819




170




  
100
  



  
 66
  




 





 





777



 			if( $2 == 23 && $3 == 59 && ($4 // 59) == 59 && ($6 // 999) == 999 ) { 




 




 




  
100
  



  
100
  




 





 





 



   




 




 




  
100
  



  
 66
  




 





 





 



   




 




 




  
100
  



  
100
  




 





 





 



   




 




 





 




  
 33
  




 





 





 



   




820




49





 





 





 





 





44



 			    $res1[$i] .= "24:"; 




821




 





 





 





 





 





 



 			} elsif( $6 > 0 ) { 




822




24





 





 





 





 





53



 			    $res1[$i] .= "$2:$3:$4$5$6"; 




823




 





 





 





 





 





 



 			} elsif( $4 > 0 ) { 




824




12





 





 





 





 





27



 			    $res1[$i] .= "$2:$3:$4"; 




825




 





 





 





 





 





 



 			} elsif( $3 > 0 ) { 




826




12





 





 





 





 





17



 			    $res1[$i] .= "$2:$3"; 




827




 





 





 





 





 





 



 			} else { 




828




73





 





 





 





 





80



 			    $res1[$i] .= "$2:"; 




829




 





 





 





 





 





 



 			} 




830




170




  
100
  




 





 





 





319



 			($res1[$i] .= $7) =~ s/:00$/:/ 




831




 





 





 





 





 





 



 			    if $7; 




832




 





 





 





 





 





 



 		    } 




833




 





 





 





 





 





 



 		} 




834




537





 





 





 





 





667



 		utf8::decode $res1[$i]; 




835




 





 





 





 





 





 



 	    } 




836




580




  
100
  




 





 





 





705



 	    $txt[$i] = 0 if @txt < $i; 




837




580





 





 





 





 





379



 	    my $len = length $res1[$i]; 




838




580




  
100
  




 





 





 





816



 	    $len[$i] = $len if $len[$i] < $len; 




839




 





 





 





 





 





 



 	} 




840




80




  
100
  




 





 





 





98



 	if( @comp ) { 




841




71





 





 





 





 





90



 	    for my $i ( 0..$#comp ) { 




842




509




  
100
  



  
100
  




 





 





857



 		undef $comp[$i] if defined $comp[$i] && $comp[$i] ne $res1[$i]; 




843




 





 





 





 





 





 



 	    } 




844




 





 





 





 





 





 



 	} else { 




845




9





 





 





 





 





20



 	    @comp = @res1; 




846




 





 





 





 





 





 



 	} 




847




80





 





 





 





 





188



 	push @res, \@res1; 




848




 





 





 





 





 





 



     } 




849




16




  
100
  




 





 





 





79



     if( @res ) { 




850




9




  
100
  




 





 





 





17



 	@comp = () if @res == 1; 




851




9





 





 





 





 





9



 	my $fmt = ''; 




852




9





 





 





 





 





22



 	for( my $i = 0; $i < @name; ++$i ) { 




853




71





 





 





 





 





56



 	    $name[$i] =~ s/\r\n/\\R/g; 




854




71





 





 





 





 





68



 	    $name[$i] =~ s/([\t\n\r])/$esc{$1}/g; 




855




71




  
 50
  




 





 





 





81



 	    if( defined $comp[$i] ) { 




856



  
0
  




 





 





 





 





0



 		my $more; 




857



  
0
  




 





 





 





 





0



 		while( defined $comp[$i] ) { 




858



  
0
  



  
  0
  




 





 





 





0



 		    printf $fmt, @name[0..$i-1] unless $more; 




859



  
0
  




 





 





 





 





0



 		    $more = 1; 




860



  
0
  




 





 





 





 





0



 		    printf "[%s=%s]", $name[$i], $comp[$i]; 




861



  
0
  




 





 





 





 





0



 		    @name[0..$i] = ('') x ($i+1); 




862



  
0
  




 





 





 





 





0



 		    for my $row ( \@comp, \@name, \@len, \@txt, @res ) { 




863



  
0
  




 





 





 





 





0



 			splice @$row, $i, 1; 




864




 





 





 





 





 





 



 		    } 




865




 





 





 





 





 





 



 		} 




866



  
0
  




 





 





 





 





0



 		print "\n"; 




867



  
0
  




 





 





 





 





0



 		--$i, next; 




868




 





 





 





 





 





 



 	    } 




869




71




  
100
  




 





 





 





83



 	    if( $len[$i] < length $name[$i] ) { 




870




9





 





 





 





 





44



 		printf "$fmt%s\n", @name[0..$i]; 




871




9





 





 





 





 





27



 		@name[0..$i] = ('') x ($i+1); 




872




 





 





 





 





 





 



 	    } 




873




71




  
100
  




 





 





 





157



 	    $fmt .= '%' . ($txt[$i] ? -$len[$i] : $len[$i]) . 's|'; 




874




 





 





 





 





 





 



 	} 




875




9





 





 





 





 





11



 	$fmt .= "\n"; 




876




9




  
100
  




 





 





 





46



 	printf $fmt, @name if $name[-1]; 




877




9





 





 





 





 





72



 	printf $fmt, map '-'x$_, @len; 




878




9





 





 





 





 





24



 	my $count = count @res;		# init 




879




9





 





 





 





 





15



 	for my $row ( @res ) { 




880




80





 





 





 





 





209



 	    printf $fmt, @$row; 




881




80




  
100
  



  
 50
  




 





 





178



 	    defined count or last if defined $count; 




882




 





 





 





 





 





 



 	} 




883




 





 





 





 





 





 



     } 




884




 





 





 





 





 





 



 } 




885




 





 





 





 





 





 



   




886




 





 





 





 





 





 



 my $yaml_re = join '', sort keys %esc; 




887




 





 





 





 





 





 



 $yaml_re =~ s!\\!\\\\!; 




888




 





 





 





 





 





 



 my $tabsize = $ENV{TABSIZE} || 8; 




889




 





 





 





 





 





 



 sub render_yaml($;$$) { 




890




2





 





 




  
2
  



  
0
  




366



     my( $sth, $filter ) = @_; 




891




2





 





 





 





 





2



     my @label;			       # Fill on 0th round with same transformation as data (but \n inline) 




892




2





 




  
100
  




 





 





6



     my $count = count $DBI::rows || 1; # init \todo don't know how many unfiltered 




893




2





 





 





 





 





3



     my @row = @{$sth->{NAME}}; 




 




2





 





 





 





 





8



   




894




2





 





 





 





 





3



     while() { 




895




6





 





 





 





 





6



 	local $_; 




896




6





 





 





 





 





5



 	my $i = 0; 




897




6





 





 





 





 





10



 	for( @row ) { 




898




54




  
100
  



  
 66
  




 





 





202



 	    if( !defined ) { 




 




 




  
100
  




 





 





 





 



   




 




 




  
 50
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




899




2





 





 





 





 





3



 		$_ = '~'; 




900




 





 





 





 





 





 



 	    } elsif( /^(?:y(?:es)?|no?|true|false|o(?:n|ff)|-?\.inf|\.nan)$/s ) { # can only be string in Perl or DB 




901



  
0
  




 





 





 





 





0



 		$_ = "'$_'"; 




902




 





 





 





 





 





 



 	    } elsif( tr/][{},?:`'"|<>&*!%#@=~\0-\010\013-\037\177-\237-// or @label ? 0 : tr/\n// ) { 




903




15





 





 





 





 





50



 		s/([$yaml_re])/$esc{$1}/go; 




904




15





 





 





 





 





13



 		s/([\0-\010\013-\037\177-\237])/sprintf "\\x%02x", ord $1/ge; 




 



  
0
  




 





 





 





 





0



   




905




15





 





 





 





 





20



 		$_ = qq!"$_"!; 




906




 





 





 





 





 





 



 	    } elsif( tr/\n// ) { 




907




1





 





 





 





 





2



 		my $nl = chomp; 




908




1





 





 





 





 





5



 		s/^/    /mg; 




909




1




  
 50
  




 





 





 





3



 		substr $_, 0, 0, $nl ? "|2\n" : "|2-\n"; 




910




 





 





 





 





 





 



 	    } 




911




54




  
100
  




 





 





 





140



 	    printf "$label[$i++]$_\n" if @label; 




912




 





 





 





 





 





 



 	} 




913




6




  
100
  




 





 





 





9



 	if( @label ) { 




914




4




  
 50
  



  
 50
  




 





 





12



 	    defined count or last if defined $count; 




915




 





 





 





 





 





 



 	} else { 




916




2





 





 





 





 





4



 	    my $maxlen = 0; 




917




2





 





 





 





 





4



 	    for( @row ) { 




918




18




  
100
  




 





 





 





27



 		substr $_, 0, 0, $maxlen ? '  ' : '- '; # 1st field if no maxlen yet 




919




18





 





 





 





 





13



 		my $length = 0; 




920




18




  
100
  




 





 





 





80



 		$length += $1 ? $tabsize - $length % $tabsize : length $2 




921




 





 





 





 





 





 



 		    while /\G(?:(\t)|([^\t]+))/gc; 




922




18





 





 





 





 





21



 		$_ .= ": $length"; 




923




18




  
100
  




 





 





 





33



 		$maxlen = $length if $maxlen < $length; 




924




 





 





 





 





 





 



 	    } 




925




18





 





 





 





 





60



 	    s/(\d+)\Z/' ' x ($maxlen - $1)/e 




926




2





 





 





 





 





19



 		for @label = @row; 




927




 





 





 





 





 





 



 	} 




928




7




  
100
  




 





 





 





12



       FETCH: 




929




 





 





 





 





 





 



 	@row = $sth->fetchrow_array 




930




 





 





 





 





 





 



 	    or last; 




931




5




  
100
  



  
100
  




 





 





82



 	$filter->( $sth->{NAME}, @row ) or goto FETCH if $filter; 




932




 





 





 





 





 





 



     } 




933




 





 





 





 





 





 



 } 




934




 





 





 





 





 





 



   




935




 





 





 





 





 





 



   




936




 





 





 





 





 





 



   




937




 





 





 





 





 





 



 my $lasttime = time; 




938




 





 





 





 





 





 



 sub run($;$\%) { 




939




12





 





 




  
12
  



  
0
  




15



     my( $sql, $filter, $opt ) = @_; 




940




12





 





 





 





 





32



     my $t0 = [gettimeofday]; 




941




12




  
 50
  



  
 33
  




 





 





52



     if( $DBI::err || $t0->[0] - $lasttime > 3600 and !$dbh->ping ) { 




 




 





 




  
 33
  




 





 





 



   




942



  
0
  




 





 





 





 





0



 	printf STDOUT "Inactive for %ds, ping failed after %.03fs, your session variables are lost.\n", 




943




 





 





 





 





 





 



 	    $t0->[0] - $lasttime, tv_interval $t0; 




944




 





 





 





 





 





 



 	#$dbh->disconnect; 




945



  
0
  




 





 





 





 





0



 	$dbh = $dbh->clone;	# reconnect 




946



  
0
  




 





 





 





 





0



 	$t0 = [gettimeofday]; 




947




 





 





 





 





 





 



     } 




948




12





 





 





 





 





10



     $lasttime = $t0->[0]; 




949




12




  
 50
  




 





 





 





104



     if( my $sth = UNIVERSAL::isa( $sql, 'DBI::st' ) ? $sql : $dbh->prepare( $sql )) { 




 




 




  
 50
  




 





 





 





 



   




950




12





 





 





 





 





143



 	my $t1 = [gettimeofday]; 




951




12





 





 





 





 





23



 	$sth->execute; 




952




12





 





 





 





 





35



 	printf STDOUT "prepare: %.03fs   execute: %.03fs   rows: %d\n", 




953




 





 





 





 





 





 



 	    tv_interval( $t0, $t1 ), tv_interval( $t1 ), $DBI::rows; 




954




12




  
 50
  




 





 





 





264



 	if( $sth->{Active} ) { 




955




12




  
100
  




 





 





 





14



 	    if( $render ) { 




956




4





 





 





 





 





8



 		&$render( $sth, $filter, $opt ); 




957




 





 





 





 





 





 



 	    } else { 




958




8





 





 





 





 





16



 		render_table $sth, $filter, $opt; 




959




 





 





 





 





 





 



 	    } 




960




 





 





 





 





 





 



 	} 




961




 





 





 





 





 





 



     } 




962




 





 





 





 





 





 



 } 




963




 





 





 





 





 





 



   




964




 





 





 





 





 





 



   




965




 





 





 





 





 





 



 =head2 shell 




966




 





 





 





 





 





 



   




967




 





 





 





 





 





 



 This function reads, converts and (if C<$dbh> is set) runs in an end-less loop 




968




 





 





 





 





 





 



 (i.e. till end of file or C<^D>).  Reading is a single line affair, unless you 




969




 





 





 





 





 





 



 request otherwise.  This can happen either, as in Unix Shell, by using 




970




 





 





 





 





 





 



 continuation lines as long as you put a backslash at the end of your lines. 




971




 





 





 





 





 





 



 Or there is a special case, if the 1st line starts with C<\\>, then everything 




972




 





 





 





 





 





 



 up to C<\\> at the end of one of the next lines, constitutes one entry. 




973




 





 





 





 





 





 



   




974




 





 





 





 





 





 



 In addition to converting, it offers a few extra features, performed in this 




975




 





 





 





 





 





 



 order (i.e. C<&I> can return C/=I> etc.): 




976




 





 





 





 





 





 



   




977




 





 





 





 





 





 



 =head3 C<&{I} I> 




978




 





 





 





 





 





 



   




979




 





 





 





 





 





 



 Run I.  It sees the optional I in C<$_> and may 




980




 





 





 





 





 





 



 modify it.  If it returns C, this statement is skipped.  If it returns 




981




 





 





 





 





 





 



 a DBI statement handle, run that instead of this statement.  Else replace with 




982




 





 





 





 





 





 



 what it returns. 




983




 





 





 





 





 





 



   




984




 





 





 





 





 





 



 Reprocess result as a shell entry (i.e. it may return another C<&I>). 




985




 





 





 





 





 





 



   




986




 





 





 





 





 





 



 =head3 C<&I; ...> E or E C<&I( I; ... ) I> 




987




 





 





 





 





 





 



   




988




 





 





 





 





 





 



 These allow canned entries and are more complex than macros, in that they take 




989




 





 





 





 





 





 



 arguments and replacement can depend on the argument. 




990




 





 





 





 





 





 



   




991




 





 





 





 





 





 



 Reprocess result as a shell entry (i.e. it may return another C<&I>). 




992




 





 





 





 





 





 



   




993




 





 





 





 





 





 



 You can define your own canned queries with: 




994




 





 





 





 





 





 



   




995




 





 





 





 





 





 



 C<    &{ Query I =E 'I', 'I' }> 




996




 





 





 





 





 





 



   




997




 





 





 





 





 





 



 Here C becomes the replacement string for C<&name>.  It may contain 




998




 





 





 





 





 





 



 arguments a bit like the Shell: C<$0> (I), C<$*> (all arguments), C<$1, 




999




 





 





 





 





 





 



 $2, ..., $10, ...> (individual arguments) and C<$E> (all arguments not 




1000




 





 





 





 





 





 



 adressed individually).  They can become quoted like 




1001




 





 





 





 





 





 



 L|/spec-strings-or-:-spec-join-strings> as C<:\II> or 




1002




 





 





 





 





 





 



 C<:\I%II>.  Here I is C<*>, C> or a number 




1003




 





 





 





 





 





 



 directly tacked on to I or I.  E.g.: C<$\-"1> splits the 1st 




1004




 





 





 





 





 





 



 (semi-colon separated from the 2nd) argument itself on C<-> (minus), quotes 




1005




 





 





 





 





 





 



 the pieces with C<"> (double quote) and joins them with C<,> (comma).  Putting 




1006




 





 





 





 





 





 



 the quotes inside the argument like this, eliminates them, if no argument is 




1007




 





 





 





 





 





 



 given. 




1008




 





 





 





 





 





 



   




1009




 





 





 





 





 





 



 =head3 C/ I> E or E C/i I> E or E C/ I> E or E C/i I> 




1010




 





 





 





 





 





 



   




1011




 





 





 





 





 





 



 This will treat the I normally, but will join each output row into 




1012




 





 





 





 





 





 



 a C<~> (tilde) separated string for matching.  NULL fields are rendered as 




1013




 





 





 





 





 





 



 that string.  E.g. to return only rows starting with a number 1-5, followed by 




1014




 





 





 





 





 





 



 a NULL field, you could write: C. 




1015




 





 





 





 





 





 



   




1016




 





 





 





 





 





 



 With a suffix C, matching becomes case insensitive.  This is why the mostly 




1017




 





 





 





 





 





 



 optional space before I is shown above.  Without an C, but if 




1018




 





 





 





 





 





 



 the statement starts with the word C (e.g. your first column name), you 




1019




 





 





 





 





 





 



 must separate it with a space.  With an C, if the statement starts with an 




1020




 





 





 





 





 





 



 alphanumeric caracter, you must separate it with a space. 




1021




 





 





 





 





 





 



   




1022




 





 





 





 





 





 



 Only matching rows are considered unless there is a preceding C 




1023




 





 





 





 





 





 



 (exclamation mark), in which case only non-matching rows are considered. 




1024




 





 





 





 





 





 



   




1025




 





 





 





 





 





 



 You can provide your own formatting of the row by setting C<$regexp_fail> to a 




1026




 





 





 





 





 





 



 Perl sub that returns a Perl expression as a string.  That expression takes 




1027




 





 





 





 





 





 



 the row in C<@_> and shall be true if the row fails to match. 




1028




 





 





 





 





 





 



   




1029




 





 





 





 





 





 



 Caveat: the whole result set of the I gets generated and 




1030




 





 





 





 





 





 



 transferred to the client.  This is definitely much more expensive than doing 




1031




 





 





 





 





 





 



 the equivalent filtering in the where clause.  But it is not a big deal for 




1032




 





 





 





 





 





 



 tens or maybe hundreds of thousands or rows, probably still faster than 




1033




 





 





 





 





 





 



 writing the corresponding SQL.  And Perl's regexps are so much more powerful. 




1034




 





 





 





 





 





 



   




1035




 





 





 





 





 





 



 =head3 C<{I}I> 




1036




 





 





 





 





 





 



   




1037




 





 





 





 





 





 



 Call I for every output row returned by the I with the 




1038




 





 





 





 





 





 



 array of column names as zeroth argument and the values after that (i.e. 




1039




 





 





 





 





 





 



 numbered from 1 like in SQL).  It may modify individual values.  If it returns 




1040




 





 





 





 





 





 



 false, the row is skipped. 




1041




 





 





 





 





 





 



   




1042




 





 





 





 





 





 



 You may combine S/{I}>> in any order and as many of them as 




1043




 





 





 





 





 





 



 you want. 




1044




 





 





 





 





 





 



   




1045




 





 





 





 





 





 



 The same caveat as for regexps applies here.  But again Perl is far more 




1046




 





 





 





 





 





 



 powerful than any SQL functions. 




1047




 





 





 





 





 





 



   




1048




 





 





 





 





 





 



 =head3 C<=I> 




1049




 





 





 





 





 





 



   




1050




 





 





 





 





 





 



 A preceding C<=> prevents conversion, useful for hitherto untreated keywords 




1051




 





 





 





 





 





 



 or where the conversion doesn't play well with your intention. 




1052




 





 





 





 





 





 



   




1053




 





 





 





 





 





 



 =head3 C 




1054




 





 





 





 





 





 



   




1055




 





 





 





 





 





 



 Help prefix.  Alone it will give an overview.  You can follow up with any of 




1056




 





 





 





 





 





 



 the special syntaxes, with or without an abbreviation.  E.g. C will show 




1057




 





 





 





 





 





 



 all function abbreviations, whereas C(> will show only those functions 




1058




 





 





 





 





 





 



 matching abbrev or C> only those tables matching abbrev. 




1059




 





 





 





 





 





 



   




1060




 





 





 





 





 





 



 =head3 C> 




1061




 





 





 





 





 





 



   




1062




 





 





 





 





 





 



 Will convert and show, but not perform I.  If C<$dbh> is not set, this 




1063




 





 





 





 





 





 



 is the default behaviour. 




1064




 





 





 





 





 





 



   




1065




 





 





 





 





 





 



 =head3 C> 




1066




 





 





 





 





 





 



   




1067




 





 





 





 





 





 



 Run I. 




1068




 





 





 





 





 





 



   




1069




 





 





 





 





 





 



 =head3 CI> E or E CEI> 




1070




 





 





 





 





 





 



   




1071




 





 





 





 





 





 



 Redirect or append next statement's output to I.  For known 




1072




 





 





 





 





 





 



 suffixes and options, see the L. 




1073




 





 





 





 





 





 



   




1074




 





 





 





 





 





 



 =head3 C<|I> 




1075




 





 





 





 





 





 



   




1076




 





 





 





 





 





 



 Pipe next statement's output through I. 




1077




 





 





 





 





 





 



   




1078




 





 





 





 





 





 



 =head2 Output Formats 




1079




 





 





 





 





 





 



   




1080




 





 





 





 





 





 



 The output format for the next SQL statement that is run, is chosen from the 




1081




 





 





 





 





 





 



 suffix of a redirection or a special suffix query.  In both cases 




1082




 





 





 





 





 





 



 comma-separated options may be passed: 




1083




 





 





 





 





 





 



   




1084




 





 





 





 





 





 



 =over 




1085




 





 





 





 





 





 



   




1086




 





 





 





 





 





 



 =item >I.I 




1087




 





 





 





 





 





 



   




1088




 





 





 





 





 





 



 =item >I.I( I; ... ) 




1089




 





 





 





 





 





 



   




1090




 





 





 





 





 





 



 =item >>I.I 




1091




 





 





 





 





 





 



   




1092




 





 





 





 





 





 



 =item >>I.I( I; ... ) 




1093




 





 





 





 





 





 



   




1094




 





 





 





 





 





 



 =item &.I; ... 




1095




 





 





 





 





 





 



   




1096




 





 





 





 





 





 



 =item &.I( I; ... ) following text 




1097




 





 





 





 





 





 



   




1098




 





 





 





 





 





 



 =back 




1099




 





 





 





 





 





 



   




1100




 





 





 





 





 





 



 The known suffixes and their respective options are: 




1101




 





 





 





 





 





 



   




1102




 





 





 





 





 





 



 =over 




1103




 





 





 





 





 





 



   




1104




 





 





 





 





 





 



 =item C<.csv> 




1105




 





 





 





 





 





 



   




1106




 





 





 





 





 





 



 This writes Comma Separated Values with one subtle trick: NULL and empty 




1107




 





 





 





 





 





 



 strings are distinguished by quoting the latter.  Some tools like Perl's file 




1108




 





 





 





 





 





 



 DB L or rather its underlying L can pick that up.  CSV 




1109




 





 





 





 





 





 



 can take one of these options: 




1110




 





 





 





 





 





 



   




1111




 





 





 





 





 





 



 =over 




1112




 





 





 





 





 





 



   




1113




 





 





 





 





 





 



 =item semi 




1114




 





 





 





 





 





 



   




1115




 





 





 





 





 





 



 Use a semicolon as a separator.  This is a common format in environments where 




1116




 





 





 





 





 





 



 the comma is the decimal separator.  However if you want decimal commas, you must 




1117




 





 





 





 





 





 



 provide such formatting yourself. 




1118




 





 





 





 





 





 



   




1119




 





 





 





 





 





 



 =item tab 




1120




 





 





 





 





 





 



   




1121




 





 





 





 





 





 



 Use tabulators as column separators.  Apart from that you get the full CSV 




1122




 





 





 





 





 





 



 formatting, so this is not the primitive F<.tsv> format some tools may have. 




1123




 





 





 





 





 





 



   




1124




 





 





 





 





 





 



 =back 




1125




 





 





 





 





 





 



   




1126




 





 





 





 





 





 



   




1127




 





 





 





 





 





 



 =item C<.table> 




1128




 





 





 





 





 





 



   




1129




 





 





 





 





 





 



 This is the default table format.  But you need to name it, if you want to set 




1130




 





 





 





 





 





 



 options. 




1131




 





 





 





 





 





 



   




1132




 





 





 





 





 





 



 =over 




1133




 





 





 





 





 





 



   




1134




 





 





 





 





 





 



 =item all 




1135




 





 





 





 





 





 



   




1136




 





 





 





 





 





 



 This is a shorthand for outputting everything in the long form, equivalent to 




1137




 





 





 





 





 





 



 C<( NULL, crlf, date )>. 




1138




 





 





 





 





 





 



   




1139




 





 





 





 





 





 



 =item crlf 




1140




 





 





 





 





 





 



   




1141




 





 





 





 





 





 



 Do not shorten C<\r\n> to C<\R>. 




1142




 





 





 





 





 





 



   




1143




 





 





 





 





 





 



 =item date 




1144




 





 





 





 





 





 



   




1145




 





 





 





 





 





 



 Output ISO dates fully instead of shortening 0000-00-00 to 0000- and 




1146




 





 





 





 





 





 



 yyyy-01-01 to yyyy- or yyyy-mm-01 to yyyy-mm-. 




1147




 





 





 





 





 





 



   




1148




 





 





 





 





 





 



 =item time 




1149




 





 





 





 





 





 



   




1150




 





 





 





 





 





 



 Output times fully instead of shortening 23:59(:59) to 24: and hh:00(:00) to 




1151




 





 





 





 





 





 



 hh: or hh:mm(:00) to hh:mm. 




1152




 





 





 





 





 





 



   




1153




 





 





 





 





 





 



 =item NULL 




1154




 





 





 





 





 





 



   




1155




 





 





 





 





 





 



 =item null 




1156




 





 





 





 





 





 



   




1157




 





 





 





 





 





 



 Output this keyword instead of the shorter C<ω> from DB theory (or whatever 




1158




 





 





 





 





 





 



 you assigned to C<$NULL>). 




1159




 





 





 





 





 





 



   




1160




 





 





 





 





 





 



 =back 




1161




 





 





 





 





 





 



   




1162




 





 





 





 





 





 



   




1163




 





 





 





 





 





 



 =item C<.yaml> 




1164




 





 





 





 





 





 



   




1165




 





 





 





 





 





 



 =item C<.yml> 




1166




 





 





 





 





 





 



   




1167




 





 





 





 





 





 



 Format output as YAML.  This format has no options.  Because its every value 




1168




 





 





 





 





 





 



 on a new line format can be more readable, there is a shorthand query C<&-> 




1169




 





 





 





 





 





 



 for it. 




1170




 





 





 





 





 





 



   




1171




 





 





 





 





 





 



 =back 




1172




 





 





 





 





 





 



   




1173




 





 





 





 





 





 



 =cut 




1174




 





 





 





 





 





 



   




1175




 





 





 





 





 





 



 our $prompt = 'steno> '; 




1176




 





 





 





 





 





 



 our $contprompt = '...>  '; 




1177




 





 





 





 





 





 



 our $echo; 




1178




 





 





 





 





 





 



 # Called for every leading re, 1st arg is the optional '!', 2nd arg '/re/' or '/re/i'.  Expression shall be true for non-matching lines. 




1179




 





 





 





 





 





 



 our $regexp_fail = sub($$) { 'join( "~", map ref() ? () : $_ // q!NULL!, @_ )' . ($_[0] ? '=~' : '!~') . $_[1] }; 




1180




 





 





 





 





 





 



 sub shell() { 




1181




1





 





 




  
1
  



  
1
  




888



     print STDERR $prompt; 




1182




1





 





 





 





 





1



     my $fh; 




1183




1





 





 





 





 





18



     while( <> ) { 




1184




19





 





 





 





 





15



 	undef $error; 




1185




19




  
100
  




 





 





 





54



 	goto NEXT unless /\S/; 




1186




17




  
100
  




 





 





 





42



 	if( s/^\s*\\\\\s*// ) { 




1187




1





 





 





 





 





6



 	    s/\s*\Z/\n/s; 




1188




1





 





 





 





 





4



 	    local $/ = "\\\\\n";	# leading \n gets chopped below 




1189




1





 





 





 





 





3



 	    $_ .= <>; 




1190




1





 





 





 





 





4



 	    chomp; 




1191




 





 





 





 





 





 



 	} else { 




1192




16





 





 





 





 





43



 	    while( s/(?




1193




1





 





 





 





 





2



 		print STDERR $contprompt; 




1194




1





 





 





 





 





4



 		$_ .= <>; 




1195




 





 





 





 





 





 



 	    } 




1196




16





 





 





 





 





27



 	    s/\A\s+//; 




1197




 





 





 





 





 





 



 	} 




1198




17





 





 





 





 





57



 	s/\s+\Z//; 




1199




17




  
 50
  




 





 





 





44



 	say if $echo; 




1200




17





 





 





 





 





22



 	until( $error ) { 




1201




32




  
100
  




 





 





 





142



 	    if( s!^&$perl_re!! ) { 




1202




2





 





 





 





 





216



 		my $perl = eval $1; 




1203




2





 





 





 





 





14



 		local $| = 1;	# flush to avoid stderr prompt overtaking last output line. 




1204




2




  
 50
  




 





 





 





5



 		warn $@ if $@; 




1205




2




  
 50
  




 





 





 





13



 		if( UNIVERSAL::isa $perl, 'DBI::st' ) { 




 




 




  
100
  




 





 





 





 



   




1206



  
0
  




 





 





 





 





0



 		    $_ = $perl; 




1207



  
0
  




 





 





 





 





0



 		    goto RUN; 




1208




 





 





 





 





 





 



 		} elsif( defined $perl ) { 




1209




1





 





 





 





 





6



 		    substr $_, 0, 0, $perl; 




1210




 





 





 





 





 





 



 		} else { 




1211




1





 





 





 





 





7



 		    goto NEXT; 




1212




 





 





 





 





 





 



 		} 




1213




 





 





 





 





 





 



 	    } else { 




1214




 





 





 





 





 





 



 		last unless 




1215




30




  
100
  



  
100
  




 





 





126



 		    s!^&(\.?\w+|-)(\(((?:(?>[^()]+)|(?2))*)\))!convert_Query $1, $3!e 




 




3





 





 





 





 





4



   




1216




11





 





 





 





 





19



 		    or s!^&(\.?\w+|-) *(.*)!convert_Query $1, $2!e; 




1217




 





 





 





 





 





 



 	    } 




1218




 





 





 





 





 





 



 	} 




1219




 





 





 





 





 





 



   




1220




16





 





 





 





 





12



 	my $filter = ''; 




1221




16





 




  
100
  




 





 





127



 	while( s/^\s*$perl_re// || s%^\s*(!?)(/.+?/(?:i\b)?)\s*%% ) { 




1222




9




  
100
  




 





 





 





18



 	    if( defined $2 ) { 




1223




3





 





 





 





 





8



 		$filter .= 'return if ' . $regexp_fail->( $1, $2 ) .  ";\n"; 




1224




 





 





 





 





 





 



 	    } else { 




1225




6





 





 





 





 





38



 		$filter .= "return unless eval $1;\n"; 




1226




 





 





 





 





 





 



 	    } 




1227




 





 





 





 





 





 



 	} 




1228




16




  
100
  




 





 





 





20



 	if( $filter ) { 




1229




7





 





 





 





 





900



 	    $filter = eval "sub {\n$filter 1; }"; 




1230




7




  
 50
  




 





 





 





29



 	    warn $@ if $@; 




1231




 





 





 





 





 





 



 	} 




1232




16




  
100
  




 





 





 





62



 	goto RUN if s/^\s*=//;	# run literally 




1233




 





 





 





 





 





 



   




1234




11





 





 





 





 





9



 	my $skip = 0; 




1235




11




  
100
  




 





 





 





24



 	if( /^\s*\?\s*(?:([?&#.:])(\w*)|(\w*)\()?/ ) { # help 




1236




2




  
 50
  



  
 33
  




 





 





10



 	    if( $1 && $1 eq '?' ) { 




1237



  
0
  




 





 





 





 





0



 		s/^\s*\?\s*\?//; 




1238



  
0
  




 





 





 





 





0



 		$skip = 1; 




1239




 





 





 





 





 





 



 	    } else { 




1240




2





 





 





 





 





6



 		help( $1, $2, $3 ); 




1241




2





 





 





 





 





10



 		goto NEXT; 




1242




 





 





 





 





 





 



 	    } 




1243




 





 





 





 





 





 



 	} 




1244




9




  
 50
  




 





 





 





13



 	if( s/^\s*!// ) { 




1245



  
0
  




 





 





 





 





0



 	    system $_; 




1246



  
0
  



  
  0
  




 





 





 





0



 	    if( $? == -1 ) { 




 




 




  
  0
  




 





 





 





 



   




1247



  
0
  




 





 





 





 





0



 		print STDERR "failed to execute: $!\n"; 




1248




 





 





 





 





 





 



 	    } elsif( my $exit = $? & 0b111_1111 ) { 




1249



  
0
  



  
  0
  




 





 





 





0



 		printf STDERR "child died with signal %d, with%s coredump\n", 




1250




 





 





 





 





 





 



 		    $exit, ($? & 0b1000_0000) ? '' : 'out'; 




1251




 





 





 





 





 





 



 	    } else { 




1252



  
0
  




 





 





 





 





0



 		printf STDERR "child exited with value %d\n", $? >> 8; 




1253




 





 





 





 





 





 



 	    } 




1254



  
0
  




 





 





 





 





0



 	    goto NEXT; 




1255




 





 





 





 





 





 



 	} 




1256




9





 





 





 





 





26



 	s/^\s*()//;			# dummy because $1 survives loop iterations :-o 




1257




9




  
 50
  




 





 





 





25



 	if( /\A(>{1,2})\s*(.+?(\.\w+)?)(?:\((.*)\))?\s*\Z/ ) {	# redirect output 




 




 




  
 50
  




 





 





 





 



   




1258



  
0
  



  
  0
  




 





 





 





0



 	    set_render $3, $4 ? split ';', $4 : () if $3; 




 




 




  
  0
  




 





 





 





 



   




1259



  
0
  




 





 





 





 





0



 	    open $fh, "$1:utf8", (glob $2)[0]; 




1260



  
0
  




 





 





 





 





0



 	    select $fh; 




1261



  
0
  




 





 





 





 





0



 	    goto NEXT; 




1262




 





 





 





 





 





 



 	} elsif( /\A\|(.+)\Z/ ) {	# pipe output 




1263



  
0
  




 





 





 





 





0



 	    open $fh, '|-:utf8', $1; 




1264



  
0
  




 





 





 





 





0



 	    select $fh; 




1265



  
0
  




 





 





 





 





0



 	    goto NEXT; 




1266




 





 





 





 





 





 



 	} 




1267




 





 





 





 





 





 



   




1268




9





 





 





 





 





8



 	undef $error; 




1269




 





 





 





 





 





 



   




1270




9




  
100
  



  
 66
  




 





 





23



 	goto NEXT unless $_ && &convert; 




1271




 





 





 





 





 





 



   




1272




7





 





 





 





 





22



 	print STDOUT "$_;\n"; 




1273




7




  
 50
  




 





 





 





12



 	goto NEXT if $skip; 




1274




 





 





 





 





 





 



   




1275




12




  
 50
  




 





 





 





38



       RUN: 




1276




 





 





 





 





 





 



 	run $_, $filter, %opt if $dbh; 




1277




12





 





 





 





 





54



 	($render, %opt) = (); 




1278




12




  
 50
  




 





 





 





18



 	if( $fh ) { 




1279



  
0
  




 





 





 





 





0



 	    close; 




1280



  
0
  




 





 





 





 





0



 	    select STDOUT; 




1281



  
0
  




 





 





 





 





0



 	    undef $fh; 




1282




 





 





 





 





 





 



 	} 




1283




 





 





 





 





 





 



       NEXT: 




1284




19





 





 





 





 





134



 	print STDERR $prompt; 




1285




 





 





 





 





 





 



     } 




1286




1





 





 





 





 





26



     print STDERR "\n"; 




1287




 





 





 





 





 





 



 } 




1288




 





 





 





 





 





 



   




1289




 





 





 





 





 





 



   




1290




 





 





 





 





 





 



   




1291




 





 





 





 





 





 



 sub helphashalt(\%@) { 




1292



  
0
  




 





 




  
0
  



  
0
  




0



     my $hash = shift; 




1293



  
0
  



  
  0
  




 





 





 





0



     if( @_ ) { 




1294



  
0
  




 





 





 





 





0



 	my $ret = $hash->{''}; 




1295



  
0
  




 





 





 





 





0



 	print "for *ptr, *cr, *cp, ...:\n"; 




1296




 





 





 





 





 





 



 	printf "%-5s %s\n", $_, &$ret( $_ ) 




1297



  
0
  




 





 





 





 





0



 	    for @_; 




1298



  
0
  




 





 





 





 





0



 	print "\n"; 




1299




 





 





 





 





 





 



     } 




1300




 





 





 





 





 





 



     $_ eq '' or printf "%-5s %s\n", $_, $hash->{$_} 




1301



  
0
  




 




  
  0
  




 





 





0



 	for sort keys %$hash; 




1302




 





 





 





 





 





 



 } 




1303




 





 





 





 





 





 



 sub helphash($$$\%;\@) { 




1304




 





 





 





 





 





 



     #my( $str, $prefix, $suffix, $hash, $list ) = @_; 




1305




2




  
 50
  




 




  
2
  



  
0
  




4



     if( $_[0] ) { 




1306




2





 





 





 





 





2



 	undef $error; 




1307




2




  
 50
  



  
 33
  




 





 





4



 	$error or printf "%-7s %s\n", "$_[1]$_[0]$_[2]", $_ if $_ = &find; 




1308




 





 





 





 





 





 



     } else { 




1309



  
0
  




 





 





 





 





0



 	my %hash = %{$_[3]}; 




 



  
0
  




 





 





 





 





0



   




1310



  
0
  



  
  0
  




 





 





 





0



 	if( my $sub = delete $hash{''} ) { 




1311



  
0
  




 





 





 





 





0



 	    my @list = $sub->(); 




1312



  
0
  




 





 





 





 





0



 	    for my $elt ( @list ) { 




1313



  
0
  




 





 





 





 





0



 		$hash{$elt->[0]} = $sub->( my $name = $elt->[0] ) . '    ' . $elt->[1]; 




1314




 





 





 





 





 





 



 	    } 




1315




 





 





 





 





 





 



 	} 




1316



  
0
  




 





 





 





 





0



 	chomp %hash; 




1317




 





 





 





 





 





 



 	printf "%-7s %s\n", "$_[1]$_$_[2]", $hash{$_} 




1318



  
0
  



  
  0
  




 





 





 





0



 	    for sort { lc( $a ) cmp lc( $b ) or  $a cmp $b } keys %hash; 




 



  
0
  




 





 





 





 





0



   




1319



  
0
  



  
  0
  




 





 





 





0



 	return unless $_[4]; 




1320



  
0
  




 





 





 





 





0



 	my $i = 0; 




1321



  
0
  



  
  0
  




 





 





 





0



 	my @list = sort { lc( $a ) cmp lc( $b ) or  $a cmp $b } @{$_[4]}; 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




1322



  
0
  




 





 





 





 





0



 	while( @list ) { 




1323



  
0
  



  
  0
  




 





 





 





0



 	    if( ($i += length $list[0]) < 80 ) { 




1324



  
0
  




 





 





 





 





0



 		print ' ', shift @list; 




1325




 





 





 





 





 





 



 	    } else { 




1326



  
0
  




 





 





 





 





0



 		$i = 0; 




1327



  
0
  




 





 





 





 





0



 		print "\n"; 




1328




 





 





 





 





 





 



 	    } 




1329




 





 





 





 





 





 



 	} 




1330



  
0
  



  
  0
  




 





 





 





0



 	print "\n" if $i; 




1331




 





 





 





 





 





 



     } 




1332




 





 





 





 





 





 



 } 




1333




 





 





 





 





 





 



   




1334




 





 





 





 





 





 



 sub help { 




1335




2




  
 50
  




 




  
2
  



  
0
  




16



     if( defined $_[2] ) { 




 




 




  
 50
  




 





 





 





 



   




 




 




  
 50
  




 





 





 





 



   




 




 




  
 50
  




 





 





 





 



   




 




 




  
 50
  




 





 





 





 



   




1336



  
0
  




 





 





 





 





0



 	helphash $_[2], '', '(', %Functions, @Functions; 




1337




 





 





 





 





 





 



     } elsif( !$_[0] ) { 




1338



  
0
  




 





 





 





 





0



 	print <<\HELP; 




1339




 





 





 





 





 





 



 All entries are single line unless \\wrapped at 1st bol and last eol\\ or continued.\ 




1340




 





 





 





 





 





 



 Queries have the form: {{!}/regexp/{i}}{=}query 




1341




 





 





 





 





 





 



 The query has lots of short-hands expanded, unless it is prefixed by the optional =. 




1342




 





 





 





 





 





 



 The fields joined with '~' are grepped if regexp is given, case-insensitively if i is given. 




1343




 





 





 





 





 





 



   




1344




 





 





 





 





 





 



 ??query		Only shows massaged query. 




1345




 





 





 





 





 





 



 !perl-code	Runs perl-code. 




1346




 





 





 





 





 





 



 >file		Next query's output to file.  In csv or yaml format if filename has that suffix. 




1347




 





 





 





 





 





 



   




1348




 





 





 





 





 





 



 Query has the form {select|update|insert|delete}{fieldlist};tablelist{;clause} or set ... 




1349




 





 





 





 





 





 



 'select' is prepended if none of these initial keywords. 




1350




 





 





 





 





 





 



 fieldlist defaults to '*', also if Query starts with '#'. 




1351




 





 





 





 





 





 



 ';' is alternately replaced by 'from' and 'where'. 




1352




 





 





 





 





 





 



   




1353




 





 





 





 





 





 



 Abbreviations, more help with ?&{abbrev}, ?:{abbrev}, ?#{abbrev}, ?.{abbrev}, ?{abbrev}( 




1354




 





 





 





 





 





 



 &{Perl code}...		# only at bol, if it returns undef then skip, else prepend to ... 




1355




 





 





 





 





 





 



 &query $1;$2;...	# only at bol 




1356




 





 





 





 





 





 



 &query($1;$2;...)...	# only at bol, only replace upto ) 




1357




 





 





 





 





 





 



 #table #table#t 




1358




 





 





 





 





 





 



 .column	.column.c	# for any table recognized in statement 




1359




 





 





 





 





 





 



 function( 




1360




 





 





 





 





 





 



 :macro 




1361




 





 





 





 





 





 



 :{Perl code}		# dynamic macro 




1362




 





 





 





 





 





 



   




1363




 





 





 





 





 





 



 Characters \t\n\r get masked in output, \r\n as \R. 




1364




 





 





 





 





 





 



 Date or time 0000-00-00 -> 0000-  1970-01-01 -> 1970-  00:00:00 -> 00:  23:59:59 -> 24: 




1365




 





 





 





 





 





 



 HELP 




1366




 





 





 





 





 





 



     } elsif( $_[0] eq '#' ) { 




1367



  
0
  



  
  0
  




 





 





 





0



 	@keys_Table_Columns = keys %Table_Columns unless @keys_Table_Columns; 




1368



  
0
  




 





 





 





 





0



 	helphash $_[1], '#', '', %Tables, @keys_Table_Columns; 




1369




 





 





 





 





 





 



     } elsif( $_[0] eq '.' ) { 




1370



  
0
  



  
  0
  




 





 





 





0



 	helphashalt %Columns, 'ptr' unless $_[1]; 




1371



  
0
  



  
  0
  



  
  0
  




 





 





0



 	$error or print "$_\n" if 




 




 





 




  
  0
  




 





 





 



   




1372




 





 





 





 





 





 



 	    $_[1] and $_ = find $_[1], '.', '', %Columns; # \todo, @column; 




1373




 





 





 





 





 





 



     } elsif( $_[0] eq '&' ) { 




1374




2




  
 50
  




 





 





 





3



 	print <<\HELP unless $_[1]; 




1375




 





 





 





 





 





 



 &{ Query name => 'doc', 'query' }   define query &name on the fly 




1376




 





 





 





 





 





 



 	query may contain arguments a bit like the Shell: $1, $2, ..., $* 




1377




 





 





 





 





 





 



 	they can become quoted: $\1, $\"2, $\`*, $\[3, $\{}> 




1378




 





 





 





 





 





 



 	$* means all args; $> the remaining args after using up the numbered ones 




1379




 





 





 





 





 





 



 	if it is quoted, each arg gets quoted, separated by a comma 




1380




 





 





 





 





 





 



 	$?arg?arg-replacement?no-arg-replacement? 1st if $arg has a value 




1381




 





 





 





 





 





 



 HELP 




1382




2





 





 





 





 





9



 	helphash $_[1], '&', '', %Queries_help; 




1383




 





 





 





 





 





 



     } else { 




1384



  
0
  



  
  0
  




 





 





 





 



 	print <<\HELP unless $_[1]; 




1385




 





 





 





 





 





 



 :\(...)	 split arguments and quote in many ways 




1386




 





 





 





 





 





 



 HELP 




1387



  
0
  




 





 





 





 





 



 	local $Tables{TBL} = 'TABLE'; 




1388




0





 





 





 





 





 



 	helphash $_[1], ':', '', %Macros; 




1389




 





 





 





 





 





 



     } 




1390




 





 





 





 





 





 



 } 




1391




 





 





 





 





 





 



   




1392




 





 





 





 





 





 



 1; 




1393




 





 





 





 





 





 



   




1394




 





 





 





 





 





 



 =head1 YOUR SCRIPT 




1395




 





 





 





 





 





 



   




1396




 





 





 





 





 





 



     package SQL::Steno;		# doesn't export yet, so get the functions easily 




1397




 





 





 





 





 





 



     use SQL::Steno; 




1398




 





 





 





 





 





 



     use DBI; 




1399




 





 





 





 





 





 



     our $dbh = DBI->connect( ... ); # preferably mysql, but other DBs should work (with limitations). 




1400




 





 





 





 





 





 



     # If you want #tbl and .col to work, (only) one of: 




1401




 





 





 





 





 





 



     init_from_query;		# fast, defaults to mysql information_schema, for which you need read permission 




1402




 





 





 





 





 





 



     init;			# slow, using DBI dbh methods. 




1403




 





 





 





 





 





 



     # Set any of the variables mentioned above to get you favourite abbreviations. 




1404




 





 





 





 





 





 



     shell; 




1405




 





 





 





 





 





 



   




1406




 





 





 





 





 





 



 =head1 LICENSE 




1407




 





 





 





 





 





 



   




1408




 





 





 





 





 





 



 This program is free software; you may redistribute it and/or modify it under 




1409




 





 





 





 





 





 



 the same terms as Perl itself. 




1410




 





 





 





 





 





 



   




1411




 





 





 





 





 





 



 =head1 SEE ALSO 




1412




 





 





 





 





 





 



   




1413




 





 





 





 





 





 



 L, L, L, L, L 




1414




 





 





 





 





 





 



   




1415




 





 





 





 





 





 



 =head1 AUTHOR 




1416




 





 





 





 





 





 



   




1417




 





 





 





 





 





 



 (C) 2015, 2016 by Daniel Pfeiffer .
without the leading C<#>.  E.g. C<:ljtbl#t> might expand to C
t>.

Those starting with C<:gb> (group by) or C<:ob> (order by) may be followed by
result columns numbers from 1-9, each optionally followed by a or d for asc or
desc.  E.g. C<:ob2d3> gives C.

=head3 C<:+I> E or E C<:I+I> E or E C<:-I> E or E C<:I-I>

These are time calculation macros, where an optional leading letter indicates
a base time, and an optional trailing letter with an optional count means the
offset.  The letters are:

=over

=item y

(this) year(start).  E.g. C<:y+2m> is march this year.

=item q

(this) quarter(start).  E.g. C<:q+0> is this quarter, C<:q+q> is next quarter.

=item m

(this) month(start).  E.g. C<:-3m> is whatever precedes, minus 3 months.

=item w

(this) week(start).  E.g. C<:w+3d> is this week thursday (or wednesday if you
set C<$weekstart> to not follow ISO 8601 and the bible).

=item d

(this) day(start).  E.g. C<:d-w> is midnight one week ago.

=item h

(this) hour(start).  E.g. C<:h+30M> is half past current hour.

=item M

(this) minute(start).  E.g. C<:+10M> is whatever precedes, plus 10min.

=item s

(this) second.  E.g. C<:s-2h> is exactly 2h ago.

=back


=head3 C<:{I}>

This gets replaced by what it returns.


=head3 C<#I> E or E C<#I#> E or E C<#I#I>

Here I is a key of C<%Tables> or any abbreviation of known tables in
C<@Tables>.  If followed by C<#>, the abbreviation is used as an alias, unless
an I directly follows, in which case that is used.


=head3 C<.I

Here I
recognized in the query.  If followed by C<.>, the abbreviation is used as an
alias, unless an I directly follows, in which case that is used.  It tries
to be clever about whether the 1st C<.> needs to be preserved, i.e. following
a table name.

=head3 C(> E or E C\I(I)> E
or E C\I%I(I)>

Here I is a key of C<%Functions> or any
abbreviation of known functions in C<@Functions>, which includes words
typically followed by an opening parenthesis, such as C for C.
C becomes C, whereas C becomes C.

If the 2nd or 3rd form is used, the I inside of the parentheses are treated
just like C(I)|/spec-strings-or-:-spec-join-strings>>,
but in this case preserving the parentheses.

If the 1st argument of a function is empty and the abbrev or function is found
in C<%DefaultArguments> the value becomes the 1st argument.
E.g. C or C both become
C.

=head3 Abbreviated Keyword

Finally it picks on the structure of the statement: These keywords can be
abbreviated: C, C, C or C.  If none of
these or C is present, C is assumed as default (more keywords
need to be recognized in the future).

For C, semicolons are alternately replaced by C (the 1st being
optional if it starts with a table name) and C.  If no result columns
are given, they default to C<*>, see L.  For C, semicolons
are frst replaced by C and then C.

=cut

sub convert {
    # Handle :\...(str1, str2, str3)
    s<(?:\b(\w+)|:)$quote_re\((.+?)\)> {
	($1 ? "$1(" : '') .
 	quote($2, $3, $4 ) .
	($1 ? ')' : '')
    }ge;
    my @strings;		# extract strings to prevent following replacements inside.
    while( /\G.*?(['"`[{])/gc ) {
	my $rq = $rq{$1}||$1;
	my $pos = pos;
	while( /\G.*?([$rq\\])/gc ) {
	    if( $1 eq '\\' ) {
		++pos;		# skip next
	    } elsif( ! /\G$rq/gc ) { # skip doubled quote
		push @strings,
		    substr $_, $pos - 1, 1 - $pos + pos, # get string
		    "\cS".@strings."\cZ"; # and replace with counter
		last;
	    }
	}
    }

    until( $error ) {
	s&:$perl_re&my $ret = eval $1; warn $@ if $@; $ret // ' NULL '&ego or
	    # \todo (?(?<=\w)\b)
	    s&:($timespec_re[+-]\d*$timespec_re(?(?<=\w)\b)|l?j\w+(?:#(\w*))|\w+)&find $1, ':', '', %Macros&ego or
		last;
    }

    s&^(?=#)&;&;		# Assume empty fieldlist before table name
    &convert_table_column;
    s&^(?=$table_re)&;&;	# Assume empty fieldlist before table name

    s&\b(\w+)\((?=\s*([,)])?)&my $fn = find $1, '', '(', %Functions, @Functions; ($fn || $1).'('.($2 and $DefaultArguments{$1} || $DefaultArguments{$fn} or '')&eg unless $error;
    #s&\b(\w+)(?=\()&find $1, '', '(', %Functions, @Functions or $1&eg unless $error;

    return if $error;
    s/\A\s*;/*;/;
    s/;\s*\Z//;
    if( s/^upd(?:a(?:t(?:e)?)?)?\b/update/i ) {
	s/(?
    } else {
	s/(?
	s/^ins(?:e(?:r(?:t)?)?)?\b/insert/i ||
	    s/^del(?:e(?:t(?:e)?)?)?\b/delete/i ||
	    s/^(?!se(?:lec)?t)/select /i;
    }

    s/ $//mg;
    s/ {2,}/ /g;
    s/\cS(\d+)\cZ/$strings[$1]/g; # put back the strings

    1;
}


# escape map for special replacement characters
my %esc = map { $_ eq 'v' ? "\013" : eval( qq!"\\$_"! ), "\\$_" } qw'0 a b e f n r t v \ "';

# With an argument of total number of rows, init output counting and return undef if it is to be skipped (not stdout).
# Without an argument, do the counting and return undef if no more rows wanted.
{
    my( $total, $cnt, $i );
    sub count(;$) {
	if( @_ ) {
	    $total = $_[0];
	    $cnt = 0;
	    $i = 100;
	    return select eq 'main::STDOUT' ? 1 : undef;
	}
	++$cnt;
	if( --$i <= 0 && $cnt < $total ) {
	    printf STDERR "How many more, * for all, or q to quit? (%d of %d) [default: 100] ",
		$cnt, $total;
	    $i = <>;
	    if( defined $i ) {
		$i =~ tr/qQxX \t\n\r/0000/d;
		$i = (0 == length $i) ? 100 :
		    $i eq '*' ? ~0 :
			$i == 0 ? return :
			    $i;
	    } else {
		print "\n";
		return;
	    }
	}
	1;
    }
}

sub render_csv($;$$) {
    my( $sth, $filter ) = @_;
    my( $semi, $tab ) =
	(exists $_[2]{semi},
	 exists $_[2]{tab})
	if $_[2];
    my $name = $sth->{NAME};
    my @row = @$name;
    while() {
	for( @row ) {
	    if( defined ) {
		$_ = qq!"$_"! if
		    /\A\Z/ or
		    s/"/""/g or
		    $semi ? tr/;\n// : $tab ? tr/\t\n// : tr/,\n// or
		    /\A=/;
	    } else {
		$_ = '';
	    }
	    utf8::decode $_;
	}
	print join( $semi ? ';' : $tab ? "\t" : ',', @row ) . "\n";

      FETCH:
	@row = $sth->fetchrow_array
	    or last;
	$filter->( $name, @row ) or goto FETCH if $filter;
    }
}

our $NULL = 'ω';
utf8::decode $NULL;
my( $r1, $r2, $r3, $r5 ) = ('[01]\d', '[0-2]\d', '[0-3]\d', '[0-5]\d');
sub render_table($;$$) {
    my( $sth, $filter ) = @_;
    my( $null, $crlf, $date, $time ) =
	exists $_[2]{all} ?
	('NULL', 1, 1, 1) :
	(exists $_[2]{NULL} ? 'NULL' : exists $_[2]{null} ? 'null' : 0,
	 exists $_[2]{crlf},
	 exists $_[2]{date},
	 exists $_[2]{time})
	if $_[2];
    $null ||= $NULL;
    my @name = @{$sth->{NAME}};
    my @len = (0) x @name;
    my( @txt, @res, @comp );
    while( my @res1 = $sth->fetchrow_array ) {
	$filter->( \@name, @res1 ) or next if $filter;
	for my $i ( 0..$#res1 ) {
	    if( !defined $res1[$i] ) {
		$res1[$i] = $null;
	    } elsif( $res1[$i] !~ /^\d+(?:\.\d+)?$/ ) {
		$txt[$i] = 1;
		$res1[$i] =~ s/\r\n/\\R/g unless $crlf;
		$res1[$i] =~ s/([\t\n\r])/$esc{$1}/g;
		no warnings 'uninitialized';
		unless( $date ) {
		    if( $res1[$i] =~ s/^(\d{4}-)($r1)-0[01]([T ]$r2:$r5(?::$r5(?:[.,]\d{3})?)?(?:Z|[+-]$r2:$r5)?)?$/$1/o ) {
			$res1[$i] .= "$2-" if $2 > 1;
			$res1[$i] .= $3 if $3;
		    }
		}
		unless( $time ) {
		    if( $res1[$i] =~ s/^(\d{4}-(?:$r1-(?:$r3)?)?[T ])?($r2):($r5)(?::($r5)(?:([.,])(\d{3}))?)?(Z|[+-]$r2:$r5)?$/$1/o ) {
			$res1[$i] = $1 || '';
			if( $2 == 23 && $3 == 59 && ($4 // 59) == 59 && ($6 // 999) == 999 ) {
			    $res1[$i] .= "24:";
			} elsif( $6 > 0 ) {
			    $res1[$i] .= "$2:$3:$4$5$6";
			} elsif( $4 > 0 ) {
			    $res1[$i] .= "$2:$3:$4";
			} elsif( $3 > 0 ) {
			    $res1[$i] .= "$2:$3";
			} else {
			    $res1[$i] .= "$2:";
			}
			($res1[$i] .= $7) =~ s/:00$/:/
			    if $7;
		    }
		}
		utf8::decode $res1[$i];
	    }
	    $txt[$i] = 0 if @txt < $i;
	    my $len = length $res1[$i];
	    $len[$i] = $len if $len[$i] < $len;
	}
	if( @comp ) {
	    for my $i ( 0..$#comp ) {
		undef $comp[$i] if defined $comp[$i] && $comp[$i] ne $res1[$i];
	    }
	} else {
	    @comp = @res1;
	}
	push @res, \@res1;
    }
    if( @res ) {
	@comp = () if @res == 1;
	my $fmt = '';
	for( my $i = 0; $i < @name; ++$i ) {
	    $name[$i] =~ s/\r\n/\\R/g;
	    $name[$i] =~ s/([\t\n\r])/$esc{$1}/g;
	    if( defined $comp[$i] ) {
		my $more;
		while( defined $comp[$i] ) {
		    printf $fmt, @name[0..$i-1] unless $more;
		    $more = 1;
		    printf "[%s=%s]", $name[$i], $comp[$i];
		    @name[0..$i] = ('') x ($i+1);
		    for my $row ( \@comp, \@name, \@len, \@txt, @res ) {
			splice @$row, $i, 1;
		    }
		}
		print "\n";
		--$i, next;
	    }
	    if( $len[$i] < length $name[$i] ) {
		printf "$fmt%s\n", @name[0..$i];
		@name[0..$i] = ('') x ($i+1);
	    }
	    $fmt .= '%' . ($txt[$i] ? -$len[$i] : $len[$i]) . 's|';
	}
	$fmt .= "\n";
	printf $fmt, @name if $name[-1];
	printf $fmt, map '-'x$_, @len;
	my $count = count @res;		# init
	for my $row ( @res ) {
	    printf $fmt, @$row;
	    defined count or last if defined $count;
	}
    }
}

my $yaml_re = join '', sort keys %esc;
$yaml_re =~ s!\\!\\\\!;
my $tabsize = $ENV{TABSIZE} || 8;
sub render_yaml($;$$) {
    my( $sth, $filter ) = @_;
    my @label;			       # Fill on 0th round with same transformation as data (but \n inline)
    my $count = count $DBI::rows || 1; # init \todo don't know how many unfiltered
    my @row = @{$sth->{NAME}};
    while() {
	local $_;
	my $i = 0;
	for( @row ) {
	    if( !defined ) {
		$_ = '~';
	    } elsif( /^(?:y(?:es)?|no?|true|false|o(?:n|ff)|-?\.inf|\.nan)$/s ) { # can only be string in Perl or DB
		$_ = "'$_'";
	    } elsif( tr/][{},?:`'"|<>&*!%#@=~\0-\010\013-\037\177-\237-// or @label ? 0 : tr/\n// ) {
		s/([$yaml_re])/$esc{$1}/go;
		s/([\0-\010\013-\037\177-\237])/sprintf "\\x%02x", ord $1/ge;
		$_ = qq!"$_"!;
	    } elsif( tr/\n// ) {
		my $nl = chomp;
		s/^/    /mg;
		substr $_, 0, 0, $nl ? "|2\n" : "|2-\n";
	    }
	    printf "$label[$i++]$_\n" if @label;
	}
	if( @label ) {
	    defined count or last if defined $count;
	} else {
	    my $maxlen = 0;
	    for( @row ) {
		substr $_, 0, 0, $maxlen ? '  ' : '- '; # 1st field if no maxlen yet
		my $length = 0;
		$length += $1 ? $tabsize - $length % $tabsize : length $2
		    while /\G(?:(\t)|([^\t]+))/gc;
		$_ .= ": $length";
		$maxlen = $length if $maxlen < $length;
	    }
	    s/(\d+)\Z/' ' x ($maxlen - $1)/e
		for @label = @row;
	}
      FETCH:
	@row = $sth->fetchrow_array
	    or last;
	$filter->( $sth->{NAME}, @row ) or goto FETCH if $filter;
    }
}



my $lasttime = time;
sub run($;$\%) {
    my( $sql, $filter, $opt ) = @_;
    my $t0 = [gettimeofday];
    if( $DBI::err || $t0->[0] - $lasttime > 3600 and !$dbh->ping ) {
	printf STDOUT "Inactive for %ds, ping failed after %.03fs, your session variables are lost.\n",
	    $t0->[0] - $lasttime, tv_interval $t0;
	#$dbh->disconnect;
	$dbh = $dbh->clone;	# reconnect
	$t0 = [gettimeofday];
    }
    $lasttime = $t0->[0];
    if( my $sth = UNIVERSAL::isa( $sql, 'DBI::st' ) ? $sql : $dbh->prepare( $sql )) {
	my $t1 = [gettimeofday];
	$sth->execute;
	printf STDOUT "prepare: %.03fs   execute: %.03fs   rows: %d\n",
	    tv_interval( $t0, $t1 ), tv_interval( $t1 ), $DBI::rows;
	if( $sth->{Active} ) {
	    if( $render ) {
		&$render( $sth, $filter, $opt );
	    } else {
		render_table $sth, $filter, $opt;
	    }
	}
    }
}


=head2 shell

This function reads, converts and (if C<$dbh> is set) runs in an end-less loop
(i.e. till end of file or C<^D>).  Reading is a single line affair, unless you
request otherwise.  This can happen either, as in Unix Shell, by using
continuation lines as long as you put a backslash at the end of your lines.
Or there is a special case, if the 1st line starts with C<\\>, then everything
up to C<\\> at the end of one of the next lines, constitutes one entry.

In addition to converting, it offers a few extra features, performed in this
order (i.e. C<&I> can return C/=I> etc.):

=head3 C<&{I} I>

Run I.  It sees the optional I in C<$_> and may
modify it.  If it returns C, this statement is skipped.  If it returns
a DBI statement handle, run that instead of this statement.  Else replace with
what it returns.

Reprocess result as a shell entry (i.e. it may return another C<&I>).

=head3 C<&I; ...> E or E C<&I( I; ... ) I>

These allow canned entries and are more complex than macros, in that they take
arguments and replacement can depend on the argument.

Reprocess result as a shell entry (i.e. it may return another C<&I>).

You can define your own canned queries with:

C<    &{ Query I =E 'I', 'I' }>

Here C becomes the replacement string for C<&name>.  It may contain
arguments a bit like the Shell: C<$0> (I), C<$*> (all arguments), C<$1,
$2, ..., $10, ...> (individual arguments) and C<$E> (all arguments not
adressed individually).  They can become quoted like
L|/spec-strings-or-:-spec-join-strings> as C<:\II> or
C<:\I%II>.  Here I is C<*>, C> or a number
directly tacked on to I or I.  E.g.: C<$\-"1> splits the 1st
(semi-colon separated from the 2nd) argument itself on C<-> (minus), quotes
the pieces with C<"> (double quote) and joins them with C<,> (comma).  Putting
the quotes inside the argument like this, eliminates them, if no argument is
given.

=head3 C/ I> E or E C/i I> E or E C/ I> E or E C/i I>

This will treat the I normally, but will join each output row into
a C<~> (tilde) separated string for matching.  NULL fields are rendered as
that string.  E.g. to return only rows starting with a number 1-5, followed by
a NULL field, you could write: C.

With a suffix C, matching becomes case insensitive.  This is why the mostly
optional space before I is shown above.  Without an C, but if
the statement starts with the word C (e.g. your first column name), you
must separate it with a space.  With an C, if the statement starts with an
alphanumeric caracter, you must separate it with a space.

Only matching rows are considered unless there is a preceding C
(exclamation mark), in which case only non-matching rows are considered.

You can provide your own formatting of the row by setting C<$regexp_fail> to a
Perl sub that returns a Perl expression as a string.  That expression takes
the row in C<@_> and shall be true if the row fails to match.

Caveat: the whole result set of the I gets generated and
transferred to the client.  This is definitely much more expensive than doing
the equivalent filtering in the where clause.  But it is not a big deal for
tens or maybe hundreds of thousands or rows, probably still faster than
writing the corresponding SQL.  And Perl's regexps are so much more powerful.

=head3 C<{I}I>

Call I for every output row returned by the I with the
array of column names as zeroth argument and the values after that (i.e.
numbered from 1 like in SQL).  It may modify individual values.  If it returns
false, the row is skipped.

You may combine S/{I}>> in any order and as many of them as
you want.

The same caveat as for regexps applies here.  But again Perl is far more
powerful than any SQL functions.

=head3 C<=I>

A preceding C<=> prevents conversion, useful for hitherto untreated keywords
or where the conversion doesn't play well with your intention.

=head3 C

Help prefix.  Alone it will give an overview.  You can follow up with any of
the special syntaxes, with or without an abbreviation.  E.g. C will show
all function abbreviations, whereas C(> will show only those functions
matching abbrev or C> only those tables matching abbrev.

=head3 C>

Will convert and show, but not perform I.  If C<$dbh> is not set, this
is the default behaviour.

=head3 C>

Run I.

=head3 CI> E or E CEI>

Redirect or append next statement's output to I.  For known
suffixes and options, see the L.

=head3 C<|I>

Pipe next statement's output through I.

=head2 Output Formats

The output format for the next SQL statement that is run, is chosen from the
suffix of a redirection or a special suffix query.  In both cases
comma-separated options may be passed:

=over

=item >I.I

=item >I.I( I; ... )

=item >>I.I

=item >>I.I( I; ... )

=item &.I; ...

=item &.I( I; ... ) following text

=back

The known suffixes and their respective options are:

=over

=item C<.csv>

This writes Comma Separated Values with one subtle trick: NULL and empty
strings are distinguished by quoting the latter.  Some tools like Perl's file
DB L or rather its underlying L can pick that up.  CSV
can take one of these options:

=over

=item semi

Use a semicolon as a separator.  This is a common format in environments where
the comma is the decimal separator.  However if you want decimal commas, you must
provide such formatting yourself.

=item tab

Use tabulators as column separators.  Apart from that you get the full CSV
formatting, so this is not the primitive F<.tsv> format some tools may have.

=back


=item C<.table>

This is the default table format.  But you need to name it, if you want to set
options.

=over

=item all

This is a shorthand for outputting everything in the long form, equivalent to
C<( NULL, crlf, date )>.

=item crlf

Do not shorten C<\r\n> to C<\R>.

=item date

Output ISO dates fully instead of shortening 0000-00-00 to 0000- and
yyyy-01-01 to yyyy- or yyyy-mm-01 to yyyy-mm-.

=item time

Output times fully instead of shortening 23:59(:59) to 24: and hh:00(:00) to
hh: or hh:mm(:00) to hh:mm.

=item NULL

=item null

Output this keyword instead of the shorter C<ω> from DB theory (or whatever
you assigned to C<$NULL>).

=back


=item C<.yaml>

=item C<.yml>

Format output as YAML.  This format has no options.  Because its every value
on a new line format can be more readable, there is a shorthand query C<&->
for it.

=back

=cut

our $prompt = 'steno> ';
our $contprompt = '...>  ';
our $echo;
# Called for every leading re, 1st arg is the optional '!', 2nd arg '/re/' or '/re/i'.  Expression shall be true for non-matching lines.
our $regexp_fail = sub($$) { 'join( "~", map ref() ? () : $_ // q!NULL!, @_ )' . ($_[0] ? '=~' : '!~') . $_[1] };
sub shell() {
    print STDERR $prompt;
    my $fh;
    while( <> ) {
	undef $error;
	goto NEXT unless /\S/;
	if( s/^\s*\\\\\s*// ) {
	    s/\s*\Z/\n/s;
	    local $/ = "\\\\\n";	# leading \n gets chopped below
	    $_ .= <>;
	    chomp;
	} else {
	    while( s/(?
		print STDERR $contprompt;
		$_ .= <>;
	    }
	    s/\A\s+//;
	}
	s/\s+\Z//;
	say if $echo;
	until( $error ) {
	    if( s!^&$perl_re!! ) {
		my $perl = eval $1;
		local $| = 1;	# flush to avoid stderr prompt overtaking last output line.
		warn $@ if $@;
		if( UNIVERSAL::isa $perl, 'DBI::st' ) {
		    $_ = $perl;
		    goto RUN;
		} elsif( defined $perl ) {
		    substr $_, 0, 0, $perl;
		} else {
		    goto NEXT;
		}
	    } else {
		last unless
		    s!^&(\.?\w+|-)(\(((?:(?>[^()]+)|(?2))*)\))!convert_Query $1, $3!e
		    or s!^&(\.?\w+|-) *(.*)!convert_Query $1, $2!e;
	    }
	}

	my $filter = '';
	while( s/^\s*$perl_re// || s%^\s*(!?)(/.+?/(?:i\b)?)\s*%% ) {
	    if( defined $2 ) {
		$filter .= 'return if ' . $regexp_fail->( $1, $2 ) .  ";\n";
	    } else {
		$filter .= "return unless eval $1;\n";
	    }
	}
	if( $filter ) {
	    $filter = eval "sub {\n$filter 1; }";
	    warn $@ if $@;
	}
	goto RUN if s/^\s*=//;	# run literally

	my $skip = 0;
	if( /^\s*\?\s*(?:([?&#.:])(\w*)|(\w*)\()?/ ) { # help
	    if( $1 && $1 eq '?' ) {
		s/^\s*\?\s*\?//;
		$skip = 1;
	    } else {
		help( $1, $2, $3 );
		goto NEXT;
	    }
	}
	if( s/^\s*!// ) {
	    system $_;
	    if( $? == -1 ) {
		print STDERR "failed to execute: $!\n";
	    } elsif( my $exit = $? & 0b111_1111 ) {
		printf STDERR "child died with signal %d, with%s coredump\n",
		    $exit, ($? & 0b1000_0000) ? '' : 'out';
	    } else {
		printf STDERR "child exited with value %d\n", $? >> 8;
	    }
	    goto NEXT;
	}
	s/^\s*()//;			# dummy because $1 survives loop iterations :-o
	if( /\A(>{1,2})\s*(.+?(\.\w+)?)(?:\((.*)\))?\s*\Z/ ) {	# redirect output
	    set_render $3, $4 ? split ';', $4 : () if $3;
	    open $fh, "$1:utf8", (glob $2)[0];
	    select $fh;
	    goto NEXT;
	} elsif( /\A\|(.+)\Z/ ) {	# pipe output
	    open $fh, '|-:utf8', $1;
	    select $fh;
	    goto NEXT;
	}

	undef $error;

	goto NEXT unless $_ && &convert;

	print STDOUT "$_;\n";
	goto NEXT if $skip;

      RUN:
	run $_, $filter, %opt if $dbh;
	($render, %opt) = ();
	if( $fh ) {
	    close;
	    select STDOUT;
	    undef $fh;
	}
      NEXT:
	print STDERR $prompt;
    }
    print STDERR "\n";
}



sub helphashalt(\%@) {
    my $hash = shift;
    if( @_ ) {
	my $ret = $hash->{''};
	print "for *ptr, *cr, *cp, ...:\n";
	printf "%-5s %s\n", $_, &$ret( $_ )
	    for @_;
	print "\n";
    }
    $_ eq '' or printf "%-5s %s\n", $_, $hash->{$_}
	for sort keys %$hash;
}
sub helphash($$$\%;\@) {
    #my( $str, $prefix, $suffix, $hash, $list ) = @_;
    if( $_[0] ) {
	undef $error;
	$error or printf "%-7s %s\n", "$_[1]$_[0]$_[2]", $_ if $_ = &find;
    } else {
	my %hash = %{$_[3]};
	if( my $sub = delete $hash{''} ) {
	    my @list = $sub->();
	    for my $elt ( @list ) {
		$hash{$elt->[0]} = $sub->( my $name = $elt->[0] ) . '    ' . $elt->[1];
	    }
	}
	chomp %hash;
	printf "%-7s %s\n", "$_[1]$_$_[2]", $hash{$_}
	    for sort { lc( $a ) cmp lc( $b ) or  $a cmp $b } keys %hash;
	return unless $_[4];
	my $i = 0;
	my @list = sort { lc( $a ) cmp lc( $b ) or  $a cmp $b } @{$_[4]};
	while( @list ) {
	    if( ($i += length $list[0]) < 80 ) {
		print ' ', shift @list;
	    } else {
		$i = 0;
		print "\n";
	    }
	}
	print "\n" if $i;
    }
}

sub help {
    if( defined $_[2] ) {
	helphash $_[2], '', '(', %Functions, @Functions;
    } elsif( !$_[0] ) {
	print <<\HELP;
All entries are single line unless \\wrapped at 1st bol and last eol\\ or continued.\
Queries have the form: {{!}/regexp/{i}}{=}query
The query has lots of short-hands expanded, unless it is prefixed by the optional =.
The fields joined with '~' are grepped if regexp is given, case-insensitively if i is given.

??query		Only shows massaged query.
!perl-code	Runs perl-code.
>file		Next query's output to file.  In csv or yaml format if filename has that suffix.

Query has the form {select|update|insert|delete}{fieldlist};tablelist{;clause} or set ...
'select' is prepended if none of these initial keywords.
fieldlist defaults to '*', also if Query starts with '#'.
';' is alternately replaced by 'from' and 'where'.

Abbreviations, more help with ?&{abbrev}, ?:{abbrev}, ?#{abbrev}, ?.{abbrev}, ?{abbrev}(
&{Perl code}...		# only at bol, if it returns undef then skip, else prepend to ...
&query $1;$2;...	# only at bol
&query($1;$2;...)...	# only at bol, only replace upto )
#table #table#t
.column	.column.c	# for any table recognized in statement
function(
:macro
:{Perl code}		# dynamic macro

Characters \t\n\r get masked in output, \r\n as \R.
Date or time 0000-00-00 -> 0000-  1970-01-01 -> 1970-  00:00:00 -> 00:  23:59:59 -> 24:
HELP
    } elsif( $_[0] eq '#' ) {
	@keys_Table_Columns = keys %Table_Columns unless @keys_Table_Columns;
	helphash $_[1], '#', '', %Tables, @keys_Table_Columns;
    } elsif( $_[0] eq '.' ) {
	helphashalt %Columns, 'ptr' unless $_[1];
	$error or print "$_\n" if
	    $_[1] and $_ = find $_[1], '.', '', %Columns; # \todo, @column;
    } elsif( $_[0] eq '&' ) {
	print <<\HELP unless $_[1];
&{ Query name => 'doc', 'query' }   define query &name on the fly
	query may contain arguments a bit like the Shell: $1, $2, ..., $*
	they can become quoted: $\1, $\"2, $\`*, $\[3, $\{}>
	$* means all args; $> the remaining args after using up the numbered ones
	if it is quoted, each arg gets quoted, separated by a comma
	$?arg?arg-replacement?no-arg-replacement? 1st if $arg has a value
HELP
	helphash $_[1], '&', '', %Queries_help;
    } else {
	print <<\HELP unless $_[1];
:\(...)	 split arguments and quote in many ways
HELP
	local $Tables{TBL} = 'TABLE';
	helphash $_[1], ':', '', %Macros;
    }
}

1;

=head1 YOUR SCRIPT

    package SQL::Steno;		# doesn't export yet, so get the functions easily
    use SQL::Steno;
    use DBI;
    our $dbh = DBI->connect( ... ); # preferably mysql, but other DBs should work (with limitations).
    # If you want #tbl and .col to work, (only) one of:
    init_from_query;		# fast, defaults to mysql information_schema, for which you need read permission
    init;			# slow, using DBI dbh methods.
    # Set any of the variables mentioned above to get you favourite abbreviations.
    shell;

=head1 LICENSE

This program is free software; you may redistribute it and/or modify it under
the same terms as Perl itself.

=head1 SEE ALSO

L, L, L, L, L

=head1 AUTHOR

(C) 2015, 2016 by Daniel Pfeiffer .