[BACK]Return to OpenBSDTorrents.pm CVS log [TXT][DIR] Up to [local] / openbsd / OpenBSDTorrents / lib

Annotation of openbsd/OpenBSDTorrents/lib/OpenBSDTorrents.pm, Revision 1.14

1.1       andrew      1: package OpenBSDTorrents;
1.14    ! andrew      2: #$RedRiver: OpenBSDTorrents.pm,v 1.13 2010/03/22 20:13:53 andrew Exp $
1.1       andrew      3: use 5.008005;
                      4: use strict;
                      5: use warnings;
                      6:
1.2       andrew      7: require Exporter;
1.1       andrew      8:
1.2       andrew      9: our @ISA = qw(Exporter);
                     10:
1.1       andrew     11: our $VERSION = '0.01';
                     12:
1.2       andrew     13: our @EXPORT = qw(
1.8       andrew     14:        $OBT
1.10      andrew     15:        $INSTALL_ISO_REGEX
1.13      andrew     16:        $SONG_REGEX
1.2       andrew     17:        &Name_Torrent
                     18:        &Get_Files_and_Dirs
1.5       andrew     19:        &justme
1.2       andrew     20: );
1.1       andrew     21:
1.8       andrew     22: my $config_file = '/etc/OpenBSDTorrents.conf';
                     23: our $OBT = Config();
1.12      andrew     24: our $INSTALL_ISO_REGEX = qr/install\d+\.iso/xms;
1.13      andrew     25: our $SONG_REGEX        = qr/^song.*\.([^\.]+)$/xms;
1.2       andrew     26:
1.8       andrew     27: sub Config
                     28: {
                     29:        my %config;
                     30:        open FILE, $config_file or die "Couldn't open FILE $config_file: $!";
                     31:        while (<FILE>) {
                     32:                chomp;
                     33:                s/#.*$//;
                     34:                s/\s+$//;
                     35:                next unless $_;
                     36:                my ($name, $val) = split /=/, $_, 2;
                     37:                $name =~ s/^OBT_//;
                     38:                # This should really look for contents that are a
                     39:                # bit safer, but I can't think of what would work here.
                     40:                if ($val =~ /^(.*)$/) {
                     41:                        $config{$name} = $1;
1.11      andrew     42:                        $config{$name} =~ s/^['"]|["']$//gxms;
1.8       andrew     43:                }
                     44:        }
                     45:        close FILE;
                     46:        return \%config;
                     47: }
1.2       andrew     48:
                     49: sub Name_Torrent
                     50: {
                     51:        my $torrent = shift;
                     52:
                     53:        my $date = Torrent_Date();
                     54:
                     55:        $torrent =~ s/\W/_/g;
                     56:        $torrent .= '-' . $date;
                     57:        $torrent .= '.torrent';
                     58:
                     59:        return $torrent;
                     60: }
                     61:
                     62:
                     63: sub Get_Files_and_Dirs
                     64: {
                     65:        my $basedir = shift;
1.14    ! andrew     66:
        !            67:        if ( -f $basedir ) {
        !            68:                $basedir =~ s{^.*/}{}xms;
        !            69:                return [], [ $basedir ];
        !            70:        }
        !            71:
1.2       andrew     72:        opendir DIR, $basedir or die "Couldn't opendir $basedir: $!";
1.4       andrew     73:        my @contents = sort grep { ! /^\.\.$/ } grep { ! /^\.$/ } readdir DIR;
1.2       andrew     74:        closedir DIR;
                     75:
1.11      andrew     76:        my @dirs;
                     77:        my @files;
                     78:        ITEM: foreach my $item (@contents) {
                     79:                if ( -d "$basedir/$item" ) {
                     80:                        if ( $OBT->{SKIP_DIRS}
                     81:                          && $item =~ /$OBT->{SKIP_DIRS}/) {
                     82:                                next ITEM;
                     83:                        }
                     84:                        push @dirs, $item;
                     85:                }
                     86:                else {
                     87:                        if ( $OBT->{SKIP_FILES}
                     88:                          && $item =~ /$OBT->{SKIP_FILES}/) {
                     89:                                next ITEM;
                     90:                        }
                     91:                        push @files, $item;
                     92:                }
1.2       andrew     93:        }
                     94:
                     95:        return \@dirs, \@files;
                     96: }
                     97:
                     98: sub Torrent_Date
                     99: {
                    100:        my ($min, $hour, $mday, $mon, $year) = (gmtime)[1..5];
                    101:        $mon++;
                    102:        $year += 1900;
                    103:        foreach ($min, $hour, $mday, $mon) {
                    104:                if (length $_ == 1) {
                    105:                        $_ = '0' . $_;
                    106:                }
                    107:        }
                    108:        return join '-', ($year, $mon, $mday, $hour . $min);
                    109: }
1.5       andrew    110:
                    111: # "There can be only one."  --the Highlander
                    112: sub justme {
                    113:
                    114:        my $myname;
                    115:
                    116:        if ($0 =~ m#([^/]+$)#) {
                    117:                $myname = $1;
                    118:        } else {
                    119:                die "Couldn't figure out myname";
                    120:        }
                    121:
1.8       andrew    122:        my $SEMA = $OBT->{DIR_HOME} . "/run/$myname.pid";
1.5       andrew    123:         if (open SEMA, "<", $SEMA) {
                    124:                 my $pid = <SEMA>;
                    125:                 if (defined $pid) {
                    126:                         chomp $pid;
                    127:                        if ($pid =~ /^(\d+)$/) {
                    128:                                $pid = $1;
                    129:                        } else {
                    130:                                die "invalid pid read '$pid'";
                    131:                        }
                    132:                         if (kill(0, $pid)) {
                    133:                               print "$0 already running (pid $pid), bailing out\n";
                    134:                               exit 253;
                    135:                         }
                    136:                 }
                    137:                 close SEMA;
                    138:         }
                    139:         open (SEMA, ">", $SEMA)      or die "can't write $SEMA: $!";
                    140:         print SEMA "$$\n";
                    141:         close(SEMA)                    or die "can't close $SEMA: $!";
                    142: }
                    143:
1.1       andrew    144:
                    145: 1;
                    146: __END__
                    147: # Below is stub documentation for your module. You'd better edit it!
                    148:
                    149: =head1 NAME
                    150:
                    151: OpenBSDTorrents - Perl extension for blah blah blah
                    152:
                    153: =head1 SYNOPSIS
                    154:
                    155:   use OpenBSDTorrents;
                    156:   blah blah blah
                    157:
                    158: =head1 DESCRIPTION
                    159:
                    160: Stub documentation for OpenBSDTorrents, created by h2xs. It looks like the
                    161: author of the extension was negligent enough to leave the stub
                    162: unedited.
                    163:
                    164: Blah blah blah.
                    165:
                    166:
                    167: =head1 SEE ALSO
                    168:
                    169: Mention other useful documentation such as the documentation of
                    170: related modules or operating system documentation (such as man pages
                    171: in UNIX), or any relevant external documentation such as RFCs or
                    172: standards.
                    173:
                    174: If you have a mailing list set up for your module, mention it here.
                    175:
                    176: If you have a web site set up for your module, mention it here.
                    177:
                    178: =head1 AUTHOR
                    179:
                    180: Andrew Fresh, E<lt>andrew@E<gt>
                    181:
                    182: =head1 COPYRIGHT AND LICENSE
                    183:
                    184: Copyright (C) 2005 by Andrew Fresh
                    185:
                    186: This library is free software; you can redistribute it and/or modify
                    187: it under the same terms as Perl itself, either Perl version 5.8.5 or,
                    188: at your option, any later version of Perl 5 you may have available.
                    189:
                    190:
                    191: =cut

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>