|
#!/usr/bin/perl
|
|
|
|
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 {
|
|
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 File::Slurp;
|
|
use Getopt::Long;
|
|
use Pod::Usage;
|
|
|
|
use SL::LxOfficeConf;
|
|
SL::LxOfficeConf->read;
|
|
|
|
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 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;
|
|
|
|
use utf8;
|
|
use CGI qw( -no_xhtml);
|
|
use DateTime;
|
|
use SL::Auth;
|
|
use SL::Form;
|
|
use SL::Helper::DateTime;
|
|
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 ($client, $login) = @_;
|
|
|
|
die 'need client and login' unless $client && $login;
|
|
|
|
package main;
|
|
|
|
$::lxdebug = LXDebug->new(file => $debug_file);
|
|
$::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 = SL::Request->new(
|
|
cgi => CGI->new({}),
|
|
layout => SL::Layout::None->new,
|
|
);
|
|
|
|
die 'cannot reach auth db' unless $::auth->session_tables_present;
|
|
|
|
$::auth->restore_session;
|
|
|
|
require "bin/mozilla/common.pl";
|
|
|
|
die "cannot find user $login" unless %::myconfig = $::auth->read_user(login => $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;
|
|
|
|
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 {
|
|
require Module::Reload;
|
|
Module::Reload->check();
|
|
|
|
return "modules reloaded";
|
|
}
|
|
|
|
sub quit {
|
|
exit;
|
|
}
|
|
|
|
sub help {
|
|
print <<EOL;
|
|
|
|
kivitendo Konsole
|
|
|
|
./scripts/console [login]
|
|
|
|
Spezielle Kommandos:
|
|
|
|
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
|
|
|
|
part - shortcuts auf die jeweilige SL::DB::{...}::find_by
|
|
customer, vendor,
|
|
order, invoice,
|
|
purchase_invoice,
|
|
chart
|
|
|
|
EOL
|
|
# load 'module' - läd das angegebene Modul, d.h. bin/mozilla/module.pl und SL/Module.pm.
|
|
}
|
|
|
|
sub pp {
|
|
local $Data::Dumper::Indent = 2;
|
|
local $Data::Dumper::Maxdepth = 2;
|
|
local $Data::Dumper::Sortkeys = 1;
|
|
Data::Dumper::Dumper(@_);
|
|
}
|
|
|
|
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) . '>';
|
|
}
|
|
|
|
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 - kivitendo console
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
./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<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.
|
|
|
|
=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.
|
|
|
|
=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
|
|
|
|
=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.
|
|
|
|
=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'));
|
|
|
|
=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');
|
|
|
|
=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:
|
|
|
|
config/kivitendo.conf
|
|
config/kivitendo.conf.default
|
|
|
|
See there for interesting options.
|
|
|
|
=head1 AUTHOR
|
|
|
|
Sven Schöling <s.schoeling@linet-services.de>
|
|
|
|
=cut
|