TOOLS/w32codec_dl.pl

   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 }