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
21 getotaker dbh datasrc getsecrets driver_name myconnect
28 $freeside_uid = scalar(getpwnam('freeside'));
30 $conf_dir = "%%%FREESIDE_CONF%%%";
31 $cache_dir = "%%%FREESIDE_CACHE%%%";
33 $AutoCommit = 1; #ours, not DBI
39 FS::UID - Subroutines for database login and assorted other stuff
43 use FS::UID qw(adminsuidsetup cgisuidsetup dbh datasrc getotaker
49 $dbh = cgisuidsetup($cgi);
55 $driver_name = driver_name;
59 Provides a hodgepodge of subroutines.
65 =item adminsuidsetup USER
67 Sets the user to USER (see config.html from the base documentation).
68 Cleans the environment.
69 Make sure the script is running as freeside, or setuid freeside.
70 Opens a connection to the database.
71 Swaps real and effective UIDs.
72 Runs any defined callbacks (see below).
73 Returns the DBI database handle (usually you don't need this).
78 $dbh->disconnect if $dbh;
85 warn "$me forksuidsetup starting for $user\n" if $DEBUG;
87 if ( $FS::CurrentUser::upgrade_hack ) {
88 $user = 'fs_bootstrap';
90 croak "fatal: adminsuidsetup called without arguements" unless $user;
92 $user =~ /^([\w\-\.]+)$/ or croak "fatal: illegal user $user";
96 $ENV{'PATH'} ='/usr/local/bin:/usr/bin:/usr/ucb:/bin';
97 $ENV{'SHELL'} = '/bin/sh';
98 $ENV{'IFS'} = " \t\n";
101 $ENV{'BASH_ENV'} = '';
103 croak "Not running uid freeside (\$>=$>, \$<=$<)\n" unless checkeuid();
105 warn "$me forksuidsetup connecting to database\n" if $DEBUG;
106 if ( $FS::CurrentUser::upgrade_hack && $olduser ) {
107 $dbh = &myconnect($olduser);
111 warn "$me forksuidsetup connected to database with handle $dbh\n" if $DEBUG;
113 warn "$me forksuidsetup loading schema\n" if $DEBUG;
114 use FS::Schema qw(reload_dbdef dbdef);
115 reload_dbdef("$conf_dir/dbdef.$datasrc")
116 unless $FS::Schema::setup_hack;
118 warn "$me forksuidsetup deciding upon config system to use\n" if $DEBUG;
120 if ( ! $FS::Schema::setup_hack && dbdef->table('conf') ) {
122 my $sth = $dbh->prepare("SELECT COUNT(*) FROM conf") or die $dbh->errstr;
123 $sth->execute or die $sth->errstr;
124 my $confcount = $sth->fetchrow_arrayref->[0];
129 die "NO CONFIGURATION RECORDS FOUND";
133 die "NO CONFIGURATION TABLE FOUND" unless $FS::Schema::setup_hack;
136 unless ( $callback_hack ) {
137 warn "$me calling callbacks\n" if $DEBUG;
138 foreach ( keys %callback ) {
140 # breaks multi-database installs # delete $callback{$_}; #run once
143 &{$_} foreach @callback;
145 warn "$me skipping callbacks (callback_hack set)\n" if $DEBUG;
148 warn "$me forksuidsetup loading user\n" if $DEBUG;
149 FS::CurrentUser->load_user($user);
154 # start of backported functions from HEAD/4.x only used in development w/
155 # a new style AuthCookie setup
157 $dbh->disconnect if $dbh;
166 $ENV{'PATH'} ='/usr/local/bin:/usr/bin:/bin';
167 $ENV{'SHELL'} = '/bin/sh';
168 $ENV{'IFS'} = " \t\n";
171 $ENV{'BASH_ENV'} = '';
178 croak "Not running uid freeside (\$>=$>, \$<=$<)\n" unless checkeuid();
180 warn "$me forksuidsetup connecting to database\n" if $DEBUG;
181 if ( $FS::CurrentUser::upgrade_hack && $olduser ) {
182 $dbh = &myconnect($olduser);
186 warn "$me forksuidsetup connected to database with handle $dbh\n" if $DEBUG;
188 warn "$me forksuidsetup loading schema\n" if $DEBUG;
189 use FS::Schema qw(reload_dbdef dbdef);
190 reload_dbdef("$conf_dir/dbdef.$datasrc")
191 unless $FS::Schema::setup_hack;
193 warn "$me forksuidsetup deciding upon config system to use\n" if $DEBUG;
195 if ( ! $FS::Schema::setup_hack && dbdef->table('conf') ) {
197 my $sth = $dbh->prepare("SELECT COUNT(*) FROM conf") or die $dbh->errstr;
198 $sth->execute or die $sth->errstr;
199 my $confcount = $sth->fetchrow_arrayref->[0];
204 die "NO CONFIGURATION RECORDS FOUND";
208 die "NO CONFIGURATION TABLE FOUND" unless $FS::Schema::setup_hack;
213 # end of backported functions from HEAD/4.x only used in development
217 unless ( $callback_hack ) {
218 warn "$me calling callbacks\n" if $DEBUG;
219 foreach ( keys %callback ) {
221 # breaks multi-database installs # delete $callback{$_}; #run once
224 &{$_} foreach @callback;
226 warn "$me skipping callbacks (callback_hack set)\n" if $DEBUG;
233 my $handle = DBI->connect( getsecrets(@_), { 'AutoCommit' => 0,
235 'ShowErrorStatement' => 1,
236 'pg_enable_utf8' => 1,
237 #'mysql_enable_utf8' => 1,
240 or die "DBI->connect error: $DBI::errstr\n";
243 use DBIx::DBSchema::_util qw(_load_driver ); #quelle hack
244 my $driver = _load_driver($handle);
245 if ( $driver =~ /^Pg/ ) {
246 no warnings 'redefine';
247 eval "sub DBIx::DBSchema::DBD::${driver}::default_db_schema {'$schema'}";
255 =item install_callback
257 A package can install a callback to be run in adminsuidsetup by passing
258 a coderef to the FS::UID->install_callback class method. If adminsuidsetup has
259 run already, the callback will also be run immediately.
261 $coderef = sub { warn "Hi, I'm returning your call!" };
262 FS::UID->install_callback($coderef);
264 install_callback FS::UID sub {
265 warn "Hi, I'm returning your call!"
270 sub install_callback {
272 my $callback = shift;
273 push @callback, $callback;
274 &{$callback} if $dbh;
277 =item cgisuidsetup CGI_object
279 Takes a single argument, which is a CGI (see L<CGI>) or Apache (see L<Apache>)
280 object (CGI::Base is depriciated). Runs cgisetotaker and then adminsuidsetup.
286 if ( $cgi->isa('CGI::Base') ) {
287 carp "Use of CGI::Base is depriciated";
288 } elsif ( $cgi->isa('Apache') ) {
290 } elsif ( ! $cgi->isa('CGI') ) {
291 croak "fatal: unrecognized object $cgi";
294 adminsuidsetup($user);
299 Returns the CGI (see L<CGI>) object.
304 carp "warning: \$FS::UID::cgi isa Apache" if $cgi->isa('Apache');
310 Returns the DBI database handle.
320 Returns the DBI data source.
330 Returns just the driver name portion of the DBI data source.
335 return $driver_name if defined $driver_name;
336 $driver_name = ( split(':', $datasrc) )[1];
340 croak "suidsetup depriciated";
345 Returns the current Freeside user.
355 Sets and returns the CGI REMOTE_USER. $cgi should be defined as a CGI.pm
356 object (see L<CGI>) or an Apache object (see L<Apache>). Support for CGI::Base
357 and derived classes is depriciated.
362 if ( $cgi && $cgi->isa('CGI::Base') && defined $cgi->var('REMOTE_USER')) {
363 carp "Use of CGI::Base is depriciated";
364 $user = lc ( $cgi->var('REMOTE_USER') );
365 } elsif ( $cgi && $cgi->isa('CGI') && defined $cgi->remote_user ) {
366 $user = lc ( $cgi->remote_user );
367 } elsif ( $cgi && $cgi->isa('Apache') ) {
368 $user = lc ( $cgi->connection->user );
370 die "fatal: Can't get REMOTE_USER! for cgi $cgi - you need to setup ".
371 "Apache user authentication as documented in the installation instructions";
378 Returns true if effective UID is that of the freeside user.
383 #$> = $freeside_uid unless $>; #huh. mpm-itk hack
384 ( $> == $freeside_uid );
389 Returns true if the real UID is that of the freeside user.
394 ( $< == $freeside_uid );
397 =item getsecrets [ USER ]
399 Sets the user to USER, if supplied.
400 Sets and returns the DBI datasource, username and password for this user from
401 the `/usr/local/etc/freeside/mapsecrets' file.
406 my($setuser) = shift;
407 $user = $setuser if $setuser;
409 if ( -e "$conf_dir/mapsecrets" ) {
410 die "No user!" unless $user;
411 my($line) = grep /^\s*($user|\*)\s/,
412 map { /^(.*)$/; $1 } readline(new IO::File "$conf_dir/mapsecrets");
413 confess "User $user not found in mapsecrets!" unless $line;
414 $line =~ /^\s*($user|\*)\s+(.*)$/;
416 die "Illegal mapsecrets line for user?!" unless $secrets;
418 # no mapsecrets file at all, so do the default thing
419 $secrets = 'secrets';
422 ($datasrc, $db_user, $db_pass, $schema) =
423 map { /^(.*)$/; $1 } readline(new IO::File "$conf_dir/$secrets")
424 or die "Can't get secrets: $conf_dir/$secrets: $!\n";
427 ($datasrc, $db_user, $db_pass);
432 Returns true whenever we should use 1.7 configuration compatibility.
444 Warning: this interface is (still) likely to change in future releases.
446 New (experimental) callback interface:
448 A package can install a callback to be run in adminsuidsetup by passing
449 a coderef to the FS::UID->install_callback class method. If adminsuidsetup has
450 run already, the callback will also be run immediately.
452 $coderef = sub { warn "Hi, I'm returning your call!" };
453 FS::UID->install_callback($coderef);
455 install_callback FS::UID sub {
456 warn "Hi, I'm returning your call!"
459 Old (deprecated) callback interface:
461 A package can install a callback to be run in adminsuidsetup by putting a
462 coderef into the hash %FS::UID::callback :
464 $coderef = sub { warn "Hi, I'm returning your call!" };
465 $FS::UID::callback{'Package::Name'} = $coderef;
469 Too many package-global variables.
473 No capabilities yet. When mod_perl and Authen::DBI are implemented,
474 cgisuidsetup will go away as well.
476 Goes through contortions to support non-OO syntax with multiple datasrc's.
478 Callbacks are (still) inelegant.
482 L<FS::Record>, L<CGI>, L<DBI>, config.html from the base documentation.