├── README
└── faceextract.pl


/README:
--------------------------------------------------------------------------------
 1 | Script written to be able to use face detection data from Picasa in Lightroom.
 2 | 
 3 | Parses Piacsa files, and writes info into xmp-files.
 4 | 
 5 | Before using the script, you need to change some variables to point to the right 
 6 | contacts file and such. You also need the XML library for Perl, and the Perl Exiftool-library installed.
 7 | 
 8 | The script has only been tested in Windows 7, with Cygwin.
 9 | 
10 | The procedure goes as follow:
11 | 
12 | In Picasa, do the face tagging. Check the picasa website for help on that.
13 | In Lightroom, make sure you select all the pictures you want to update, and write all the metadata to files. Thats from the metadata menu.
14 | Go to the folder you have some pictures with people in it and run the Perl script.
15 | Open Lightroom again, select the pictures, and choose to read metadata from files.
16 | 
17 | It seems to be working okay now, but I take no responsibility for damages it may do to your pictures if you try it. Make sure you have a backup first!
18 | 
19 | To run the script recursively I use the command:
20 | 	find . -name \.picasa\.ini -execdir ~/scriptlocation/faceextract.pl \;
21 | 
22 | 


--------------------------------------------------------------------------------
/faceextract.pl:
--------------------------------------------------------------------------------
  1 | #!/bin/perl -w
  2 | #
  3 | use strict;
  4 | use utf8;
  5 | use XML::Simple qw(:strict);
  6 | use Data::Dumper;
  7 | use Image::ExifTool qw(:Public);
  8 | 
  9 | if(scalar(@ARGV) == 1)
 10 | {
 11 | 	chdir($ARGV[0]);
 12 | }
 13 | 
 14 | # Location of contact file
 15 | my $contactsfile = "/cygdrive/c/Users/greger/AppData/Local/Google/Picasa2/contacts/contacts.xml"; 
 16 | 
 17 | # Picasa-file-filename
 18 | my $filename = ".picasa.ini";
 19 | 
 20 | my $xml = new XML::Simple ( ForceArray => 1);
 21 | my $xmpinfo;
 22 | 
 23 | # Parse the contacts file, and make a contact map
 24 | my $contacts = $xml->XMLin($contactsfile, ForceArray=>1, KeyAttr =>{}, );
 25 | my %contactmap = ();
 26 | my $conts = $contacts->{contact};
 27 | foreach my $contact (@$conts)
 28 | {
 29 | 	$contactmap{$contact->{id}} = $contact->{name};
 30 | }
 31 | 
 32 | 
 33 | # Open and read the picasa file into an array
 34 | open(PICASAFILE, $filename) || die("Could not open picasafile: $!");
 35 | my @picasadata = <PICASAFILE>;
 36 | close(PICASAFILE);
 37 | 
 38 | # Remove all carriage returns.
 39 | foreach my $line (@picasadata)
 40 | {
 41 | 	$line =~ s/\r\n/\n/;
 42 | }
 43 | 
 44 | # Go through the picasa file
 45 | for(my $i = 0; $i < scalar(@picasadata); $i++)
 46 | {
 47 | 	if($picasadata[$i] =~ /^\[(.*)\]/)
 48 | 	{
 49 | 		my $exifTool = new Image::ExifTool();
 50 | 		print $1."\n";
 51 | 		my $xmpfile = $1;
 52 | 		if($xmpfile =~ m/NEF/i)
 53 | 		{
 54 | 			$xmpfile =~ s/NEF/xmp/gi;
 55 | 		}
 56 | 		print "Using $xmpfile for info.\n";
 57 | 		$exifTool->Options(List => 1);
 58 | 		$xmpinfo = $exifTool->ImageInfo($xmpfile);
 59 | 		
 60 | 		my $Subjects = $exifTool->GetValue('Subject');
 61 | 		my $Hierarchical = $exifTool->GetValue('HierarchicalSubject');
 62 | 		
 63 | 		$i++;
 64 | 		my $changes = 0;
 65 | 		if($picasadata[$i] =~ /^faces=(.*)/)
 66 | 		{
 67 | 			my @faces = split(/;/, $1);
 68 | 			print "\tFound ".scalar(@faces)." faces\n";
 69 | 			foreach my $face (@faces)
 70 | 			{
 71 | 				my ($region, $id) = split(/,/, $face);
 72 | 				my $new_subject = $contactmap{$id};
 73 | 				print "\t\tFound: ".$new_subject."\n";
 74 | 				my $old = 0;
 75 | 				if(ref($Subjects) eq "ARRAY")
 76 | 				{
 77 | 					for my $subject (@$Subjects)
 78 | 					{
 79 | 						if($subject eq $new_subject)
 80 | 						{
 81 | 							$old = 1;
 82 | 						}
 83 | 					}
 84 | 				}
 85 | 				elsif(ref($Subjects) eq "SCALAR")
 86 | 				{
 87 | 					if($$Subjects eq $new_subject)
 88 | 					{
 89 | 						$old = 1;
 90 | 					}
 91 | 
 92 | 				}
 93 | 				if(!$old)
 94 | 				{
 95 | 					$exifTool->SetNewValue(Subject => $new_subject, AddValue=>1);
 96 | 					print "Added to keywords.\n";
 97 | 					$changes++;
 98 | 				}
 99 | 
100 | 				$old = 0;
101 | 				#print Dumper($Hierarchical);
102 | 				if(ref($Hierarchical) eq "ARRAY")
103 | 				{				
104 | 					for my $subject (@$Hierarchical)
105 | 					{
106 | 						if($subject eq ("People|Persons|".$new_subject))
107 | 						{
108 | 							$old = 1;
109 | 						}
110 | 					}
111 | 				}
112 | 				elsif(ref($Hierarchical) eq "SCALAR")
113 | 				{
114 | 					if($$Hierarchical eq ("People|Persons|".$new_subject))
115 | 					{
116 | 						$old = 1;
117 | 					}
118 | 				}
119 | 				
120 | 				if(!$old)
121 | 				{
122 | 					$exifTool->SetNewValue(HierarchicalSubject => ("People|Persons|".$new_subject), AddValue=>1);
123 | 					print "Added to hierarchical keywords.\n";
124 | 					$changes++;
125 | 				}
126 | 
127 | 			}
128 | 		}
129 | #		$changes = 0;
130 | 		if($changes > 0)
131 | 		{
132 | 			my $ret = $exifTool->WriteInfo($xmpfile);
133 | 			if($ret == 1) { print "\tFile written ok.\n"; }
134 | 			if($ret == 2) { print "\tFile written, no changes.\n"; } #Should not happen
135 | 			if($ret == 0) { print "\t *** File write error on file: ".$xmpfile." ***\n"; }
136 | 		}
137 | 		else
138 | 		{
139 | 			print "\tNo changes to file.\n";
140 | 		}
141 | 	}
142 | 	print "\n";
143 | 
144 | }
145 | 
146 | 
147 | 


--------------------------------------------------------------------------------