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