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