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
 122   $::instance_conf->init;
 123
 124   return "logged in as $login";
 125 }
 126
 127 # these function provides a load command to slurp in a lx-office module
 128 # since it's seldomly useful, it's not documented in help
 129 sub load {
 130   my $module = shift;
 131   $module =~ s/[^\w]//g;
 132   require "bin/mozilla/$module.pl";
 133 }
 134
 135 sub reload {
 136   require Module::Reload;
 137   Module::Reload->check();
 138
 139   return "modules reloaded";
 140 }
 141
 142 sub quit {
 143   exit;
 144 }
 145
 146 sub help {
 147   print <<EOL;
 148
 149   kivitendo Konsole
 150
 151   ./scripts/console [login]
 152
 153 Spezielle Kommandos:
 154
 155   help              - zeigt diese Hilfe an.
 156   lxinit 'login'    - lädt das kivitendo-Environment für den User 'login'.
 157   reload            - lädt modifizierte Module neu.
 158   pp DATA           - zeigt die Datenstruktur mit Data::Dumper an.
 159   clock { CODE }    - zeigt die gebrauchte Zeit für die Ausführung von CODE 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 sub clock (&) {
 252   my $s = [Time::HiRes::gettimeofday()];
 253   $_[0]->();
 254   Time::HiRes::tv_interval($s);
 255 }
 256
 257
 258 1;
 259
 260 __END__
 261
 262 =head1 NAME
 263
 264 scripts/console - kivitendo console
 265
 266 =head1 SYNOPSIS
 267
 268   ./script/console [options]
 269   > help               # displays a brief documentation
 270
 271 =head1 OPTIONS
 272
 273 The list of supported command line options includes:
 274
 275 =over 8
 276
 277 =item B<--help>, B<-h>
 278
 279 Print this help message and exit.
 280
 281 =item B<--man>
 282
 283 Print the manual page and exit.
 284
 285 =item B<-l>, B<--login>=C<username>
 286
 287 Log in as C<username>. The default is to use the value from the
 288 configuration file and C<demo> if none is set there.
 289
 290 =item B<-o>, B<--log-file>=C<filename>
 291
 292 Use C<filename> as the log file. The default is to use the value from
 293 the configuration file and C</tmp/kivitendo_console_debug.log> if none
 294 is set there.
 295
 296 =item B<-i>, B<--history-file>=C<filename>
 297
 298 Use C<filename> as the history file for commands input by the
 299 user. The default is to use the value from the configuration file and
 300 C</tmp/kivitendo_console_history.log> if none is set there.
 301
 302 =item B<-e>, B<--execute>=C<perl-code>
 303
 304 Execute this code on startup and exit afterwards.
 305
 306 =item B<-f>, B<--file>=C<filename>
 307
 308 Execute the code from the file C<filename> on startup and exit
 309 afterwards.
 310
 311 =back
 312
 313 =head1 DESCRIPTION
 314
 315 Users of Ruby on Rails will recognize this as a perl reimplementation of the
 316 rails scripts/console. It's intend is to provide a shell environment to the
 317 lx-office internals. This will mostly not interest you if you just want to do
 318 your ERP stuff with lx-office, but will be invaluable for those who wish to
 319 make changes to lx-office itself.
 320
 321 =head1 FUNCTIONS
 322
 323 You can do most things in the console that you could do in an actual perl
 324 script. Certain helper functions will aid you in debugging the state of the
 325 program:
 326
 327 =head2 pp C<DATA>
 328
 329 Named after the rails pretty print gem, this will call Data::Dumper on the
 330 given C<DATA>. Use it to see what is going on.
 331
 332 Currently C<pp> will set the Data::Dumper depth to 2, so if you need a
 333 different depth, you'll have to change that. A nice feature would be to
 334 configure that, or at least to be able to change it at runtime.
 335
 336 =head2 ptab C<@data>
 337
 338 Returns a tabular representation of C<@data>. C<@data> must be an
 339 array or array reference containing hash references. Column widths are
 340 calculated automatically.
 341
 342 Undefined values are represented by an empty column.
 343
 344 Example usage:
 345
 346     ptab($dbh->selectall_arrayref("SELECT * FROM employee", { Slice => {} }));
 347
 348 =head2 pobj C<$obj>
 349
 350 Returns a textual representation of the L<Rose::DB> instance
 351 C<$obj>. This includes the class name, then the primary key columns as
 352 name/value pairs and then all other columns as name/value pairs.
 353
 354 Undefined values are represented by C<UNDEF>.
 355
 356 Example usage:
 357
 358     pobj(SL::DB::Manager::Employee->find_by(login => 'demo'));
 359
 360 =head2 sql C<[ $dbh, ] $query, @bind_values>
 361
 362 Executes an SQL query using the optional bind values. If the first
 363 parameter is a database handle then that database handle is used;
 364 otherwise the handle returned by L<SL::Form/get_standard_dbh> is used.
 365
 366 If the query is a C<SELECT> then the result is filtered through
 367 L<ptab()>. Otherwise the result of C<$dbh-&gt;do($query, undef, @bind_values)>
 368 is returned.
 369
 370 Example usage:
 371
 372     sql(qq|SELECT * FROM employee|);
 373     sql(SL::DB::Employee->new->db->dbh,
 374         qq|UPDATE employee SET notes = ? WHERE login = ?|,
 375         'This guy is evil!', 'demo');
 376
 377 =head2 lxinit C<login>
 378
 379 Login into lx-office using a specified login. No password will be required, and
 380 security mechanisms will mostly be inactive. form, locale, myconfig will be
 381 correctly set.
 382
 383 =head2 reload
 384
 385 Attempts to reload modules that changed since last reload (or inital startup).
 386 This will mostly work just fine, except for Moose classes that have been made
 387 immutable. Keep in mind that existing objects will continue to have the methods
 388 of the classes they were created with.
 389
 390 =head1 BUGS
 391
 392  - Reload on immutable Moose classes is buggy.
 393  - Logging in more than once is not supported by the program, and thus not by
 394    the console. It seems to work, but strange things may happen.
 395
 396 =head1 SEE ALSO
 397
 398 Configuration of this script is located in:
 399
 400  config/kivitendo.conf
 401  config/kivitendo.conf.default
 402
 403 See there for interesting options.
 404
 405 =head1 AUTHOR
 406
 407   Sven Schöling <s.schoeling@linet-services.de>
 408
 409 =cut