![[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.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