X-Git-Url: http://wagnertech.de/git?a=blobdiff_plain;f=scripts%2Fconsole;h=bf4ffaa6c8fb05b16c2e47b77e6cbdb07c51377a;hb=2b9a68bb2041ebde41a7c52db436efc8dde06350;hp=e183ac83a516b5fb2bf85b7aa881e1ac6c03e83b;hpb=8a40e3dd0f638557b8c666fe708ccbc1ac709c4e;p=kivitendo-erp.git diff --git a/scripts/console b/scripts/console index e183ac83a..bf4ffaa6c 100755 --- a/scripts/console +++ b/scripts/console @@ -2,38 +2,82 @@ use warnings; use strict; +use utf8; +use open qw(:std :utf8); use 5.008; # too much magic in here to include perl 5.6 BEGIN { - unshift @INC, "modules/override"; # Use our own versions of various modules (e.g. YAML). - push @INC, "modules/fallback"; # Only use our own versions of modules if there's no system version. + use FindBin; + + unshift(@INC, $FindBin::Bin . '/../modules/override'); # Use our own versions of various modules (e.g. YAML). + push (@INC, $FindBin::Bin . '/..'); + push (@INC, $FindBin::Bin . '/../modules/fallback'); # Only use our own versions of modules if there's no system version. } use Data::Dumper; use Devel::REPL 1.002001; -use Term::ReadLine::Perl::Bind; # use sane key binding for rxvt users +use File::Slurp; +use Getopt::Long; +use Pod::Usage; use SL::LxOfficeConf; SL::LxOfficeConf->read; -my $login = shift || $::lx_office_conf{console}{login} || 'demo'; -my $history_file = $::lx_office_conf{console}{history_file} || '/tmp/lxoffice_console_history.log'; # fallback if users is not writable -my $debug_file = $::lx_office_conf{console}{log_file} || '/tmp/lxoffice_console_debug.log'; -my $autorun = $::lx_office_conf{console}{autorun}; +my $client = $::lx_office_conf{console}{client}; +my $login = $::lx_office_conf{console}{login} || 'demo'; +my $history_file = $::lx_office_conf{console}{history_file} || '/tmp/kivitendo_console_history.log'; # fallback if users is not writable +my $debug_file = $::lx_office_conf{console}{log_file} || '/tmp/kivitendo_console_debug.log'; +my $autorun = $::lx_office_conf{console}{autorun}; +my ($execute_code, $execute_file, $help, $man); + +my $result = GetOptions( + "login|l=s" => \$login, + "client|c=s" => \$client, + "history-file|i=s" => \$history_file, + "log-file|o=s" => \$debug_file, + "execute|e=s" => \$execute_code, + "file|f=s" => \$execute_file, + "help|h" => \$help, + "man" => \$man, +); +pod2usage(2) if !$result; +pod2usage(1) if $help; +pod2usage(-exitstatus => 0, -verbose => 2) if $man; # will be configed eventually my @plugins = qw(History LexEnv Colors MultiLine::PPI FancyPrompt PermanentHistory AutoloadModules); +sub execute_code { + my ($repl, $code) = @_; + + my $result = $repl->eval($code); + if (ref($result) eq 'Devel::REPL::Error') { + $repl->print($result->message); + return 0; + } + if ($@) { + $repl->print($@); + return 0; + } + + return 1; +} + my $repl = Devel::REPL->new; $repl->load_plugin($_) for @plugins; $repl->load_history($history_file); + +binmode($repl->out_fh, 'utf8'); + +$repl->eval('use utf8;'); $repl->eval('help'); -$repl->print("trying to auto login as '$login'..."); -$repl->print($repl->eval("lxinit '$login'")); -if ($autorun) { - my $result = $repl->eval($autorun); - $repl->print($result->message) if ref($result) eq 'Devel::REPL::Error'; -} +$repl->print("trying to auto login into client '$client' with login '$login'...\n"); +execute_code($repl, "lxinit '$client', '$login'"); + +my @code_to_execute = grep { $_ } ($autorun, $execute_code, $execute_file ? join('', read_file($execute_file)) : undef); +execute_code($repl, $_) || exit 1 for @code_to_execute; +exit if $execute_code || $execute_file; + $repl->run; package Devel::REPL; @@ -48,15 +92,17 @@ use SL::InstanceConfiguration; use SL::Locale; use SL::LXDebug; use Data::Dumper; +use List::Util qw(max); +use Time::HiRes; # this is a cleaned up version of am.pl # it lacks redirection, some html setup and most of the authentication process. # it is assumed that anyone with physical access and execution rights on this script # won't be hindered by authentication anyway. sub lxinit { - my $login = shift; + my ($client, $login) = @_; - die 'need login' unless $login; + die 'need client and login' unless $client && $login; package main; @@ -64,8 +110,13 @@ sub lxinit { $::locale = Locale->new($::lx_office_conf{system}->{language}); $::form = Form->new; $::auth = SL::Auth->new; + die "Cannot find client with ID or name '$client'" if !$::auth->set_client($client); + $::instance_conf = SL::InstanceConfiguration->new; - $::request = { cgi => CGI->new({}) }; + $::request = SL::Request->new( + cgi => CGI->new({}), + layout => SL::Layout::None->new, + ); die 'cannot reach auth db' unless $::auth->session_tables_present; @@ -75,9 +126,8 @@ sub lxinit { die "cannot find user $login" unless %::myconfig = $::auth->read_user(login => $login); - $::form->{login} = $login; # normaly implicit at login - die "cannot find locale for user $login" unless $::locale = Locale->new($::myconfig{countrycode}); + $::myconfig{login} = $login; # so SL::DB::Manager::Employee->current works in test database $::instance_conf->init; @@ -106,17 +156,24 @@ sub quit { sub help { print <' unless @rows; + + my @columns = sort keys %{ $rows[0] }; + my @widths = map { max @{ $_ } } map { my $column = $_; [ length($column), map { length("" . ($_->{$column} // '')) } @rows ] } @columns; + my @output = (join ' | ', map { my $width = $widths[$_]; sprintf "\%-${width}s", $columns[$_] } (0..@columns - 1)); + push @output, join('-+-', map { '-' x $_ } @widths); + push @output, map { my $row = $_; join(' | ', map { my $width = $widths[$_]; sprintf "\%-${width}s", $row->{ $columns[$_] } // '' } (0..@columns - 1) ) } @rows; + + return join("\n", @output); +} + +sub pobj { + my ($obj) = @_; + return '' unless $obj; + + my $ref = ref $obj; + $ref =~ s/^SL::DB:://; + my %primaries = map { ($_ => 1) } $obj->meta->primary_key; + my @columns = map { "${_}:" . ($obj->$_ // 'UNDEF') } sort $obj->meta->primary_key; + push @columns, map { "${_}:" . ($obj->$_ // 'UNDEF') } grep { !$primaries{$_} } sort map { $_->{name} } $obj->meta->columns; + + return "<${ref} " . join(' ', @columns) . '>'; +} + +sub sql { + my $dbh = ref($_[0]) ? shift : $::form->get_standard_dbh; + my ($query, @args) = @_; + + if ($query =~ m/^\s*select/i) { + ptab($dbh->selectall_arrayref($query, { Slice => {} }, @args)); + } else { + $dbh->do($query, { Slice => {} }, @args); + } +} + +sub part { + require SL::DB::Part; + SL::DB::Manager::Part->find_by(@_) +} + +sub order { + require SL::DB::Order; + SL::DB::Manager::Order->find_by(@_) +} + +sub invoice { + require SL::DB::Invoice; + SL::DB::Manager::Invoice->find_by(@_) +} + +sub purchase_invoice { + require SL::DB::PurchaseInvoice; + SL::DB::Manager::PurchaseInvoice->find_by(@_) +} + +sub customer { + require SL::DB::Customer; + SL::DB::Manager::Customer->find_by(@_) +} + +sub vendor { + require SL::DB::Vendor; + SL::DB::Manager::Vendor->find_by(@_) +} + +sub chart { + require SL::DB::Chart; + SL::DB::Manager::Chart->find_by(@_) +} + +sub clock (&) { + my $s = [Time::HiRes::gettimeofday()]; + $_[0]->(); + Time::HiRes::tv_interval($s); +} + + 1; __END__ =head1 NAME -scripts/console - Lx-Office console +scripts/console - kivitendo console =head1 SYNOPSIS - ./script/console + ./script/console [options] > help # displays a brief documentation +=head1 OPTIONS + +The list of supported command line options includes: + +=over 8 + +=item B<--help>, B<-h> + +Print this help message and exit. + +=item B<--man> + +Print the manual page and exit. + +=item B<-l>, B<--login>=C + +Log in as C. The default is to use the value from the +configuration file and C if none is set there. + +=item B<-c>, B<--client>=C + +Use the database for client C. C can be a client's +database ID or its name. The default is to use the value from the +configuration file. + +=item B<-o>, B<--log-file>=C + +Use C as the log file. The default is to use the value from +the configuration file and C if none +is set there. + +=item B<-i>, B<--history-file>=C + +Use C as the history file for commands input by the +user. The default is to use the value from the configuration file and +C if none is set there. + +=item B<-e>, B<--execute>=C + +Execute this code on startup and exit afterwards. + +=item B<-f>, B<--file>=C + +Execute the code from the file C on startup and exit +afterwards. + +=back + =head1 DESCRIPTION Users of Ruby on Rails will recognize this as a perl reimplementation of the @@ -165,6 +349,47 @@ Currently C will set the Data::Dumper depth to 2, so if you need a different depth, you'll have to change that. A nice feature would be to configure that, or at least to be able to change it at runtime. +=head2 ptab C<@data> + +Returns a tabular representation of C<@data>. C<@data> must be an +array or array reference containing hash references. Column widths are +calculated automatically. + +Undefined values are represented by an empty column. + +Example usage: + + ptab($dbh->selectall_arrayref("SELECT * FROM employee", { Slice => {} })); + +=head2 pobj C<$obj> + +Returns a textual representation of the L instance +C<$obj>. This includes the class name, then the primary key columns as +name/value pairs and then all other columns as name/value pairs. + +Undefined values are represented by C. + +Example usage: + + pobj(SL::DB::Manager::Employee->find_by(login => 'demo')); + +=head2 sql C<[ $dbh, ] $query, @bind_values> + +Executes an SQL query using the optional bind values. If the first +parameter is a database handle then that database handle is used; +otherwise the handle returned by L is used. + +If the query is a C