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