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 use Term::ReadLine::Perl::Bind;     # use sane key binding for rxvt users
  18
  19 use SL::LxOfficeConf;
  20 SL::LxOfficeConf->read;
  21
  22 my $client       = $::lx_office_conf{console}{client};
  23 my $login        = $::lx_office_conf{console}{login}        || 'demo';
  24 my $history_file = $::lx_office_conf{console}{history_file} || '/tmp/kivitendo_console_history.log'; # fallback if users is not writable
  25 my $debug_file   = $::lx_office_conf{console}{log_file}     || '/tmp/kivitendo_console_debug.log';
  26 my $autorun      = $::lx_office_conf{console}{autorun};
  27 my ($execute_code, $execute_file, $help, $man);
  28
  29 my $result = GetOptions(
  30   "login|l=s"        => \$login,
  31   "client|c=s"       => \$client,
  32   "history-file|i=s" => \$history_file,
  33   "log-file|o=s"     => \$debug_file,
  34   "execute|e=s"      => \$execute_code,
  35   "file|f=s"         => \$execute_file,
  36   "help|h"           => \$help,
  37   "man"              => \$man,
  38 );
  39 pod2usage(2)                               if !$result;
  40 pod2usage(1)                               if $help;
  41 pod2usage(-exitstatus => 0, -verbose => 2) if $man;
  42
  43 # will be configed eventually
  44 my @plugins      = qw(History LexEnv Colors MultiLine::PPI FancyPrompt PermanentHistory AutoloadModules);
  45
  46 sub execute_code {
  47   my ($repl, $code) = @_;
  48
  49   my $result = $repl->eval($code);
  50   if (ref($result) eq 'Devel::REPL::Error') {
  51     $repl->print($result->message);
  52     return 0;
  53   }
  54   if ($@) {
  55     $repl->print($@);
  56     return 0;
  57   }
  58
  59   return 1;
  60 }
  61
  62 my $repl = Devel::REPL->new;
  63 $repl->load_plugin($_) for @plugins;
  64 $repl->load_history($history_file);
  65 $repl->eval('help');
  66 $repl->print("trying to auto login into client '$client' with login '$login'...\n");
  67 execute_code($repl, "lxinit '$client', '$login'");
  68
  69 my @code_to_execute = grep { $_ } ($autorun, $execute_code, $execute_file ? join('', read_file($execute_file)) : undef);
  70 execute_code($repl, $_) || exit 1 for @code_to_execute;
  71 exit  if $execute_code || $execute_file;
  72
  73 $repl->run;
  74
  75 package Devel::REPL;
  76
  77 use utf8;
  78 use CGI qw( -no_xhtml);
  79 use DateTime;
  80 use SL::Auth;
  81 use SL::Form;
  82 use SL::Helper::DateTime;
  83 use SL::InstanceConfiguration;
  84 use SL::Locale;
  85 use SL::LXDebug;
  86 use Data::Dumper;
  87 use List::Util qw(max);
  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   $::form->{login} = $login; # normaly implicit at login
 121
 122   die "cannot find locale for user $login" unless $::locale   = Locale->new($::myconfig{countrycode});
 123
 124   $::instance_conf->init;
 125
 126   return "logged in as $login";
 127 }
 128
 129 # these function provides a load command to slurp in a lx-office module
 130 # since it's seldomly useful, it's not documented in help
 131 sub load {
 132   my $module = shift;
 133   $module =~ s/[^\w]//g;
 134   require "bin/mozilla/$module.pl";
 135 }
 136
 137 sub reload {
 138   require Module::Reload;
 139   Module::Reload->check();
 140
 141   return "modules reloaded";
 142 }
 143
 144 sub quit {
 145   exit;
 146 }
 147
 148 sub help {
 149   print <<EOL;
 150
 151   kivitendo Konsole
 152
 153   ./scripts/console [login]
 154
 155 Spezielle Kommandos:
 156
 157   help                - zeigt diese Hilfe an.
 158   lxinit 'login'      - lädt das kivitendo-Environment für den User 'login'.
 159   reload              - lädt modifizierte Module neu.
 160   pp DATA             - zeigt die Datenstruktur mit Data::Dumper an.
 161   quit                - beendet die Konsole
 162
 163 EOL
 164 #  load   'module'     - läd das angegebene Modul, d.h. bin/mozilla/module.pl und SL/Module.pm.
 165 }
 166
 167 sub pp {
 168   local $Data::Dumper::Indent   = 2;
 169   local $Data::Dumper::Maxdepth = 2;
 170   local $Data::Dumper::Sortkeys = 1;
 171   Data::Dumper::Dumper(@_);
 172 }
 173
 174 sub ptab {
 175   my @rows = ref($_[0]) eq 'ARRAY' ? @{ $_[0] } : @_;
 176   return '<empty result set>' unless @rows;
 177
 178   my @columns = sort keys %{ $rows[0] };
 179   my @widths  = map { max @{ $_ } } map { my $column = $_; [ length($column), map { length("" . ($_->{$column} // '')) } @rows ] } @columns;
 180   my @output  = (join ' | ', map { my $width = $widths[$_]; sprintf "\%-${width}s", $columns[$_] } (0..@columns - 1));
 181   push @output, join('-+-', map { '-' x $_ } @widths);
 182   push @output, map { my $row = $_; join(' | ', map { my $width = $widths[$_]; sprintf "\%-${width}s", $row->{ $columns[$_] } // '' } (0..@columns - 1) ) } @rows;
 183
 184   return join("\n", @output);
 185 }
 186
 187 sub pobj {
 188   my ($obj) = @_;
 189   return '<no object>' unless $obj;
 190
 191   my $ref        =  ref $obj;
 192   $ref           =~ s/^SL::DB:://;
 193   my %primaries  =  map { ($_ => 1) } $obj->meta->primary_key;
 194   my @columns    =  map { "${_}:" . ($obj->$_ // 'UNDEF') } sort $obj->meta->primary_key;
 195   push @columns,    map { "${_}:" . ($obj->$_ // 'UNDEF') } grep { !$primaries{$_} } sort map { $_->{name} } $obj->meta->columns;
 196
 197   return "<${ref} " . join(' ', @columns) . '>';
 198 }
 199
 200 sub sql {
 201   my $dbh            = ref($_[0]) ? shift : $::form->get_standard_dbh;
 202   my ($query, @args) = @_;
 203
 204   if ($query =~ m/^\s*select/i) {
 205     ptab($dbh->selectall_arrayref($query, { Slice => {} }, @args));
 206   } else {
 207     $dbh->do($query, { Slice => {} }, @args);
 208   }
 209 }
 210
 211 1;
 212
 213 __END__
 214
 215 =head1 NAME
 216
 217 scripts/console - kivitendo console
 218
 219 =head1 SYNOPSIS
 220
 221   ./script/console [options]
 222   > help               # displays a brief documentation
 223
 224 =head1 OPTIONS
 225
 226 The list of supported command line options includes:
 227
 228 =over 8
 229
 230 =item B<--help>, B<-h>
 231
 232 Print this help message and exit.
 233
 234 =item B<--man>
 235
 236 Print the manual page and exit.
 237
 238 =item B<-l>, B<--login>=C<username>
 239
 240 Log in as C<username>. The default is to use the value from the
 241 configuration file and C<demo> if none is set there.
 242
 243 =item B<-o>, B<--log-file>=C<filename>
 244
 245 Use C<filename> as the log file. The default is to use the value from
 246 the configuration file and C</tmp/kivitendo_console_debug.log> if none
 247 is set there.
 248
 249 =item B<-i>, B<--history-file>=C<filename>
 250
 251 Use C<filename> as the history file for commands input by the
 252 user. The default is to use the value from the configuration file and
 253 C</tmp/kivitendo_console_history.log> if none is set there.
 254
 255 =item B<-e>, B<--execute>=C<perl-code>
 256
 257 Execute this code on startup and exit afterwards.
 258
 259 =item B<-f>, B<--file>=C<filename>
 260
 261 Execute the code from the file C<filename> on startup and exit
 262 afterwards.
 263
 264 =back
 265
 266 =head1 DESCRIPTION
 267
 268 Users of Ruby on Rails will recognize this as a perl reimplementation of the
 269 rails scripts/console. It's intend is to provide a shell environment to the
 270 lx-office internals. This will mostly not interest you if you just want to do
 271 your ERP stuff with lx-office, but will be invaluable for those who wish to
 272 make changes to lx-office itself.
 273
 274 =head1 FUNCTIONS
 275
 276 You can do most things in the console that you could do in an actual perl
 277 script. Certain helper functions will aid you in debugging the state of the
 278 program:
 279
 280 =head2 pp C<DATA>
 281
 282 Named after the rails pretty print gem, this will call Data::Dumper on the
 283 given C<DATA>. Use it to see what is going on.
 284
 285 Currently C<pp> will set the Data::Dumper depth to 2, so if you need a
 286 different depth, you'll have to change that. A nice feature would be to
 287 configure that, or at least to be able to change it at runtime.
 288
 289 =head2 ptab C<@data>
 290
 291 Returns a tabular representation of C<@data>. C<@data> must be an
 292 array or array reference containing hash references. Column widths are
 293 calculated automatically.
 294
 295 Undefined values are represented by an empty column.
 296
 297 Example usage:
 298
 299     ptab($dbh->selectall_arrayref("SELECT * FROM employee", { Slice => {} }));
 300
 301 =head2 pobj C<$obj>
 302
 303 Returns a textual representation of the L<Rose::DB> instance
 304 C<$obj>. This includes the class name, then the primary key columns as
 305 name/value pairs and then all other columns as name/value pairs.
 306
 307 Undefined values are represented by C<UNDEF>.
 308
 309 Example usage:
 310
 311     pobj(SL::DB::Manager::Employee->find_by(login => 'demo'));
 312
 313 =head2 sql C<[ $dbh, ] $query, @bind_values>
 314
 315 Executes an SQL query using the optional bind values. If the first
 316 parameter is a database handle then that database handle is used;
 317 otherwise the handle returned by L<SL::Form/get_standard_dbh> is used.
 318
 319 If the query is a C<SELECT> then the result is filtered through
 320 L<ptab()>. Otherwise the result of C<$dbh-&gt;do($query, undef, @bind_values)>
 321 is returned.
 322
 323 Example usage:
 324
 325     sql(qq|SELECT * FROM employee|);
 326     sql(SL::DB::Employee->new->db->dbh,
 327         qq|UPDATE employee SET notes = ? WHERE login = ?|,
 328         'This guy is evil!', 'demo');
 329
 330 =head2 lxinit C<login>
 331
 332 Login into lx-office using a specified login. No password will be required, and
 333 security mechanisms will mostly be inactive. form, locale, myconfig will be
 334 correctly set.
 335
 336 =head2 reload
 337
 338 Attempts to reload modules that changed since last reload (or inital startup).
 339 This will mostly work just fine, except for Moose classes that have been made
 340 immutable. Keep in mind that existing objects will continue to have the methods
 341 of the classes they were created with.
 342
 343 =head1 BUGS
 344
 345  - Reload on immutable Moose classes is buggy.
 346  - Logging in more than once is not supported by the program, and thus not by
 347    the console. It seems to work, but strange things may happen.
 348
 349 =head1 SEE ALSO
 350
 351 Configuration of this script is located in:
 352
 353  config/kivitendo.conf
 354  config/kivitendo.conf.default
 355
 356 See there for interesting options.
 357
 358 =head1 AUTHOR
 359
 360   Sven Schöling <s.schoeling@linet-services.de>
 361
 362 =cut