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