scripts/console

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