106 lines
2.7 KiB
Perl
106 lines
2.7 KiB
Perl
|
#!/usr/bin/perl
|
||
|
|
# This code was forked from the LiveJournal project owned and operated
|
||
|
|
# by Live Journal, Inc. The code has been modified and expanded by
|
||
|
|
# Dreamwidth Studios, LLC. These files were originally licensed under
|
||
|
|
# the terms of the license supplied by Live Journal, Inc, which can
|
||
|
|
# currently be found at:
|
||
|
|
#
|
||
|
|
# http://code.livejournal.org/trac/livejournal/browser/trunk/LICENSE-LiveJournal.txt
|
||
|
|
#
|
||
|
|
# In accordance with the original license, this code and all its
|
||
|
|
# modifications are provided under the GNU General Public License.
|
||
|
|
# A copy of that license can be found in the LICENSE file included as
|
||
|
|
# part of this distribution.
|
||
|
|
|
||
|
|
package LJ::ModuleLoader;
|
||
|
|
|
||
|
|
use strict;
|
||
|
|
use IO::Dir;
|
||
|
|
require Exporter;
|
||
|
|
|
||
|
|
our @ISA = qw(Exporter);
|
||
|
|
our @EXPORT = qw(module_subclasses);
|
||
|
|
|
||
|
|
use DW;
|
||
|
|
use LJ::Directories;
|
||
|
|
|
||
|
|
# given a module name, looks under cgi-bin/ for its patch and, if valid,
|
||
|
|
# returns (assumed) package names of all modules in the directory
|
||
|
|
sub module_subclasses {
|
||
|
|
shift if @_ > 1; # get rid of classname
|
||
|
|
my $base_class = shift;
|
||
|
|
my $base_path = join( "/", 'cgi-bin', split( "::", $base_class ) );
|
||
|
|
|
||
|
|
my @dirs = LJ::get_all_directories($base_path);
|
||
|
|
|
||
|
|
my @files;
|
||
|
|
while (@dirs) {
|
||
|
|
my $dir = shift @dirs;
|
||
|
|
my $d = IO::Dir->new($dir);
|
||
|
|
while ( my $file = $d->read ) {
|
||
|
|
if ( $file =~ /^\./ ) {
|
||
|
|
next;
|
||
|
|
}
|
||
|
|
elsif ( $file =~ /\.pm$/ ) {
|
||
|
|
push @files, "$dir/$file";
|
||
|
|
}
|
||
|
|
elsif ( -d "$dir/$file" ) {
|
||
|
|
push @dirs, "$dir/$file";
|
||
|
|
}
|
||
|
|
}
|
||
|
|
$d->close;
|
||
|
|
}
|
||
|
|
|
||
|
|
return map {
|
||
|
|
s!.+cgi-bin/!!;
|
||
|
|
s!/!::!g;
|
||
|
|
s/\.pm$//;
|
||
|
|
$_;
|
||
|
|
} @files;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub autouse_subclasses {
|
||
|
|
shift if @_ > 1; # get rid of classname
|
||
|
|
my $base_class = shift;
|
||
|
|
|
||
|
|
foreach my $class ( LJ::ModuleLoader->module_subclasses($base_class) ) {
|
||
|
|
eval "use Class::Autouse qw($class)";
|
||
|
|
die "Error loading $class: $@" if $@;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
sub require_subclasses {
|
||
|
|
shift if @_ > 1; # get rid of classname
|
||
|
|
my $base_class = shift;
|
||
|
|
|
||
|
|
foreach my $class ( LJ::ModuleLoader->module_subclasses($base_class) ) {
|
||
|
|
eval "use $class";
|
||
|
|
die "Error loading $class: $@" if $@;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
sub require_if_exists {
|
||
|
|
shift if @_ > 1; # get rid of classname
|
||
|
|
|
||
|
|
my $req_file = shift;
|
||
|
|
|
||
|
|
# allow caller to pass in "filename.pl", which will be
|
||
|
|
# assumed in $LJHOME/cgi-bin/, otherwise a full path
|
||
|
|
$req_file = DW->home . "/cgi-bin/$req_file"
|
||
|
|
unless $req_file =~ m!/!;
|
||
|
|
|
||
|
|
# lib should return 1
|
||
|
|
if ( -e $req_file ) {
|
||
|
|
my $rv = do $req_file;
|
||
|
|
warn $@ if $@;
|
||
|
|
return $rv;
|
||
|
|
}
|
||
|
|
|
||
|
|
# no library loaded, return 0
|
||
|
|
return 0;
|
||
|
|
}
|
||
|
|
|
||
|
|
# FIXME: This should do more...
|
||
|
|
|
||
|
|
1;
|