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