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