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