5 @ISA @EXPORT_OK $DEBUG $me $cgi $freeside_uid $user $conf_dir $cache_dir
6 $secrets $datasrc $db_user $db_pass $schema $dbh $driver_name
7 $AutoCommit %callback @callback $callback_hack $use_confcompat
10 getsecrets cgisetotaker
13 use Carp qw(carp croak cluck confess);
19 @EXPORT_OK = qw(checkeuid checkruid cgisuidsetup adminsuidsetup forksuidsetup
20 getotaker dbh datasrc getsecrets driver_name myconnect
26 $freeside_uid = scalar(getpwnam('freeside'));
28 $conf_dir = "%%%FREESIDE_CONF%%%";
29 $cache_dir = "%%%FREESIDE_CACHE%%%";
31 $AutoCommit = 1; #ours, not DBI
37 FS::UID - Subroutines for database login and assorted other stuff
41 use FS::UID qw(adminsuidsetup cgisuidsetup dbh datasrc getotaker
47 $dbh = cgisuidsetup($cgi);
53 $driver_name = driver_name;
57 Provides a hodgepodge of subroutines.
63 =item adminsuidsetup USER
65 Sets the user to USER (see config.html from the base documentation).
66 Cleans the environment.
67 Make sure the script is running as freeside, or setuid freeside.
68 Opens a connection to the database.
69 Swaps real and effective UIDs.
70 Runs any defined callbacks (see below).
71 Returns the DBI database handle (usually you don't need this).
76 $dbh->disconnect if $dbh;
83 warn "$me forksuidsetup starting for $user\n" if $DEBUG;
85 if ( $FS::CurrentUser::upgrade_hack ) {
86 $user = 'fs_bootstrap';
88 croak "fatal: adminsuidsetup called without arguements" unless $user;
90 $user =~ /^([\w\-\.]+)$/ or croak "fatal: illegal user $user";
94 $ENV{'PATH'} ='/usr/local/bin:/usr/bin:/usr/ucb:/bin';
95 $ENV{'SHELL'} = '/bin/sh';
96 $ENV{'IFS'} = " \t\n";
99 $ENV{'BASH_ENV'} = '';
101 croak "Not running uid freeside (\$>=$>, \$<=$<)\n" unless checkeuid();
103 warn "$me forksuidsetup connecting to database\n" if $DEBUG;
104 if ( $FS::CurrentUser::upgrade_hack && $olduser ) {
105 $dbh = &myconnect($olduser);
109 warn "$me forksuidsetup connected to database with handle $dbh\n" if $DEBUG;
111 warn "$me forksuidsetup loading schema\n" if $DEBUG;
112 use FS::Schema qw(reload_dbdef dbdef);
113 reload_dbdef("$conf_dir/dbdef.$datasrc")
114 unless $FS::Schema::setup_hack;
116 warn "$me forksuidsetup deciding upon config system to use\n" if $DEBUG;
118 if ( ! $FS::Schema::setup_hack && dbdef->table('conf') ) {
120 my $sth = $dbh->prepare("SELECT COUNT(*) FROM conf") or die $dbh->errstr;
121 $sth->execute or die $sth->errstr;
122 my $confcount = $sth->fetchrow_arrayref->[0];
127 die "NO CONFIGURATION RECORDS FOUND";
131 die "NO CONFIGURATION TABLE FOUND" unless $FS::Schema::setup_hack;
134 unless ( $callback_hack ) {
135 warn "$me calling callbacks\n" if $DEBUG;
136 foreach ( keys %callback ) {
138 # breaks multi-database installs # delete $callback{$_}; #run once
141 &{$_} foreach @callback;
143 warn "$me skipping callbacks (callback_hack set)\n" if $DEBUG;
146 warn "$me forksuidsetup loading user\n" if $DEBUG;
147 FS::CurrentUser->load_user($user);
153 my $handle = DBI->connect( getsecrets(@_), { 'AutoCommit' => 0,
155 'ShowErrorStatement' => 1,
156 'pg_enable_utf8' => 1,
157 #'mysql_enable_utf8' => 1,
160 or die "DBI->connect error: $DBI::errstr\n";
163 use DBIx::DBSchema::_util qw(_load_driver ); #quelle hack
164 my $driver = _load_driver($handle);
165 if ( $driver =~ /^Pg/ ) {
166 no warnings 'redefine';
167 eval "sub DBIx::DBSchema::DBD::${driver}::default_db_schema {'$schema'}";
175 =item install_callback
177 A package can install a callback to be run in adminsuidsetup by passing
178 a coderef to the FS::UID->install_callback class method. If adminsuidsetup has
179 run already, the callback will also be run immediately.
181 $coderef = sub { warn "Hi, I'm returning your call!" };
182 FS::UID->install_callback($coderef);
184 install_callback FS::UID sub {
185 warn "Hi, I'm returning your call!"
190 sub install_callback {
192 my $callback = shift;
193 push @callback, $callback;
194 &{$callback} if $dbh;
197 =item cgisuidsetup CGI_object
199 Takes a single argument, which is a CGI (see L<CGI>) or Apache (see L<Apache>)
200 object (CGI::Base is depriciated). Runs cgisetotaker and then adminsuidsetup.
206 if ( $cgi->isa('CGI::Base') ) {
207 carp "Use of CGI::Base is depriciated";
208 } elsif ( $cgi->isa('Apache') ) {
210 } elsif ( ! $cgi->isa('CGI') ) {
211 croak "fatal: unrecognized object $cgi";
214 adminsuidsetup($user);
219 Returns the CGI (see L<CGI>) object.
224 carp "warning: \$FS::UID::cgi isa Apache" if $cgi->isa('Apache');
230 Returns the DBI database handle.
240 Returns the DBI data source.
250 Returns just the driver name portion of the DBI data source.
255 return $driver_name if defined $driver_name;
256 $driver_name = ( split(':', $datasrc) )[1];
260 croak "suidsetup depriciated";
265 Returns the current Freeside user.
275 Sets and returns the CGI REMOTE_USER. $cgi should be defined as a CGI.pm
276 object (see L<CGI>) or an Apache object (see L<Apache>). Support for CGI::Base
277 and derived classes is depriciated.
282 if ( $cgi && $cgi->isa('CGI::Base') && defined $cgi->var('REMOTE_USER')) {
283 carp "Use of CGI::Base is depriciated";
284 $user = lc ( $cgi->var('REMOTE_USER') );
285 } elsif ( $cgi && $cgi->isa('CGI') && defined $cgi->remote_user ) {
286 $user = lc ( $cgi->remote_user );
287 } elsif ( $cgi && $cgi->isa('Apache') ) {
288 $user = lc ( $cgi->connection->user );
290 die "fatal: Can't get REMOTE_USER! for cgi $cgi - you need to setup ".
291 "Apache user authentication as documented in the installation instructions";
298 Returns true if effective UID is that of the freeside user.
303 #$> = $freeside_uid unless $>; #huh. mpm-itk hack
304 ( $> == $freeside_uid );
309 Returns true if the real UID is that of the freeside user.
314 ( $< == $freeside_uid );
317 =item getsecrets [ USER ]
319 Sets the user to USER, if supplied.
320 Sets and returns the DBI datasource, username and password for this user from
321 the `/usr/local/etc/freeside/mapsecrets' file.
326 my($setuser) = shift;
327 $user = $setuser if $setuser;
329 if ( -e "$conf_dir/mapsecrets" ) {
330 die "No user!" unless $user;
331 my($line) = grep /^\s*($user|\*)\s/,
332 map { /^(.*)$/; $1 } readline(new IO::File "$conf_dir/mapsecrets");
333 confess "User $user not found in mapsecrets!" unless $line;
334 $line =~ /^\s*($user|\*)\s+(.*)$/;
336 die "Illegal mapsecrets line for user?!" unless $secrets;
338 # no mapsecrets file at all, so do the default thing
339 $secrets = 'secrets';
342 ($datasrc, $db_user, $db_pass, $schema) =
343 map { /^(.*)$/; $1 } readline(new IO::File "$conf_dir/$secrets")
344 or die "Can't get secrets: $conf_dir/$secrets: $!\n";
347 ($datasrc, $db_user, $db_pass);
352 Returns true whenever we should use 1.7 configuration compatibility.
364 Warning: this interface is (still) likely to change in future releases.
366 New (experimental) callback interface:
368 A package can install a callback to be run in adminsuidsetup by passing
369 a coderef to the FS::UID->install_callback class method. If adminsuidsetup has
370 run already, the callback will also be run immediately.
372 $coderef = sub { warn "Hi, I'm returning your call!" };
373 FS::UID->install_callback($coderef);
375 install_callback FS::UID sub {
376 warn "Hi, I'm returning your call!"
379 Old (deprecated) callback interface:
381 A package can install a callback to be run in adminsuidsetup by putting a
382 coderef into the hash %FS::UID::callback :
384 $coderef = sub { warn "Hi, I'm returning your call!" };
385 $FS::UID::callback{'Package::Name'} = $coderef;
389 Too many package-global variables.
393 No capabilities yet. When mod_perl and Authen::DBI are implemented,
394 cgisuidsetup will go away as well.
396 Goes through contortions to support non-OO syntax with multiple datasrc's.
398 Callbacks are (still) inelegant.
402 L<FS::Record>, L<CGI>, L<DBI>, config.html from the base documentation.