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<-o>, B<--log-file>=C<filename>
 292
 293 Use C<filename> as the log file. The default is to use the value from
 294 the configuration file and C</tmp/kivitendo_console_debug.log> if none
 295 is set there.
 296
 297 =item B<-i>, B<--history-file>=C<filename>
 298
 299 Use C<filename> as the history file for commands input by the
 300 user. The default is to use the value from the configuration file and
 301 C</tmp/kivitendo_console_history.log> if none is set there.
 302
 303 =item B<-e>, B<--execute>=C<perl-code>
 304
 305 Execute this code on startup and exit afterwards.
 306
 307 =item B<-f>, B<--file>=C<filename>
 308
 309 Execute the code from the file C<filename> on startup and exit
 310 afterwards.
 311
 312 =back
 313
 314 =head1 DESCRIPTION
 315
 316 Users of Ruby on Rails will recognize this as a perl reimplementation of the
 317 rails scripts/console. It's intend is to provide a shell environment to the
 318 lx-office internals. This will mostly not interest you if you just want to do
 319 your ERP stuff with lx-office, but will be invaluable for those who wish to
 320 make changes to lx-office itself.
 321
 322 =head1 FUNCTIONS
 323
 324 You can do most things in the console that you could do in an actual perl
 325 script. Certain helper functions will aid you in debugging the state of the
 326 program:
 327
 328 =head2 pp C<DATA>
 329
 330 Named after the rails pretty print gem, this will call Data::Dumper on the
 331 given C<DATA>. Use it to see what is going on.
 332
 333 Currently C<pp> will set the Data::Dumper depth to 2, so if you need a
 334 different depth, you'll have to change that. A nice feature would be to
 335 configure that, or at least to be able to change it at runtime.
 336
 337 =head2 ptab C<@data>
 338
 339 Returns a tabular representation of C<@data>. C<@data> must be an
 340 array or array reference containing hash references. Column widths are
 341 calculated automatically.
 342
 343 Undefined values are represented by an empty column.
 344
 345 Example usage:
 346
 347     ptab($dbh->selectall_arrayref("SELECT * FROM employee", { Slice => {} }));
 348
 349 =head2 pobj C<$obj>
 350
 351 Returns a textual representation of the L<Rose::DB> instance
 352 C<$obj>. This includes the class name, then the primary key columns as
 353 name/value pairs and then all other columns as name/value pairs.
 354
 355 Undefined values are represented by C<UNDEF>.
 356
 357 Example usage:
 358
 359     pobj(SL::DB::Manager::Employee->find_by(login => 'demo'));
 360
 361 =head2 sql C<[ $dbh, ] $query, @bind_values>
 362
 363 Executes an SQL query using the optional bind values. If the first
 364 parameter is a database handle then that database handle is used;
 365 otherwise the handle returned by L<SL::Form/get_standard_dbh> is used.
 366
 367 If the query is a C<SELECT> then the result is filtered through
 368 L<ptab()>. Otherwise the result of C<$dbh-&gt;do($query, undef, @bind_values)>
 369 is returned.
 370
 371 Example usage:
 372
 373     sql(qq|SELECT * FROM employee|);
 374     sql(SL::DB::Employee->new->db->dbh,
 375         qq|UPDATE employee SET notes = ? WHERE login = ?|,
 376         'This guy is evil!', 'demo');
 377
 378 =head2 lxinit C<login>
 379
 380 Login into lx-office using a specified login. No password will be required, and
 381 security mechanisms will mostly be inactive. form, locale, myconfig will be
 382 correctly set.
 383
 384 =head2 reload
 385
 386 Attempts to reload modules that changed since last reload (or inital startup).
 387 This will mostly work just fine, except for Moose classes that have been made
 388 immutable. Keep in mind that existing objects will continue to have the methods
 389 of the classes they were created with.
 390
 391 =head1 BUGS
 392
 393  - Reload on immutable Moose classes is buggy.
 394  - Logging in more than once is not supported by the program, and thus not by
 395    the console. It seems to work, but strange things may happen.
 396
 397 =head1 SEE ALSO
 398
 399 Configuration of this script is located in:
 400
 401  config/kivitendo.conf
 402  config/kivitendo.conf.default
 403
 404 See there for interesting options.
 405
 406 =head1 AUTHOR
 407
 408   Sven Schöling <s.schoeling@linet-services.de>
 409
 410 =cut