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   $::form->{login} = $login; # normaly implicit at login
 121
 122   die "cannot find locale for user $login" unless $::locale   = Locale->new($::myconfig{countrycode});
 123
 124   $::instance_conf->init;
 125
 126   return "logged in as $login";
 127 }
 128
 129 # these function provides a load command to slurp in a lx-office module
 130 # since it's seldomly useful, it's not documented in help
 131 sub load {
 132   my $module = shift;
 133   $module =~ s/[^\w]//g;
 134   require "bin/mozilla/$module.pl";
 135 }
 136
 137 sub reload {
 138   require Module::Reload;
 139   Module::Reload->check();
 140
 141   return "modules reloaded";
 142 }
 143
 144 sub quit {
 145   exit;
 146 }
 147
 148 sub help {
 149   print <<EOL;
 150
 151   kivitendo Konsole
 152
 153   ./scripts/console [login]
 154
 155 Spezielle Kommandos:
 156
 157   help              - zeigt diese Hilfe an.
 158   lxinit 'login'    - lädt das kivitendo-Environment für den User 'login'.
 159   reload            - lädt modifizierte Module neu.
 160   pp DATA           - zeigt die Datenstruktur mit Data::Dumper an.
 161   clock { CODE }    - zeigt die gebrauchte Zeit für die Ausführung von CODE an
 162   quit              - beendet die Konsole
 163
 164   part              - shortcuts auf die jeweilige SL::DB::{...}::find_by
 165   customer, vendor,
 166   order, invoice,
 167   purchase_invoice,
 168   chart
 169
 170 EOL
 171 #  load   'module'     - läd das angegebene Modul, d.h. bin/mozilla/module.pl und SL/Module.pm.
 172 }
 173
 174 sub pp {
 175   local $Data::Dumper::Indent   = 2;
 176   local $Data::Dumper::Maxdepth = 2;
 177   local $Data::Dumper::Sortkeys = 1;
 178   Data::Dumper::Dumper(@_);
 179 }
 180
 181 sub ptab {
 182   my @rows = ref($_[0]) eq 'ARRAY' ? @{ $_[0] } : @_;
 183   return '<empty result set>' unless @rows;
 184
 185   my @columns = sort keys %{ $rows[0] };
 186   my @widths  = map { max @{ $_ } } map { my $column = $_; [ length($column), map { length("" . ($_->{$column} // '')) } @rows ] } @columns;
 187   my @output  = (join ' | ', map { my $width = $widths[$_]; sprintf "\%-${width}s", $columns[$_] } (0..@columns - 1));
 188   push @output, join('-+-', map { '-' x $_ } @widths);
 189   push @output, map { my $row = $_; join(' | ', map { my $width = $widths[$_]; sprintf "\%-${width}s", $row->{ $columns[$_] } // '' } (0..@columns - 1) ) } @rows;
 190
 191   return join("\n", @output);
 192 }
 193
 194 sub pobj {
 195   my ($obj) = @_;
 196   return '<no object>' unless $obj;
 197
 198   my $ref        =  ref $obj;
 199   $ref           =~ s/^SL::DB:://;
 200   my %primaries  =  map { ($_ => 1) } $obj->meta->primary_key;
 201   my @columns    =  map { "${_}:" . ($obj->$_ // 'UNDEF') } sort $obj->meta->primary_key;
 202   push @columns,    map { "${_}:" . ($obj->$_ // 'UNDEF') } grep { !$primaries{$_} } sort map { $_->{name} } $obj->meta->columns;
 203
 204   return "<${ref} " . join(' ', @columns) . '>';
 205 }
 206
 207 sub sql {
 208   my $dbh            = ref($_[0]) ? shift : $::form->get_standard_dbh;
 209   my ($query, @args) = @_;
 210
 211   if ($query =~ m/^\s*select/i) {
 212     ptab($dbh->selectall_arrayref($query, { Slice => {} }, @args));
 213   } else {
 214     $dbh->do($query, { Slice => {} }, @args);
 215   }
 216 }
 217
 218 sub part {
 219   require SL::DB::Part;
 220   SL::DB::Manager::Part->find_by(@_)
 221 }
 222
 223 sub order {
 224   require SL::DB::Order;
 225   SL::DB::Manager::Order->find_by(@_)
 226 }
 227
 228 sub invoice {
 229   require SL::DB::Invoice;
 230   SL::DB::Manager::Invoice->find_by(@_)
 231 }
 232
 233 sub purchase_invoice {
 234   require SL::DB::PurchaseInvoice;
 235   SL::DB::Manager::PurchaseInvoice->find_by(@_)
 236 }
 237
 238 sub customer {
 239   require SL::DB::Customer;
 240   SL::DB::Manager::Customer->find_by(@_)
 241 }
 242
 243 sub vendor {
 244   require SL::DB::Vendor;
 245   SL::DB::Manager::Vendor->find_by(@_)
 246 }
 247
 248 sub chart {
 249   require SL::DB::Chart;
 250   SL::DB::Manager::Chart->find_by(@_)
 251 }
 252
 253 sub clock (&) {
 254   my $s = [Time::HiRes::gettimeofday()];
 255   $_[0]->();
 256   Time::HiRes::tv_interval($s);
 257 }
 258
 259
 260 1;
 261
 262 __END__
 263
 264 =head1 NAME
 265
 266 scripts/console - kivitendo console
 267
 268 =head1 SYNOPSIS
 269
 270   ./script/console [options]
 271   > help               # displays a brief documentation
 272
 273 =head1 OPTIONS
 274
 275 The list of supported command line options includes:
 276
 277 =over 8
 278
 279 =item B<--help>, B<-h>
 280
 281 Print this help message and exit.
 282
 283 =item B<--man>
 284
 285 Print the manual page and exit.
 286
 287 =item B<-l>, B<--login>=C<username>
 288
 289 Log in as C<username>. The default is to use the value from the
 290 configuration file and C<demo> if none is set there.
 291
 292 =item B<-o>, B<--log-file>=C<filename>
 293
 294 Use C<filename> as the log file. The default is to use the value from
 295 the configuration file and C</tmp/kivitendo_console_debug.log> if none
 296 is set there.
 297
 298 =item B<-i>, B<--history-file>=C<filename>
 299
 300 Use C<filename> as the history file for commands input by the
 301 user. The default is to use the value from the configuration file and
 302 C</tmp/kivitendo_console_history.log> if none is set there.
 303
 304 =item B<-e>, B<--execute>=C<perl-code>
 305
 306 Execute this code on startup and exit afterwards.
 307
 308 =item B<-f>, B<--file>=C<filename>
 309
 310 Execute the code from the file C<filename> on startup and exit
 311 afterwards.
 312
 313 =back
 314
 315 =head1 DESCRIPTION
 316
 317 Users of Ruby on Rails will recognize this as a perl reimplementation of the
 318 rails scripts/console. It's intend is to provide a shell environment to the
 319 lx-office internals. This will mostly not interest you if you just want to do
 320 your ERP stuff with lx-office, but will be invaluable for those who wish to
 321 make changes to lx-office itself.
 322
 323 =head1 FUNCTIONS
 324
 325 You can do most things in the console that you could do in an actual perl
 326 script. Certain helper functions will aid you in debugging the state of the
 327 program:
 328
 329 =head2 pp C<DATA>
 330
 331 Named after the rails pretty print gem, this will call Data::Dumper on the
 332 given C<DATA>. Use it to see what is going on.
 333
 334 Currently C<pp> will set the Data::Dumper depth to 2, so if you need a
 335 different depth, you'll have to change that. A nice feature would be to
 336 configure that, or at least to be able to change it at runtime.
 337
 338 =head2 ptab C<@data>
 339
 340 Returns a tabular representation of C<@data>. C<@data> must be an
 341 array or array reference containing hash references. Column widths are
 342 calculated automatically.
 343
 344 Undefined values are represented by an empty column.
 345
 346 Example usage:
 347
 348     ptab($dbh->selectall_arrayref("SELECT * FROM employee", { Slice => {} }));
 349
 350 =head2 pobj C<$obj>
 351
 352 Returns a textual representation of the L<Rose::DB> instance
 353 C<$obj>. This includes the class name, then the primary key columns as
 354 name/value pairs and then all other columns as name/value pairs.
 355
 356 Undefined values are represented by C<UNDEF>.
 357
 358 Example usage:
 359
 360     pobj(SL::DB::Manager::Employee->find_by(login => 'demo'));
 361
 362 =head2 sql C<[ $dbh, ] $query, @bind_values>
 363
 364 Executes an SQL query using the optional bind values. If the first
 365 parameter is a database handle then that database handle is used;
 366 otherwise the handle returned by L<SL::Form/get_standard_dbh> is used.
 367
 368 If the query is a C<SELECT> then the result is filtered through
 369 L<ptab()>. Otherwise the result of C<$dbh-&gt;do($query, undef, @bind_values)>
 370 is returned.
 371
 372 Example usage:
 373
 374     sql(qq|SELECT * FROM employee|);
 375     sql(SL::DB::Employee->new->db->dbh,
 376         qq|UPDATE employee SET notes = ? WHERE login = ?|,
 377         'This guy is evil!', 'demo');
 378
 379 =head2 lxinit C<login>
 380
 381 Login into lx-office using a specified login. No password will be required, and
 382 security mechanisms will mostly be inactive. form, locale, myconfig will be
 383 correctly set.
 384
 385 =head2 reload
 386
 387 Attempts to reload modules that changed since last reload (or inital startup).
 388 This will mostly work just fine, except for Moose classes that have been made
 389 immutable. Keep in mind that existing objects will continue to have the methods
 390 of the classes they were created with.
 391
 392 =head1 BUGS
 393
 394  - Reload on immutable Moose classes is buggy.
 395  - Logging in more than once is not supported by the program, and thus not by
 396    the console. It seems to work, but strange things may happen.
 397
 398 =head1 SEE ALSO
 399
 400 Configuration of this script is located in:
 401
 402  config/kivitendo.conf
 403  config/kivitendo.conf.default
 404
 405 See there for interesting options.
 406
 407 =head1 AUTHOR
 408
 409   Sven Schöling <s.schoeling@linet-services.de>
 410
 411 =cut