kivitendo/scripts/console @ 4a663bf8
| c7edb248 | Sven Schöling | #!/usr/bin/perl
|
||
use warnings;
|
||||
use strict;
|
||||
| 00a6bdd7 | Sven Schöling | use utf8;
|
||
use open qw(:std :utf8);
|
||||
| c7edb248 | Sven Schöling | use 5.008; # too much magic in here to include perl 5.6
|
||
BEGIN {
|
||||
| 419facb2 | Moritz Bunkus | 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.
|
||||
| c7edb248 | Sven Schöling | }
|
||
use Data::Dumper;
|
||||
use Devel::REPL 1.002001;
|
||||
| 17a0869f | Moritz Bunkus | use File::Slurp;
|
||
use Getopt::Long;
|
||||
use Pod::Usage;
|
||||
| c7edb248 | Sven Schöling | |||
| 67b21d42 | Moritz Bunkus | use SL::LxOfficeConf;
|
||
SL::LxOfficeConf->read;
|
||||
| c7edb248 | Sven Schöling | |||
| 72033e2d | Moritz Bunkus | my $client = $::lx_office_conf{console}{client};
|
||
| 17a0869f | Moritz Bunkus | 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,
|
||||
| 72033e2d | Moritz Bunkus | "client|c=s" => \$client,
|
||
| 17a0869f | Moritz Bunkus | "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;
|
||||
| c7edb248 | Sven Schöling | |||
# will be configed eventually
|
||||
my @plugins = qw(History LexEnv Colors MultiLine::PPI FancyPrompt PermanentHistory AutoloadModules);
|
||||
| 17a0869f | Moritz Bunkus | 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;
|
||||
}
|
||||
| c7edb248 | Sven Schöling | my $repl = Devel::REPL->new;
|
||
$repl->load_plugin($_) for @plugins;
|
||||
$repl->load_history($history_file);
|
||||
| 00a6bdd7 | Sven Schöling | |||
binmode($repl->out_fh, 'utf8');
|
||||
$repl->eval('use utf8;');
|
||||
| c7edb248 | Sven Schöling | $repl->eval('help');
|
||
| 72033e2d | Moritz Bunkus | $repl->print("trying to auto login into client '$client' with login '$login'...\n");
|
||
execute_code($repl, "lxinit '$client', '$login'");
|
||||
| 17a0869f | Moritz Bunkus | |||
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;
|
||||
| c7edb248 | Sven Schöling | $repl->run;
|
||
package Devel::REPL;
|
||||
| 05c6840d | Moritz Bunkus | use utf8;
|
||
| 4440782f | Sven Schöling | use CGI qw( -no_xhtml);
|
||
| cad439ef | Moritz Bunkus | use DateTime;
|
||
| 4440782f | Sven Schöling | use SL::Auth;
|
||
use SL::Form;
|
||||
| cad439ef | Moritz Bunkus | use SL::Helper::DateTime;
|
||
| 891411c1 | Moritz Bunkus | use SL::InstanceConfiguration;
|
||
| 4440782f | Sven Schöling | use SL::Locale;
|
||
use SL::LXDebug;
|
||||
use Data::Dumper;
|
||||
| 3307dfca | Moritz Bunkus | use List::Util qw(max);
|
||
| 271e8829 | Sven Schöling | use Time::HiRes;
|
||
| c7edb248 | Sven Schöling | |||
# 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 {
|
||||
| 72033e2d | Moritz Bunkus | my ($client, $login) = @_;
|
||
| c7edb248 | Sven Schöling | |||
| 72033e2d | Moritz Bunkus | die 'need client and login' unless $client && $login;
|
||
| c7edb248 | Sven Schöling | |||
package main;
|
||||
| 27e80751 | Moritz Bunkus | $::lxdebug = LXDebug->new(file => $debug_file);
|
||
$::locale = Locale->new($::lx_office_conf{system}->{language});
|
||||
$::form = Form->new;
|
||||
$::auth = SL::Auth->new;
|
||||
| 72033e2d | Moritz Bunkus | die "Cannot find client with ID or name '$client'" if !$::auth->set_client($client);
|
||
| 891411c1 | Moritz Bunkus | $::instance_conf = SL::InstanceConfiguration->new;
|
||
| 3e2ecde7 | Moritz Bunkus | $::request = SL::Request->new(
|
||
cgi => CGI->new({}),
|
||||
layout => SL::Layout::None->new,
|
||||
);
|
||||
| c7edb248 | Sven Schöling | |||
die 'cannot reach auth db' unless $::auth->session_tables_present;
|
||||
$::auth->restore_session;
|
||||
require "bin/mozilla/common.pl";
|
||||
| 4531a6c7 | Sven Schöling | die "cannot find user $login" unless %::myconfig = $::auth->read_user(login => $login);
|
||
| c8c6d1e8 | Sven Schöling | |||
| c7edb248 | Sven Schöling | die "cannot find locale for user $login" unless $::locale = Locale->new($::myconfig{countrycode});
|
||
| 7019e2b6 | Geoffrey Richardson | $::myconfig{login} = $login; # so SL::DB::Manager::Employee->current works in test database
|
||
| c7edb248 | Sven Schöling | |||
| 891411c1 | Moritz Bunkus | $::instance_conf->init;
|
||
| c8c6d1e8 | Sven Schöling | |||
| c7edb248 | Sven Schöling | return "logged in as $login";
|
||
}
|
||||
# these function provides a load command to slurp in a lx-office module
|
||||
# since it's seldomly useful, it's not documented in help
|
||||
sub load {
|
||||
my $module = shift;
|
||||
$module =~ s/[^\w]//g;
|
||||
require "bin/mozilla/$module.pl";
|
||||
}
|
||||
sub reload {
|
||||
| b7fa831d | Sven Schöling | require Module::Reload;
|
||
| c7edb248 | Sven Schöling | Module::Reload->check();
|
||
return "modules reloaded";
|
||||
}
|
||||
sub quit {
|
||||
exit;
|
||||
}
|
||||
sub help {
|
||||
print <<EOL;
|
||||
| 008c2e15 | Moritz Bunkus | kivitendo Konsole
|
||
| c7edb248 | Sven Schöling | |||
./scripts/console [login]
|
||||
Spezielle Kommandos:
|
||||
| 271e8829 | Sven Schöling | help - zeigt diese Hilfe an.
|
||
lxinit 'login' - lädt das kivitendo-Environment für den User 'login'.
|
||||
reload - lädt modifizierte Module neu.
|
||||
pp DATA - zeigt die Datenstruktur mit Data::Dumper an.
|
||||
clock { CODE } - zeigt die gebrauchte Zeit für die Ausführung von CODE an
|
||||
quit - beendet die Konsole
|
||||
| c7edb248 | Sven Schöling | |||
| 271e8829 | Sven Schöling | part - shortcuts auf die jeweilige SL::DB::{...}::find_by
|
||
| e170abc7 | Geoffrey Richardson | customer, vendor,
|
||
order, invoice,
|
||||
| 3f556b78 | Geoffrey Richardson | purchase_invoice,
|
||
| e170abc7 | Geoffrey Richardson | chart
|
||
| 1192822f | Sven Schöling | |||
| c7edb248 | Sven Schöling | EOL
|
||
| 05c6840d | Moritz Bunkus | # load 'module' - läd das angegebene Modul, d.h. bin/mozilla/module.pl und SL/Module.pm.
|
||
| c7edb248 | Sven Schöling | }
|
||
sub pp {
|
||||
| f942a47a | Moritz Bunkus | local $Data::Dumper::Indent = 2;
|
||
local $Data::Dumper::Maxdepth = 2;
|
||||
| 27fee47d | Moritz Bunkus | local $Data::Dumper::Sortkeys = 1;
|
||
| c7edb248 | Sven Schöling | Data::Dumper::Dumper(@_);
|
||
}
|
||||
| 3307dfca | Moritz Bunkus | sub ptab {
|
||
my @rows = ref($_[0]) eq 'ARRAY' ? @{ $_[0] } : @_;
|
||||
return '<empty result set>' 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 '<no object>' 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) . '>';
|
||||
}
|
||||
| 665fb6bc | Moritz Bunkus | 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);
|
||||
}
|
||||
}
|
||||
| 1192822f | Sven Schöling | 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(@_)
|
||||
}
|
||||
| 3f556b78 | Geoffrey Richardson | sub purchase_invoice {
|
||
require SL::DB::PurchaseInvoice;
|
||||
SL::DB::Manager::PurchaseInvoice->find_by(@_)
|
||||
}
|
||||
| 1192822f | Sven Schöling | sub customer {
|
||
require SL::DB::Customer;
|
||||
SL::DB::Manager::Customer->find_by(@_)
|
||||
}
|
||||
sub vendor {
|
||||
require SL::DB::Vendor;
|
||||
SL::DB::Manager::Vendor->find_by(@_)
|
||||
}
|
||||
| e170abc7 | Geoffrey Richardson | sub chart {
|
||
require SL::DB::Chart;
|
||||
SL::DB::Manager::Chart->find_by(@_)
|
||||
}
|
||||
| 1192822f | Sven Schöling | |||
| 271e8829 | Sven Schöling | sub clock (&) {
|
||
my $s = [Time::HiRes::gettimeofday()];
|
||||
$_[0]->();
|
||||
Time::HiRes::tv_interval($s);
|
||||
}
|
||||
| c7edb248 | Sven Schöling | 1;
|
||
__END__
|
||||
=head1 NAME
|
||||
| 008c2e15 | Moritz Bunkus | scripts/console - kivitendo console
|
||
| c7edb248 | Sven Schöling | |||
=head1 SYNOPSIS
|
||||
| 17a0869f | Moritz Bunkus | ./script/console [options]
|
||
| c7edb248 | Sven Schöling | > help # displays a brief documentation
|
||
| 17a0869f | Moritz Bunkus | =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<username>
|
||||
Log in as C<username>. The default is to use the value from the
|
||||
configuration file and C<demo> if none is set there.
|
||||
| 066bbae7 | Bernd Bleßmann | =item B<-c>, B<--client>=C<client>
|
||
Use the database for client C<client>. C<client> can be a client's
|
||||
database ID or its name. The default is to use the value from the
|
||||
configuration file.
|
||||
| 17a0869f | Moritz Bunkus | =item B<-o>, B<--log-file>=C<filename>
|
||
Use C<filename> as the log file. The default is to use the value from
|
||||
the configuration file and C</tmp/kivitendo_console_debug.log> if none
|
||||
is set there.
|
||||
=item B<-i>, B<--history-file>=C<filename>
|
||||
Use C<filename> as the history file for commands input by the
|
||||
user. The default is to use the value from the configuration file and
|
||||
C</tmp/kivitendo_console_history.log> if none is set there.
|
||||
=item B<-e>, B<--execute>=C<perl-code>
|
||||
Execute this code on startup and exit afterwards.
|
||||
=item B<-f>, B<--file>=C<filename>
|
||||
Execute the code from the file C<filename> on startup and exit
|
||||
afterwards.
|
||||
=back
|
||||
| c7edb248 | Sven Schöling | =head1 DESCRIPTION
|
||
Users of Ruby on Rails will recognize this as a perl reimplementation of the
|
||||
rails scripts/console. It's intend is to provide a shell environment to the
|
||||
lx-office internals. This will mostly not interest you if you just want to do
|
||||
your ERP stuff with lx-office, but will be invaluable for those who wish to
|
||||
make changes to lx-office itself.
|
||||
=head1 FUNCTIONS
|
||||
You can do most things in the console that you could do in an actual perl
|
||||
script. Certain helper functions will aid you in debugging the state of the
|
||||
program:
|
||||
=head2 pp C<DATA>
|
||||
Named after the rails pretty print gem, this will call Data::Dumper on the
|
||||
given C<DATA>. Use it to see what is going on.
|
||||
Currently C<pp> 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.
|
||||
| 3307dfca | Moritz Bunkus | =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<Rose::DB> 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<UNDEF>.
|
||||
Example usage:
|
||||
pobj(SL::DB::Manager::Employee->find_by(login => 'demo'));
|
||||
| 665fb6bc | Moritz Bunkus | =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<SL::Form/get_standard_dbh> is used.
|
||||
If the query is a C<SELECT> then the result is filtered through
|
||||
L<ptab()>. Otherwise the result of C<$dbh->do($query, undef, @bind_values)>
|
||||
is returned.
|
||||
Example usage:
|
||||
sql(qq|SELECT * FROM employee|);
|
||||
sql(SL::DB::Employee->new->db->dbh,
|
||||
qq|UPDATE employee SET notes = ? WHERE login = ?|,
|
||||
'This guy is evil!', 'demo');
|
||||
| c7edb248 | Sven Schöling | =head2 lxinit C<login>
|
||
Login into lx-office using a specified login. No password will be required, and
|
||||
security mechanisms will mostly be inactive. form, locale, myconfig will be
|
||||
correctly set.
|
||||
=head2 reload
|
||||
Attempts to reload modules that changed since last reload (or inital startup).
|
||||
This will mostly work just fine, except for Moose classes that have been made
|
||||
immutable. Keep in mind that existing objects will continue to have the methods
|
||||
of the classes they were created with.
|
||||
=head1 BUGS
|
||||
- Reload on immutable Moose classes is buggy.
|
||||
- Logging in more than once is not supported by the program, and thus not by
|
||||
the console. It seems to work, but strange things may happen.
|
||||
=head1 SEE ALSO
|
||||
Configuration of this script is located in:
|
||||
| 4bacfb02 | Moritz Bunkus | config/kivitendo.conf
|
||
config/kivitendo.conf.default
|
||||
| c7edb248 | Sven Schöling | |||
See there for interesting options.
|
||||
=head1 AUTHOR
|
||||
| 05c6840d | Moritz Bunkus | Sven Schöling <s.schoeling@linet-services.de>
|
||
| c7edb248 | Sven Schöling | |||
=cut
|