scripts/console

   1 #!/usr/bin/perl
   2
   3 use warnings;
   4 use strict;
   5 use utf8;
   6 use open qw(:std :utf8);
   7 use 5.008;                          # too much magic in here to include perl 5.6
   8
   9 BEGIN {
  10   use FindBin;
  11
  12   unshift(@INC, $FindBin::Bin . '/../modules/override'); # Use our own versions of various modules (e.g. YAML).
  13   push   (@INC, $FindBin::Bin . '/..');
  14   push   (@INC, $FindBin::Bin . '/../modules/fallback'); # Only use our own versions of modules if there's no system version.
  15 }
  16
  17 use Data::Dumper;
  18 use Devel::REPL 1.002001;
  19 use File::Slurp;
  20 use Getopt::Long;
  21 use Pod::Usage;
  22
  23 use SL::LxOfficeConf;
  24 SL::LxOfficeConf->read;
  25
  26 my $client       = $::lx_office_conf{console}{client};
  27 my $login        = $::lx_office_conf{console}{login}        || 'demo';
  28 my $history_file = $::lx_office_conf{console}{history_file} || '/tmp/kivitendo_console_history.log'; # fallback if users is not writable
  29 my $debug_file   = $::lx_office_conf{console}{log_file}     || '/tmp/kivitendo_console_debug.log';
  30 my $autorun      = $::lx_office_conf{console}{autorun};
  31 my ($execute_code, $execute_file, $help, $man);
  32
  33 my $result = GetOptions(
  34   "login|l=s"        => \$login,
  35   "client|c=s"       => \$client,
  36   "history-file|i=s" => \$history_file,
  37   "log-file|o=s"     => \$debug_file,
  38   "execute|e=s"      => \$execute_code,
  39   "file|f=s"         => \$execute_file,
  40   "help|h"           => \$help,
  41   "man"              => \$man,
  42 );
  43 pod2usage(2)                               if !$result;
  44 pod2usage(1)                               if $help;
  45 pod2usage(-exitstatus => 0, -verbose => 2) if $man;
  46
  47 # will be configed eventually
  48 my @plugins      = qw(History LexEnv Colors MultiLine::PPI FancyPrompt PermanentHistory AutoloadModules);
  49
  50 sub execute_code {
  51   my ($repl, $code) = @_;
  52
  53   my $result = $repl->eval($code);
  54   if (ref($result) eq 'Devel::REPL::Error') {
  55     $repl->print($result->message);
  56     return 0;
  57   }
  58   if ($@) {
  59     $repl->print($@);
  60     return 0;
  61   }
  62
  63   return 1;
  64 }
  65
  66 my $repl = Devel::REPL->new;
  67 $repl->load_plugin($_) for @plugins;
  68 $repl->load_history($history_file);
  69
  70 binmode($repl->out_fh, 'utf8');
  71
  72 $repl->eval('use utf8;');
  73 $repl->eval('help');
  74 $repl->print("trying to auto login into client '$client' with login '$login'...\n");
  75 execute_code($repl, "lxinit '$client', '$login'");
  76
  77 my @code_to_execute = grep { $_ } ($autorun, $execute_code, $execute_file ? join('', read_file($execute_file)) : undef);
  78 execute_code($repl, $_) || exit 1 for @code_to_execute;
  79 exit  if $execute_code || $execute_file;
  80
  81 $repl->run;
  82
  83 package Devel::REPL;
  84
  85 use utf8;
  86 use CGI qw( -no_xhtml);
  87 use DateTime;
  88 use SL::Auth;
  89 use SL::Form;
  90 use SL::Helper::DateTime;
  91 use SL::InstanceConfiguration;
  92 use SL::Locale;
  93 use SL::LXDebug;
  94 use Data::Dumper;
  95 use List::Util qw(max);
  96 use Time::HiRes;
  97
  98 # this is a cleaned up version of am.pl
  99 # it lacks redirection, some html setup and most of the authentication process.
 100 # it is assumed that anyone with physical access and execution rights on this script
 101 # won't be hindered by authentication anyway.
 102 sub lxinit {
 103   my ($client, $login) = @_;
 104
 105   die 'need client and login' unless $client && $login;
 106
 107   package main;
 108
 109   $::lxdebug       = LXDebug->new(file => $debug_file);
 110   $::locale        = Locale->new($::lx_office_conf{system}->{language});
 111   $::form          = Form->new;
 112   $::auth          = SL::Auth->new;
 113   die "Cannot find client with ID or name '$client'" if !$::auth->set_client($client);
 114
 115   $::instance_conf = SL::InstanceConfiguration->new;
 116   $::request       = SL::Request->new(
 117     cgi    => CGI->new({}),
 118     layout => SL::Layout::None->new,
 119   );
 120
 121   die 'cannot reach auth db'               unless $::auth->session_tables_present;
 122
 123   $::auth->restore_session;
 124
 125   require "bin/mozilla/common.pl";
 126
 127   die "cannot find user $login"            unless %::myconfig = $::auth->read_user(login => $login);
 128
 129   die "cannot find locale for user $login" unless $::locale   = Locale->new($::myconfig{countrycode});
 130   $::myconfig{login} = $login; # so SL::DB::Manager::Employee->current works in test database
 131
 132   $::instance_conf->init;
 133
 134   return "logged in as $login";
 135 }
 136
 137 # these function provides a load command to slurp in a lx-office module
 138 # since it's seldomly useful, it's not documented in help
 139 sub load {
 140   my $module = shift;
 141   $module =~ s/[^\w]//g;
 142   require "bin/mozilla/$module.pl";
 143 }
 144
 145 sub reload {
 146   require Module::Reload;
 147   Module::Reload->check();
 148
 149   return "modules reloaded";
 150 }
 151
 152 sub quit {
 153   exit;
 154 }
 155
 156 sub help {
 157   print <<EOL;
 158
 159   kivitendo Konsole
 160
 161   ./scripts/console [login]
 162
 163 Spezielle Kommandos:
 164
 165   help              - zeigt diese Hilfe an.
 166   lxinit 'login'    - lädt das kivitendo-Environment für den User 'login'.
 167   reload            - lädt modifizierte Module neu.
 168   pp DATA           - zeigt die Datenstruktur mit Data::Dumper an.
 169   clock { CODE }    - zeigt die gebrauchte Zeit für die Ausführung von CODE an
 170   quit              - beendet die Konsole
 171
 172   part              - shortcuts auf die jeweilige SL::DB::{...}::find_by
 173   customer, vendor,
 174   order, invoice,
 175   purchase_invoice,
 176   chart
 177
 178 EOL
 179 #  load   'module'     - läd das angegebene Modul, d.h. bin/mozilla/module.pl und SL/Module.pm.
 180 }
 181
 182 sub pp {
 183   local $Data::Dumper::Indent   = 2;
 184   local $Data::Dumper::Maxdepth = 2;
 185   local $Data::Dumper::Sortkeys = 1;
 186   Data::Dumper::Dumper(@_);
 187 }
 188
 189 sub ptab {
 190   my @rows = ref($_[0]) eq 'ARRAY' ? @{ $_[0] } : @_;
 191   return '<empty result set>' unless @rows;
 192
 193   my @columns = sort keys %{ $rows[0] };
 194   my @widths  = map { max @{ $_ } } map { my $column = $_; [ length($column), map { length("" . ($_->{$column} // '')) } @rows ] } @columns;
 195   my @output  = (join ' | ', map { my $width = $widths[$_]; sprintf "\%-${width}s", $columns[$_] } (0..@columns - 1));
 196   push @output, join('-+-', map { '-' x $_ } @widths);
 197   push @output, map { my $row = $_; join(' | ', map { my $width = $widths[$_]; sprintf "\%-${width}s", $row->{ $columns[$_] } // '' } (0..@columns - 1) ) } @rows;
 198
 199   return join("\n", @output);
 200 }
 201
 202 sub pobj {
 203   my ($obj) = @_;
 204   return '<no object>' unless $obj;
 205
 206   my $ref        =  ref $obj;
 207   $ref           =~ s/^SL::DB:://;
 208   my %primaries  =  map { ($_ => 1) } $obj->meta->primary_key;
 209   my @columns    =  map { "${_}:" . ($obj->$_ // 'UNDEF') } sort $obj->meta->primary_key;
 210   push @columns,    map { "${_}:" . ($obj->$_ // 'UNDEF') } grep { !$primaries{$_} } sort map { $_->{name} } $obj->meta->columns;
 211
 212   return "<${ref} " . join(' ', @columns) . '>';
 213 }
 214
 215 sub sql {
 216   my $dbh            = ref($_[0]) ? shift : $::form->get_standard_dbh;
 217   my ($query, @args) = @_;
 218
 219   if ($query =~ m/^\s*select/i) {
 220     ptab($dbh->selectall_arrayref($query, { Slice => {} }, @args));
 221   } else {
 222     $dbh->do($query, { Slice => {} }, @args);
 223   }
 224 }
 225
 226 sub part {
 227   require SL::DB::Part;
 228   SL::DB::Manager::Part->find_by(@_)
 229 }
 230
 231 sub order {
 232   require SL::DB::Order;
 233   SL::DB::Manager::Order->find_by(@_)
 234 }
 235
 236 sub invoice {
 237   require SL::DB::Invoice;
 238   SL::DB::Manager::Invoice->find_by(@_)
 239 }
 240
 241 sub purchase_invoice {
 242   require SL::DB::PurchaseInvoice;
 243   SL::DB::Manager::PurchaseInvoice->find_by(@_)
 244 }
 245
 246 sub customer {
 247   require SL::DB::Customer;
 248   SL::DB::Manager::Customer->find_by(@_)
 249 }
 250
 251 sub vendor {
 252   require SL::DB::Vendor;
 253   SL::DB::Manager::Vendor->find_by(@_)
 254 }
 255
 256 sub chart {
 257   require SL::DB::Chart;
 258   SL::DB::Manager::Chart->find_by(@_)
 259 }
 260
 261 sub clock (&) {
 262   my $s = [Time::HiRes::gettimeofday()];
 263   $_[0]->();
 264   Time::HiRes::tv_interval($s);
 265 }
 266
 267
 268 1;
 269
 270 __END__
 271
 272 =head1 NAME
 273
 274 scripts/console - kivitendo console
 275
 276 =head1 SYNOPSIS
 277
 278   ./script/console [options]
 279   > help               # displays a brief documentation
 280
 281 =head1 OPTIONS
 282
 283 The list of supported command line options includes:
 284
 285 =over 8
 286
 287 =item B<--help>, B<-h>
 288
 289 Print this help message and exit.
 290
 291 =item B<--man>
 292
 293 Print the manual page and exit.
 294
 295 =item B<-l>, B<--login>=C<username>
 296
 297 Log in as C<username>. The default is to use the value from the
 298 configuration file and C<demo> if none is set there.
 299
 300 =item B<-c>, B<--client>=C<client>
 301
 302 Use the database for client C<client>. C<client> can be a client's
 303 database ID or its name. The default is to use the value from the
 304 configuration file.
 305
 306 =item B<-o>, B<--log-file>=C<filename>
 307
 308 Use C<filename> as the log file. The default is to use the value from
 309 the configuration file and C</tmp/kivitendo_console_debug.log> if none
 310 is set there.
 311
 312 =item B<-i>, B<--history-file>=C<filename>
 313
 314 Use C<filename> as the history file for commands input by the
 315 user. The default is to use the value from the configuration file and
 316 C</tmp/kivitendo_console_history.log> if none is set there.
 317
 318 =item B<-e>, B<--execute>=C<perl-code>
 319
 320 Execute this code on startup and exit afterwards.
 321
 322 =item B<-f>, B<--file>=C<filename>
 323
 324 Execute the code from the file C<filename> on startup and exit
 325 afterwards.
 326
 327 =back
 328
 329 =head1 DESCRIPTION
 330
 331 Users of Ruby on Rails will recognize this as a perl reimplementation of the
 332 rails scripts/console. It's intend is to provide a shell environment to the
 333 lx-office internals. This will mostly not interest you if you just want to do
 334 your ERP stuff with lx-office, but will be invaluable for those who wish to
 335 make changes to lx-office itself.
 336
 337 =head1 FUNCTIONS
 338
 339 You can do most things in the console that you could do in an actual perl
 340 script. Certain helper functions will aid you in debugging the state of the
 341 program:
 342
 343 =head2 pp C<DATA>
 344
 345 Named after the rails pretty print gem, this will call Data::Dumper on the
 346 given C<DATA>. Use it to see what is going on.
 347
 348 Currently C<pp> will set the Data::Dumper depth to 2, so if you need a
 349 different depth, you'll have to change that. A nice feature would be to
 350 configure that, or at least to be able to change it at runtime.
 351
 352 =head2 ptab C<@data>
 353
 354 Returns a tabular representation of C<@data>. C<@data> must be an
 355 array or array reference containing hash references. Column widths are
 356 calculated automatically.
 357
 358 Undefined values are represented by an empty column.
 359
 360 Example usage:
 361
 362     ptab($dbh->selectall_arrayref("SELECT * FROM employee", { Slice => {} }));
 363
 364 =head2 pobj C<$obj>
 365
 366 Returns a textual representation of the L<Rose::DB> instance
 367 C<$obj>. This includes the class name, then the primary key columns as
 368 name/value pairs and then all other columns as name/value pairs.
 369
 370 Undefined values are represented by C<UNDEF>.
 371
 372 Example usage:
 373
 374     pobj(SL::DB::Manager::Employee->find_by(login => 'demo'));
 375
 376 =head2 sql C<[ $dbh, ] $query, @bind_values>
 377
 378 Executes an SQL query using the optional bind values. If the first
 379 parameter is a database handle then that database handle is used;
 380 otherwise the handle returned by L<SL::Form/get_standard_dbh> is used.
 381
 382 If the query is a C<SELECT> then the result is filtered through
 383 L<ptab()>. Otherwise the result of C<$dbh-&gt;do($query, undef, @bind_values)>
 384 is returned.
 385
 386 Example usage:
 387
 388     sql(qq|SELECT * FROM employee|);
 389     sql(SL::DB::Employee->new->db->dbh,
 390         qq|UPDATE employee SET notes = ? WHERE login = ?|,
 391         'This guy is evil!', 'demo');
 392
 393 =head2 lxinit C<login>
 394
 395 Login into lx-office using a specified login. No password will be required, and
 396 security mechanisms will mostly be inactive. form, locale, myconfig will be
 397 correctly set.
 398
 399 =head2 reload
 400
 401 Attempts to reload modules that changed since last reload (or inital startup).
 402 This will mostly work just fine, except for Moose classes that have been made
 403 immutable. Keep in mind that existing objects will continue to have the methods
 404 of the classes they were created with.
 405
 406 =head1 BUGS
 407
 408  - Reload on immutable Moose classes is buggy.
 409  - Logging in more than once is not supported by the program, and thus not by
 410    the console. It seems to work, but strange things may happen.
 411
 412 =head1 SEE ALSO
 413
 414 Configuration of this script is located in:
 415
 416  config/kivitendo.conf
 417  config/kivitendo.conf.default
 418
 419 See there for interesting options.
 420
 421 =head1 AUTHOR
 422
 423   Sven Schöling <s.schoeling@linet-services.de>
 424
 425 =cut