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