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