![[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.13 ! andrew 2: #$RedRiver: OpenBSDTorrents.pm,v 1.12 2010/03/22 19:08:48 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;
66: opendir DIR, $basedir or die "Couldn't opendir $basedir: $!";
1.4 andrew 67: my @contents = sort grep { ! /^\.\.$/ } grep { ! /^\.$/ } readdir DIR;
1.2 andrew 68: closedir DIR;
69:
1.11 andrew 70: my @dirs;
71: my @files;
72: ITEM: foreach my $item (@contents) {
73: if ( -d "$basedir/$item" ) {
74: if ( $OBT->{SKIP_DIRS}
75: && $item =~ /$OBT->{SKIP_DIRS}/) {
76: next ITEM;
77: }
78: push @dirs, $item;
79: }
80: else {
81: if ( $OBT->{SKIP_FILES}
82: && $item =~ /$OBT->{SKIP_FILES}/) {
83: next ITEM;
84: }
85: push @files, $item;
86: }
1.2 andrew 87: }
88:
89: return \@dirs, \@files;
90: }
91:
92: sub Torrent_Date
93: {
94: my ($min, $hour, $mday, $mon, $year) = (gmtime)[1..5];
95: $mon++;
96: $year += 1900;
97: foreach ($min, $hour, $mday, $mon) {
98: if (length $_ == 1) {
99: $_ = '0' . $_;
100: }
101: }
102: return join '-', ($year, $mon, $mday, $hour . $min);
103: }
1.5 andrew 104:
105: # "There can be only one." --the Highlander
106: sub justme {
107:
108: my $myname;
109:
110: if ($0 =~ m#([^/]+$)#) {
111: $myname = $1;
112: } else {
113: die "Couldn't figure out myname";
114: }
115:
1.8 andrew 116: my $SEMA = $OBT->{DIR_HOME} . "/run/$myname.pid";
1.5 andrew 117: if (open SEMA, "<", $SEMA) {
118: my $pid = <SEMA>;
119: if (defined $pid) {
120: chomp $pid;
121: if ($pid =~ /^(\d+)$/) {
122: $pid = $1;
123: } else {
124: die "invalid pid read '$pid'";
125: }
126: if (kill(0, $pid)) {
127: print "$0 already running (pid $pid), bailing out\n";
128: exit 253;
129: }
130: }
131: close SEMA;
132: }
133: open (SEMA, ">", $SEMA) or die "can't write $SEMA: $!";
134: print SEMA "$$\n";
135: close(SEMA) or die "can't close $SEMA: $!";
136: }
137:
1.1 andrew 138:
139: 1;
140: __END__
141: # Below is stub documentation for your module. You'd better edit it!
142:
143: =head1 NAME
144:
145: OpenBSDTorrents - Perl extension for blah blah blah
146:
147: =head1 SYNOPSIS
148:
149: use OpenBSDTorrents;
150: blah blah blah
151:
152: =head1 DESCRIPTION
153:
154: Stub documentation for OpenBSDTorrents, created by h2xs. It looks like the
155: author of the extension was negligent enough to leave the stub
156: unedited.
157:
158: Blah blah blah.
159:
160:
161: =head1 SEE ALSO
162:
163: Mention other useful documentation such as the documentation of
164: related modules or operating system documentation (such as man pages
165: in UNIX), or any relevant external documentation such as RFCs or
166: standards.
167:
168: If you have a mailing list set up for your module, mention it here.
169:
170: If you have a web site set up for your module, mention it here.
171:
172: =head1 AUTHOR
173:
174: Andrew Fresh, E<lt>andrew@E<gt>
175:
176: =head1 COPYRIGHT AND LICENSE
177:
178: Copyright (C) 2005 by Andrew Fresh
179:
180: This library is free software; you can redistribute it and/or modify
181: it under the same terms as Perl itself, either Perl version 5.8.5 or,
182: at your option, any later version of Perl 5 you may have available.
183:
184:
185: =cut