Mercurial > mplayer.hg
comparison TOOLS/w32codec_dl.pl @ 6195:39805251ef61
Downloads w32codecs from M$, script by Tom Lees <tal26 at cam.ac.uk>
author | atmos4 |
---|---|
date | Sun, 26 May 2002 12:50:58 +0000 |
parents | |
children | 0f1b5b68af32 |
comparison
equal
deleted
inserted
replaced
6194:156144ee6810 | 6195:39805251ef61 |
---|---|
1 #!/usr/bin/perl | |
2 | |
3 ## usage: w32codec_dl.pl (codec.conf location) | |
4 | |
5 # this script will use MS's codec dl interface as used by MS Media Player | |
6 # to attempt to locate the codecs listed in codecs.conf. It will download | |
7 # them to a directory "codecs/" below the current dir. | |
8 # you will need the libwww-perl stuff and the utility "cabextract" | |
9 # which may be found at http://www.kyz.uklinux.net/cabextract.php3 | |
10 | |
11 # By Tom Lees, 2002. I hereby place this script into the public domain. | |
12 | |
13 #use LWP::Debug qw(+); | |
14 use LWP::UserAgent; | |
15 | |
16 $ua = LWP::UserAgent->new; | |
17 $ua->agent ("Mozilla/4.0 (compatible; MSIE 5.0; Windows 98; DigExt)"); | |
18 | |
19 # Parse the etc/codecs.conf file | |
20 my $cconf = $ARGV[0]; | |
21 open CCONF, "<$cconf"; | |
22 | |
23 my $codec = "(none)"; | |
24 my $mscodec = 0; | |
25 | |
26 my $cc, @ccl; | |
27 | |
28 mkdir "codecs"; | |
29 chdir "codecs"; | |
30 | |
31 CC: while (<CCONF>) | |
32 { | |
33 next CC if (m/^[ \t]*\;/); | |
34 s/\;.*//g; | |
35 s/#.*//g; | |
36 | |
37 if (m/^videocodec (.*)/) | |
38 { | |
39 $codec = $1; | |
40 } | |
41 elsif (m/^[ \t]+driver (.*)/) | |
42 { | |
43 if ($1 eq "dshow" || $1 eq "vfw") | |
44 { | |
45 $mscodec = 1; | |
46 } | |
47 else | |
48 { | |
49 $mscodec = 0; | |
50 } | |
51 } | |
52 elsif (m/^[ \t]+fourcc (.*)/ && $mscodec == 1) | |
53 { | |
54 $cclist = $1; | |
55 chomp $cclist; | |
56 #@ccl = (); | |
57 do | |
58 { | |
59 if ($cclist =~ m/\"(....)\"[, ]*(.*)/) | |
60 { | |
61 $cc = $1; | |
62 $cclist = $2; | |
63 } | |
64 elsif ($cclist =~ m/[, ]*(....)[, ]*(.*)/) | |
65 { | |
66 $cc = $1; | |
67 $cclist = $2; | |
68 } | |
69 else | |
70 { | |
71 $cc = $cclist; | |
72 $cclist = ""; | |
73 } | |
74 if (!($cc =~ m/^[ \t]+/)) | |
75 { | |
76 push @ccl, ($cc); | |
77 } | |
78 } while (length ($cclist) > 0); | |
79 } | |
80 } | |
81 close CCONF; | |
82 | |
83 # Find the codecs | |
84 open CODEC_CABS, ">codecs.locations.info"; | |
85 %fcc_try = (); | |
86 while ($#ccl > 0) | |
87 { | |
88 $cc = pop (@ccl); | |
89 if (!$fcc_try{"$cc"}) | |
90 { | |
91 $fcc_try{"$cc"} = 1; | |
92 if (!find_codec ($cc)) | |
93 { | |
94 print "$cc found\n"; | |
95 } | |
96 else | |
97 { | |
98 print "MS didn't find $cc\n"; | |
99 } | |
100 } | |
101 } | |
102 close CODEC_CABS; | |
103 | |
104 %got_codecs = (); | |
105 sub find_codec | |
106 { | |
107 my ($fourcc) = @_; | |
108 | |
109 my $guid = sprintf ("%08X", unpack ("V", $fourcc))."-0000-0010-8000-00AA00389B71"; | |
110 | |
111 my $req = HTTP::Request->new (POST => "http://activex.microsoft.com/objects/ocget.dll"); | |
112 $req->header ('Accept', '*/*'); | |
113 $req->content_type ('application/x-www-form-urlencoded'); | |
114 $req->content ("CLSID=%7B${guid}%7D\n"); | |
115 #$req->content ('CLSID={'.${guid}.'}'); | |
116 | |
117 my $res = $ua->request ($req); | |
118 | |
119 if ($res->is_success) { | |
120 print "Lookup returned success... weird!\n"; | |
121 return 1; | |
122 } else { | |
123 # Codec location | |
124 if ($res->code == 302) | |
125 { | |
126 my $loc = $res->headers->header ("Location"); | |
127 if (!$got_codecs{"$loc"}) | |
128 { | |
129 print CODEC_CABS "$loc\n"; | |
130 $got_codecs{"$loc"} = 1; | |
131 get_codec ($loc); | |
132 } | |
133 # else | |
134 # { | |
135 # print "Already have $loc\n"; | |
136 # } | |
137 return 0; | |
138 } | |
139 else | |
140 { | |
141 # print "Lookup failed (Microsoft probably doesn't know this codec)\n"; | |
142 return 1; | |
143 } | |
144 } | |
145 } | |
146 | |
147 sub get_codec | |
148 { | |
149 my ($url) = @_; | |
150 | |
151 my $req = HTTP::Request->new (GET => $url); | |
152 $req->header ("Accept", "*/*"); | |
153 my $res = $ua->request ($req); | |
154 | |
155 if ($res->is_success) | |
156 { | |
157 open TMP, ">tmp.cab" or die "Unable to open tmp.cab"; | |
158 print TMP $res->content; | |
159 close TMP; | |
160 | |
161 system "cabextract tmp.cab"; | |
162 unlink "tmp.cab"; | |
163 } | |
164 else | |
165 { | |
166 print "No such file!\n"; | |
167 } | |
168 } | |
169 |