Writer.pl 262 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771177217731774177517761777177817791780178117821783178417851786178717881789179017911792179317941795179617971798179918001801180218031804180518061807180818091810181118121813181418151816181718181819182018211822182318241825182618271828182918301831183218331834183518361837183818391840184118421843184418451846184718481849185018511852185318541855185618571858185918601861186218631864186518661867186818691870187118721873187418751876187718781879188018811882188318841885188618871888188918901891189218931894189518961897189818991900190119021903190419051906190719081909191019111912191319141915191619171918191919201921192219231924192519261927192819291930193119321933193419351936193719381939194019411942194319441945194619471948194919501951195219531954195519561957195819591960196119621963196419651966196719681969197019711972197319741975197619771978197919801981198219831984198519861987198819891990199119921993199419951996199719981999200020012002200320042005200620072008200920102011201220132014201520162017201820192020202120222023202420252026202720282029203020312032203320342035203620372038203920402041204220432044204520462047204820492050205120522053205420552056205720582059206020612062206320642065206620672068206920702071207220732074207520762077207820792080208120822083208420852086208720882089209020912092209320942095209620972098209921002101210221032104210521062107210821092110211121122113211421152116211721182119212021212122212321242125212621272128212921302131213221332134213521362137213821392140214121422143214421452146214721482149215021512152215321542155215621572158215921602161216221632164216521662167216821692170217121722173217421752176217721782179218021812182218321842185218621872188218921902191219221932194219521962197219821992200220122022203220422052206220722082209221022112212221322142215221622172218221922202221222222232224222522262227222822292230223122322233223422352236223722382239224022412242224322442245224622472248224922502251225222532254225522562257225822592260226122622263226422652266226722682269227022712272227322742275227622772278227922802281228222832284228522862287228822892290229122922293229422952296229722982299230023012302230323042305230623072308230923102311231223132314231523162317231823192320232123222323232423252326232723282329233023312332233323342335233623372338233923402341234223432344234523462347234823492350235123522353235423552356235723582359236023612362236323642365236623672368236923702371237223732374237523762377237823792380238123822383238423852386238723882389239023912392239323942395239623972398239924002401240224032404240524062407240824092410241124122413241424152416241724182419242024212422242324242425242624272428242924302431243224332434243524362437243824392440244124422443244424452446244724482449245024512452245324542455245624572458245924602461246224632464246524662467246824692470247124722473247424752476247724782479248024812482248324842485248624872488248924902491249224932494249524962497249824992500250125022503250425052506250725082509251025112512251325142515251625172518251925202521252225232524252525262527252825292530253125322533253425352536253725382539254025412542254325442545254625472548254925502551255225532554255525562557255825592560256125622563256425652566256725682569257025712572257325742575257625772578257925802581258225832584258525862587258825892590259125922593259425952596259725982599260026012602260326042605260626072608260926102611261226132614261526162617261826192620262126222623262426252626262726282629263026312632263326342635263626372638263926402641264226432644264526462647264826492650265126522653265426552656265726582659266026612662266326642665266626672668266926702671267226732674267526762677267826792680268126822683268426852686268726882689269026912692269326942695269626972698269927002701270227032704270527062707270827092710271127122713271427152716271727182719272027212722272327242725272627272728272927302731273227332734273527362737273827392740274127422743274427452746274727482749275027512752275327542755275627572758275927602761276227632764276527662767276827692770277127722773277427752776277727782779278027812782278327842785278627872788278927902791279227932794279527962797279827992800280128022803280428052806280728082809281028112812281328142815281628172818281928202821282228232824282528262827282828292830283128322833283428352836283728382839284028412842284328442845284628472848284928502851285228532854285528562857285828592860286128622863286428652866286728682869287028712872287328742875287628772878287928802881288228832884288528862887288828892890289128922893289428952896289728982899290029012902290329042905290629072908290929102911291229132914291529162917291829192920292129222923292429252926292729282929293029312932293329342935293629372938293929402941294229432944294529462947294829492950295129522953295429552956295729582959296029612962296329642965296629672968296929702971297229732974297529762977297829792980298129822983298429852986298729882989299029912992299329942995299629972998299930003001300230033004300530063007300830093010301130123013301430153016301730183019302030213022302330243025302630273028302930303031303230333034303530363037303830393040304130423043304430453046304730483049305030513052305330543055305630573058305930603061306230633064306530663067306830693070307130723073307430753076307730783079308030813082308330843085308630873088308930903091309230933094309530963097309830993100310131023103310431053106310731083109311031113112311331143115311631173118311931203121312231233124312531263127312831293130313131323133313431353136313731383139314031413142314331443145314631473148314931503151315231533154315531563157315831593160316131623163316431653166316731683169317031713172317331743175317631773178317931803181318231833184318531863187318831893190319131923193319431953196319731983199320032013202320332043205320632073208320932103211321232133214321532163217321832193220322132223223322432253226322732283229323032313232323332343235323632373238323932403241324232433244324532463247324832493250325132523253325432553256325732583259326032613262326332643265326632673268326932703271327232733274327532763277327832793280328132823283328432853286328732883289329032913292329332943295329632973298329933003301330233033304330533063307330833093310331133123313331433153316331733183319332033213322332333243325332633273328332933303331333233333334333533363337333833393340334133423343334433453346334733483349335033513352335333543355335633573358335933603361336233633364336533663367336833693370337133723373337433753376337733783379338033813382338333843385338633873388338933903391339233933394339533963397339833993400340134023403340434053406340734083409341034113412341334143415341634173418341934203421342234233424342534263427342834293430343134323433343434353436343734383439344034413442344334443445344634473448344934503451345234533454345534563457345834593460346134623463346434653466346734683469347034713472347334743475347634773478347934803481348234833484348534863487348834893490349134923493349434953496349734983499350035013502350335043505350635073508350935103511351235133514351535163517351835193520352135223523352435253526352735283529353035313532353335343535353635373538353935403541354235433544354535463547354835493550355135523553355435553556355735583559356035613562356335643565356635673568356935703571357235733574357535763577357835793580358135823583358435853586358735883589359035913592359335943595359635973598359936003601360236033604360536063607360836093610361136123613361436153616361736183619362036213622362336243625362636273628362936303631363236333634363536363637363836393640364136423643364436453646364736483649365036513652365336543655365636573658365936603661366236633664366536663667366836693670367136723673367436753676367736783679368036813682368336843685368636873688368936903691369236933694369536963697369836993700370137023703370437053706370737083709371037113712371337143715371637173718371937203721372237233724372537263727372837293730373137323733373437353736373737383739374037413742374337443745374637473748374937503751375237533754375537563757375837593760376137623763376437653766376737683769377037713772377337743775377637773778377937803781378237833784378537863787378837893790379137923793379437953796379737983799380038013802380338043805380638073808380938103811381238133814381538163817381838193820382138223823382438253826382738283829383038313832383338343835383638373838383938403841384238433844384538463847384838493850385138523853385438553856385738583859386038613862386338643865386638673868386938703871387238733874387538763877387838793880388138823883388438853886388738883889389038913892389338943895389638973898389939003901390239033904390539063907390839093910391139123913391439153916391739183919392039213922392339243925392639273928392939303931393239333934393539363937393839393940394139423943394439453946394739483949395039513952395339543955395639573958395939603961396239633964396539663967396839693970397139723973397439753976397739783979398039813982398339843985398639873988398939903991399239933994399539963997399839994000400140024003400440054006400740084009401040114012401340144015401640174018401940204021402240234024402540264027402840294030403140324033403440354036403740384039404040414042404340444045404640474048404940504051405240534054405540564057405840594060406140624063406440654066406740684069407040714072407340744075407640774078407940804081408240834084408540864087408840894090409140924093409440954096409740984099410041014102410341044105410641074108410941104111411241134114411541164117411841194120412141224123412441254126412741284129413041314132413341344135413641374138413941404141414241434144414541464147414841494150415141524153415441554156415741584159416041614162416341644165416641674168416941704171417241734174417541764177417841794180418141824183418441854186418741884189419041914192419341944195419641974198419942004201420242034204420542064207420842094210421142124213421442154216421742184219422042214222422342244225422642274228422942304231423242334234423542364237423842394240424142424243424442454246424742484249425042514252425342544255425642574258425942604261426242634264426542664267426842694270427142724273427442754276427742784279428042814282428342844285428642874288428942904291429242934294429542964297429842994300430143024303430443054306430743084309431043114312431343144315431643174318431943204321432243234324432543264327432843294330433143324333433443354336433743384339434043414342434343444345434643474348434943504351435243534354435543564357435843594360436143624363436443654366436743684369437043714372437343744375437643774378437943804381438243834384438543864387438843894390439143924393439443954396439743984399440044014402440344044405440644074408440944104411441244134414441544164417441844194420442144224423442444254426442744284429443044314432443344344435443644374438443944404441444244434444444544464447444844494450445144524453445444554456445744584459446044614462446344644465446644674468446944704471447244734474447544764477447844794480448144824483448444854486448744884489449044914492449344944495449644974498449945004501450245034504450545064507450845094510451145124513451445154516451745184519452045214522452345244525452645274528452945304531453245334534453545364537453845394540454145424543454445454546454745484549455045514552455345544555455645574558455945604561456245634564456545664567456845694570457145724573457445754576457745784579458045814582458345844585458645874588458945904591459245934594459545964597459845994600460146024603460446054606460746084609461046114612461346144615461646174618461946204621462246234624462546264627462846294630463146324633463446354636463746384639464046414642464346444645464646474648464946504651465246534654465546564657465846594660466146624663466446654666466746684669467046714672467346744675467646774678467946804681468246834684468546864687468846894690469146924693469446954696469746984699470047014702470347044705470647074708470947104711471247134714471547164717471847194720472147224723472447254726472747284729473047314732473347344735473647374738473947404741474247434744474547464747474847494750475147524753475447554756475747584759476047614762476347644765476647674768476947704771477247734774477547764777477847794780478147824783478447854786478747884789479047914792479347944795479647974798479948004801480248034804480548064807480848094810481148124813481448154816481748184819482048214822482348244825482648274828482948304831483248334834483548364837483848394840484148424843484448454846484748484849485048514852485348544855485648574858485948604861486248634864486548664867486848694870487148724873487448754876487748784879488048814882488348844885488648874888488948904891489248934894489548964897489848994900490149024903490449054906490749084909491049114912491349144915491649174918491949204921492249234924492549264927492849294930493149324933493449354936493749384939494049414942494349444945494649474948494949504951495249534954495549564957495849594960496149624963496449654966496749684969497049714972497349744975497649774978497949804981498249834984498549864987498849894990499149924993499449954996499749984999500050015002500350045005500650075008500950105011501250135014501550165017501850195020502150225023502450255026502750285029503050315032503350345035503650375038503950405041504250435044504550465047504850495050505150525053505450555056505750585059506050615062506350645065506650675068506950705071507250735074507550765077507850795080508150825083508450855086508750885089509050915092509350945095509650975098509951005101510251035104510551065107510851095110511151125113511451155116511751185119512051215122512351245125512651275128512951305131513251335134513551365137513851395140514151425143514451455146514751485149515051515152515351545155515651575158515951605161516251635164516551665167516851695170517151725173517451755176517751785179518051815182518351845185518651875188518951905191519251935194519551965197519851995200520152025203520452055206520752085209521052115212521352145215521652175218521952205221522252235224522552265227522852295230523152325233523452355236523752385239524052415242524352445245524652475248524952505251525252535254525552565257525852595260526152625263526452655266526752685269527052715272527352745275527652775278527952805281528252835284528552865287528852895290529152925293529452955296529752985299530053015302530353045305530653075308530953105311531253135314531553165317531853195320532153225323532453255326532753285329533053315332533353345335533653375338533953405341534253435344534553465347534853495350535153525353535453555356535753585359536053615362536353645365536653675368536953705371537253735374537553765377537853795380538153825383538453855386538753885389539053915392539353945395539653975398539954005401540254035404540554065407540854095410541154125413541454155416541754185419542054215422542354245425542654275428542954305431543254335434543554365437543854395440544154425443544454455446544754485449545054515452545354545455545654575458545954605461546254635464546554665467546854695470547154725473547454755476547754785479548054815482548354845485548654875488548954905491549254935494549554965497549854995500550155025503550455055506550755085509551055115512551355145515551655175518551955205521552255235524552555265527552855295530553155325533553455355536553755385539554055415542554355445545554655475548554955505551555255535554555555565557555855595560556155625563556455655566556755685569557055715572557355745575557655775578557955805581558255835584558555865587558855895590559155925593559455955596559755985599560056015602560356045605560656075608560956105611561256135614561556165617561856195620562156225623562456255626562756285629563056315632563356345635563656375638563956405641564256435644564556465647564856495650565156525653565456555656565756585659566056615662566356645665566656675668566956705671567256735674567556765677567856795680568156825683568456855686568756885689569056915692569356945695569656975698569957005701570257035704570557065707570857095710571157125713571457155716571757185719572057215722572357245725572657275728572957305731573257335734573557365737573857395740574157425743574457455746574757485749575057515752575357545755575657575758575957605761576257635764576557665767576857695770577157725773577457755776577757785779578057815782578357845785578657875788578957905791579257935794579557965797579857995800580158025803580458055806580758085809581058115812581358145815581658175818581958205821582258235824582558265827582858295830583158325833583458355836583758385839584058415842584358445845584658475848584958505851585258535854585558565857585858595860586158625863586458655866586758685869587058715872587358745875587658775878587958805881588258835884588558865887588858895890589158925893589458955896589758985899590059015902590359045905590659075908590959105911591259135914591559165917591859195920592159225923592459255926592759285929593059315932593359345935593659375938593959405941594259435944594559465947594859495950595159525953595459555956595759585959596059615962596359645965596659675968596959705971597259735974597559765977597859795980598159825983598459855986598759885989599059915992599359945995599659975998599960006001600260036004600560066007600860096010601160126013601460156016601760186019602060216022602360246025602660276028602960306031603260336034603560366037603860396040604160426043604460456046604760486049605060516052605360546055605660576058605960606061606260636064606560666067606860696070607160726073607460756076607760786079608060816082608360846085608660876088608960906091609260936094609560966097609860996100610161026103610461056106610761086109611061116112611361146115611661176118611961206121612261236124612561266127612861296130613161326133613461356136613761386139614061416142614361446145614661476148614961506151615261536154615561566157615861596160616161626163616461656166616761686169617061716172617361746175617661776178617961806181618261836184618561866187618861896190619161926193619461956196
  1. #------------------------------------------------------------------------------
  2. # File: Writer.pl
  3. #
  4. # Description: ExifTool write routines
  5. #
  6. # Notes: Also contains some less used ExifTool functions
  7. #
  8. # URL: http://owl.phy.queensu.ca/~phil/exiftool/
  9. #
  10. # Revisions: 12/16/2004 - P. Harvey Created
  11. #------------------------------------------------------------------------------
  12. package Image::ExifTool;
  13. use strict;
  14. use Image::ExifTool::TagLookup qw(FindTagInfo TagExists);
  15. use Image::ExifTool::Fixup;
  16. sub AssembleRational($$@);
  17. sub LastInList($);
  18. sub CreateDirectory($$);
  19. sub NextFreeTagKey($$);
  20. sub RemoveNewValueHash($$$);
  21. sub RemoveNewValuesForGroup($$);
  22. sub GetWriteGroup1($$);
  23. sub Sanitize($$);
  24. sub ConvInv($$$$$;$$);
  25. my $loadedAllTables; # flag indicating we loaded all tables
  26. # the following is a road map of where we write each directory
  27. # in the different types of files.
  28. my %tiffMap = (
  29. IFD0 => 'TIFF',
  30. IFD1 => 'IFD0',
  31. XMP => 'IFD0',
  32. ICC_Profile => 'IFD0',
  33. ExifIFD => 'IFD0',
  34. GPS => 'IFD0',
  35. SubIFD => 'IFD0',
  36. GlobParamIFD => 'IFD0',
  37. PrintIM => 'IFD0',
  38. IPTC => 'IFD0',
  39. Photoshop => 'IFD0',
  40. InteropIFD => 'ExifIFD',
  41. MakerNotes => 'ExifIFD',
  42. CanonVRD => 'MakerNotes', # (so VRDOffset will get updated)
  43. NikonCapture => 'MakerNotes', # (to allow delete by group)
  44. );
  45. my %exifMap = (
  46. IFD1 => 'IFD0',
  47. EXIF => 'IFD0', # to write EXIF as a block
  48. ExifIFD => 'IFD0',
  49. GPS => 'IFD0',
  50. SubIFD => 'IFD0',
  51. GlobParamIFD => 'IFD0',
  52. PrintIM => 'IFD0',
  53. InteropIFD => 'ExifIFD',
  54. MakerNotes => 'ExifIFD',
  55. NikonCapture => 'MakerNotes', # (to allow delete by group)
  56. # (no CanonVRD trailer allowed)
  57. );
  58. my %jpegMap = (
  59. %exifMap, # covers all JPEG EXIF mappings
  60. JFIF => 'APP0',
  61. CIFF => 'APP0',
  62. IFD0 => 'APP1',
  63. XMP => 'APP1',
  64. ICC_Profile => 'APP2',
  65. FlashPix => 'APP2',
  66. MPF => 'APP2',
  67. Meta => 'APP3',
  68. MetaIFD => 'Meta',
  69. RMETA => 'APP5',
  70. Ducky => 'APP12',
  71. Photoshop => 'APP13',
  72. Adobe => 'APP14',
  73. IPTC => 'Photoshop',
  74. MakerNotes => ['ExifIFD', 'CIFF'], # (first parent is the default)
  75. CanonVRD => 'MakerNotes', # (so VRDOffset will get updated)
  76. NikonCapture => 'MakerNotes', # (to allow delete by group)
  77. Comment => 'COM',
  78. );
  79. my %dirMap = (
  80. JPEG => \%jpegMap,
  81. EXV => \%jpegMap,
  82. TIFF => \%tiffMap,
  83. ORF => \%tiffMap,
  84. RAW => \%tiffMap,
  85. EXIF => \%exifMap,
  86. );
  87. # groups we are allowed to delete
  88. # Notes:
  89. # 1) these names must either exist in %dirMap, or be translated in InitWriteDirs())
  90. # 2) any dependencies must be added to %excludeGroups
  91. my @delGroups = qw(
  92. Adobe AFCP APP0 APP1 APP2 APP3 APP4 APP5 APP6 APP7 APP8 APP9 APP10 APP11 APP12
  93. APP13 APP14 APP15 CanonVRD CIFF Ducky EXIF ExifIFD File FlashPix FotoStation
  94. GlobParamIFD GPS ICC_Profile IFD0 IFD1 InteropIFD IPTC JFIF Jpeg2000 MakerNotes
  95. Meta MetaIFD MIE MPF NikonCapture PDF PDF-update PhotoMechanic Photoshop PNG
  96. PNG-pHYs PrintIM RMETA RSRC SubIFD Trailer XML XML-* XMP XMP-*
  97. );
  98. # family 2 group names that we can delete
  99. my @delGroup2 = qw(
  100. Audio Author Camera Document ExifTool Image Location Other Preview Printing
  101. Time Video
  102. );
  103. # lookup for all valid family 2 groups (lower case)
  104. my %family2groups = map { lc $_ => 1 } @delGroup2, 'Unknown';
  105. # groups we don't delete when deleting all information
  106. my $protectedGroups = '(IFD1|SubIFD|InteropIFD|GlobParamIFD|PDF-update|Adobe)';
  107. # other group names of new tag values to remove when deleting an entire group
  108. my %removeGroups = (
  109. IFD0 => [ 'EXIF', 'MakerNotes' ],
  110. EXIF => [ 'MakerNotes' ],
  111. ExifIFD => [ 'MakerNotes', 'InteropIFD' ],
  112. Trailer => [ 'CanonVRD' ], #(because we can add back CanonVRD as a block)
  113. );
  114. # related family 0/1 groups in @delGroups (and not already in %jpegMap)
  115. # that must be removed from delete list when excluding a group
  116. my %excludeGroups = (
  117. EXIF => [ qw(IFD0 IFD1 ExifIFD GPS MakerNotes GlobParamIFD InteropIFD PrintIM SubIFD) ],
  118. IFD0 => [ 'EXIF' ],
  119. IFD1 => [ 'EXIF' ],
  120. ExifIFD => [ 'EXIF' ],
  121. GPS => [ 'EXIF' ],
  122. MakerNotes => [ 'EXIF' ],
  123. InteropIFD => [ 'EXIF' ],
  124. GlobParamIFD => [ 'EXIF' ],
  125. PrintIM => [ 'EXIF' ],
  126. CIFF => [ 'MakerNotes' ],
  127. # technically correct, but very uncommon and not a good reason to avoid deleting trailer
  128. # IPTC => [ qw(AFCP FotoStation Trailer) ],
  129. AFCP => [ 'Trailer' ],
  130. FotoStation => [ 'Trailer' ],
  131. CanonVRD => [ 'Trailer' ],
  132. PhotoMechanic=> [ 'Trailer' ],
  133. MIE => [ 'Trailer' ],
  134. );
  135. # translate (lower case) wanted group when writing for tags where group name may change
  136. my %translateWantGroup = (
  137. ciff => 'canonraw',
  138. );
  139. # group names to translate for writing
  140. my %translateWriteGroup = (
  141. EXIF => 'ExifIFD',
  142. Meta => 'MetaIFD',
  143. File => 'Comment',
  144. # any entry in this table causes the write group to be set from the
  145. # tag information instead of whatever the user specified...
  146. MIE => 'MIE',
  147. APP14 => 'APP14',
  148. );
  149. # names of valid EXIF and Meta directories (lower case keys):
  150. my %exifDirs = (
  151. gps => 'GPS',
  152. exififd => 'ExifIFD',
  153. subifd => 'SubIFD',
  154. globparamifd => 'GlobParamIFD',
  155. interopifd => 'InteropIFD',
  156. makernotes => 'MakerNotes',
  157. previewifd => 'PreviewIFD', # (in MakerNotes)
  158. metaifd => 'MetaIFD', # Kodak APP3 Meta
  159. );
  160. # min/max values for integer formats
  161. my %intRange = (
  162. 'int8u' => [0, 0xff],
  163. 'int8s' => [-0x80, 0x7f],
  164. 'int16u' => [0, 0xffff],
  165. 'int16uRev' => [0, 0xffff],
  166. 'int16s' => [-0x8000, 0x7fff],
  167. 'int32u' => [0, 0xffffffff],
  168. 'int32s' => [-0x80000000, 0x7fffffff],
  169. );
  170. # lookup for file types with block-writable EXIF
  171. my %blockExifTypes = map { $_ => 1 } qw(JPEG PNG JP2 MIE EXIF);
  172. my $maxSegmentLen = 0xfffd; # maximum length of data in a JPEG segment
  173. my $maxXMPLen = $maxSegmentLen; # maximum length of XMP data in JPEG
  174. # value separators when conversion list is used (in SetNewValue)
  175. my %listSep = ( PrintConv => '; ?', ValueConv => ' ' );
  176. # printConv hash keys to ignore when doing reverse lookup
  177. my %ignorePrintConv = map { $_ => 1 } qw(OTHER BITMASK Notes);
  178. #------------------------------------------------------------------------------
  179. # Set tag value
  180. # Inputs: 0) ExifTool object reference
  181. # 1) tag key, tag name, or '*' (optionally prefixed by group name),
  182. # or undef to reset all previous SetNewValue() calls
  183. # 2) new value (scalar, scalar ref or list ref), or undef to delete tag
  184. # 3-N) Options:
  185. # Type => PrintConv, ValueConv or Raw - specifies value type
  186. # AddValue => true to add to list of existing values instead of overwriting
  187. # DelValue => true to delete this existing value value from a list
  188. # Group => family 0 or 1 group name (case insensitive)
  189. # Replace => 0, 1 or 2 - overwrite previous new values (2=reset)
  190. # Protected => bitmask to write tags with specified protections
  191. # EditOnly => true to only edit existing tags (don't create new tag)
  192. # EditGroup => true to only edit existing groups (don't create new group)
  193. # Shift => undef, 0, +1 or -1 - shift value if possible
  194. # NoFlat => treat flattened tags as 'unsafe'
  195. # NoShortcut => true to prevent looking up shortcut tags
  196. # ProtectSaved => protect existing new values with a save count greater than this
  197. # CreateGroups => [internal use] createGroups hash ref from related tags
  198. # ListOnly => [internal use] set only list or non-list tags
  199. # SetTags => [internal use] hash ref to return tagInfo refs of set tags
  200. # Returns: number of tags set (plus error string in list context)
  201. # Notes: For tag lists (like Keywords), call repeatedly with the same tag name for
  202. # each value in the list. Internally, the new information is stored in
  203. # the following members of the $$self{NEW_VALUE}{$tagInfo} hash:
  204. # TagInfo - tag info ref
  205. # DelValue - list ref for values to delete
  206. # Value - list ref for values to add (not defined if deleting the tag)
  207. # IsCreating - must be set for the tag to be added for the standard file types,
  208. # otherwise just changed if it already exists. This may be
  209. # overridden for file types with a PREFERRED metadata type.
  210. # Set to 2 to create inidividual tags but not new groups
  211. # EditOnly - flag set if tag should never be created (regardless of file type).
  212. # If this is set, then IsCreating must be false
  213. # CreateOnly - flag set if creating only (never edit existing tag)
  214. # CreateGroups - hash of all family 0 group names where tag may be created
  215. # WriteGroup - group name where information is being written (correct case)
  216. # WantGroup - group name as specified in call to function (case insensitive)
  217. # Next - pointer to next new value hash (if more than one)
  218. # NoReplace - set for List-type tag if value was created with Replace=0
  219. # AddBefore - number of list items added by a subsequent Replace=0 call
  220. # IsNVH - Flag indicating this is a new value hash
  221. # Shift - shift value
  222. # Save - counter used by SaveNewValues()/RestoreNewValues()
  223. # MAKER_NOTE_FIXUP - pointer to fixup if necessary for a maker note value
  224. sub SetNewValue($;$$%)
  225. {
  226. local $_;
  227. my ($self, $tag, $value, %options) = @_;
  228. my ($err, $tagInfo, $family);
  229. my $verbose = $$self{OPTIONS}{Verbose};
  230. my $out = $$self{OPTIONS}{TextOut};
  231. my $protected = $options{Protected} || 0;
  232. my $listOnly = $options{ListOnly};
  233. my $setTags = $options{SetTags};
  234. my $noFlat = $options{NoFlat};
  235. my $numSet = 0;
  236. unless (defined $tag) {
  237. delete $$self{NEW_VALUE};
  238. $$self{SAVE_COUNT} = 0;
  239. $$self{DEL_GROUP} = { };
  240. return 1;
  241. }
  242. # allow value to be scalar or list reference
  243. if (ref $value) {
  244. if (ref $value eq 'ARRAY') {
  245. # value is an ARRAY so it may have more than one entry
  246. # - set values both separately and as a combined string if there are more than one
  247. if (@$value > 1) {
  248. # set all list-type tags first
  249. my $replace = $options{Replace};
  250. my $noJoin;
  251. foreach (@$value) {
  252. $noJoin = 1 if ref $_;
  253. my ($n, $e) = SetNewValue($self, $tag, $_, %options, ListOnly => 1);
  254. $err = $e if $e;
  255. $numSet += $n;
  256. delete $options{Replace}; # don't replace earlier values in list
  257. }
  258. return $numSet if $noJoin; # don't join if list contains objects
  259. # and now set only non-list tags
  260. $value = join $$self{OPTIONS}{ListSep}, @$value;
  261. $options{Replace} = $replace;
  262. $listOnly = $options{ListOnly} = 0;
  263. } else {
  264. $value = $$value[0];
  265. }
  266. } elsif (ref $value eq 'SCALAR') {
  267. $value = $$value;
  268. }
  269. }
  270. # un-escape as necessary and make sure the Perl UTF-8 flag is OFF for the value
  271. # if perl is 5.6 or greater (otherwise our byte manipulations get corrupted!!)
  272. $self->Sanitize(\$value) if defined $value and not ref $value;
  273. # set group name in options if specified
  274. ($options{Group}, $tag) = ($1, $2) if $tag =~ /(.*):(.+)/;
  275. # allow trailing '#' for ValueConv value
  276. $options{Type} = 'ValueConv' if $tag =~ s/#$//;
  277. my $convType = $options{Type} || ($$self{OPTIONS}{PrintConv} ? 'PrintConv' : 'ValueConv');
  278. my (@wantGroup, $family2);
  279. my $wantGroup = $options{Group};
  280. if ($wantGroup) {
  281. foreach (split /:/, $wantGroup) {
  282. next unless length($_) and /^(\d+)?(.*)/; # separate family number and group name
  283. my ($f, $g) = ($1, lc $2);
  284. # save group/family unless '*' or 'all'
  285. push @wantGroup, [ $f, $g ] unless $g eq '*' or $g eq 'all';
  286. if (defined $f) {
  287. $f > 2 and return 0; # only allow family 0, 1 or 2
  288. $family2 = 1 if $f == 2; # set flag indicating family 2 was used
  289. } else {
  290. $family2 = 1 if $family2groups{$g};
  291. }
  292. }
  293. undef $wantGroup unless @wantGroup;
  294. }
  295. $tag =~ s/ .*//; # convert from tag key to tag name if necessary
  296. $tag = '*' if lc($tag) eq 'all'; # use '*' instead of 'all'
  297. #
  298. # handle group delete
  299. #
  300. while ($tag eq '*' and not defined $value and not $family2 and @wantGroup < 2) {
  301. # set groups to delete
  302. my (@del, $grp);
  303. my $remove = ($options{Replace} and $options{Replace} > 1);
  304. if ($wantGroup) {
  305. @del = grep /^$wantGroup$/i, @delGroups unless $wantGroup =~ /^XM[LP]-\*$/i;
  306. # remove associated groups when excluding from mass delete
  307. if (@del and $remove) {
  308. # remove associated groups in other family
  309. push @del, @{$excludeGroups{$del[0]}} if $excludeGroups{$del[0]};
  310. # remove upstream groups according to JPEG map
  311. my $dirName = $del[0];
  312. my @dirNames;
  313. for (;;) {
  314. my $parent = $jpegMap{$dirName};
  315. if (ref $parent) {
  316. push @dirNames, @$parent;
  317. $parent = pop @dirNames;
  318. }
  319. $dirName = $parent || shift @dirNames or last;
  320. push @del, $dirName; # exclude this too
  321. }
  322. }
  323. # allow MIE groups to be deleted by number,
  324. # and allow any XMP family 1 group to be deleted
  325. push @del, uc($wantGroup) if $wantGroup =~ /^(MIE\d+|XM[LP]-[-\w]*\w)$/i;
  326. } else {
  327. # push all groups plus '*', except the protected groups
  328. push @del, (grep !/^$protectedGroups$/, @delGroups), '*';
  329. }
  330. if (@del) {
  331. ++$numSet;
  332. my @donegrps;
  333. my $delGroup = $$self{DEL_GROUP};
  334. foreach $grp (@del) {
  335. if ($remove) {
  336. my $didExcl;
  337. if ($grp =~ /^(XM[LP])(-.*)?$/) {
  338. my $x = $1;
  339. if ($grp eq $x) {
  340. # exclude all related family 1 groups too
  341. foreach (keys %$delGroup) {
  342. next unless /^(-?)$x-/;
  343. push @donegrps, $_ unless $1;
  344. delete $$delGroup{$_};
  345. }
  346. } elsif ($$delGroup{"$x-*"} and not $$delGroup{"-$grp"}) {
  347. # must also exclude XMP or XML to prevent bulk delete
  348. if ($$delGroup{$x}) {
  349. push @donegrps, $x;
  350. delete $$delGroup{$x};
  351. }
  352. # flag XMP/XML family 1 group for exclusion with leading '-'
  353. $$delGroup{"-$grp"} = 1;
  354. $didExcl = 1;
  355. }
  356. }
  357. if (exists $$delGroup{$grp}) {
  358. delete $$delGroup{$grp};
  359. } else {
  360. next unless $didExcl;
  361. }
  362. } else {
  363. $$delGroup{$grp} = 1;
  364. # add flag for XMP/XML family 1 groups if deleting all XMP
  365. if ($grp =~ /^XM[LP]$/) {
  366. $$delGroup{"$grp-*"} = 1;
  367. push @donegrps, "$grp-*";
  368. }
  369. # remove all of this group from previous new values
  370. $self->RemoveNewValuesForGroup($grp);
  371. }
  372. push @donegrps, $grp;
  373. }
  374. if ($verbose > 1 and @donegrps) {
  375. @donegrps = sort @donegrps;
  376. my $msg = $remove ? 'Excluding from deletion' : 'Deleting tags in';
  377. print $out " $msg: @donegrps\n";
  378. }
  379. } elsif (grep /^$wantGroup$/i, @delGroup2) {
  380. last; # allow tags to be deleted by group2 name
  381. } else {
  382. $err = "Not a deletable group: $wantGroup";
  383. }
  384. # all done
  385. return ($numSet, $err) if wantarray;
  386. $err and warn "$err\n";
  387. return $numSet;
  388. }
  389. # initialize write/create flags
  390. my $createOnly;
  391. my $editOnly = $options{EditOnly};
  392. my $editGroup = $options{EditGroup};
  393. my $writeMode = $$self{OPTIONS}{WriteMode};
  394. if ($writeMode ne 'wcg') {
  395. $createOnly = 1 if $writeMode !~ /w/i; # don't write existing tags
  396. if ($writeMode !~ /c/i) {
  397. return 0 if $createOnly; # nothing to do unless writing existing tags
  398. $editOnly = 1; # don't create new tags
  399. } elsif ($writeMode !~ /g/i) {
  400. $editGroup = 1; # don't create new groups
  401. }
  402. }
  403. #
  404. # get list of tags we want to set
  405. #
  406. my $origTag = $tag;
  407. my @matchingTags = FindTagInfo($tag);
  408. until (@matchingTags) {
  409. my $langCode;
  410. # allow language suffix of form "-en_CA" or "-<rfc3066>" on tag name
  411. if ($tag =~ /^([?*\w]+)-([a-z]{2})(_[a-z]{2})$/i or # MIE
  412. $tag =~ /^([?*\w]+)-([a-z]{2,3}|[xi])(-[a-z\d]{2,8}(-[a-z\d]{1,8})*)?$/i) # XMP/PNG
  413. {
  414. $tag = $1;
  415. # normalize case of language codes
  416. $langCode = lc($2);
  417. $langCode .= (length($3) == 3 ? uc($3) : lc($3)) if $3;
  418. my @newMatches = FindTagInfo($tag);
  419. foreach $tagInfo (@newMatches) {
  420. # only allow language codes in tables which support them
  421. next unless $$tagInfo{Table};
  422. my $langInfoProc = $$tagInfo{Table}{LANG_INFO} or next;
  423. my $langInfo = &$langInfoProc($tagInfo, $langCode);
  424. push @matchingTags, $langInfo if $langInfo;
  425. }
  426. last if @matchingTags;
  427. } elsif (not $options{NoShortcut}) {
  428. # look for a shortcut or alias
  429. require Image::ExifTool::Shortcuts;
  430. my ($match) = grep /^\Q$tag\E$/i, keys %Image::ExifTool::Shortcuts::Main;
  431. undef $err;
  432. if ($match) {
  433. $options{NoShortcut} = 1;
  434. foreach $tag (@{$Image::ExifTool::Shortcuts::Main{$match}}) {
  435. my ($n, $e) = $self->SetNewValue($tag, $value, %options);
  436. $numSet += $n;
  437. $e and $err = $e;
  438. }
  439. undef $err if $numSet; # no error if any set successfully
  440. return ($numSet, $err) if wantarray;
  441. $err and warn "$err\n";
  442. return $numSet;
  443. }
  444. }
  445. unless ($listOnly) {
  446. if (not TagExists($tag)) {
  447. $err = "Tag '$origTag' does not exist";
  448. $err .= ' or has a bad language code' if $origTag =~ /-/;
  449. } elsif ($langCode) {
  450. $err = "Tag '$tag' does not support alternate languages";
  451. } elsif ($wantGroup) {
  452. $err = "Sorry, $wantGroup:$origTag doesn't exist or isn't writable";
  453. } else {
  454. $err = "Sorry, $origTag is not writable";
  455. }
  456. $verbose > 2 and print $out "$err\n";
  457. }
  458. # all done
  459. return ($numSet, $err) if wantarray;
  460. $err and warn "$err\n";
  461. return $numSet;
  462. }
  463. # get group name that we're looking for
  464. my $foundMatch = 0;
  465. my ($ifdName, $mieGroup, $movGroup, $fg);
  466. # set family 1 group names
  467. foreach $fg (@wantGroup) {
  468. next if $$fg[0] and $$fg[0] != 1;
  469. $_ = $$fg[1];
  470. # set $ifdName if this group is a valid IFD or SubIFD name
  471. if (/^IFD(\d+)$/i) {
  472. $ifdName = "IFD$1";
  473. } elsif (/^SubIFD(\d+)$/i) {
  474. $ifdName = "SubIFD$1";
  475. } elsif (/^Version(\d+)$/i) {
  476. $ifdName = "Version$1"; # Sony IDC VersionIFD
  477. } elsif (/^Track(\d+)$/i) {
  478. $movGroup = "Track$1"; # QuickTime track
  479. } elsif (/^MIE(\d*-?)(\w+)$/i) {
  480. $mieGroup = "MIE$1" . ucfirst(lc($2));
  481. } else {
  482. $ifdName = $exifDirs{$_} if $exifDirs{$_};
  483. if (not $ifdName and /^XMP\b/i) {
  484. # must load XMP table to set group1 names
  485. my $table = GetTagTable('Image::ExifTool::XMP::Main');
  486. my $writeProc = $$table{WRITE_PROC};
  487. $writeProc and &$writeProc();
  488. }
  489. }
  490. }
  491. #
  492. # determine the groups for all tags found, and the tag with
  493. # the highest priority group
  494. #
  495. my (@tagInfoList, @writeAlsoList, %writeGroup, %preferred, %tagPriority);
  496. my (%avoid, $wasProtected, $noCreate, %highestPriority);
  497. TAG: foreach $tagInfo (@matchingTags) {
  498. $tag = $$tagInfo{Name}; # get tag name for warnings
  499. my $lcTag = lc $tag; # get lower-case tag name for use in variables
  500. # initialize highest priority if we are starting a new tag
  501. $highestPriority{$lcTag} = -999 unless defined $highestPriority{$lcTag};
  502. my ($priority, $writeGroup);
  503. if ($wantGroup) {
  504. my @grp = $self->GetGroup($tagInfo);
  505. foreach $fg (@wantGroup) {
  506. my ($fam, $lcWant) = @$fg;
  507. $lcWant = $translateWantGroup{$lcWant} if $translateWantGroup{$lcWant};
  508. # only set tag in specified group
  509. if (not defined $fam) {
  510. next if $lcWant eq lc $grp[0] or $lcWant eq lc $grp[2];
  511. } elsif ($fam != 1 and not $$tagInfo{AllowGroup}) {
  512. next if $lcWant eq lc $grp[$fam];
  513. next TAG; # wrong group
  514. }
  515. # handle family 1 groups specially
  516. if ($grp[0] eq 'EXIF' or $grp[0] eq 'SonyIDC') {
  517. next TAG unless $ifdName and $lcWant eq lc($ifdName);
  518. # can't yet write PreviewIFD tags
  519. $ifdName eq 'PreviewIFD' and ++$foundMatch, next TAG;
  520. $writeGroup = $ifdName; # write to the specified IFD
  521. } elsif ($grp[0] eq 'QuickTime' and $grp[1] eq 'Track#') {
  522. next TAG unless $movGroup and $lcWant eq lc($movGroup);
  523. $writeGroup = $movGroup;
  524. } elsif ($grp[0] eq 'MIE') {
  525. next TAG unless $mieGroup and $lcWant eq lc($mieGroup);
  526. $writeGroup = $mieGroup; # write to specific MIE group
  527. # set specific write group with document number if specified
  528. if ($writeGroup =~ /^MIE\d+$/ and $$tagInfo{Table}{WRITE_GROUP}) {
  529. $writeGroup = $$tagInfo{Table}{WRITE_GROUP};
  530. $writeGroup =~ s/^MIE/$mieGroup/;
  531. }
  532. } elsif (not $$tagInfo{AllowGroup} or $lcWant !~ /^$$tagInfo{AllowGroup}$/i) {
  533. # allow group1 name to be specified
  534. next TAG unless $lcWant eq lc $grp[1];
  535. }
  536. }
  537. $writeGroup or $writeGroup = $grp[0];
  538. $priority = 1000; # highest priority since group was specified
  539. }
  540. ++$foundMatch;
  541. # must do a dummy call to the write proc to autoload write package
  542. # before checking Writable flag
  543. my $table = $$tagInfo{Table};
  544. my $writeProc = $$table{WRITE_PROC};
  545. # load source table if this was a user-defined table
  546. if ($$table{SRC_TABLE}) {
  547. my $src = GetTagTable($$table{SRC_TABLE});
  548. $writeProc = $$src{WRITE_PROC} unless $writeProc;
  549. }
  550. next unless $writeProc and &$writeProc();
  551. # must still check writable flags in case of UserDefined tags
  552. my $writable = $$tagInfo{Writable};
  553. next unless $writable or ($$table{WRITABLE} and
  554. not defined $writable and not $$tagInfo{SubDirectory});
  555. # set specific write group (if we didn't already)
  556. if (not $writeGroup or $translateWriteGroup{$writeGroup}) {
  557. # use default write group
  558. $writeGroup = $$tagInfo{WriteGroup} || $$tagInfo{Table}{WRITE_GROUP};
  559. # use group 0 name if no WriteGroup specified
  560. my $group0 = $self->GetGroup($tagInfo, 0);
  561. $writeGroup or $writeGroup = $group0;
  562. # get priority for this group
  563. unless ($priority) {
  564. $priority = $$self{WRITE_PRIORITY}{lc($writeGroup)};
  565. unless ($priority) {
  566. $priority = $$self{WRITE_PRIORITY}{lc($group0)} || 0;
  567. }
  568. }
  569. }
  570. # don't write tag if protected
  571. my $prot = $$tagInfo{Protected};
  572. $prot = 1 if $noFlat and defined $$tagInfo{Flat};
  573. if ($prot) {
  574. $prot &= ~$protected;
  575. if ($prot) {
  576. my %lkup = ( 1=>'unsafe', 2=>'protected', 3=>'unsafe and protected');
  577. $wasProtected = $lkup{$prot};
  578. if ($verbose > 1) {
  579. my $wgrp1 = $self->GetWriteGroup1($tagInfo, $writeGroup);
  580. print $out "Sorry, $wgrp1:$tag is $wasProtected for writing\n";
  581. }
  582. next;
  583. }
  584. }
  585. # set priority for this tag
  586. $tagPriority{$tagInfo} = $priority;
  587. if ($priority > $highestPriority{$lcTag}) {
  588. $highestPriority{$lcTag} = $priority;
  589. $preferred{$lcTag} = { $tagInfo => 1 };
  590. $avoid{$lcTag} = $$tagInfo{Avoid} ? 1 : 0;
  591. } elsif ($priority == $highestPriority{$lcTag}) {
  592. # create all tags with highest priority
  593. $preferred{$lcTag}{$tagInfo} = 1;
  594. ++$avoid{$lcTag} if $$tagInfo{Avoid};
  595. }
  596. if ($$tagInfo{WriteAlso}) {
  597. # store WriteAlso tags separately so we can set them first
  598. push @writeAlsoList, $tagInfo;
  599. } else {
  600. push @tagInfoList, $tagInfo;
  601. }
  602. $writeGroup{$tagInfo} = $writeGroup;
  603. }
  604. # sort tag info list in reverse order of priority (higest number last)
  605. # so we get the highest priority error message in the end
  606. @tagInfoList = sort { $tagPriority{$a} <=> $tagPriority{$b} } @tagInfoList;
  607. # must write any tags which also write other tags first
  608. unshift @tagInfoList, @writeAlsoList if @writeAlsoList;
  609. # check priorities for each set of tags we are writing
  610. my $lcTag;
  611. foreach $lcTag (keys %preferred) {
  612. # don't create tags with priority 0 if group priorities are set
  613. if ($preferred{$lcTag} and $highestPriority{$lcTag} == 0 and
  614. %{$$self{WRITE_PRIORITY}})
  615. {
  616. delete $preferred{$lcTag}
  617. }
  618. # avoid creating tags with 'Avoid' flag set if there are other alternatives
  619. if ($avoid{$lcTag} and $preferred{$lcTag}) {
  620. if ($avoid{$lcTag} < scalar(keys %{$preferred{$lcTag}})) {
  621. # just remove the 'Avoid' tags since there are other preferred tags
  622. foreach $tagInfo (@tagInfoList) {
  623. next unless $lcTag eq lc $$tagInfo{Name};
  624. delete $preferred{$lcTag}{$tagInfo} if $$tagInfo{Avoid};
  625. }
  626. } elsif ($highestPriority{$lcTag} < 1000) {
  627. # look for another priority tag to create instead
  628. my $nextHighest = 0;
  629. my @nextBestTags;
  630. foreach $tagInfo (@tagInfoList) {
  631. next unless $lcTag eq lc $$tagInfo{Name};
  632. my $priority = $tagPriority{$tagInfo} or next;
  633. next if $priority == $highestPriority{$lcTag};
  634. next if $priority < $nextHighest;
  635. next if $$tagInfo{Avoid} or $$tagInfo{Permanent};
  636. next if $writeGroup{$tagInfo} eq 'MakerNotes';
  637. if ($nextHighest < $priority) {
  638. $nextHighest = $priority;
  639. undef @nextBestTags;
  640. }
  641. push @nextBestTags, $tagInfo;
  642. }
  643. if (@nextBestTags) {
  644. # change our preferred tags to the next best tags
  645. delete $preferred{$lcTag};
  646. foreach $tagInfo (@nextBestTags) {
  647. $preferred{$lcTag}{$tagInfo} = 1;
  648. }
  649. }
  650. }
  651. }
  652. }
  653. #
  654. # generate new value hash for each tag
  655. #
  656. my ($prioritySet, $createGroups, %alsoWrote);
  657. delete $$self{CHECK_WARN}; # reset CHECK_PROC warnings
  658. # loop through all valid tags to find the one(s) to write
  659. foreach $tagInfo (@tagInfoList) {
  660. next if $alsoWrote{$tagInfo}; # don't rewrite tags we already wrote
  661. # only process List or non-List tags if specified
  662. next if defined $listOnly and ($listOnly xor $$tagInfo{List});
  663. my $noConv;
  664. my $writeGroup = $writeGroup{$tagInfo};
  665. my $permanent = $$tagInfo{Permanent};
  666. $writeGroup eq 'MakerNotes' and $permanent = 1 unless defined $permanent;
  667. my $wgrp1 = $self->GetWriteGroup1($tagInfo, $writeGroup);
  668. $tag = $$tagInfo{Name}; # get tag name for warnings
  669. my $pref = $preferred{lc $tag} || { };
  670. my $shift = $options{Shift};
  671. my $addValue = $options{AddValue};
  672. if (defined $shift) {
  673. # (can't currently shift list-type tags)
  674. if (not $$tagInfo{List}) {
  675. unless ($shift) {
  676. # set shift according to AddValue/DelValue
  677. $shift = 1 if $addValue;
  678. if ($options{DelValue}) {
  679. # can shift a date/time with -=, but this is
  680. # a conditional delete operation for other tags
  681. $shift = -1 if $$tagInfo{Shift} and $$tagInfo{Shift} eq 'Time';
  682. }
  683. }
  684. if ($shift and (not defined $value or not length $value)) {
  685. # (now allow -= to be used for shiftable tag - v8.05)
  686. #$err = "No value for time shift of $wgrp1:$tag";
  687. #$verbose > 2 and print $out "$err\n";
  688. #next;
  689. undef $shift;
  690. }
  691. } elsif ($shift) {
  692. $err = "$wgrp1:$tag is not shiftable";
  693. $verbose > 2 and print $out "$err\n";
  694. next;
  695. }
  696. }
  697. my $val = $value;
  698. if (defined $val) {
  699. # check to make sure this is a List or Shift tag if adding
  700. if ($addValue and not ($shift or $$tagInfo{List})) {
  701. if ($addValue eq '2') {
  702. undef $addValue; # quitely reset this option
  703. } else {
  704. $err = "Can't add $wgrp1:$tag (not a List type)";
  705. $verbose > 2 and print $out "$err\n";
  706. next;
  707. }
  708. }
  709. if ($shift) {
  710. if ($$tagInfo{Shift} and $$tagInfo{Shift} eq 'Time') {
  711. # add '+' or '-' prefix to indicate shift direction
  712. $val = ($shift > 0 ? '+' : '-') . $val;
  713. # check the shift for validity
  714. require 'Image/ExifTool/Shift.pl';
  715. my $err2 = CheckShift($$tagInfo{Shift}, $val);
  716. if ($err2) {
  717. $err = "$err2 for $wgrp1:$tag";
  718. $verbose > 2 and print $out "$err\n";
  719. next;
  720. }
  721. } elsif (IsFloat($val)) {
  722. $val *= $shift;
  723. } else {
  724. $err = "Shift value for $wgrp1:$tag is not a number";
  725. $verbose > 2 and print $out "$err\n";
  726. next;
  727. }
  728. $noConv = 1; # no conversions if shifting tag
  729. } elsif (not length $val and $options{DelValue}) {
  730. $noConv = 1; # no conversions for deleting empty value
  731. } elsif (ref $val eq 'HASH' and not $$tagInfo{Struct}) {
  732. $err = "Can't write a structure to $wgrp1:$tag";
  733. $verbose > 2 and print $out "$err\n";
  734. next;
  735. }
  736. } elsif ($permanent) {
  737. # can't delete permanent tags, so set them to DelValue or empty string instead
  738. if (defined $$tagInfo{DelValue}) {
  739. $val = $$tagInfo{DelValue};
  740. $noConv = 1; # DelValue is the raw value, so no conversion necessary
  741. } else {
  742. $val = '';
  743. }
  744. } elsif ($addValue or $options{DelValue}) {
  745. $err = "No value to add or delete in $wgrp1:$tag";
  746. $verbose > 2 and print $out "$err\n";
  747. next;
  748. } else {
  749. if ($$tagInfo{DelCheck}) {
  750. #### eval DelCheck ($self, $tagInfo, $wantGroup)
  751. my $err2 = eval $$tagInfo{DelCheck};
  752. $@ and warn($@), $err2 = 'Error evaluating DelCheck';
  753. if (defined $err2) {
  754. # (allow other tags to be set using DelCheck as a hook)
  755. $err2 or goto WriteAlso; # GOTO!
  756. $err2 .= ' for' unless $err2 =~ /delete$/;
  757. $err = "$err2 $wgrp1:$tag";
  758. $verbose > 2 and print $out "$err\n";
  759. next;
  760. }
  761. }
  762. $noConv = 1; # value is not defined, so don't do conversion
  763. }
  764. # apply inverse PrintConv and ValueConv conversions
  765. # save ValueConv setting for use in ConvInv()
  766. unless ($noConv) {
  767. # set default conversion type used by ConvInv() and CHECK_PROC routines
  768. $$self{ConvType} = $convType;
  769. my $e;
  770. ($val,$e) = $self->ConvInv($val,$tagInfo,$tag,$wgrp1,$$self{ConvType},$wantGroup);
  771. if (defined $e) {
  772. # empty error string causes error to be ignored without setting the value
  773. $e or goto WriteAlso; # GOTO!
  774. $err = $e;
  775. }
  776. }
  777. if (not defined $val and defined $value) {
  778. # if value conversion failed, we must still add a NEW_VALUE
  779. # entry for this tag it it was a DelValue
  780. next unless $options{DelValue};
  781. $val = 'xxx never delete xxx';
  782. }
  783. $$self{NEW_VALUE} or $$self{NEW_VALUE} = { };
  784. if ($options{Replace}) {
  785. # delete the previous new value
  786. $self->GetNewValueHash($tagInfo, $writeGroup, 'delete', $options{ProtectSaved});
  787. # also delete related tag previous new values
  788. if ($$tagInfo{WriteAlso}) {
  789. my $wtag;
  790. foreach $wtag (keys %{$$tagInfo{WriteAlso}}) {
  791. my ($n,$e) = $self->SetNewValue($wtag, undef, Replace=>2);
  792. $numSet += $n;
  793. }
  794. }
  795. $options{Replace} == 2 and ++$numSet, next;
  796. }
  797. if (defined $val) {
  798. # we are editing this tag, so create a NEW_VALUE hash entry
  799. my $nvHash = $self->GetNewValueHash($tagInfo, $writeGroup, 'create', $options{ProtectSaved});
  800. # ignore new values protected with ProtectSaved
  801. $nvHash or ++$numSet, next; # (increment $numSet to avoid warning)
  802. $$nvHash{NoReplace} = 1 if $$tagInfo{List} and not $options{Replace};
  803. $$nvHash{WantGroup} = $wantGroup;
  804. $$nvHash{EditOnly} = 1 if $editOnly;
  805. # save maker note information if writing maker notes
  806. if ($$tagInfo{MakerNotes}) {
  807. $$nvHash{MAKER_NOTE_FIXUP} = $$self{MAKER_NOTE_FIXUP};
  808. }
  809. if ($createOnly) { # create only (never edit)
  810. # empty item in DelValue list to never edit existing value
  811. $$nvHash{DelValue} = [ '' ];
  812. $$nvHash{CreateOnly} = 1;
  813. } elsif ($options{DelValue} or $addValue or $shift) {
  814. # flag any AddValue or DelValue by creating the DelValue list
  815. $$nvHash{DelValue} or $$nvHash{DelValue} = [ ];
  816. if ($shift) {
  817. # add shift value to list
  818. $$nvHash{Shift} = $val;
  819. } elsif ($options{DelValue}) {
  820. # don't create if we are replacing a specific value
  821. $$nvHash{IsCreating} = 0 unless $val eq '' or $$tagInfo{List};
  822. # add delete value to list
  823. push @{$$nvHash{DelValue}}, ref $val eq 'ARRAY' ? @$val : $val;
  824. if ($verbose > 1) {
  825. my $verb = $permanent ? 'Replacing' : 'Deleting';
  826. my $fromList = $$tagInfo{List} ? ' from list' : '';
  827. my @vals = (ref $val eq 'ARRAY' ? @$val : $val);
  828. foreach (@vals) {
  829. if (ref $_ eq 'HASH') {
  830. require 'Image/ExifTool/XMPStruct.pl';
  831. $_ = Image::ExifTool::XMP::SerializeStruct($_);
  832. }
  833. print $out "$verb $wgrp1:$tag$fromList if value is '$_'\n";
  834. }
  835. }
  836. }
  837. }
  838. # set priority flag to add only the high priority info
  839. # (will only create the priority tag if it doesn't exist,
  840. # others get changed only if they already exist)
  841. if ($$pref{$tagInfo} or $$tagInfo{Table}{PREFERRED}) {
  842. if ($permanent or $shift) {
  843. # don't create permanent or Shift-ed tag but define IsCreating
  844. # so we know that it is the preferred tag
  845. $$nvHash{IsCreating} = 0;
  846. } elsif (($$tagInfo{List} and not $options{DelValue}) or
  847. not ($$nvHash{DelValue} and @{$$nvHash{DelValue}}) or
  848. # also create tag if any DelValue value is empty ('')
  849. grep(/^$/,@{$$nvHash{DelValue}}))
  850. {
  851. $$nvHash{IsCreating} = $editOnly ? 0 : ($editGroup ? 2 : 1);
  852. # add to hash of groups where this tag is being created
  853. $createGroups or $createGroups = $options{CreateGroups} || { };
  854. $$createGroups{$self->GetGroup($tagInfo, 0)} = 1;
  855. $$nvHash{CreateGroups} = $createGroups;
  856. }
  857. }
  858. if ($$nvHash{IsCreating}) {
  859. if (%{$$self{DEL_GROUP}}) {
  860. my ($grp, @grps);
  861. foreach $grp (keys %{$$self{DEL_GROUP}}) {
  862. next if $$self{DEL_GROUP}{$grp} == 2;
  863. # set flag indicating tags were written after this group was deleted
  864. $$self{DEL_GROUP}{$grp} = 2;
  865. push @grps, $grp;
  866. }
  867. if ($verbose > 1 and @grps) {
  868. @grps = sort @grps;
  869. print $out " Writing new tags after deleting groups: @grps\n";
  870. }
  871. }
  872. } elsif ($createOnly) {
  873. $noCreate = $permanent ? 'permanent' : ($$tagInfo{Avoid} ? 'avoided' : '');
  874. $noCreate or $noCreate = $shift ? 'shifting' : 'not preferred';
  875. $verbose > 2 and print $out "Not creating $wgrp1:$tag ($noCreate)\n";
  876. next; # nothing to do (not creating and not editing)
  877. }
  878. if ($shift or not $options{DelValue}) {
  879. $$nvHash{Value} or $$nvHash{Value} = [ ];
  880. if (not $$tagInfo{List}) {
  881. # not a List tag -- overwrite existing value
  882. $$nvHash{Value}[0] = $val;
  883. } elsif (defined $$nvHash{AddBefore} and @{$$nvHash{Value}} >= $$nvHash{AddBefore}) {
  884. # values from a later argument have been added (ie. Replace=0)
  885. # to this list, so the new values should come before these
  886. splice @{$$nvHash{Value}}, -$$nvHash{AddBefore}, 0, ref $val eq 'ARRAY' ? @$val : $val;
  887. } else {
  888. # add at end of existing list
  889. push @{$$nvHash{Value}}, ref $val eq 'ARRAY' ? @$val : $val;
  890. }
  891. if ($verbose > 1) {
  892. my $ifExists = $$nvHash{IsCreating} ? ( $createOnly ?
  893. ($$nvHash{IsCreating} == 2 ?
  894. " if $writeGroup exists and tag doesn't" :
  895. " if tag doesn't exist") :
  896. ($$nvHash{IsCreating} == 2 ? " if $writeGroup exists" : '')) :
  897. (($$nvHash{DelValue} and @{$$nvHash{DelValue}}) ?
  898. ' if tag was deleted' : ' if tag exists');
  899. my $verb = ($shift ? 'Shifting' : ($addValue ? 'Adding' : 'Writing'));
  900. print $out "$verb $wgrp1:$tag$ifExists\n";
  901. }
  902. }
  903. } elsif ($permanent) {
  904. $err = "Can't delete Permanent tag $wgrp1:$tag";
  905. $verbose > 1 and print $out "$err\n";
  906. next;
  907. } elsif ($addValue or $options{DelValue}) {
  908. $verbose > 1 and print $out "Adding/Deleting nothing does nothing\n";
  909. next;
  910. } else {
  911. # create empty new value hash entry to delete this tag
  912. $self->GetNewValueHash($tagInfo, $writeGroup, 'delete');
  913. my $nvHash = $self->GetNewValueHash($tagInfo, $writeGroup, 'create');
  914. $$nvHash{WantGroup} = $wantGroup;
  915. $verbose > 1 and print $out "Deleting $wgrp1:$tag\n";
  916. }
  917. $$setTags{$tagInfo} = 1 if $setTags;
  918. $prioritySet = 1 if $$pref{$tagInfo};
  919. WriteAlso:
  920. ++$numSet;
  921. # also write related tags
  922. my $writeAlso = $$tagInfo{WriteAlso};
  923. if ($writeAlso) {
  924. my ($wtag, $n);
  925. local $SIG{'__WARN__'} = \&SetWarning;
  926. foreach $wtag (keys %$writeAlso) {
  927. my %opts = (
  928. Type => 'ValueConv',
  929. Protected => $protected | 0x02,
  930. AddValue => $addValue,
  931. DelValue => $options{DelValue},
  932. Replace => $options{Replace}, # handle lists properly
  933. CreateGroups => $createGroups,
  934. SetTags => \%alsoWrote, # remember tags already written
  935. );
  936. undef $evalWarning;
  937. #### eval WriteAlso ($val)
  938. my $v = eval $$writeAlso{$wtag};
  939. $@ and $evalWarning = $@;
  940. unless ($evalWarning) {
  941. ($n,$evalWarning) = $self->SetNewValue($wtag, $v, %opts);
  942. $numSet += $n;
  943. # count this as being set if any related tag is set
  944. $prioritySet = 1 if $n and $$pref{$tagInfo};
  945. }
  946. if ($evalWarning and (not $err or $verbose > 2)) {
  947. my $str = CleanWarning();
  948. if ($str) {
  949. $str .= " for $wtag" unless $str =~ / for [-\w:]+$/;
  950. $str .= " in $wgrp1:$tag (WriteAlso)";
  951. $err or $err = $str;
  952. print $out "$str\n" if $verbose > 2;
  953. }
  954. }
  955. }
  956. }
  957. }
  958. # print warning if we couldn't set our priority tag
  959. if (defined $err and not $prioritySet) {
  960. warn "$err\n" if $err and not wantarray;
  961. } elsif (not $numSet) {
  962. my $pre = $wantGroup ? ($ifdName || $wantGroup) . ':' : '';
  963. if ($wasProtected) {
  964. $verbose = 0; # we already printed this verbose message
  965. unless ($options{Replace} and $options{Replace} == 2) {
  966. $err = "Sorry, $pre$tag is $wasProtected for writing";
  967. }
  968. } elsif (not $listOnly) {
  969. if ($origTag =~ /[?*]/) {
  970. if ($noCreate) {
  971. $err = "No tags matching 'pre$origTag' will be created";
  972. $verbose = 0; # (already printed)
  973. } elsif ($foundMatch) {
  974. $err = "Sorry, no writable tags matching '$pre$origTag'";
  975. } else {
  976. $err = "No matching tags for '$pre$origTag'";
  977. }
  978. } elsif ($noCreate) {
  979. $err = "Not creating $pre$tag";
  980. $verbose = 0; # (already printed)
  981. } elsif ($foundMatch) {
  982. $err = "Sorry, $pre$tag is not writable";
  983. } else {
  984. $err = "Tag '$pre$tag' does not exist";
  985. }
  986. }
  987. if ($err) {
  988. $verbose > 2 and print $out "$err\n";
  989. warn "$err\n" unless wantarray;
  990. }
  991. } elsif ($$self{CHECK_WARN}) {
  992. $err = $$self{CHECK_WARN};
  993. $verbose > 2 and print $out "$err\n";
  994. } elsif ($err and not $verbose) {
  995. undef $err;
  996. }
  997. return ($numSet, $err) if wantarray;
  998. return $numSet;
  999. }
  1000. #------------------------------------------------------------------------------
  1001. # set new values from information in specified file
  1002. # Inputs: 0) ExifTool object reference, 1) source file name or reference, etc
  1003. # 2-N) List of tags to set (or all if none specified), or reference(s) to
  1004. # hash for options to pass to SetNewValue. The Replace option defaults
  1005. # to 1 for SetNewValuesFromFile -- set this to 0 to allow multiple tags
  1006. # to be copied to a list
  1007. # Returns: Hash of information set successfully (includes Warning or Error messages)
  1008. # Notes: Tag names may contain a group prefix, a leading '-' to exclude from copy,
  1009. # and/or a trailing '#' to copy the ValueConv value. The tag name '*' may
  1010. # be used to represent all tags in a group. An optional destination tag
  1011. # may be specified with '>DSTTAG' ('DSTTAG<TAG' also works, but in this
  1012. # case the source tag may also be an expression involving tag names).
  1013. sub SetNewValuesFromFile($$;@)
  1014. {
  1015. local $_;
  1016. my ($self, $srcFile, @setTags) = @_;
  1017. my ($key, $tag, @exclude, @reqTags);
  1018. # get initial SetNewValuesFromFile options
  1019. my %opts = ( Replace => 1 ); # replace existing list items by default
  1020. while (ref $setTags[0] eq 'HASH') {
  1021. $_ = shift @setTags;
  1022. foreach $key (keys %$_) {
  1023. $opts{$key} = $$_{$key};
  1024. }
  1025. }
  1026. # expand shortcuts
  1027. @setTags and ExpandShortcuts(\@setTags);
  1028. my $srcExifTool = new Image::ExifTool;
  1029. # set flag to indicate we are being called from inside SetNewValuesFromFile()
  1030. $$srcExifTool{TAGS_FROM_FILE} = 1;
  1031. # synchronize and increment the file sequence number
  1032. $$srcExifTool{FILE_SEQUENCE} = $$self{FILE_SEQUENCE}++;
  1033. # set options for our extraction tool
  1034. my $options = $$self{OPTIONS};
  1035. # copy both structured and flattened tags by default (but flattened tags are "unsafe")
  1036. my $structOpt = defined $$options{Struct} ? $$options{Struct} : 2;
  1037. # copy structures only if no tags specified (since flattened tags are "unsafe")
  1038. $structOpt = 1 if $structOpt eq '2' and not @setTags;
  1039. # +------------------------------------------+
  1040. # ! DON'T FORGET!! Must consider each new !
  1041. # ! option to decide how it is handled here. !
  1042. # +------------------------------------------+
  1043. $srcExifTool->Options(
  1044. Binary => 1,
  1045. Charset => $$options{Charset},
  1046. CharsetEXIF => $$options{CharsetEXIF},
  1047. CharsetFileName => $$options{CharsetFileName},
  1048. CharsetID3 => $$options{CharsetID3},
  1049. CharsetIPTC => $$options{CharsetIPTC},
  1050. CharsetPhotoshop=> $$options{CharsetPhotoshop},
  1051. Composite => $$options{Composite},
  1052. CoordFormat => $$options{CoordFormat} || '%d %d %.8f', # copy coordinates at high resolution unless otherwise specified
  1053. DateFormat => $$options{DateFormat},
  1054. Duplicates => 1,
  1055. Escape => $$options{Escape},
  1056. # Exclude set below
  1057. ExtendedXMP => $$options{ExtendedXMP},
  1058. ExtractEmbedded => $$options{ExtractEmbedded},
  1059. FastScan => $$options{FastScan},
  1060. Filter => $$options{Filter},
  1061. FixBase => $$options{FixBase},
  1062. GlobalTimeShift => $$options{GlobalTimeShift},
  1063. IgnoreMinorErrors=>$$options{IgnoreMinorErrors},
  1064. Lang => $$options{Lang},
  1065. LargeFileSupport=> $$options{LargeFileSupport},
  1066. List => 1,
  1067. ListItem => $$options{ListItem},
  1068. ListSep => $$options{ListSep},
  1069. MakerNotes => $$options{FastScan} && $$options{FastScan} > 1 ? undef : 1,
  1070. MDItemTags => $$options{MDItemTags},
  1071. MissingTagValue => $$options{MissingTagValue},
  1072. NoPDFList => $$options{NoPDFList},
  1073. Password => $$options{Password},
  1074. PrintConv => $$options{PrintConv},
  1075. QuickTimeUTC => $$options{QuickTimeUTC},
  1076. RequestAll => 1, # (is this still necessary now that RequestTags are being set?)
  1077. RequestTags => $$options{RequestTags},
  1078. ScanForXMP => $$options{ScanForXMP},
  1079. StrictDate => 1,
  1080. Struct => $structOpt,
  1081. SystemTags => $$options{SystemTags},
  1082. Unknown => $$options{Unknown},
  1083. UserParam => $$options{UserParam},
  1084. XMPAutoConv => $$options{XMPAutoConv},
  1085. );
  1086. foreach $tag (@setTags) {
  1087. next if ref $tag;
  1088. if ($tag =~ /^-(.*)/) {
  1089. # avoid extracting tags that are excluded
  1090. push @exclude, $1;
  1091. next;
  1092. }
  1093. # add specified tags to list of requested tags
  1094. $_ = $tag;
  1095. if (/(.+?)\s*(>|<)\s*(.+)/) {
  1096. if ($2 eq '>') {
  1097. $_ = $1;
  1098. } else {
  1099. $_ = $3;
  1100. /\$/ and push(@reqTags, /\$\{?(?:[-\w]+:)*([-\w?*]+)/g), next;
  1101. }
  1102. }
  1103. push @reqTags, $2 if /(^|:)([-\w?*]+)#?$/;
  1104. }
  1105. if (@exclude) {
  1106. ExpandShortcuts(\@exclude, 1);
  1107. $srcExifTool->Options(Exclude => \@exclude);
  1108. }
  1109. $srcExifTool->Options(RequestTags => \@reqTags) if @reqTags;
  1110. my $printConv = $$options{PrintConv};
  1111. if ($opts{Type}) {
  1112. # save source type separately because it may be different than dst Type
  1113. $opts{SrcType} = $opts{Type};
  1114. # override PrintConv option with initial Type if given
  1115. $printConv = ($opts{Type} eq 'PrintConv' ? 1 : 0);
  1116. $srcExifTool->Options(PrintConv => $printConv);
  1117. }
  1118. my $srcType = $printConv ? 'PrintConv' : 'ValueConv';
  1119. # get all tags from source file (including MakerNotes block)
  1120. my $info = $srcExifTool->ImageInfo($srcFile);
  1121. return $info if $$info{Error} and $$info{Error} eq 'Error opening file';
  1122. delete $$srcExifTool{VALUE}{Error}; # delete so we can check this later
  1123. # sort tags in reverse order so we get priority tag last
  1124. my @tags = reverse sort keys %$info;
  1125. #
  1126. # simply transfer all tags from source image if no tags specified
  1127. #
  1128. unless (@setTags) {
  1129. # transfer maker note information to this object
  1130. $$self{MAKER_NOTE_FIXUP} = $$srcExifTool{MAKER_NOTE_FIXUP};
  1131. $$self{MAKER_NOTE_BYTE_ORDER} = $$srcExifTool{MAKER_NOTE_BYTE_ORDER};
  1132. foreach $tag (@tags) {
  1133. # don't try to set errors or warnings
  1134. next if $tag =~ /^(Error|Warning)\b/;
  1135. # get approprite value type if necessary
  1136. if ($opts{SrcType} and $opts{SrcType} ne $srcType) {
  1137. $$info{$tag} = $srcExifTool->GetValue($tag, $opts{SrcType});
  1138. }
  1139. # set value for this tag
  1140. my ($n, $e) = $self->SetNewValue($tag, $$info{$tag}, %opts);
  1141. # delete this tag if we could't set it
  1142. $n or delete $$info{$tag};
  1143. }
  1144. return $info;
  1145. }
  1146. #
  1147. # transfer specified tags in the proper order
  1148. #
  1149. # 1) loop through input list of tags to set, and build @setList
  1150. my (@setList, $set, %setMatches, $t);
  1151. foreach $t (@setTags) {
  1152. if (ref $t eq 'HASH') {
  1153. # update current options
  1154. foreach $key (keys %$t) {
  1155. $opts{$key} = $$t{$key};
  1156. }
  1157. next;
  1158. }
  1159. # make a copy of the current options for this setTag
  1160. # (also use this hash to store expression and wildcard flags, EXPR and WILD)
  1161. my $opts = { %opts };
  1162. $tag = lc $t; # change tag/group names to all lower case
  1163. my (@fg, $grp, $dst, $dstGrp, $dstTag, $isExclude);
  1164. # handle redirection to another tag
  1165. if ($tag =~ /(.+?)\s*(>|<)\s*(.+)/) {
  1166. $dstGrp = '';
  1167. my $opt;
  1168. if ($2 eq '>') {
  1169. ($tag, $dstTag) = ($1, $3);
  1170. # flag add and delete (eg. '+<' and '-<') redirections
  1171. $opt = $1 if $tag =~ s/\s*([-+])$// or $dstTag =~ s/^([-+])\s*//;
  1172. } else {
  1173. ($tag, $dstTag) = ($3, $1);
  1174. $opt = $1 if $dstTag =~ s/\s*([-+])$//;
  1175. # handle expressions
  1176. if ($tag =~ /\$/) {
  1177. $tag = $t; # restore original case
  1178. # recover leading whitespace (except for initial single space)
  1179. $tag =~ s/(.+?)\s*(>|<) ?//;
  1180. $$opts{EXPR} = 1; # flag this expression
  1181. } else {
  1182. $opt = $1 if $tag =~ s/^([-+])\s*//;
  1183. }
  1184. }
  1185. # validate tag name(s)
  1186. $$opts{EXPR} or ValidTagName($tag) or $self->Warn("Invalid tag name '$tag'"), next;
  1187. ValidTagName($dstTag) or $self->Warn("Invalid tag name '$dstTag'"), next;
  1188. # translate '+' and '-' to appropriate SetNewValue option
  1189. if ($opt) {
  1190. $$opts{{ '+' => 'AddValue', '-' => 'DelValue' }->{$opt}} = 1;
  1191. $$opts{Shift} = 0; # shift if shiftable
  1192. }
  1193. ($dstGrp, $dstTag) = ($1, $2) if $dstTag =~ /(.*):(.+)/;
  1194. # ValueConv may be specified separately on the destination with '#'
  1195. $$opts{Type} = 'ValueConv' if $dstTag =~ s/#$//;
  1196. # replace tag name of 'all' with '*'
  1197. $dstTag = '*' if $dstTag eq 'all';
  1198. }
  1199. unless ($$opts{EXPR}) {
  1200. $isExclude = ($tag =~ s/^-//);
  1201. if ($tag =~ /(.*):(.+)/) {
  1202. ($grp, $tag) = ($1, $2);
  1203. foreach (split /:/, $grp) {
  1204. # save family/groups in list (ignoring 'all' and '*')
  1205. next unless length($_) and /^(\d+)?(.*)/;
  1206. push @fg, [ $1, $2 ] unless $2 eq '*' or $2 eq 'all';
  1207. }
  1208. }
  1209. # allow ValueConv to be specified by a '#' on the tag name
  1210. if ($tag =~ s/#$//) {
  1211. $$opts{SrcType} = 'ValueConv';
  1212. $$opts{Type} = 'ValueConv' unless $dstTag;
  1213. }
  1214. # replace 'all' with '*' in tag and group names
  1215. $tag = '*' if $tag eq 'all';
  1216. # allow wildcards in tag names (handle differently from all tags: '*')
  1217. if ($tag =~ /[?*]/ and $tag ne '*') {
  1218. $$opts{WILD} = 1; # set flag indicating wildcards were used in source tag
  1219. $tag =~ s/\*/[-\\w]*/g;
  1220. $tag =~ s/\?/[-\\w]/g;
  1221. }
  1222. }
  1223. # redirect, exclude or set this tag (Note: @fg is empty if we don't care about the group)
  1224. if ($dstTag) {
  1225. # redirect this tag
  1226. $isExclude and return { Error => "Can't redirect excluded tag" };
  1227. # set destination group the same as source if necessary
  1228. # (removed in 7.72 so '-xmp:*>*:*' will preserve XMP family 1 groups)
  1229. # $dstGrp = $grp if $dstGrp eq '*' and $grp;
  1230. # write to specified destination group/tag
  1231. $dst = [ $dstGrp, $dstTag ];
  1232. } elsif ($isExclude) {
  1233. # implicitly assume '*' if first entry is an exclusion
  1234. unshift @setList, [ [ ], '*', [ '', '*' ], $opts ] unless @setList;
  1235. # exclude this tag by leaving $dst undefined
  1236. } else {
  1237. $dst = [ $grp || '', $$opts{WILD} ? '*' : $tag ]; # use same group name for dest
  1238. }
  1239. # save in reverse order so we don't set tags before an exclude
  1240. unshift @setList, [ \@fg, $tag, $dst, $opts ];
  1241. }
  1242. # 2) initialize lists of matching tags for each setTag
  1243. foreach $set (@setList) {
  1244. $$set[2] and $setMatches{$set} = [ ];
  1245. }
  1246. # 3) loop through all tags in source image and save tags matching each setTag
  1247. my %rtnInfo;
  1248. foreach $tag (@tags) {
  1249. # don't try to set errors or warnings
  1250. if ($tag =~ /^(Error|Warning)( |$)/) {
  1251. $rtnInfo{$tag} = $$info{$tag};
  1252. next;
  1253. }
  1254. # only set specified tags
  1255. my $lcTag = lc(GetTagName($tag));
  1256. my (@grp, %grp);
  1257. SET: foreach $set (@setList) {
  1258. # check first for matching tag
  1259. unless ($$set[1] eq $lcTag or $$set[1] eq '*') {
  1260. # handle wildcards
  1261. next unless $$set[3]{WILD} and $lcTag =~ /^$$set[1]$/;
  1262. }
  1263. # then check for matching group
  1264. if (@{$$set[0]}) {
  1265. # get lower case group names if not done already
  1266. unless (@grp) {
  1267. @grp = map(lc, $srcExifTool->GetGroup($tag));
  1268. $grp{$_} = 1 foreach @grp;
  1269. }
  1270. foreach (@{$$set[0]}) {
  1271. my ($f, $g) = @$_;
  1272. if (defined $f) {
  1273. next SET unless defined $grp[$f] and $g eq $grp[$f];
  1274. } else {
  1275. next SET unless $grp{$g};
  1276. }
  1277. }
  1278. }
  1279. last unless $$set[2]; # all done if we hit an exclude
  1280. # add to the list of tags matching this setTag
  1281. push @{$setMatches{$set}}, $tag;
  1282. }
  1283. }
  1284. # 4) loop through each setTag in original order, setting new tag values
  1285. foreach $set (reverse @setList) {
  1286. # get options for SetNewValue
  1287. my $opts = $$set[3];
  1288. # handle expressions
  1289. if ($$opts{EXPR}) {
  1290. my $val = $srcExifTool->InsertTagValues(\@tags, $$set[1], 'Error');
  1291. if ($$srcExifTool{VALUE}{Error}) {
  1292. # pass on any error as a warning
  1293. $tag = NextFreeTagKey(\%rtnInfo, 'Warning');
  1294. $rtnInfo{$tag} = $$srcExifTool{VALUE}{Error};
  1295. delete $$srcExifTool{VALUE}{Error};
  1296. next unless defined $val;
  1297. }
  1298. my ($dstGrp, $dstTag) = @{$$set[2]};
  1299. $$opts{Protected} = 1 unless $dstTag =~ /[?*]/ and $dstTag ne '*';
  1300. $$opts{Group} = $dstGrp if $dstGrp;
  1301. my @rtnVals = $self->SetNewValue($dstTag, $val, %$opts);
  1302. $rtnInfo{$dstTag} = $val if $rtnVals[0]; # tag was set successfully
  1303. next;
  1304. }
  1305. foreach $tag (@{$setMatches{$set}}) {
  1306. my ($val, $noWarn);
  1307. if ($$opts{SrcType} and $$opts{SrcType} ne $srcType) {
  1308. $val = $srcExifTool->GetValue($tag, $$opts{SrcType});
  1309. } else {
  1310. $val = $$info{$tag};
  1311. }
  1312. my ($dstGrp, $dstTag) = @{$$set[2]};
  1313. if ($dstGrp) {
  1314. my @dstGrp = split /:/, $dstGrp;
  1315. # destination group of '*' writes to same group as source tag
  1316. # (family 1 unless otherwise specified)
  1317. foreach (@dstGrp) {
  1318. next unless /^(\d*)(all|\*)$/i;
  1319. $_ = $1 . $srcExifTool->GetGroup($tag, length $1 ? $1 : 1);
  1320. $noWarn = 1; # don't warn on wildcard destinations
  1321. }
  1322. $$opts{Group} = join ':', @dstGrp;
  1323. } else {
  1324. delete $$opts{Group};
  1325. }
  1326. # transfer maker note information if setting this tag
  1327. if ($$srcExifTool{TAG_INFO}{$tag}{MakerNotes}) {
  1328. $$self{MAKER_NOTE_FIXUP} = $$srcExifTool{MAKER_NOTE_FIXUP};
  1329. $$self{MAKER_NOTE_BYTE_ORDER} = $$srcExifTool{MAKER_NOTE_BYTE_ORDER};
  1330. }
  1331. if ($dstTag eq '*') {
  1332. $dstTag = $tag;
  1333. $noWarn = 1;
  1334. }
  1335. if ($$set[1] eq '*' or $$set[3]{WILD}) {
  1336. # don't copy from protected binary tags when using wildcards
  1337. next if $$srcExifTool{TAG_INFO}{$tag}{Protected} and
  1338. $$srcExifTool{TAG_INFO}{$tag}{Binary};
  1339. # don't copy to protected tags when using wildcards
  1340. delete $$opts{Protected};
  1341. # don't copy flattened tags if copying structures too when copying all
  1342. $$opts{NoFlat} = $structOpt eq '2' ? 1 : 0;
  1343. } else {
  1344. # allow protected tags to be copied if specified explicitly
  1345. $$opts{Protected} = 1 unless $dstTag =~ /[?*]/;
  1346. delete $$opts{NoFlat};
  1347. }
  1348. # set value(s) for this tag
  1349. my ($rtn, $wrn) = $self->SetNewValue($dstTag, $val, %$opts);
  1350. # this was added in version 9.14, and allowed actions like "-subject<all" to
  1351. # write values of multiple tags into a list, but it had the side effect of
  1352. # duplicating items if there were multiple list tags with the same name
  1353. # (eg. -use mwg "-creator<creator"), so disable this as of ExifTool 9.36:
  1354. # $$opts{Replace} = 0; # accumulate values from tags matching a single argument
  1355. if ($wrn and not $noWarn) {
  1356. # return this warning
  1357. $rtnInfo{NextFreeTagKey(\%rtnInfo, 'Warning')} = $wrn;
  1358. $noWarn = 1;
  1359. }
  1360. $rtnInfo{$tag} = $val if $rtn; # tag was set successfully
  1361. }
  1362. }
  1363. return \%rtnInfo; # return information that we set
  1364. }
  1365. #------------------------------------------------------------------------------
  1366. # Get new value(s) for tag
  1367. # Inputs: 0) ExifTool object reference, 1) tag name or tagInfo hash ref
  1368. # 2) optional pointer to return new value hash reference (not part of public API)
  1369. # or 0) ExifTool ref, 1) new value hash reference (not part of public API)
  1370. # Returns: List of new Raw values (list may be empty if tag is being deleted)
  1371. # Notes: 1) Preferentially returns new value from Extra table if writable Extra tag exists
  1372. # 2) Must call AFTER IsOverwriting() returns 1 to get proper value for shifted times
  1373. # 3) Tag name is case sensitive and may be prefixed by family 0 or 1 group name
  1374. # 4) Value may have been modified by CHECK_PROC routine after ValueConv
  1375. sub GetNewValue($$;$)
  1376. {
  1377. local $_;
  1378. my $self = shift;
  1379. my $tag = shift;
  1380. my $nvHash;
  1381. if ((ref $tag eq 'HASH' and $$tag{IsNVH}) or not defined $tag) {
  1382. $nvHash = $tag;
  1383. } else {
  1384. my $newValueHashPt = shift;
  1385. if ($$self{NEW_VALUE}) {
  1386. my ($group, $tagInfo);
  1387. if (ref $tag) {
  1388. $nvHash = $self->GetNewValueHash($tag);
  1389. } elsif (defined($tagInfo = $Image::ExifTool::Extra{$tag}) and
  1390. $$tagInfo{Writable})
  1391. {
  1392. $nvHash = $self->GetNewValueHash($tagInfo);
  1393. } else {
  1394. # separate group from tag name
  1395. $group = $1 if $tag =~ s/(.*)://;
  1396. my @tagInfoList = FindTagInfo($tag);
  1397. # decide which tag we want
  1398. GNV_TagInfo: foreach $tagInfo (@tagInfoList) {
  1399. my $nvh = $self->GetNewValueHash($tagInfo) or next;
  1400. # select tag in specified group if necessary
  1401. while ($group and $group ne $$nvh{WriteGroup}) {
  1402. my @grps = $self->GetGroup($tagInfo);
  1403. if ($grps[0] eq $$nvh{WriteGroup}) {
  1404. # check family 1 group only if WriteGroup is not specific
  1405. last if $group eq $grps[1];
  1406. } else {
  1407. # otherwise check family 0 group
  1408. last if $group eq $grps[0];
  1409. }
  1410. # step to next entry in list
  1411. $nvh = $$nvh{Next} or next GNV_TagInfo;
  1412. }
  1413. $nvHash = $nvh;
  1414. # give priority to the one we are creating
  1415. last if defined $$nvHash{IsCreating};
  1416. }
  1417. }
  1418. }
  1419. # return new value hash if requested
  1420. $newValueHashPt and $$newValueHashPt = $nvHash;
  1421. }
  1422. unless ($nvHash and $$nvHash{Value}) {
  1423. return () if wantarray; # return empty list
  1424. return undef;
  1425. }
  1426. my $vals = $$nvHash{Value};
  1427. # do inverse raw conversion if necessary
  1428. # - must also check after doing a Shift
  1429. if ($$nvHash{TagInfo}{RawConvInv} or $$nvHash{Shift}) {
  1430. my @copyVals = @$vals; # modify a copy of the values
  1431. $vals = \@copyVals;
  1432. my $tagInfo = $$nvHash{TagInfo};
  1433. my $conv = $$tagInfo{RawConvInv};
  1434. my $table = $$tagInfo{Table};
  1435. my ($val, $checkProc);
  1436. $checkProc = $$table{CHECK_PROC} if $$nvHash{Shift} and $table;
  1437. local $SIG{'__WARN__'} = \&SetWarning;
  1438. undef $evalWarning;
  1439. foreach $val (@$vals) {
  1440. # must check value now if it was shifted
  1441. if ($checkProc) {
  1442. my $err = &$checkProc($self, $tagInfo, \$val);
  1443. if ($err or not defined $val) {
  1444. $err or $err = 'Error generating raw value';
  1445. $self->WarnOnce("$err for $$tagInfo{Name}");
  1446. @$vals = ();
  1447. last;
  1448. }
  1449. next unless $conv;
  1450. } else {
  1451. last unless $conv;
  1452. }
  1453. # do inverse raw conversion
  1454. if (ref($conv) eq 'CODE') {
  1455. $val = &$conv($val, $self);
  1456. } else {
  1457. #### eval RawConvInv ($self, $val, $taginfo)
  1458. $val = eval $conv;
  1459. $@ and $evalWarning = $@;
  1460. }
  1461. if ($evalWarning) {
  1462. # an empty warning ("\n") ignores tag with no error
  1463. if ($evalWarning ne "\n") {
  1464. my $err = CleanWarning() . " in $$tagInfo{Name} (RawConvInv)";
  1465. $self->WarnOnce($err);
  1466. }
  1467. @$vals = ();
  1468. last;
  1469. }
  1470. }
  1471. }
  1472. # return our value(s)
  1473. return @$vals if wantarray;
  1474. return $$vals[0];
  1475. }
  1476. #------------------------------------------------------------------------------
  1477. # Return the total number of new values set
  1478. # Inputs: 0) ExifTool object reference
  1479. # Returns: Scalar context) Number of new values that have been set
  1480. # List context) Number of new values, number of "pseudo" values
  1481. # ("pseudo" values are those which don't require rewriting the file to change)
  1482. sub CountNewValues($)
  1483. {
  1484. my $self = shift;
  1485. my $newVal = $$self{NEW_VALUE};
  1486. my $num = 0;
  1487. my $tag;
  1488. if ($newVal) {
  1489. $num += scalar keys %$newVal;
  1490. # don't count "fake" tags (only in Extra table)
  1491. foreach $tag (qw{Geotag Geosync}) {
  1492. --$num if defined $$newVal{$Image::ExifTool::Extra{$tag}};
  1493. }
  1494. }
  1495. $num += scalar keys %{$$self{DEL_GROUP}};
  1496. return $num unless wantarray;
  1497. my $pseudo = 0;
  1498. if ($newVal) {
  1499. # (Note: all writable "pseudo" tags must be found in Extra table)
  1500. foreach $tag (qw{FileName Directory FileModifyDate FileCreateDate HardLink TestName}) {
  1501. ++$pseudo if defined $$newVal{$Image::ExifTool::Extra{$tag}};
  1502. }
  1503. }
  1504. return ($num, $pseudo);
  1505. }
  1506. #------------------------------------------------------------------------------
  1507. # Save new values for subsequent restore
  1508. # Inputs: 0) ExifTool object reference
  1509. # Returns: Number of times new values have been saved
  1510. # Notes: increments Save flag each time routine is called
  1511. sub SaveNewValues($)
  1512. {
  1513. my $self = shift;
  1514. my $newValues = $$self{NEW_VALUE};
  1515. my $saveCount = ++$$self{SAVE_COUNT};
  1516. my $key;
  1517. foreach $key (keys %$newValues) {
  1518. my $nvHash = $$newValues{$key};
  1519. while ($nvHash) {
  1520. # set Save count if not done already
  1521. $$nvHash{Save} or $$nvHash{Save} = $saveCount;
  1522. $nvHash = $$nvHash{Next};
  1523. }
  1524. }
  1525. # initialize hash for saving overwritten new values
  1526. $$self{SAVE_NEW_VALUE} = { };
  1527. # make a copy of the delete group hash
  1528. my %delGrp = %{$$self{DEL_GROUP}};
  1529. $$self{SAVE_DEL_GROUP} = \%delGrp;
  1530. return $saveCount;
  1531. }
  1532. #------------------------------------------------------------------------------
  1533. # Restore new values to last saved state
  1534. # Inputs: 0) ExifTool object reference
  1535. # Notes: Restores saved new values, but currently doesn't restore them in the
  1536. # original order, so there may be some minor side-effects when restoring tags
  1537. # with overlapping groups. eg) XMP:Identifier, XMP-dc:Identifier
  1538. sub RestoreNewValues($)
  1539. {
  1540. my $self = shift;
  1541. my $newValues = $$self{NEW_VALUE};
  1542. my $savedValues = $$self{SAVE_NEW_VALUE};
  1543. my $key;
  1544. # 1) remove any new values which don't have the Save flag set
  1545. if ($newValues) {
  1546. my @keys = keys %$newValues;
  1547. foreach $key (@keys) {
  1548. my $lastHash;
  1549. my $nvHash = $$newValues{$key};
  1550. while ($nvHash) {
  1551. if ($$nvHash{Save}) {
  1552. $lastHash = $nvHash;
  1553. } else {
  1554. # remove this entry from the list
  1555. if ($lastHash) {
  1556. $$lastHash{Next} = $$nvHash{Next};
  1557. } elsif ($$nvHash{Next}) {
  1558. $$newValues{$key} = $$nvHash{Next};
  1559. } else {
  1560. delete $$newValues{$key};
  1561. }
  1562. }
  1563. $nvHash = $$nvHash{Next};
  1564. }
  1565. }
  1566. }
  1567. # 2) restore saved new values
  1568. if ($savedValues) {
  1569. $newValues or $newValues = $$self{NEW_VALUE} = { };
  1570. foreach $key (keys %$savedValues) {
  1571. if ($$newValues{$key}) {
  1572. # add saved values to end of list
  1573. my $nvHash = LastInList($$newValues{$key});
  1574. $$nvHash{Next} = $$savedValues{$key};
  1575. } else {
  1576. $$newValues{$key} = $$savedValues{$key};
  1577. }
  1578. }
  1579. $$self{SAVE_NEW_VALUE} = { }; # reset saved new values
  1580. }
  1581. # 3) restore delete groups
  1582. my %delGrp = %{$$self{SAVE_DEL_GROUP}};
  1583. $$self{DEL_GROUP} = \%delGrp;
  1584. }
  1585. #------------------------------------------------------------------------------
  1586. # Set filesystem time from from FileModifyDate or FileCreateDate tag
  1587. # Inputs: 0) ExifTool object reference, 1) file name or file ref
  1588. # 2) time (-M or -C) of original file (used for shift; obtained from file if not given)
  1589. # 3) tag name to write (undef for 'FileModifyDate')
  1590. # 4) flag set if argument 2 has already been converted to Unix seconds
  1591. # Returns: 1=time changed OK, 0=nothing done, -1=error setting time
  1592. # (increments CHANGED flag and sets corresponding WRITTEN tag)
  1593. sub SetFileModifyDate($$;$$$)
  1594. {
  1595. my ($self, $file, $originalTime, $tag, $isUnixTime) = @_;
  1596. my $nvHash;
  1597. $tag = 'FileModifyDate' unless defined $tag;
  1598. my $val = $self->GetNewValue($tag, \$nvHash);
  1599. return 0 unless defined $val;
  1600. my $isOverwriting = $self->IsOverwriting($nvHash);
  1601. return 0 unless $isOverwriting;
  1602. # can currently only set creation date on Windows systems
  1603. return 0 if $tag eq 'FileCreateDate' and $^O ne 'MSWin32';
  1604. if ($isOverwriting < 0) { # are we shifting time?
  1605. # use original time of this file if not specified
  1606. unless (defined $originalTime) {
  1607. my ($aTime, $mTime, $cTime) = $self->GetFileTime($file);
  1608. $originalTime = ($tag eq 'FileCreateDate') ? $cTime : $mTime;
  1609. return 0 unless defined $originalTime;
  1610. $isUnixTime = 1;
  1611. }
  1612. $originalTime = int($^T - $originalTime*(24*3600) + 0.5) unless $isUnixTime;
  1613. return 0 unless $self->IsOverwriting($nvHash, $originalTime);
  1614. $val = $$nvHash{Value}[0]; # get shifted value
  1615. }
  1616. my ($aTime, $mTime, $cTime);
  1617. if ($tag eq 'FileCreateDate') {
  1618. eval { require Win32::API } or $self->WarnOnce("Install Win32::API to set $tag"), return -1;
  1619. eval { require Win32API::File } or $self->WarnOnce("Install Win32API::File to set $tag"), return -1;
  1620. $cTime = $val;
  1621. } else {
  1622. $aTime = $mTime = $val;
  1623. }
  1624. $self->SetFileTime($file, $aTime, $mTime, $cTime) or $self->Warn("Error setting $tag"), return -1;
  1625. ++$$self{CHANGED};
  1626. $$self{WRITTEN}{$tag} = $val; # remember that we wrote this tag
  1627. $self->VerboseValue("+ $tag", $val);
  1628. return 1;
  1629. }
  1630. #------------------------------------------------------------------------------
  1631. # Change file name and/or directory from FileName and Directory tags
  1632. # Inputs: 0) ExifTool object reference, 1) current file name (including path)
  1633. # 2) new name (or undef to build from FileName and Directory tags)
  1634. # 3) option: 'Link' to create link instead of renaming file
  1635. # 'Test' to only print new file name
  1636. # Returns: 1=name changed OK, 0=nothing changed, -1=error changing name
  1637. # (and increments CHANGED flag if filename changed)
  1638. # Notes: Will not overwrite existing file. Creates directories as necessary.
  1639. sub SetFileName($$;$$)
  1640. {
  1641. my ($self, $file, $newName, $opt) = @_;
  1642. my ($nvHash, $doName, $doDir);
  1643. $opt or $opt = '';
  1644. # determine the new file name
  1645. unless (defined $newName) {
  1646. if ($opt) {
  1647. if ($opt eq 'Link') {
  1648. $newName = $self->GetNewValue('HardLink');
  1649. } elsif ($opt eq 'Test') {
  1650. $newName = $self->GetNewValue('TestName');
  1651. }
  1652. return 0 unless defined $newName;
  1653. } else {
  1654. my $filename = $self->GetNewValue('FileName', \$nvHash);
  1655. $doName = 1 if defined $filename and $self->IsOverwriting($nvHash, $file);
  1656. my $dir = $self->GetNewValue('Directory', \$nvHash);
  1657. $doDir = 1 if defined $dir and $self->IsOverwriting($nvHash, $file);
  1658. return 0 unless $doName or $doDir; # nothing to do
  1659. if ($doName) {
  1660. $newName = GetNewFileName($file, $filename);
  1661. $newName = GetNewFileName($newName, $dir) if $doDir;
  1662. } else {
  1663. $newName = GetNewFileName($file, $dir);
  1664. }
  1665. }
  1666. }
  1667. $newName =~ tr/\0//d; # make sure name doesn't contain nulls
  1668. # protect against empty file name
  1669. length $newName or $self->Warn('New file name is empty'), return -1;
  1670. # don't replace existing file
  1671. if ($self->Exists($newName)) {
  1672. if ($file ne $newName or $opt eq 'Link') {
  1673. $self->Warn("File '$newName' already exists");
  1674. return -1;
  1675. } else {
  1676. $self->Warn('File name is unchanged');
  1677. return 0;
  1678. }
  1679. }
  1680. if ($opt eq 'Test') {
  1681. my $out = $$self{OPTIONS}{TextOut};
  1682. print $out "'$file' --> '$newName'\n";
  1683. return 1;
  1684. }
  1685. # create directory for new file if necessary
  1686. my $result;
  1687. if (($result = $self->CreateDirectory($newName)) != 0) {
  1688. if ($result < 0) {
  1689. $self->Warn("Error creating directory for '$newName'");
  1690. return -1;
  1691. }
  1692. $self->VPrint(0, "Created directory for '$newName'");
  1693. }
  1694. if ($opt eq 'Link') {
  1695. unless (link $file, $newName) {
  1696. $self->Warn("Error creating link '$newName'");
  1697. return -1;
  1698. }
  1699. ++$$self{CHANGED};
  1700. $self->VerboseValue('+ HardLink', $newName);
  1701. return 1;
  1702. }
  1703. # attempt to rename the file
  1704. unless ($self->Rename($file, $newName)) {
  1705. local (*EXIFTOOL_SFN_IN, *EXIFTOOL_SFN_OUT);
  1706. # renaming didn't work, so copy the file instead
  1707. unless ($self->Open(\*EXIFTOOL_SFN_IN, $file)) {
  1708. $self->Warn("Error opening '$file'");
  1709. return -1;
  1710. }
  1711. unless ($self->Open(\*EXIFTOOL_SFN_OUT, $newName, '>')) {
  1712. close EXIFTOOL_SFN_IN;
  1713. $self->Warn("Error creating '$newName'");
  1714. return -1;
  1715. }
  1716. binmode EXIFTOOL_SFN_IN;
  1717. binmode EXIFTOOL_SFN_OUT;
  1718. my ($buff, $err);
  1719. while (read EXIFTOOL_SFN_IN, $buff, 65536) {
  1720. print EXIFTOOL_SFN_OUT $buff or $err = 1;
  1721. }
  1722. close EXIFTOOL_SFN_OUT or $err = 1;
  1723. close EXIFTOOL_SFN_IN;
  1724. if ($err) {
  1725. $self->Unlink($newName); # erase bad output file
  1726. $self->Warn("Error writing '$newName'");
  1727. return -1;
  1728. }
  1729. # preserve modification time
  1730. my ($aTime, $mTime, $cTime) = $self->GetFileTime($file);
  1731. $self->SetFileTime($newName, $aTime, $mTime, $cTime);
  1732. # remove the original file
  1733. $self->Unlink($file) or $self->Warn('Error removing old file');
  1734. }
  1735. $$self{NewName} = $newName; # remember new file name
  1736. ++$$self{CHANGED};
  1737. $self->VerboseValue('+ FileName', $newName);
  1738. return 1;
  1739. }
  1740. #------------------------------------------------------------------------------
  1741. # Write information back to file
  1742. # Inputs: 0) ExifTool object reference,
  1743. # 1) input filename, file ref, RAF ref, or scalar ref (or '' or undef to create from scratch)
  1744. # 2) output filename, file ref, or scalar ref (or undef to overwrite)
  1745. # 3) optional output file type (required only if input file is not specified
  1746. # and output file is a reference)
  1747. # Returns: 1=file written OK, 2=file written but no changes made, 0=file write error
  1748. sub WriteInfo($$;$$)
  1749. {
  1750. local ($_, *EXIFTOOL_FILE2, *EXIFTOOL_OUTFILE);
  1751. my ($self, $infile, $outfile, $outType) = @_;
  1752. my (@fileTypeList, $fileType, $tiffType, $hdr, $seekErr, $type, $tmpfile, $hardLink, $testName);
  1753. my ($inRef, $outRef, $closeIn, $closeOut, $outPos, $outBuff, $eraseIn, $raf);
  1754. my $oldRaf = $$self{RAF};
  1755. my $rtnVal = 0;
  1756. # initialize member variables
  1757. $self->Init();
  1758. # first, save original file modify date if necessary
  1759. # (do this now in case we are modifying file in place and shifting date)
  1760. my ($nvHash, $nvHash2, $originalTime, $createTime);
  1761. my $fileModifyDate = $self->GetNewValue('FileModifyDate', \$nvHash);
  1762. my $fileCreateDate = $self->GetNewValue('FileCreateDate', \$nvHash2);
  1763. my ($aTime, $mTime, $cTime);
  1764. if (defined $fileModifyDate and $self->IsOverwriting($nvHash) < 0 and
  1765. defined $infile and ref $infile ne 'SCALAR')
  1766. {
  1767. ($aTime, $mTime, $cTime) = $self->GetFileTime($infile);
  1768. $originalTime = $mTime;
  1769. }
  1770. if (defined $fileCreateDate and $self->IsOverwriting($nvHash2) < 0 and
  1771. defined $infile and ref $infile ne 'SCALAR')
  1772. {
  1773. ($aTime, $mTime, $cTime) = $self->GetFileTime($infile) unless defined $cTime;
  1774. $createTime = $cTime;
  1775. }
  1776. #
  1777. # do quick in-place change of file dir/name or date if that is all we are doing
  1778. #
  1779. my ($numNew, $numPseudo) = $self->CountNewValues();
  1780. if (not defined $outfile and defined $infile) {
  1781. $hardLink = $self->GetNewValue('HardLink');
  1782. $testName = $self->GetNewValue('TestName');
  1783. undef $hardLink if defined $hardLink and not length $hardLink;
  1784. undef $testName if defined $testName and not length $testName;
  1785. my $newFileName = $self->GetNewValue('FileName', \$nvHash);
  1786. my $newDir = $self->GetNewValue('Directory');
  1787. if (defined $newDir and length $newDir) {
  1788. $newDir .= '/' unless $newDir =~ m{/$};
  1789. } else {
  1790. undef $newDir;
  1791. }
  1792. if ($numNew == $numPseudo) {
  1793. $rtnVal = 2;
  1794. if (defined $fileModifyDate and (not ref $infile or UNIVERSAL::isa($infile,'GLOB'))) {
  1795. $self->SetFileModifyDate($infile) > 0 and $rtnVal = 1;
  1796. }
  1797. if (defined $fileCreateDate and (not ref $infile or UNIVERSAL::isa($infile,'GLOB'))) {
  1798. $self->SetFileModifyDate($infile, undef, 'FileCreateDate') > 0 and $rtnVal = 1;
  1799. }
  1800. if ((defined $newFileName or defined $newDir) and not ref $infile) {
  1801. $self->SetFileName($infile) > 0 and $rtnVal = 1;
  1802. }
  1803. if (defined $hardLink or defined $testName) {
  1804. my $src = $$self{NewName};
  1805. $src = $infile unless defined $src;
  1806. $hardLink and $self->SetFileName($src, $hardLink, 'Link') and $rtnVal = 1;
  1807. $testName and $self->SetFileName($src, $testName, 'Test') and $rtnVal = 1;
  1808. }
  1809. return $rtnVal;
  1810. } elsif (defined $newFileName and length $newFileName) {
  1811. # can't simply rename file, so just set the output name if new FileName
  1812. # --> in this case, must erase original copy
  1813. if (ref $infile) {
  1814. $outfile = $newFileName;
  1815. # can't delete original
  1816. } elsif ($self->IsOverwriting($nvHash, $infile)) {
  1817. $outfile = GetNewFileName($infile, $newFileName);
  1818. $eraseIn = 1; # delete original
  1819. }
  1820. }
  1821. # set new directory if specified
  1822. if (defined $newDir) {
  1823. $outfile = $infile unless defined $outfile or ref $infile;
  1824. if (defined $outfile) {
  1825. $outfile = GetNewFileName($outfile, $newDir);
  1826. $eraseIn = 1 unless ref $infile;
  1827. }
  1828. }
  1829. }
  1830. #
  1831. # set up input file
  1832. #
  1833. if (ref $infile) {
  1834. $inRef = $infile;
  1835. if (UNIVERSAL::isa($inRef,'GLOB')) {
  1836. seek($inRef, 0, 0); # make sure we are at the start of the file
  1837. } elsif (UNIVERSAL::isa($inRef,'File::RandomAccess')) {
  1838. $inRef->Seek(0);
  1839. $raf = $inRef;
  1840. } elsif ($] >= 5.006 and (eval { require Encode; Encode::is_utf8($$inRef) } or $@)) {
  1841. # convert image data from UTF-8 to character stream if necessary
  1842. my $buff = $@ ? pack('C*',unpack($] < 5.010000 ? 'U0C*' : 'C0C*',$$inRef)) : Encode::encode('utf8',$$inRef);
  1843. if (defined $outfile) {
  1844. $inRef = \$buff;
  1845. } else {
  1846. $$inRef = $buff;
  1847. }
  1848. }
  1849. } elsif (defined $infile and $infile ne '') {
  1850. # write to a temporary file if no output file given
  1851. $outfile = $tmpfile = "${infile}_exiftool_tmp" unless defined $outfile;
  1852. if ($self->Open(\*EXIFTOOL_FILE2, $infile)) {
  1853. $fileType = GetFileType($infile);
  1854. @fileTypeList = GetFileType($infile);
  1855. $tiffType = $$self{FILE_EXT} = GetFileExtension($infile);
  1856. $self->VPrint(0, "Rewriting $infile...\n");
  1857. $inRef = \*EXIFTOOL_FILE2;
  1858. $closeIn = 1; # we must close the file since we opened it
  1859. } else {
  1860. $self->Error('Error opening file');
  1861. return 0;
  1862. }
  1863. } elsif (not defined $outfile) {
  1864. $self->Error("WriteInfo(): Must specify infile or outfile\n");
  1865. return 0;
  1866. } else {
  1867. # create file from scratch
  1868. $outType = GetFileExtension($outfile) unless $outType or ref $outfile;
  1869. if (CanCreate($outType)) {
  1870. $fileType = $tiffType = $outType; # use output file type if no input file
  1871. $infile = "$fileType file"; # make bogus file name
  1872. $self->VPrint(0, "Creating $infile...\n");
  1873. $inRef = \ ''; # set $inRef to reference to empty data
  1874. } elsif ($outType) {
  1875. $self->Error("Can't create $outType files");
  1876. return 0;
  1877. } else {
  1878. $self->Error("Can't create file (unknown type)");
  1879. return 0;
  1880. }
  1881. }
  1882. unless (@fileTypeList) {
  1883. if ($fileType) {
  1884. @fileTypeList = ( $fileType );
  1885. } else {
  1886. @fileTypeList = @fileTypes;
  1887. $tiffType = 'TIFF';
  1888. }
  1889. }
  1890. #
  1891. # set up output file
  1892. #
  1893. if (ref $outfile) {
  1894. $outRef = $outfile;
  1895. if (UNIVERSAL::isa($outRef,'GLOB')) {
  1896. binmode($outRef);
  1897. $outPos = tell($outRef);
  1898. } else {
  1899. # initialize our output buffer if necessary
  1900. defined $$outRef or $$outRef = '';
  1901. $outPos = length($$outRef);
  1902. }
  1903. } elsif (not defined $outfile) {
  1904. # editing in place, so write to memory first
  1905. # (only when infile is a file ref or scalar ref)
  1906. if ($raf) {
  1907. $self->Error("Can't edit File::RandomAccess object in place");
  1908. return 0;
  1909. }
  1910. $outBuff = '';
  1911. $outRef = \$outBuff;
  1912. $outPos = 0;
  1913. } elsif ($self->Exists($outfile)) {
  1914. $self->Error("File already exists: $outfile");
  1915. } elsif ($self->Open(\*EXIFTOOL_OUTFILE, $outfile, '>')) {
  1916. $outRef = \*EXIFTOOL_OUTFILE;
  1917. $closeOut = 1; # we must close $outRef
  1918. binmode($outRef);
  1919. $outPos = 0;
  1920. } else {
  1921. my $tmp = $tmpfile ? ' temporary' : '';
  1922. $self->Error("Error creating$tmp file: $outfile");
  1923. }
  1924. #
  1925. # write the file
  1926. #
  1927. until ($$self{VALUE}{Error}) {
  1928. # create random access file object (disable seek test in case of straight copy)
  1929. $raf or $raf = new File::RandomAccess($inRef, 1);
  1930. $raf->BinMode();
  1931. if ($numNew == $numPseudo) {
  1932. $rtnVal = 1;
  1933. # just do a straight copy of the file (no "real" tags are being changed)
  1934. my $buff;
  1935. while ($raf->Read($buff, 65536)) {
  1936. Write($outRef, $buff) or $rtnVal = -1, last;
  1937. }
  1938. last;
  1939. } elsif (not ref $infile and ($infile eq '-' or $infile =~ /\|$/)) {
  1940. # patch for Windows command shell pipe
  1941. $$raf{TESTED} = -1; # force buffering
  1942. } else {
  1943. $raf->SeekTest();
  1944. }
  1945. # $raf->Debug() and warn " RAF debugging enabled!\n";
  1946. my $inPos = $raf->Tell();
  1947. $$self{RAF} = $raf;
  1948. my %dirInfo = (
  1949. RAF => $raf,
  1950. OutFile => $outRef,
  1951. );
  1952. $raf->Read($hdr, 1024) or $hdr = '';
  1953. $raf->Seek($inPos, 0) or $seekErr = 1;
  1954. my $wrongType;
  1955. until ($seekErr) {
  1956. $type = shift @fileTypeList;
  1957. # do quick test to see if this is the right file type
  1958. if ($magicNumber{$type} and length($hdr) and $hdr !~ /^$magicNumber{$type}/s) {
  1959. next if @fileTypeList;
  1960. $wrongType = 1;
  1961. last;
  1962. }
  1963. # save file type in member variable
  1964. $dirInfo{Parent} = $$self{FILE_TYPE} = $$self{PATH}[0] = $type;
  1965. # determine which directories we must write for this file type
  1966. $self->InitWriteDirs($type);
  1967. if ($type eq 'JPEG' or $type eq 'EXV') {
  1968. $rtnVal = $self->WriteJPEG(\%dirInfo);
  1969. } elsif ($type eq 'TIFF') {
  1970. # disallow writing of some TIFF-based RAW images:
  1971. if (grep /^$tiffType$/, @{$noWriteFile{TIFF}}) {
  1972. $fileType = $tiffType;
  1973. undef $rtnVal;
  1974. } else {
  1975. $dirInfo{Parent} = $tiffType;
  1976. $rtnVal = $self->ProcessTIFF(\%dirInfo);
  1977. }
  1978. } elsif ($type eq 'GIF') {
  1979. require Image::ExifTool::GIF;
  1980. $rtnVal = Image::ExifTool::GIF::ProcessGIF($self,\%dirInfo);
  1981. } elsif ($type eq 'CRW') {
  1982. require Image::ExifTool::CanonRaw;
  1983. $rtnVal = Image::ExifTool::CanonRaw::WriteCRW($self, \%dirInfo);
  1984. } elsif ($type eq 'MRW') {
  1985. require Image::ExifTool::MinoltaRaw;
  1986. $rtnVal = Image::ExifTool::MinoltaRaw::ProcessMRW($self, \%dirInfo);
  1987. } elsif ($type eq 'RAF') {
  1988. require Image::ExifTool::FujiFilm;
  1989. $rtnVal = Image::ExifTool::FujiFilm::WriteRAF($self, \%dirInfo);
  1990. } elsif ($type eq 'ORF' or $type eq 'RAW') {
  1991. $rtnVal = $self->ProcessTIFF(\%dirInfo);
  1992. } elsif ($type eq 'X3F') {
  1993. require Image::ExifTool::SigmaRaw;
  1994. $rtnVal = Image::ExifTool::SigmaRaw::ProcessX3F($self, \%dirInfo);
  1995. } elsif ($type eq 'PNG') {
  1996. require Image::ExifTool::PNG;
  1997. $rtnVal = Image::ExifTool::PNG::ProcessPNG($self, \%dirInfo);
  1998. } elsif ($type eq 'MIE') {
  1999. require Image::ExifTool::MIE;
  2000. $rtnVal = Image::ExifTool::MIE::ProcessMIE($self, \%dirInfo);
  2001. } elsif ($type eq 'XMP') {
  2002. require Image::ExifTool::XMP;
  2003. $rtnVal = Image::ExifTool::XMP::WriteXMP($self, \%dirInfo);
  2004. } elsif ($type eq 'PPM') {
  2005. require Image::ExifTool::PPM;
  2006. $rtnVal = Image::ExifTool::PPM::ProcessPPM($self, \%dirInfo);
  2007. } elsif ($type eq 'PSD') {
  2008. require Image::ExifTool::Photoshop;
  2009. $rtnVal = Image::ExifTool::Photoshop::ProcessPSD($self, \%dirInfo);
  2010. } elsif ($type eq 'EPS' or $type eq 'PS') {
  2011. require Image::ExifTool::PostScript;
  2012. $rtnVal = Image::ExifTool::PostScript::WritePS($self, \%dirInfo);
  2013. } elsif ($type eq 'PDF') {
  2014. require Image::ExifTool::PDF;
  2015. $rtnVal = Image::ExifTool::PDF::WritePDF($self, \%dirInfo);
  2016. } elsif ($type eq 'ICC') {
  2017. require Image::ExifTool::ICC_Profile;
  2018. $rtnVal = Image::ExifTool::ICC_Profile::WriteICC($self, \%dirInfo);
  2019. } elsif ($type eq 'VRD') {
  2020. require Image::ExifTool::CanonVRD;
  2021. $rtnVal = Image::ExifTool::CanonVRD::ProcessVRD($self, \%dirInfo);
  2022. } elsif ($type eq 'DR4') {
  2023. require Image::ExifTool::CanonVRD;
  2024. $rtnVal = Image::ExifTool::CanonVRD::ProcessDR4($self, \%dirInfo);
  2025. } elsif ($type eq 'JP2') {
  2026. require Image::ExifTool::Jpeg2000;
  2027. $rtnVal = Image::ExifTool::Jpeg2000::ProcessJP2($self, \%dirInfo);
  2028. } elsif ($type eq 'IND') {
  2029. require Image::ExifTool::InDesign;
  2030. $rtnVal = Image::ExifTool::InDesign::ProcessIND($self, \%dirInfo);
  2031. } elsif ($type eq 'MOV') {
  2032. require Image::ExifTool::QuickTime;
  2033. $rtnVal = Image::ExifTool::QuickTime::WriteMOV($self, \%dirInfo);
  2034. } elsif ($type eq 'EXIF') {
  2035. # go through WriteDirectory so block writes, etc are handled
  2036. my $tagTablePtr = GetTagTable('Image::ExifTool::Exif::Main');
  2037. my $buff = $self->WriteDirectory(\%dirInfo, $tagTablePtr, \&WriteTIFF);
  2038. if (defined $buff) {
  2039. $rtnVal = Write($outRef, $buff) ? 1 : -1;
  2040. } else {
  2041. $rtnVal = 0;
  2042. }
  2043. } else {
  2044. undef $rtnVal; # flag that we don't write this type of file
  2045. }
  2046. # all done unless we got the wrong type
  2047. last if $rtnVal;
  2048. last unless @fileTypeList;
  2049. # seek back to original position in files for next try
  2050. $raf->Seek($inPos, 0) or $seekErr = 1, last;
  2051. if (UNIVERSAL::isa($outRef,'GLOB')) {
  2052. seek($outRef, 0, $outPos);
  2053. } else {
  2054. $$outRef = substr($$outRef, 0, $outPos);
  2055. }
  2056. }
  2057. # print file format errors
  2058. unless ($rtnVal) {
  2059. my $err;
  2060. if ($seekErr) {
  2061. $err = 'Error seeking in file';
  2062. } elsif ($fileType and defined $rtnVal) {
  2063. if ($$self{VALUE}{Error}) {
  2064. # existing error message will do
  2065. } elsif ($fileType eq 'RAW') {
  2066. $err = 'Writing this type of RAW file is not supported';
  2067. } else {
  2068. if ($wrongType) {
  2069. $err = "Not a valid $fileType";
  2070. # do a quick check to see what this file looks like
  2071. foreach $type (@fileTypes) {
  2072. next unless $magicNumber{$type};
  2073. next unless $hdr =~ /^$magicNumber{$type}/s;
  2074. $err .= " (looks more like a $type)";
  2075. last;
  2076. }
  2077. } else {
  2078. $err = 'Format error in file';
  2079. }
  2080. }
  2081. } elsif ($fileType) {
  2082. # get specific type of file from extension
  2083. $fileType = GetFileExtension($infile) if $infile and GetFileType($infile);
  2084. $err = "Writing of $fileType files is not yet supported";
  2085. } else {
  2086. $err = 'Writing of this type of file is not supported';
  2087. }
  2088. $self->Error($err) if $err;
  2089. $rtnVal = 0; # (in case it was undef)
  2090. }
  2091. # $raf->Close(); # only used to force debug output
  2092. last; # (didn't really want to loop)
  2093. }
  2094. # don't return success code if any error occurred
  2095. if ($rtnVal > 0) {
  2096. unless (Tell($outRef) or $$self{VALUE}{Error}) {
  2097. # don't write a file with zero length
  2098. if (defined $hdr and length $hdr) {
  2099. $self->Error("Can't delete all meta information from $type file");
  2100. } else {
  2101. $self->Error('Nothing to write');
  2102. }
  2103. }
  2104. $rtnVal = 0 if $$self{VALUE}{Error};
  2105. }
  2106. # rewrite original file in place if required
  2107. if (defined $outBuff) {
  2108. if ($rtnVal <= 0 or not $$self{CHANGED}) {
  2109. # nothing changed, so no need to write $outBuff
  2110. } elsif (UNIVERSAL::isa($inRef,'GLOB')) {
  2111. my $len = length($outBuff);
  2112. my $size;
  2113. $rtnVal = -1 unless
  2114. seek($inRef, 0, 2) and # seek to the end of file
  2115. ($size = tell $inRef) >= 0 and # get the file size
  2116. seek($inRef, 0, 0) and # seek back to the start
  2117. print $inRef $outBuff and # write the new data
  2118. ($len >= $size or # if necessary:
  2119. eval { truncate($inRef, $len) }); # shorten output file
  2120. } else {
  2121. $$inRef = $outBuff; # replace original data
  2122. }
  2123. $outBuff = ''; # free memory but leave $outBuff defined
  2124. }
  2125. # close input file if we opened it
  2126. if ($closeIn) {
  2127. # errors on input file are significant if we edited the file in place
  2128. $rtnVal and $rtnVal = -1 unless close($inRef) or not defined $outBuff;
  2129. if ($rtnVal > 0) {
  2130. # copy Mac OS resource fork if it exists
  2131. if ($^O eq 'darwin' and -s "$infile/..namedfork/rsrc") {
  2132. if ($$self{DEL_GROUP}{RSRC}) {
  2133. $self->VPrint(0,"Deleting Mac OS resource fork\n");
  2134. ++$$self{CHANGED};
  2135. } else {
  2136. $self->VPrint(0,"Copying Mac OS resource fork\n");
  2137. my ($buf, $err);
  2138. local (*SRC, *DST);
  2139. if ($self->Open(\*SRC, "$infile/..namedfork/rsrc")) {
  2140. if ($self->Open(\*DST, "$outfile/..namedfork/rsrc", '>')) {
  2141. binmode SRC; # (not necessary for Darwin, but let's be thorough)
  2142. binmode DST;
  2143. while (read SRC, $buf, 65536) {
  2144. print DST $buf or $err = 'copying', last;
  2145. }
  2146. close DST or $err or $err = 'closing';
  2147. } else {
  2148. # (this is normal if the destination filesystem isn't Mac OS)
  2149. $self->Warn('Error creating Mac OS resource fork');
  2150. }
  2151. close SRC;
  2152. } else {
  2153. $err = 'opening';
  2154. }
  2155. $rtnVal = 0 if $err and $self->Error("Error $err Mac OS resource fork", 2);
  2156. }
  2157. }
  2158. # erase input file if renaming while editing information in place
  2159. $self->Unlink($infile) or $self->Warn('Error erasing original file') if $eraseIn;
  2160. }
  2161. }
  2162. # close output file if we created it
  2163. if ($closeOut) {
  2164. # close file and set $rtnVal to -1 if there was an error
  2165. $rtnVal and $rtnVal = -1 unless close($outRef);
  2166. # erase the output file if we weren't successful
  2167. if ($rtnVal <= 0) {
  2168. $self->Unlink($outfile);
  2169. # else rename temporary file if necessary
  2170. } elsif ($tmpfile) {
  2171. CopyFileAttrs($infile, $tmpfile); # copy attributes to new file
  2172. unless ($self->Rename($tmpfile, $infile)) {
  2173. # some filesystems won't overwrite with 'rename', so try erasing original
  2174. if (not $self->Unlink($infile)) {
  2175. $self->Unlink($tmpfile);
  2176. $self->Error('Error renaming temporary file');
  2177. $rtnVal = 0;
  2178. } elsif (not $self->Rename($tmpfile, $infile)) {
  2179. $self->Error('Error renaming temporary file after deleting original');
  2180. $rtnVal = 0;
  2181. }
  2182. }
  2183. }
  2184. }
  2185. # set FileModifyDate if requested (and if possible!)
  2186. if ($rtnVal > 0 and ($closeOut or ($closeIn and defined $outBuff))) {
  2187. my $target = $closeOut ? $outfile : $infile;
  2188. if (defined $fileModifyDate and
  2189. $self->SetFileModifyDate($target, $originalTime, undef, 1) > 0)
  2190. {
  2191. ++$$self{CHANGED}; # we changed something
  2192. }
  2193. # set FileCreateDate if requested (and if possible!)
  2194. if (defined $fileCreateDate and
  2195. $self->SetFileModifyDate($target, $createTime, 'FileCreateDate', 1))
  2196. {
  2197. ++$$self{CHANGED}; # we changed something
  2198. }
  2199. # create hard link if requested and no output filename specified (and if possible!)
  2200. if (defined $hardLink and $self->SetFileName($target, $hardLink, 'Link')) {
  2201. ++$$self{CHANGED}; # we changed something (sort of)
  2202. }
  2203. defined $testName and $self->SetFileName($target, $testName, 'Test');
  2204. }
  2205. # check for write error and set appropriate error message and return value
  2206. if ($rtnVal < 0) {
  2207. $self->Error('Error writing output file') unless $$self{VALUE}{Error};
  2208. $rtnVal = 0; # return 0 on failure
  2209. } elsif ($rtnVal > 0) {
  2210. ++$rtnVal unless $$self{CHANGED};
  2211. }
  2212. # set things back to the way they were
  2213. $$self{RAF} = $oldRaf;
  2214. return $rtnVal;
  2215. }
  2216. #------------------------------------------------------------------------------
  2217. # Get list of all available tags for specified group
  2218. # Inputs: 0) optional group name (or string of names separated by colons)
  2219. # Returns: tag list (sorted alphabetically)
  2220. # Notes: Can't get tags for specific IFD
  2221. sub GetAllTags(;$)
  2222. {
  2223. local $_;
  2224. my $group = shift;
  2225. my (%allTags, @groups);
  2226. @groups = split ':', $group if $group;
  2227. my $et = new Image::ExifTool;
  2228. LoadAllTables(); # first load all our tables
  2229. my @tableNames = keys %allTables;
  2230. # loop through all tables and save tag names to %allTags hash
  2231. while (@tableNames) {
  2232. my $table = GetTagTable(pop @tableNames);
  2233. # generate flattened tag names for structure fields if this is an XMP table
  2234. if ($$table{GROUPS} and $$table{GROUPS}{0} eq 'XMP') {
  2235. Image::ExifTool::XMP::AddFlattenedTags($table);
  2236. }
  2237. my $tagID;
  2238. foreach $tagID (TagTableKeys($table)) {
  2239. my @infoArray = GetTagInfoList($table,$tagID);
  2240. my $tagInfo;
  2241. GATInfo: foreach $tagInfo (@infoArray) {
  2242. my $tag = $$tagInfo{Name};
  2243. $tag or warn("no name for tag!\n"), next;
  2244. # don't list subdirectories unless they are writable
  2245. next if $$tagInfo{SubDirectory} and not $$tagInfo{Writable};
  2246. next if $$tagInfo{Hidden}; # ignore hidden tags
  2247. if (@groups) {
  2248. my @tg = $et->GetGroup($tagInfo);
  2249. foreach $group (@groups) {
  2250. next GATInfo unless grep /^$group$/i, @tg;
  2251. }
  2252. }
  2253. $allTags{$tag} = 1;
  2254. }
  2255. }
  2256. }
  2257. return sort keys %allTags;
  2258. }
  2259. #------------------------------------------------------------------------------
  2260. # Get list of all writable tags
  2261. # Inputs: 0) optional group name (or names separated by colons)
  2262. # Returns: tag list (sorted alphabetically)
  2263. sub GetWritableTags(;$)
  2264. {
  2265. local $_;
  2266. my $group = shift;
  2267. my (%writableTags, @groups);
  2268. @groups = split ':', $group if $group;
  2269. my $et = new Image::ExifTool;
  2270. LoadAllTables();
  2271. my @tableNames = keys %allTables;
  2272. while (@tableNames) {
  2273. my $tableName = pop @tableNames;
  2274. my $table = GetTagTable($tableName);
  2275. # generate flattened tag names for structure fields if this is an XMP table
  2276. if ($$table{GROUPS} and $$table{GROUPS}{0} eq 'XMP') {
  2277. Image::ExifTool::XMP::AddFlattenedTags($table);
  2278. }
  2279. # attempt to load Write tables if autoloaded
  2280. my @parts = split(/::/,$tableName);
  2281. if (@parts > 3) {
  2282. my $i = $#parts - 1;
  2283. $parts[$i] = "Write$parts[$i]"; # add 'Write' before class name
  2284. my $module = join('::',@parts[0..$i]);
  2285. eval { require $module }; # (fails silently if nothing loaded)
  2286. }
  2287. my $tagID;
  2288. foreach $tagID (TagTableKeys($table)) {
  2289. my @infoArray = GetTagInfoList($table,$tagID);
  2290. my $tagInfo;
  2291. GWTInfo: foreach $tagInfo (@infoArray) {
  2292. my $tag = $$tagInfo{Name};
  2293. $tag or warn("no name for tag!\n"), next;
  2294. my $writable = $$tagInfo{Writable};
  2295. next unless $writable or ($$table{WRITABLE} and
  2296. not defined $writable and not $$tagInfo{SubDirectory});
  2297. next if $$tagInfo{Hidden}; # ignore hidden tags
  2298. if (@groups) {
  2299. my @tg = $et->GetGroup($tagInfo);
  2300. foreach $group (@groups) {
  2301. next GWTInfo unless grep /^$group$/i, @tg;
  2302. }
  2303. }
  2304. $writableTags{$tag} = 1;
  2305. }
  2306. }
  2307. }
  2308. return sort keys %writableTags;
  2309. }
  2310. #------------------------------------------------------------------------------
  2311. # Get list of all group names
  2312. # Inputs: 0) Group family number
  2313. # Returns: List of group names (sorted alphabetically)
  2314. sub GetAllGroups($)
  2315. {
  2316. local $_;
  2317. my $family = shift || 0;
  2318. $family == 3 and return('Doc#', 'Main');
  2319. $family == 4 and return('Copy#');
  2320. LoadAllTables(); # first load all our tables
  2321. my @tableNames = keys %allTables;
  2322. # loop through all tag tables and get all group names
  2323. my %allGroups;
  2324. while (@tableNames) {
  2325. my $table = GetTagTable(pop @tableNames);
  2326. my ($grps, $grp, $tag, $tagInfo);
  2327. $allGroups{$grp} = 1 if ($grps = $$table{GROUPS}) and ($grp = $$grps{$family});
  2328. foreach $tag (TagTableKeys($table)) {
  2329. my @infoArray = GetTagInfoList($table, $tag);
  2330. foreach $tagInfo (@infoArray) {
  2331. next unless ($grps = $$tagInfo{Groups}) and ($grp = $$grps{$family});
  2332. $allGroups{$grp} = 1;
  2333. }
  2334. }
  2335. }
  2336. return sort keys %allGroups;
  2337. }
  2338. #------------------------------------------------------------------------------
  2339. # get priority group list for new values
  2340. # Inputs: 0) ExifTool object reference
  2341. # Returns: List of group names
  2342. sub GetNewGroups($)
  2343. {
  2344. my $self = shift;
  2345. return @{$$self{WRITE_GROUPS}};
  2346. }
  2347. #------------------------------------------------------------------------------
  2348. # Get list of all deletable group names
  2349. # Returns: List of group names (sorted alphabetically)
  2350. sub GetDeleteGroups()
  2351. {
  2352. return sort @delGroups, @delGroup2;
  2353. }
  2354. #------------------------------------------------------------------------------
  2355. # Add user-defined tags at run time
  2356. # Inputs: 0) destination table name, 1) tagID/tagInfo pairs for tags to add
  2357. # Returns: number of tags added
  2358. # Notes: will replace existing tags
  2359. sub AddUserDefinedTags($%)
  2360. {
  2361. local $_;
  2362. my ($tableName, %addTags) = @_;
  2363. my $table = GetTagTable($tableName) or return 0;
  2364. # add tags to writer lookup
  2365. Image::ExifTool::TagLookup::AddTags(\%addTags, $tableName);
  2366. my $tagID;
  2367. my $num = 0;
  2368. foreach $tagID (keys %addTags) {
  2369. next if $specialTags{$tagID};
  2370. delete $$table{$tagID}; # delete old entry if it existed
  2371. AddTagToTable($table, $tagID, $addTags{$tagID}, 1);
  2372. ++$num;
  2373. }
  2374. return $num;
  2375. }
  2376. #==============================================================================
  2377. # Functions below this are not part of the public API
  2378. #------------------------------------------------------------------------------
  2379. # Maintain backward compatibility for old GetNewValues function name
  2380. sub GetNewValues($$;$)
  2381. {
  2382. my ($self, $tag, $nvHashPt) = @_;
  2383. return $self->GetNewValue($tag, $nvHashPt);
  2384. }
  2385. #------------------------------------------------------------------------------
  2386. # Un-escape string according to options settings and clear UTF-8 flag
  2387. # Inputs: 0) ExifTool ref, 1) string ref or string ref ref
  2388. # Notes: also de-references SCALAR values
  2389. sub Sanitize($$)
  2390. {
  2391. my ($self, $valPt) = @_;
  2392. # de-reference SCALAR references
  2393. $$valPt = $$$valPt if ref $$valPt eq 'SCALAR';
  2394. # make sure the Perl UTF-8 flag is OFF for the value if perl 5.6 or greater
  2395. # (otherwise our byte manipulations get corrupted!!)
  2396. if ($] >= 5.006 and (eval { require Encode; Encode::is_utf8($$valPt) } or $@)) {
  2397. # repack by hand if Encode isn't available
  2398. $$valPt = $@ ? pack('C*',unpack($] < 5.010000 ? 'U0C*' : 'C0C*',$$valPt)) : Encode::encode('utf8',$$valPt);
  2399. }
  2400. # un-escape value if necessary
  2401. if ($$self{OPTIONS}{Escape}) {
  2402. # (XMP.pm and HTML.pm were require'd as necessary when option was set)
  2403. if ($$self{OPTIONS}{Escape} eq 'XML') {
  2404. $$valPt = Image::ExifTool::XMP::UnescapeXML($$valPt);
  2405. } elsif ($$self{OPTIONS}{Escape} eq 'HTML') {
  2406. $$valPt = Image::ExifTool::HTML::UnescapeHTML($$valPt);
  2407. }
  2408. }
  2409. }
  2410. #------------------------------------------------------------------------------
  2411. # Apply inverse conversions
  2412. # Inputs: 0) ExifTool ref, 1) value, 2) tagInfo (or Struct item) ref,
  2413. # 3) tag name, 4) group 1 name, 5) conversion type (or undef),
  2414. # 6) [optional] want group ("" for structure field)
  2415. # Returns: 0) converted value, 1) error string (or undef on success)
  2416. # Notes:
  2417. # - uses ExifTool "ConvType" member when conversion type is undef
  2418. # - conversion types other than 'ValueConv' and 'PrintConv' are treated as 'Raw'
  2419. sub ConvInv($$$$$;$$)
  2420. {
  2421. my ($self, $val, $tagInfo, $tag, $wgrp1, $convType, $wantGroup) = @_;
  2422. my ($err, $type);
  2423. Conv: for (;;) {
  2424. if (not defined $type) {
  2425. # split value into list if necessary
  2426. if ($$tagInfo{List}) {
  2427. my $listSplit = $$tagInfo{AutoSplit} || $$self{OPTIONS}{ListSplit};
  2428. if (defined $listSplit and not $$tagInfo{Struct} and
  2429. ($wantGroup or not defined $wantGroup))
  2430. {
  2431. $listSplit = ',?\s+' if $listSplit eq '1' and $$tagInfo{AutoSplit};
  2432. my @splitVal = split /$listSplit/, $val;
  2433. $val = \@splitVal if @splitVal > 1;
  2434. }
  2435. }
  2436. $type = $convType || $$self{ConvType} || 'PrintConv';
  2437. } elsif ($type eq 'PrintConv') {
  2438. $type = 'ValueConv';
  2439. } else {
  2440. # split raw value if necessary
  2441. if ($$tagInfo{RawJoin} and $$tagInfo{List} and not ref $val) {
  2442. my @splitVal = split ' ', $val;
  2443. $val = \@splitVal if @splitVal > 1;
  2444. }
  2445. # finally, do our value check
  2446. my ($err2, $v);
  2447. if ($$tagInfo{WriteCheck}) {
  2448. #### eval WriteCheck ($self, $tagInfo, $val)
  2449. $err2 = eval $$tagInfo{WriteCheck};
  2450. $@ and warn($@), $err2 = 'Error evaluating WriteCheck';
  2451. }
  2452. unless ($err2) {
  2453. my $table = $$tagInfo{Table};
  2454. if ($table and $$table{CHECK_PROC} and not $$tagInfo{RawConvInv}) {
  2455. my $checkProc = $$table{CHECK_PROC};
  2456. if (ref $val eq 'ARRAY') {
  2457. # loop through array values
  2458. foreach $v (@$val) {
  2459. $err2 = &$checkProc($self, $tagInfo, \$v);
  2460. last if $err2;
  2461. }
  2462. } else {
  2463. $err2 = &$checkProc($self, $tagInfo, \$val);
  2464. }
  2465. }
  2466. }
  2467. if (defined $err2) {
  2468. if ($err2) {
  2469. $err = "$err2 for $wgrp1:$tag";
  2470. $self->VPrint(2, "$err\n");
  2471. undef $val; # value was invalid
  2472. } else {
  2473. $err = $err2; # empty error (quietly don't write tag)
  2474. }
  2475. }
  2476. last;
  2477. }
  2478. my $conv = $$tagInfo{$type};
  2479. my $convInv = $$tagInfo{"${type}Inv"};
  2480. # nothing to do at this level if no conversion defined
  2481. next unless defined $conv or defined $convInv;
  2482. my (@valList, $index, $convList, $convInvList);
  2483. if (ref $val eq 'ARRAY') {
  2484. # handle ValueConv of ListSplit and AutoSplit values
  2485. @valList = @$val;
  2486. $val = $valList[$index = 0];
  2487. } elsif (ref $conv eq 'ARRAY' or ref $convInv eq 'ARRAY') {
  2488. # handle conversion lists
  2489. @valList = split /$listSep{$type}/, $val;
  2490. $val = $valList[$index = 0];
  2491. if (ref $conv eq 'ARRAY') {
  2492. $convList = $conv;
  2493. $conv = $$conv[0];
  2494. }
  2495. if (ref $convInv eq 'ARRAY') {
  2496. $convInvList = $convInv;
  2497. $convInv = $$convInv[0];
  2498. }
  2499. }
  2500. # loop through multiple values if necessary
  2501. for (;;) {
  2502. if ($convInv) {
  2503. # capture eval warnings too
  2504. local $SIG{'__WARN__'} = \&SetWarning;
  2505. undef $evalWarning;
  2506. if (ref($convInv) eq 'CODE') {
  2507. $val = &$convInv($val, $self);
  2508. } else {
  2509. #### eval PrintConvInv/ValueConvInv ($val, $self, $wantGroup)
  2510. $val = eval $convInv;
  2511. $@ and $evalWarning = $@;
  2512. }
  2513. if ($evalWarning) {
  2514. # an empty warning ("\n") ignores tag with no error
  2515. if ($evalWarning eq "\n") {
  2516. $err = '' unless defined $err;
  2517. } else {
  2518. $err = CleanWarning() . " in $wgrp1:$tag (${type}Inv)";
  2519. $self->VPrint(2, "$err\n");
  2520. }
  2521. undef $val;
  2522. last Conv;
  2523. } elsif (not defined $val) {
  2524. $err = "Error converting value for $wgrp1:$tag (${type}Inv)";
  2525. $self->VPrint(2, "$err\n");
  2526. last Conv;
  2527. }
  2528. } elsif ($conv) {
  2529. if (ref $conv eq 'HASH') {
  2530. my ($multi, $lc);
  2531. # insert alternate language print conversions if required
  2532. if ($$self{CUR_LANG} and $type eq 'PrintConv' and
  2533. ref($lc = $$self{CUR_LANG}{$tag}) eq 'HASH' and
  2534. ($lc = $$lc{PrintConv}))
  2535. {
  2536. my %newConv;
  2537. foreach (keys %$conv) {
  2538. my $val = $$conv{$_};
  2539. defined $$lc{$val} or $newConv{$_} = $val, next;
  2540. $newConv{$_} = $self->Decode($$lc{$val}, 'UTF8');
  2541. }
  2542. if ($$conv{BITMASK}) {
  2543. foreach (keys %{$$conv{BITMASK}}) {
  2544. my $val = $$conv{BITMASK}{$_};
  2545. defined $$lc{$val} or $newConv{BITMASK}{$_} = $val, next;
  2546. $newConv{BITMASK}{$_} = $self->Decode($$lc{$val}, 'UTF8');
  2547. }
  2548. }
  2549. $conv = \%newConv;
  2550. }
  2551. if ($$conv{BITMASK}) {
  2552. my $lookupBits = $$conv{BITMASK};
  2553. my ($wbits, $tbits) = @$tagInfo{'BitsPerWord','BitsTotal'};
  2554. my ($val2, $err2) = EncodeBits($val, $lookupBits, $wbits, $tbits);
  2555. if ($err2) {
  2556. # ok, try matching a straight value
  2557. ($val, $multi) = ReverseLookup($val, $conv);
  2558. unless (defined $val) {
  2559. $err = "Can't encode $wgrp1:$tag ($err2)";
  2560. $self->VPrint(2, "$err\n");
  2561. last Conv;
  2562. }
  2563. } elsif (defined $val2) {
  2564. $val = $val2;
  2565. } else {
  2566. delete $$conv{BITMASK};
  2567. ($val, $multi) = ReverseLookup($val, $conv);
  2568. $$conv{BITMASK} = $lookupBits;
  2569. }
  2570. } else {
  2571. ($val, $multi) = ReverseLookup($val, $conv);
  2572. }
  2573. unless (defined $val) {
  2574. $err = "Can't convert $wgrp1:$tag (" .
  2575. ($multi ? 'matches more than one' : 'not in') . " $type)";
  2576. $self->VPrint(2, "$err\n");
  2577. last Conv;
  2578. }
  2579. } elsif (not $$tagInfo{WriteAlso}) {
  2580. $err = "Can't convert value for $wgrp1:$tag (no ${type}Inv)";
  2581. $self->VPrint(2, "$err\n");
  2582. undef $val;
  2583. last Conv;
  2584. }
  2585. }
  2586. last unless @valList;
  2587. $valList[$index] = $val;
  2588. if (++$index >= @valList) {
  2589. # leave AutoSplit lists in ARRAY form, or join conversion lists
  2590. $val = $$tagInfo{List} ? \@valList : join ' ', @valList;
  2591. last;
  2592. }
  2593. $conv = $$convList[$index] if $convList;
  2594. $convInv = $$convInvList[$index] if $convInvList;
  2595. $val = $valList[$index];
  2596. }
  2597. } # end ValueConv/PrintConv loop
  2598. return($val, $err);
  2599. }
  2600. #------------------------------------------------------------------------------
  2601. # convert tag names to values in a string (eg. '${EXIF:ISO}x $$' --> '100x $')
  2602. # Inputs: 0) ExifTool object ref, 1) reference to list of found tags
  2603. # 2) string with embedded tag names, 3) Options:
  2604. # undef - set missing tags to ''
  2605. # 'Error' - issue minor error on missing tag (and return undef)
  2606. # 'Warn' - issue minor warning on missing tag (and return undef)
  2607. # Hash ref - hash for return of tag/value pairs
  2608. # Returns: string with embedded tag values (or '$info{TAGNAME}' entries with Hash ref option)
  2609. # Notes:
  2610. # - tag names are not case sensitive and may end with '#' for ValueConv value
  2611. # - uses MissingTagValue option if set
  2612. # - '$GROUP:all' evaluates to 1 if any tag from GROUP exists, or 0 otherwise
  2613. # - advanced feature allows Perl expressions inside braces (eg. '${model;tr/ //d}')
  2614. # - an error/warning in an advanced expression ("${TAG;EXPR}") generates an error
  2615. # if option set to 'Error', or a warning otherwise
  2616. sub InsertTagValues($$$;$)
  2617. {
  2618. local $_;
  2619. my ($self, $foundTags, $line, $opt) = @_;
  2620. my $rtnStr = '';
  2621. while ($line =~ /(.*?)\$(\{\s*)?([-\w]*\w|\$|\/)(.*)/s) {
  2622. my (@tags, $pre, $var, $bra, $val, $tg, @vals, $type, $expr, $level);
  2623. ($pre, $bra, $var, $line) = ($1, $2, $3, $4);
  2624. # "$$" represents a "$" symbol, and "$/" is a newline
  2625. if ($var eq '$' or $var eq '/') {
  2626. $var = "\n" if $var eq '/';
  2627. $rtnStr .= "$pre$var";
  2628. $line =~ s/^\s*\}// if $bra;
  2629. next;
  2630. }
  2631. # allow multiple group names
  2632. while ($line =~ /^:([-\w]*\w)(.*)/s) {
  2633. my $group = $var;
  2634. ($var, $line) = ($1, $2);
  2635. $var = "$group:$var";
  2636. }
  2637. # allow trailing '#' to indicate ValueConv value
  2638. $type = 'ValueConv' if $line =~ s/^#//;
  2639. # remove trailing bracket if there was a leading one
  2640. # and extract Perl expression from inside brackets if it exists
  2641. if ($bra and not $line =~ s/^\s*\}// and $line =~ s/^\s*;\s*(.*?)\}//s) {
  2642. my $part = $1;
  2643. $expr = '';
  2644. for ($level=0; ; --$level) {
  2645. # increase nesting level for each opening brace
  2646. ++$level while $part =~ /\{/g;
  2647. $expr .= $part;
  2648. last unless $level and $line =~ s/^(.*?)\}//s; # get next part
  2649. $part = $1;
  2650. $expr .= '}'; # this brace was part of the expression
  2651. }
  2652. # use default Windows filename filter if expression is empty
  2653. $expr = 'tr(/\\\\?*:|"<>\\0)()d' unless length $expr;
  2654. }
  2655. push @tags, $var;
  2656. ExpandShortcuts(\@tags);
  2657. @tags or $rtnStr .= $pre, next;
  2658. for (;;) {
  2659. my $tag = shift @tags;
  2660. my $lcTag = lc $tag;
  2661. if ($lcTag eq 'all') {
  2662. $val = 1; # always some tag available
  2663. } elsif (defined $$self{OPTIONS}{UserParam}{$lcTag}) {
  2664. $val = $$self{OPTIONS}{UserParam}{$lcTag};
  2665. } elsif ($tag =~ /(.*):(.+)/) {
  2666. my $group;
  2667. ($group, $tag) = ($1, $2);
  2668. if (lc $tag eq 'all') {
  2669. # see if any tag from the specified group exists
  2670. my $match = $self->GroupMatches($group, $foundTags);
  2671. $val = $match ? 1 : 0;
  2672. } else {
  2673. # find the specified tag
  2674. my @matches = grep /^$tag(\s|$)/i, @$foundTags;
  2675. @matches = $self->GroupMatches($group, \@matches);
  2676. foreach $tg (@matches) {
  2677. if (defined $val and $tg =~ / \((\d+)\)$/) {
  2678. # take the most recently extracted tag
  2679. my $tagNum = $1;
  2680. next if $tag !~ / \((\d+)\)$/ or $1 > $tagNum;
  2681. }
  2682. $val = $self->GetValue($tg, $type);
  2683. $tag = $tg;
  2684. last unless $tag =~ / /; # all done if we got our best match
  2685. }
  2686. }
  2687. } else {
  2688. # get the tag value
  2689. $val = $self->GetValue($tag, $type);
  2690. unless (defined $val) {
  2691. # check for tag name with different case
  2692. ($tg) = grep /^$tag$/i, @$foundTags;
  2693. if (defined $tg) {
  2694. $val = $self->GetValue($tg, $type);
  2695. $tag = $tg;
  2696. }
  2697. }
  2698. }
  2699. if (ref $val eq 'ARRAY') {
  2700. $val = join($$self{OPTIONS}{ListSep}, @$val);
  2701. } elsif (ref $val eq 'SCALAR') {
  2702. if ($$self{OPTIONS}{Binary} or $$val =~ /^Binary data/) {
  2703. $val = $$val;
  2704. } else {
  2705. $val = 'Binary data ' . length($$val) . ' bytes';
  2706. }
  2707. } elsif (ref $val eq 'HASH') {
  2708. require 'Image/ExifTool/XMPStruct.pl';
  2709. $val = Image::ExifTool::XMP::SerializeStruct($val);
  2710. } elsif (not defined $val) {
  2711. last unless @tags;
  2712. next;
  2713. }
  2714. # evaluate advanced formatting expression if given (eg. "${TAG;EXPR}")
  2715. if (defined $expr) {
  2716. local $SIG{'__WARN__'} = \&SetWarning;
  2717. undef $evalWarning;
  2718. $_ = $val;
  2719. #### eval translation expression ($_, $self)
  2720. eval $expr;
  2721. $val = $_;
  2722. $@ and $evalWarning = $@;
  2723. if ($evalWarning) {
  2724. my $str = CleanWarning() . " for $tag";
  2725. ($opt and $opt eq 'Error') ? $self->Error($str) : $self->Warn($str);
  2726. }
  2727. }
  2728. last unless @tags;
  2729. push @vals, $val;
  2730. undef $val;
  2731. }
  2732. if (@vals) {
  2733. push @vals, $val if defined $val;
  2734. $val = join '', @vals;
  2735. }
  2736. unless (defined $val or ref $opt) {
  2737. $val = $$self{OPTIONS}{MissingTagValue};
  2738. unless (defined $val) {
  2739. no strict 'refs';
  2740. return undef if $opt and &$opt($self, "Tag '$var' not defined", 2);
  2741. $val = '';
  2742. }
  2743. }
  2744. if (ref $opt eq 'HASH') {
  2745. $var .= '#' if $type;
  2746. if (defined $expr) {
  2747. # generate unique variable name for this modified tag value
  2748. my $i = 1;
  2749. ++$i while exists $$opt{"$val.expr$i"};
  2750. $var .= '.expr' . $i;
  2751. }
  2752. $rtnStr .= "$pre\$info{'$var'}";
  2753. $$opt{$var} = $val;
  2754. } else {
  2755. $rtnStr .= "$pre$val";
  2756. }
  2757. }
  2758. return $rtnStr . $line;
  2759. }
  2760. #------------------------------------------------------------------------------
  2761. # Is specified tag writable
  2762. # Inputs: 0) tag name, case insensitive (optional group name currently ignored)
  2763. # Returns: 0=exists but not writable, 1=writable, undef=doesn't exist
  2764. sub IsWritable($)
  2765. {
  2766. my $tag = shift;
  2767. $tag =~ s/^(.*)://; # ignore group name
  2768. my @tagInfo = FindTagInfo($tag);
  2769. unless (@tagInfo) {
  2770. return 0 if TagExists($tag);
  2771. return undef;
  2772. }
  2773. my $tagInfo;
  2774. foreach $tagInfo (@tagInfo) {
  2775. return $$tagInfo{Writable} ? 1 : 0 if defined $$tagInfo{Writable};
  2776. return 1 if $$tagInfo{Table}{WRITABLE};
  2777. # must call WRITE_PROC to autoload writer because this may set the writable tag
  2778. my $writeProc = $$tagInfo{Table}{WRITE_PROC};
  2779. next unless $writeProc;
  2780. &$writeProc(); # dummy call to autoload writer
  2781. return 1 if $$tagInfo{Writable};
  2782. }
  2783. return 0;
  2784. }
  2785. #------------------------------------------------------------------------------
  2786. # Create directory for specified file
  2787. # Inputs: 0) ExifTool ref, 1) complete file name including path
  2788. # Returns: 1 = directory created, 0 = nothing done, -1 = error
  2789. my $k32CreateDir;
  2790. sub CreateDirectory($$)
  2791. {
  2792. local $_;
  2793. my ($self, $file) = @_;
  2794. my $rtnVal = 0;
  2795. my $enc = $$self{OPTIONS}{CharsetFileName};
  2796. my $dir;
  2797. ($dir = $file) =~ s/[^\/]*$//; # remove filename from path specification
  2798. # recode as UTF-8 if necessary
  2799. if ($dir and not $self->IsDirectory($dir)) {
  2800. my @parts = split /\//, $dir;
  2801. $dir = '';
  2802. foreach (@parts) {
  2803. $dir .= $_;
  2804. if (length $dir and not $self->IsDirectory($dir)) {
  2805. # create directory since it doesn't exist
  2806. my $d2 = $dir; # (must make a copy in case EncodeFileName recodes it)
  2807. if ($self->EncodeFileName($d2)) {
  2808. # handle Windows Unicode directory names
  2809. unless (eval { require Win32::API }) {
  2810. $self->Warn('Install Win32::API to create directories with Unicode names');
  2811. return -1;
  2812. }
  2813. unless ($k32CreateDir) {
  2814. return -1 if defined $k32CreateDir;
  2815. $k32CreateDir = new Win32::API('KERNEL32', 'CreateDirectoryW', 'PP', 'I');
  2816. unless ($k32CreateDir) {
  2817. $self->Warn('Error calling Win32::API::CreateDirectoryW');
  2818. $k32CreateDir = 0;
  2819. return -1;
  2820. }
  2821. }
  2822. $k32CreateDir->Call($d2, 0) or return -1;
  2823. } else {
  2824. mkdir($d2, 0777) or return -1;
  2825. }
  2826. $rtnVal = 1;
  2827. }
  2828. $dir .= '/';
  2829. }
  2830. }
  2831. return $rtnVal;
  2832. }
  2833. #------------------------------------------------------------------------------
  2834. # Copy file attributes from one file to another
  2835. # Inputs: 0) source file name, 1) destination file name
  2836. # Notes: eventually add support for extended attributes?
  2837. sub CopyFileAttrs($$)
  2838. {
  2839. my ($src, $dst) = @_;
  2840. my ($mode, $uid, $gid) = (stat($src))[2, 4, 5];
  2841. eval { chmod($mode & 07777, $dst) } if defined $mode;
  2842. eval { chown($uid, $gid, $dst) } if defined $uid and defined $gid;
  2843. }
  2844. #------------------------------------------------------------------------------
  2845. # Get new file path name
  2846. # Inputs: 0) existing name (may contain directory),
  2847. # 1) new file name, new directory, or new path (dir+name)
  2848. # Returns: new file path name
  2849. sub GetNewFileName($$)
  2850. {
  2851. my ($oldName, $newName) = @_;
  2852. my ($dir, $name) = ($oldName =~ m{(.*/)(.*)});
  2853. ($dir, $name) = ('', $oldName) unless defined $dir;
  2854. if ($newName =~ m{/$}) {
  2855. $newName = "$newName$name"; # change dir only
  2856. } elsif ($newName !~ m{/}) {
  2857. $newName = "$dir$newName"; # change name only if newname doesn't specify dir
  2858. } # else change dir and name
  2859. return $newName;
  2860. }
  2861. #------------------------------------------------------------------------------
  2862. # Get next available tag key
  2863. # Inputs: 0) hash reference (keys are tag keys), 1) tag name
  2864. # Returns: next available tag key
  2865. sub NextFreeTagKey($$)
  2866. {
  2867. my ($info, $tag) = @_;
  2868. return $tag unless exists $$info{$tag};
  2869. my $i;
  2870. for ($i=1; ; ++$i) {
  2871. my $key = "$tag ($i)";
  2872. return $key unless exists $$info{$key};
  2873. }
  2874. }
  2875. #------------------------------------------------------------------------------
  2876. # Reverse hash lookup
  2877. # Inputs: 0) value, 1) hash reference
  2878. # Returns: Hash key or undef if not found (plus flag for multiple matches in list context)
  2879. sub ReverseLookup($$)
  2880. {
  2881. my ($val, $conv) = @_;
  2882. return undef unless defined $val;
  2883. my $multi;
  2884. if ($val =~ /^Unknown\s*\((.*)\)$/i) {
  2885. $val = $1; # was unknown
  2886. if ($val =~ /^0x([\da-fA-F]+)$/) {
  2887. $val = hex($val); # convert hex value
  2888. }
  2889. } else {
  2890. my $qval = $val;
  2891. $qval =~ s/\s+$//; # remove trailing whitespace
  2892. $qval = quotemeta $qval;
  2893. my @patterns = (
  2894. "^$qval\$", # exact match
  2895. "^(?i)$qval\$", # case-insensitive
  2896. "^(?i)$qval", # beginning of string
  2897. "(?i)$qval", # substring
  2898. );
  2899. # hash entries to ignore in reverse lookup
  2900. my ($pattern, $found, $matches);
  2901. PAT: foreach $pattern (@patterns) {
  2902. $matches = scalar grep /$pattern/, values(%$conv);
  2903. next unless $matches;
  2904. # multiple matches are bad unless they were exact
  2905. if ($matches > 1 and $pattern !~ /\$$/) {
  2906. # don't match entries that we should ignore
  2907. foreach (keys %ignorePrintConv) {
  2908. --$matches if defined $$conv{$_} and $$conv{$_} =~ /$pattern/;
  2909. }
  2910. last if $matches > 1;
  2911. }
  2912. foreach (sort keys %$conv) {
  2913. next if $$conv{$_} !~ /$pattern/ or $ignorePrintConv{$_};
  2914. $val = $_;
  2915. $found = 1;
  2916. last PAT;
  2917. }
  2918. }
  2919. unless ($found) {
  2920. # call OTHER conversion routine if available
  2921. $val = $$conv{OTHER} ? &{$$conv{OTHER}}($val,1,$conv) : undef;
  2922. $multi = 1 if $matches > 1;
  2923. }
  2924. }
  2925. return ($val, $multi) if wantarray;
  2926. return $val;
  2927. }
  2928. #------------------------------------------------------------------------------
  2929. # Return true if we are deleting or overwriting the specified tag
  2930. # Inputs: 0) ExifTool object ref, 1) new value hash reference
  2931. # 2) optional tag value (before RawConv) if deleting specific values
  2932. # Returns: >0 - tag should be overwritten
  2933. # =0 - the tag should be preserved
  2934. # <0 - not sure, we need the value to know
  2935. sub IsOverwriting($$;$)
  2936. {
  2937. my ($self, $nvHash, $val) = @_;
  2938. return 0 unless $nvHash;
  2939. # overwrite regardless if no DelValues specified
  2940. return 1 unless $$nvHash{DelValue};
  2941. # never overwrite if DelValue list exists but is empty
  2942. my $shift = $$nvHash{Shift};
  2943. return 0 unless @{$$nvHash{DelValue}} or defined $shift;
  2944. # return "don't know" if we don't have a value to test
  2945. return -1 unless defined $val;
  2946. # apply raw conversion if necessary
  2947. my $tagInfo = $$nvHash{TagInfo};
  2948. my $conv = $$tagInfo{RawConv};
  2949. if ($conv) {
  2950. local $SIG{'__WARN__'} = \&SetWarning;
  2951. undef $evalWarning;
  2952. if (ref $conv eq 'CODE') {
  2953. $val = &$conv($val, $self);
  2954. } else {
  2955. my $tag = $$tagInfo{Name};
  2956. #### eval RawConv ($self, $val, $tag, $tagInfo)
  2957. $val = eval $conv;
  2958. $@ and $evalWarning = $@;
  2959. }
  2960. return -1 unless defined $val;
  2961. }
  2962. # do not overwrite if only creating
  2963. return 0 if $$nvHash{CreateOnly};
  2964. # apply time/number shift if necessary
  2965. if (defined $shift) {
  2966. my $shiftType = $$tagInfo{Shift};
  2967. unless ($shiftType and $shiftType eq 'Time') {
  2968. unless (IsFloat($val)) {
  2969. $self->Warn("Can't shift $$tagInfo{Name} (not a number)");
  2970. return 0;
  2971. }
  2972. $shiftType = 'Number'; # allow any number to be shifted
  2973. }
  2974. require 'Image/ExifTool/Shift.pl';
  2975. my $err = $self->ApplyShift($shiftType, $shift, $val, $nvHash);
  2976. if ($err) {
  2977. $self->Warn("$err when shifting $$tagInfo{Name}");
  2978. return 0;
  2979. }
  2980. # ensure that the shifted value is valid and reformat if necessary
  2981. my $checkVal = $self->GetNewValue($nvHash);
  2982. return 0 unless defined $checkVal;
  2983. # don't bother overwriting if value is the same
  2984. return 0 if $val eq $$nvHash{Value}[0];
  2985. return 1;
  2986. }
  2987. # return 1 if value matches a DelValue
  2988. my $delVal;
  2989. foreach $delVal (@{$$nvHash{DelValue}}) {
  2990. return 1 if $val eq $delVal;
  2991. }
  2992. return 0;
  2993. }
  2994. #------------------------------------------------------------------------------
  2995. # Get write group for specified tag
  2996. # Inputs: 0) new value hash reference
  2997. # Returns: Write group name
  2998. sub GetWriteGroup($)
  2999. {
  3000. return $_[0]{WriteGroup};
  3001. }
  3002. #------------------------------------------------------------------------------
  3003. # Get name of write group or family 1 group
  3004. # Inputs: 0) ExifTool ref, 1) tagInfo ref, 2) write group name
  3005. # Returns: Name of group for verbose message
  3006. sub GetWriteGroup1($$)
  3007. {
  3008. my ($self, $tagInfo, $writeGroup) = @_;
  3009. return $writeGroup unless $writeGroup =~ /^(MakerNotes|XMP|Composite)$/;
  3010. return $self->GetGroup($tagInfo, 1);
  3011. }
  3012. #------------------------------------------------------------------------------
  3013. # Get new value hash for specified tagInfo/writeGroup
  3014. # Inputs: 0) ExifTool object reference, 1) reference to tag info hash
  3015. # 2) Write group name, 3) Options: 'delete' or 'create'
  3016. # 4) optional ProtectSaved value
  3017. # Returns: new value hash reference for specified write group
  3018. # (or first new value hash in linked list if write group not specified)
  3019. # Notes: May return undef when 'create' is used with ProtectSaved
  3020. sub GetNewValueHash($$;$$$)
  3021. {
  3022. my ($self, $tagInfo, $writeGroup, $opts) = @_;
  3023. my $nvHash = $$self{NEW_VALUE}{$tagInfo};
  3024. my %opts; # quick lookup for options
  3025. $opts and $opts{$opts} = 1;
  3026. $writeGroup = '' unless defined $writeGroup;
  3027. if ($writeGroup) {
  3028. # find the new value in the list with the specified write group
  3029. # (QuickTime is a special case because all group1 tags may be updated at once)
  3030. while ($nvHash and $$nvHash{WriteGroup} ne $writeGroup and
  3031. $$nvHash{WriteGroup} ne 'QuickTime')
  3032. {
  3033. $nvHash = $$nvHash{Next};
  3034. }
  3035. }
  3036. # remove this entry if deleting, or if creating a new entry and
  3037. # this entry is marked with "Save" flag
  3038. if (defined $nvHash and ($opts{'delete'} or ($opts{'create'} and $$nvHash{Save}))) {
  3039. my $protect = (defined $_[4] and defined $$nvHash{Save} and $$nvHash{Save} > $_[4]);
  3040. if ($protect and not ($$nvHash{NoReplace} and $opts{create})) {
  3041. return undef; # honour ProtectSaved value by not writing this tag
  3042. } elsif ($opts{'delete'}) {
  3043. $self->RemoveNewValueHash($nvHash, $tagInfo);
  3044. undef $nvHash;
  3045. } else {
  3046. # save a copy of this new value hash
  3047. my %copy = %$nvHash;
  3048. # make copy of Value and DelValue lists
  3049. my $key;
  3050. foreach $key (keys %copy) {
  3051. next unless ref $copy{$key} eq 'ARRAY';
  3052. $copy{$key} = [ @{$copy{$key}} ];
  3053. }
  3054. my $saveHash = $$self{SAVE_NEW_VALUE};
  3055. # add to linked list of saved new value hashes
  3056. $copy{Next} = $$saveHash{$tagInfo};
  3057. $$saveHash{$tagInfo} = \%copy;
  3058. delete $$nvHash{Save}; # don't save it again
  3059. $$nvHash{AddBefore} = scalar @{$$nvHash{Value}} if $protect and $$nvHash{Value};
  3060. }
  3061. }
  3062. if (not defined $nvHash and $opts{'create'}) {
  3063. # create a new entry
  3064. $nvHash = {
  3065. TagInfo => $tagInfo,
  3066. WriteGroup => $writeGroup,
  3067. IsNVH => 1, # set flag so we can recognize a new value hash
  3068. };
  3069. # add entry to our NEW_VALUE hash
  3070. if ($$self{NEW_VALUE}{$tagInfo}) {
  3071. # add to end of linked list
  3072. my $lastHash = LastInList($$self{NEW_VALUE}{$tagInfo});
  3073. $$lastHash{Next} = $nvHash;
  3074. } else {
  3075. $$self{NEW_VALUE}{$tagInfo} = $nvHash;
  3076. }
  3077. }
  3078. return $nvHash;
  3079. }
  3080. #------------------------------------------------------------------------------
  3081. # Load all tag tables
  3082. sub LoadAllTables()
  3083. {
  3084. return if $loadedAllTables;
  3085. # load all of our non-referenced tables (first our modules)
  3086. my $table;
  3087. foreach $table (@loadAllTables) {
  3088. my $tableName = "Image::ExifTool::$table";
  3089. $tableName .= '::Main' unless $table =~ /:/;
  3090. GetTagTable($tableName);
  3091. }
  3092. # (then our special tables)
  3093. GetTagTable('Image::ExifTool::Extra');
  3094. GetTagTable('Image::ExifTool::Composite');
  3095. # recursively load all tables referenced by the current tables
  3096. my @tableNames = keys %allTables;
  3097. my %pushedTables;
  3098. while (@tableNames) {
  3099. $table = GetTagTable(shift @tableNames);
  3100. # call write proc if it exists in case it adds tags to the table
  3101. my $writeProc = $$table{WRITE_PROC};
  3102. $writeProc and &$writeProc();
  3103. # recursively scan through tables in subdirectories
  3104. foreach (TagTableKeys($table)) {
  3105. my @infoArray = GetTagInfoList($table,$_);
  3106. my $tagInfo;
  3107. foreach $tagInfo (@infoArray) {
  3108. my $subdir = $$tagInfo{SubDirectory} or next;
  3109. my $tableName = $$subdir{TagTable} or next;
  3110. # next if table already loaded or queued for loading
  3111. next if $allTables{$tableName} or $pushedTables{$tableName};
  3112. push @tableNames, $tableName; # must scan this one too
  3113. $pushedTables{$tableName} = 1;
  3114. }
  3115. }
  3116. }
  3117. $loadedAllTables = 1;
  3118. }
  3119. #------------------------------------------------------------------------------
  3120. # Remove new value hash from linked list (and save if necessary)
  3121. # Inputs: 0) ExifTool object reference, 1) new value hash ref, 2) tagInfo ref
  3122. sub RemoveNewValueHash($$$)
  3123. {
  3124. my ($self, $nvHash, $tagInfo) = @_;
  3125. my $firstHash = $$self{NEW_VALUE}{$tagInfo};
  3126. if ($nvHash eq $firstHash) {
  3127. # remove first entry from linked list
  3128. if ($$nvHash{Next}) {
  3129. $$self{NEW_VALUE}{$tagInfo} = $$nvHash{Next};
  3130. } else {
  3131. delete $$self{NEW_VALUE}{$tagInfo};
  3132. }
  3133. } else {
  3134. # find the list element pointing to this hash
  3135. $firstHash = $$firstHash{Next} while $$firstHash{Next} ne $nvHash;
  3136. # remove from linked list
  3137. $$firstHash{Next} = $$nvHash{Next};
  3138. }
  3139. # save the existing entry if necessary
  3140. if ($$nvHash{Save}) {
  3141. my $saveHash = $$self{SAVE_NEW_VALUE};
  3142. # add to linked list of saved new value hashes
  3143. $$nvHash{Next} = $$saveHash{$tagInfo};
  3144. $$saveHash{$tagInfo} = $nvHash;
  3145. }
  3146. }
  3147. #------------------------------------------------------------------------------
  3148. # Remove all new value entries for specified group
  3149. # Inputs: 0) ExifTool object reference, 1) group name
  3150. sub RemoveNewValuesForGroup($$)
  3151. {
  3152. my ($self, $group) = @_;
  3153. return unless $$self{NEW_VALUE};
  3154. # make list of all groups we must remove
  3155. my @groups = ( $group );
  3156. push @groups, @{$removeGroups{$group}} if $removeGroups{$group};
  3157. my ($out, @keys, $hashKey);
  3158. $out = $$self{OPTIONS}{TextOut} if $$self{OPTIONS}{Verbose} > 1;
  3159. # loop though all new values, and remove any in this group
  3160. @keys = keys %{$$self{NEW_VALUE}};
  3161. foreach $hashKey (@keys) {
  3162. my $nvHash = $$self{NEW_VALUE}{$hashKey};
  3163. # loop through each entry in linked list
  3164. for (;;) {
  3165. my $nextHash = $$nvHash{Next};
  3166. my $tagInfo = $$nvHash{TagInfo};
  3167. my ($grp0,$grp1) = $self->GetGroup($tagInfo);
  3168. my $wgrp = $$nvHash{WriteGroup};
  3169. # use group1 if write group is not specific
  3170. $wgrp = $grp1 if $wgrp eq $grp0;
  3171. if (grep /^($grp0|$wgrp)$/i, @groups) {
  3172. $out and print $out "Removed new value for $wgrp:$$tagInfo{Name}\n";
  3173. # remove from linked list
  3174. $self->RemoveNewValueHash($nvHash, $tagInfo);
  3175. }
  3176. $nvHash = $nextHash or last;
  3177. }
  3178. }
  3179. }
  3180. #------------------------------------------------------------------------------
  3181. # Get list of tagInfo hashes for all new data
  3182. # Inputs: 0) ExifTool object reference, 1) optional tag table pointer
  3183. # Returns: list of tagInfo hashes
  3184. sub GetNewTagInfoList($;$)
  3185. {
  3186. my ($self, $tagTablePtr) = @_;
  3187. my @tagInfoList;
  3188. my $nv = $$self{NEW_VALUE};
  3189. if ($nv) {
  3190. my $hashKey;
  3191. foreach $hashKey (keys %$nv) {
  3192. my $tagInfo = $$nv{$hashKey}{TagInfo};
  3193. next if $tagTablePtr and $tagTablePtr ne $$tagInfo{Table};
  3194. push @tagInfoList, $tagInfo;
  3195. }
  3196. }
  3197. return @tagInfoList;
  3198. }
  3199. #------------------------------------------------------------------------------
  3200. # Get hash of tagInfo references keyed on tagID for a specific table
  3201. # Inputs: 0) ExifTool object reference, 1-N) tag table pointers
  3202. # Returns: hash reference
  3203. # Notes: returns only one tagInfo ref for each conditional list
  3204. sub GetNewTagInfoHash($@)
  3205. {
  3206. my $self = shift;
  3207. my (%tagInfoHash, $hashKey);
  3208. my $nv = $$self{NEW_VALUE};
  3209. while ($nv) {
  3210. my $tagTablePtr = shift || last;
  3211. foreach $hashKey (keys %$nv) {
  3212. my $tagInfo = $$nv{$hashKey}{TagInfo};
  3213. next if $tagTablePtr and $tagTablePtr ne $$tagInfo{Table};
  3214. $tagInfoHash{$$tagInfo{TagID}} = $tagInfo;
  3215. }
  3216. }
  3217. return \%tagInfoHash;
  3218. }
  3219. #------------------------------------------------------------------------------
  3220. # Get a tagInfo/tagID hash for subdirectories we need to add
  3221. # Inputs: 0) ExifTool object reference, 1) parent tag table reference
  3222. # 2) parent directory name (taken from GROUP0 of tag table if not defined)
  3223. # Returns: Reference to Hash of subdirectory tagInfo references keyed by tagID
  3224. # (plus Reference to edit directory hash in list context)
  3225. sub GetAddDirHash($$;$)
  3226. {
  3227. my ($self, $tagTablePtr, $parent) = @_;
  3228. $parent or $parent = $$tagTablePtr{GROUPS}{0};
  3229. my $tagID;
  3230. my %addDirHash;
  3231. my %editDirHash;
  3232. my $addDirs = $$self{ADD_DIRS};
  3233. my $editDirs = $$self{EDIT_DIRS};
  3234. foreach $tagID (TagTableKeys($tagTablePtr)) {
  3235. my @infoArray = GetTagInfoList($tagTablePtr,$tagID);
  3236. my $tagInfo;
  3237. foreach $tagInfo (@infoArray) {
  3238. next unless $$tagInfo{SubDirectory};
  3239. # get name for this sub directory
  3240. # (take directory name from SubDirectory DirName if it exists,
  3241. # otherwise Group0 name of SubDirectory TagTable or tag Group1 name)
  3242. my $dirName = $$tagInfo{SubDirectory}{DirName};
  3243. unless ($dirName) {
  3244. # use tag name for directory name and save for next time
  3245. $dirName = $$tagInfo{Name};
  3246. $$tagInfo{SubDirectory}{DirName} = $dirName;
  3247. }
  3248. # save this directory information if we are writing it
  3249. if ($$editDirs{$dirName} and $$editDirs{$dirName} eq $parent) {
  3250. $editDirHash{$tagID} = $tagInfo;
  3251. $addDirHash{$tagID} = $tagInfo if $$addDirs{$dirName};
  3252. }
  3253. }
  3254. }
  3255. return (\%addDirHash, \%editDirHash) if wantarray;
  3256. return \%addDirHash;
  3257. }
  3258. #------------------------------------------------------------------------------
  3259. # Get localized version of tagInfo hash (used by MIE, XMP, PNG and QuickTime)
  3260. # Inputs: 0) tagInfo hash ref, 1) locale code (eg. "en_CA" for MIE)
  3261. # Returns: new tagInfo hash ref, or undef if invalid
  3262. # - sets LangCode member in new tagInfo
  3263. sub GetLangInfo($$)
  3264. {
  3265. my ($tagInfo, $langCode) = @_;
  3266. # make a new tagInfo hash for this locale
  3267. my $table = $$tagInfo{Table};
  3268. my $tagID = $$tagInfo{TagID} . '-' . $langCode;
  3269. my $langInfo = $$table{$tagID};
  3270. unless ($langInfo) {
  3271. # make a new tagInfo entry for this locale
  3272. $langInfo = {
  3273. %$tagInfo,
  3274. Name => $$tagInfo{Name} . '-' . $langCode,
  3275. Description => Image::ExifTool::MakeDescription($$tagInfo{Name}) .
  3276. " ($langCode)",
  3277. LangCode => $langCode,
  3278. SrcTagInfo => $tagInfo, # save reference to original tagInfo
  3279. };
  3280. AddTagToTable($table, $tagID, $langInfo);
  3281. }
  3282. return $langInfo;
  3283. }
  3284. #------------------------------------------------------------------------------
  3285. # initialize ADD_DIRS and EDIT_DIRS hashes for all directories that need
  3286. # need to be created or will have tags changed in them
  3287. # Inputs: 0) ExifTool object reference, 1) file type string (or map hash ref)
  3288. # 2) preferred family 0 group name for creating tags
  3289. # Notes: The ADD_DIRS and EDIT_DIRS keys are the directory names, and the values
  3290. # are the names of the parent directories (undefined for a top-level directory)
  3291. sub InitWriteDirs($$;$)
  3292. {
  3293. my ($self, $fileType, $preferredGroup) = @_;
  3294. my $editDirs = $$self{EDIT_DIRS} = { };
  3295. my $addDirs = $$self{ADD_DIRS} = { };
  3296. my $fileDirs = $dirMap{$fileType};
  3297. unless ($fileDirs) {
  3298. return unless ref $fileType eq 'HASH';
  3299. $fileDirs = $fileType;
  3300. }
  3301. my @tagInfoList = $self->GetNewTagInfoList();
  3302. my ($tagInfo, $nvHash);
  3303. # save the preferred group
  3304. $$self{PreferredGroup} = $preferredGroup;
  3305. foreach $tagInfo (@tagInfoList) {
  3306. # cycle through all hashes in linked list
  3307. for ($nvHash=$self->GetNewValueHash($tagInfo); $nvHash; $nvHash=$$nvHash{Next}) {
  3308. # are we creating this tag? (otherwise just deleting or editing it)
  3309. my $isCreating = $$nvHash{IsCreating};
  3310. if ($isCreating) {
  3311. # if another group is taking priority, only create
  3312. # directory if specifically adding tags to this group
  3313. # or if this tag isn't being added to the priority group
  3314. $isCreating = 0 if $preferredGroup and
  3315. $preferredGroup ne $self->GetGroup($tagInfo, 0) and
  3316. $$nvHash{CreateGroups}{$preferredGroup};
  3317. } else {
  3318. # creating this directory if any tag is preferred and has a value
  3319. $isCreating = 1 if ($preferredGroup and $$nvHash{Value} and
  3320. $preferredGroup eq $self->GetGroup($tagInfo, 0)) and
  3321. not $$nvHash{EditOnly};
  3322. }
  3323. # tag belongs to directory specified by WriteGroup, or by
  3324. # the Group0 name if WriteGroup not defined
  3325. my $dirName = $$nvHash{WriteGroup};
  3326. # remove MIE copy number(s) if they exist
  3327. if ($dirName =~ /^MIE\d*(-[a-z]+)?\d*$/i) {
  3328. $dirName = 'MIE' . ($1 || '');
  3329. }
  3330. my @dirNames;
  3331. while ($dirName) {
  3332. my $parent = $$fileDirs{$dirName};
  3333. if (ref $parent) {
  3334. push @dirNames, reverse @$parent;
  3335. $parent = pop @dirNames;
  3336. }
  3337. $$editDirs{$dirName} = $parent;
  3338. $$addDirs{$dirName} = $parent if $isCreating and $isCreating != 2;
  3339. $dirName = $parent || shift @dirNames
  3340. }
  3341. }
  3342. }
  3343. if (%{$$self{DEL_GROUP}}) {
  3344. # add delete groups to list of edited groups
  3345. foreach (keys %{$$self{DEL_GROUP}}) {
  3346. next if /^-/; # ignore excluded groups
  3347. my $dirName = $_;
  3348. # translate necessary group 0 names
  3349. $dirName = $translateWriteGroup{$dirName} if $translateWriteGroup{$dirName};
  3350. # convert XMP group 1 names
  3351. $dirName = 'XMP' if $dirName =~ /^XMP-/;
  3352. my @dirNames;
  3353. while ($dirName) {
  3354. my $parent = $$fileDirs{$dirName};
  3355. if (ref $parent) {
  3356. push @dirNames, reverse @$parent;
  3357. $parent = pop @dirNames;
  3358. }
  3359. $$editDirs{$dirName} = $parent;
  3360. $dirName = $parent || shift @dirNames
  3361. }
  3362. }
  3363. }
  3364. # special case to edit JFIF to get resolutions if editing EXIF information
  3365. if ($$editDirs{IFD0} and $$fileDirs{JFIF}) {
  3366. $$editDirs{JFIF} = 'IFD1';
  3367. $$editDirs{APP0} = undef;
  3368. }
  3369. if ($$self{OPTIONS}{Verbose}) {
  3370. my $out = $$self{OPTIONS}{TextOut};
  3371. print $out " Editing tags in: ";
  3372. foreach (sort keys %$editDirs) { print $out "$_ "; }
  3373. print $out "\n";
  3374. return unless $$self{OPTIONS}{Verbose} > 1;
  3375. print $out " Creating tags in: ";
  3376. foreach (sort keys %$addDirs) { print $out "$_ "; }
  3377. print $out "\n";
  3378. }
  3379. }
  3380. #------------------------------------------------------------------------------
  3381. # Write an image directory
  3382. # Inputs: 0) ExifTool object reference, 1) source directory information reference
  3383. # 2) tag table reference, 3) optional reference to writing procedure
  3384. # Returns: New directory data or undefined on error
  3385. sub WriteDirectory($$$;$)
  3386. {
  3387. my ($self, $dirInfo, $tagTablePtr, $writeProc) = @_;
  3388. my ($out, $nvHash);
  3389. $tagTablePtr or return undef;
  3390. $out = $$self{OPTIONS}{TextOut} if $$self{OPTIONS}{Verbose};
  3391. # set directory name from default group0 name if not done already
  3392. my $dirName = $$dirInfo{DirName};
  3393. my $dataPt = $$dirInfo{DataPt};
  3394. my $grp0 = $$tagTablePtr{GROUPS}{0};
  3395. $dirName or $dirName = $$dirInfo{DirName} = $grp0;
  3396. if (%{$$self{DEL_GROUP}}) {
  3397. my $delGroup = $$self{DEL_GROUP};
  3398. # delete entire directory if specified
  3399. my $grp1 = $dirName;
  3400. my $delFlag = ($$delGroup{$grp0} or $$delGroup{$grp1});
  3401. if ($delFlag) {
  3402. unless ($blockExifTypes{$$self{FILE_TYPE}}) {
  3403. # restrict delete logic to prevent entire tiff image from being killed
  3404. # (don't allow IFD0 to be deleted, and delete only ExifIFD if EXIF specified)
  3405. if ($$self{FILE_TYPE} eq 'PSD') {
  3406. # don't delete Photoshop directories from PSD image
  3407. undef $grp1 if $grp0 eq 'Photoshop';
  3408. } elsif ($$self{FILE_TYPE} =~ /^(EPS|PS)$/) {
  3409. # allow anything to be deleted from PostScript files
  3410. } elsif ($grp1 eq 'IFD0') {
  3411. my $type = $$self{TIFF_TYPE} || $$self{FILE_TYPE};
  3412. $$delGroup{IFD0} and $self->Warn("Can't delete IFD0 from $type",1);
  3413. undef $grp1;
  3414. } elsif ($grp0 eq 'EXIF' and $$delGroup{$grp0}) {
  3415. undef $grp1 unless $$delGroup{$grp1} or $grp1 eq 'ExifIFD';
  3416. }
  3417. }
  3418. if ($grp1) {
  3419. if ($dataPt or $$dirInfo{RAF}) {
  3420. ++$$self{CHANGED};
  3421. $out and print $out " Deleting $grp1\n";
  3422. # can no longer validate TIFF_END if deleting an entire IFD
  3423. delete $$self{TIFF_END} if $dirName =~ /IFD/;
  3424. }
  3425. # don't add back into the wrong location
  3426. my $right = $$self{ADD_DIRS}{$grp1};
  3427. # (take care because EXIF directory name may be either EXIF or IFD0,
  3428. # but IFD0 will be the one that appears in the directory map)
  3429. $right = $$self{ADD_DIRS}{IFD0} if not $right and $grp1 eq 'EXIF';
  3430. if ($delFlag == 2 and $right) {
  3431. # also check grandparent because some routines create 2 levels in 1
  3432. my $right2 = $$self{ADD_DIRS}{$right} || '';
  3433. my $parent = $$dirInfo{Parent};
  3434. if (not $parent or $parent eq $right or $parent eq $right2) {
  3435. # prevent duplicate directories from being recreated at the same path
  3436. my $path = join '-', @{$$self{PATH}}, $dirName;
  3437. $$self{Recreated} or $$self{Recreated} = { };
  3438. if ($$self{Recreated}{$path}) {
  3439. my $p = $parent ? " in $parent" : '';
  3440. $self->Warn("Not recreating duplicate $grp1$p",1);
  3441. return '';
  3442. }
  3443. $$self{Recreated}{$path} = 1;
  3444. # empty the directory
  3445. my $data = '';
  3446. $$dirInfo{DataPt} = \$data;
  3447. $$dirInfo{DataLen} = 0;
  3448. $$dirInfo{DirStart} = 0;
  3449. $$dirInfo{DirLen} = 0;
  3450. delete $$dirInfo{RAF};
  3451. delete $$dirInfo{Base};
  3452. delete $$dirInfo{DataPos};
  3453. } else {
  3454. $self->Warn("Not recreating $grp1 in $parent (should be in $right)",1);
  3455. return '';
  3456. }
  3457. } else {
  3458. return '' unless $$dirInfo{NoDelete};
  3459. }
  3460. }
  3461. }
  3462. }
  3463. # use default proc from tag table if no proc specified
  3464. $writeProc or $writeProc = $$tagTablePtr{WRITE_PROC} or return undef;
  3465. # are we rewriting a pre-existing directory?
  3466. my $isRewriting = ($$dirInfo{DirLen} or (defined $dataPt and length $$dataPt) or $$dirInfo{RAF});
  3467. # copy or delete new directory as a block if specified
  3468. my $blockName = $dirName;
  3469. $blockName = 'EXIF' if $blockName eq 'IFD0';
  3470. my $tagInfo = $Image::ExifTool::Extra{$blockName} || $$dirInfo{TagInfo};
  3471. while ($tagInfo and ($nvHash = $$self{NEW_VALUE}{$tagInfo}) and
  3472. $self->IsOverwriting($nvHash) and not ($$nvHash{CreateOnly} and $isRewriting))
  3473. {
  3474. # protect against writing EXIF to wrong file types, etc
  3475. if ($blockName eq 'EXIF') {
  3476. unless ($blockExifTypes{$$self{FILE_TYPE}}) {
  3477. $self->Warn("Can't write EXIF as a block to $$self{FILE_TYPE} file");
  3478. last;
  3479. }
  3480. # this can happen if we call WriteDirectory for an EXIF directory without going
  3481. # through WriteTIFF as the WriteProc (which happens if conditionally replacing
  3482. # the EXIF block and the condition fails), but we never want to do a block write
  3483. # in this case because the EXIF block would end up with two TIFF headers
  3484. last unless $writeProc eq \&Image::ExifTool::WriteTIFF;
  3485. }
  3486. last unless $self->IsOverwriting($nvHash, $dataPt ? $$dataPt : '');
  3487. my $verb = 'Writing';
  3488. my $newVal = $self->GetNewValue($nvHash);
  3489. unless (defined $newVal and length $newVal) {
  3490. return '' unless $dataPt or $$dirInfo{RAF}; # nothing to do if block never existed
  3491. $verb = 'Deleting';
  3492. $newVal = '';
  3493. }
  3494. $$dirInfo{BlockWrite} = 1; # set flag indicating we did a block write
  3495. $out and print $out " $verb $blockName as a block\n";
  3496. ++$$self{CHANGED};
  3497. return $newVal;
  3498. }
  3499. # guard against writing the same directory twice
  3500. if (defined $dataPt and defined $$dirInfo{DirStart} and defined $$dirInfo{DataPos}) {
  3501. my $addr = $$dirInfo{DirStart} + $$dirInfo{DataPos} + ($$dirInfo{Base}||0) + $$self{BASE};
  3502. # (Phase One P25 IIQ files have ICC_Profile duplicated in IFD0 and IFD1)
  3503. if ($$self{PROCESSED}{$addr} and ($dirName ne 'ICC_Profile' or $$self{TIFF_TYPE} ne 'IIQ')) {
  3504. if (defined $$dirInfo{DirLen} and not $$dirInfo{DirLen} and $dirName ne $$self{PROCESSED}{$addr}) {
  3505. # it is hypothetically possible to have 2 different directories
  3506. # with the same address if one has a length of zero
  3507. } elsif ($self->Error("$dirName pointer references previous $$self{PROCESSED}{$addr} directory", 2)) {
  3508. return undef;
  3509. } else {
  3510. $self->Warn("Deleting duplicate $dirName directory");
  3511. $out and print $out " Deleting $dirName\n";
  3512. return ''; # delete the duplicate directory
  3513. }
  3514. } else {
  3515. $$self{PROCESSED}{$addr} = $dirName;
  3516. }
  3517. }
  3518. my $oldDir = $$self{DIR_NAME};
  3519. my $name;
  3520. if ($out) {
  3521. $name = ($dirName eq 'MakerNotes' and $$dirInfo{TagInfo}) ?
  3522. $$dirInfo{TagInfo}{Name} : $dirName;
  3523. if (not defined $oldDir or $oldDir ne $name) {
  3524. my $verb = $isRewriting ? 'Rewriting' : 'Creating';
  3525. print $out " $verb $name\n";
  3526. }
  3527. }
  3528. my $saveOrder = GetByteOrder();
  3529. my $oldChanged = $$self{CHANGED};
  3530. $$self{DIR_NAME} = $dirName;
  3531. push @{$$self{PATH}}, $dirName;
  3532. $$dirInfo{IsWriting} = 1;
  3533. my $newData = &$writeProc($self, $dirInfo, $tagTablePtr);
  3534. pop @{$$self{PATH}};
  3535. # nothing changed if error occurred or nothing was created
  3536. $$self{CHANGED} = $oldChanged unless defined $newData and (length($newData) or $isRewriting);
  3537. $$self{DIR_NAME} = $oldDir;
  3538. SetByteOrder($saveOrder);
  3539. print $out " Deleting $name\n" if $out and defined $newData and not length $newData;
  3540. return $newData;
  3541. }
  3542. #------------------------------------------------------------------------------
  3543. # Uncommon utility routines to for reading binary data values
  3544. # Inputs: 0) data reference, 1) offset into data
  3545. sub Get64s($$)
  3546. {
  3547. my ($dataPt, $pos) = @_;
  3548. my $pt = GetByteOrder() eq 'MM' ? 0 : 4; # get position of high word
  3549. my $hi = Get32s($dataPt, $pos + $pt); # preserve sign bit of high word
  3550. my $lo = Get32u($dataPt, $pos + 4 - $pt);
  3551. return $hi * 4294967296 + $lo;
  3552. }
  3553. sub Get64u($$)
  3554. {
  3555. my ($dataPt, $pos) = @_;
  3556. my $pt = GetByteOrder() eq 'MM' ? 0 : 4; # get position of high word
  3557. my $hi = Get32u($dataPt, $pos + $pt); # (unsigned this time)
  3558. my $lo = Get32u($dataPt, $pos + 4 - $pt);
  3559. return $hi * 4294967296 + $lo;
  3560. }
  3561. # Decode extended 80-bit float used by Apple SANE and Intel 8087
  3562. # (note: different than the IEEE standard 80-bit float)
  3563. sub GetExtended($$)
  3564. {
  3565. my ($dataPt, $pos) = @_;
  3566. my $pt = GetByteOrder() eq 'MM' ? 0 : 2; # get position of exponent
  3567. my $exp = Get16u($dataPt, $pos + $pt);
  3568. my $sig = Get64u($dataPt, $pos + 2 - $pt); # get significand as int64u
  3569. my $sign = $exp & 0x8000 ? -1 : 1;
  3570. $exp = ($exp & 0x7fff) - 16383 - 63; # (-63 to fractionalize significand)
  3571. return $sign * $sig * 2 ** $exp;
  3572. }
  3573. #------------------------------------------------------------------------------
  3574. # Dump data in hex and ASCII to console
  3575. # Inputs: 0) data reference, 1) length or undef, 2-N) Options:
  3576. # Options: Start => offset to start of data (default=0)
  3577. # Addr => address to print for data start (default=DataPos+Base+Start)
  3578. # DataPos => position of data within block (relative to Base)
  3579. # Base => base offset for pointers from start of file
  3580. # Width => width of printout (bytes, default=16)
  3581. # Prefix => prefix to print at start of line (default='')
  3582. # MaxLen => maximum length to dump
  3583. # Out => output file reference
  3584. # Len => data length
  3585. sub HexDump($;$%)
  3586. {
  3587. my $dataPt = shift;
  3588. my $len = shift;
  3589. my %opts = @_;
  3590. my $start = $opts{Start} || 0;
  3591. my $addr = $opts{Addr};
  3592. my $wid = $opts{Width} || 16;
  3593. my $prefix = $opts{Prefix} || '';
  3594. my $out = $opts{Out} || \*STDOUT;
  3595. my $maxLen = $opts{MaxLen};
  3596. my $datLen = length($$dataPt) - $start;
  3597. my $more;
  3598. $len = $opts{Len} if defined $opts{Len};
  3599. $addr = $start + ($opts{DataPos} || 0) + ($opts{Base} || 0) unless defined $addr;
  3600. $len = $datLen unless defined $len;
  3601. if ($maxLen and $len > $maxLen) {
  3602. # print one line less to allow for $more line below
  3603. $maxLen = int(($maxLen - 1) / $wid) * $wid;
  3604. $more = $len - $maxLen;
  3605. $len = $maxLen;
  3606. }
  3607. if ($len > $datLen) {
  3608. print $out "$prefix Warning: Attempted dump outside data\n";
  3609. print $out "$prefix ($len bytes specified, but only $datLen available)\n";
  3610. $len = $datLen;
  3611. }
  3612. my $format = sprintf("%%-%ds", $wid * 3);
  3613. my $tmpl = 'H2' x $wid; # ('(H2)*' would have been nice, but older perl versions don't support it)
  3614. my $i;
  3615. for ($i=0; $i<$len; $i+=$wid) {
  3616. $wid > $len-$i and $wid = $len-$i, $tmpl = 'H2' x $wid;
  3617. printf $out "$prefix%8.4x: ", $addr+$i;
  3618. my $dat = substr($$dataPt, $i+$start, $wid);
  3619. my $s = join(' ', unpack($tmpl, $dat));
  3620. printf $out $format, $s;
  3621. $dat =~ tr /\x00-\x1f\x7f-\xff/./;
  3622. print $out "[$dat]\n";
  3623. }
  3624. $more and print $out "$prefix [snip $more bytes]\n";
  3625. }
  3626. #------------------------------------------------------------------------------
  3627. # Print verbose tag information
  3628. # Inputs: 0) ExifTool object reference, 1) tag ID
  3629. # 2) tag info reference (or undef)
  3630. # 3-N) extra parms:
  3631. # Parms: Index => Index of tag in menu (starting at 0)
  3632. # Value => Tag value
  3633. # DataPt => reference to value data block
  3634. # DataPos => location of data block in file
  3635. # Base => base added to all offsets
  3636. # Size => length of value data within block
  3637. # Format => value format string
  3638. # Count => number of values
  3639. # Extra => Extra Verbose=2 information to put after tag number
  3640. # Table => Reference to tag table
  3641. # --> plus any of these HexDump() options: Start, Addr, Width
  3642. sub VerboseInfo($$$%)
  3643. {
  3644. my ($self, $tagID, $tagInfo, %parms) = @_;
  3645. my $verbose = $$self{OPTIONS}{Verbose};
  3646. my $out = $$self{OPTIONS}{TextOut};
  3647. my ($tag, $line, $hexID);
  3648. # generate hex number if tagID is numerical
  3649. if (defined $tagID) {
  3650. $tagID =~ /^\d+$/ and $hexID = sprintf("0x%.4x", $tagID);
  3651. } else {
  3652. $tagID = 'Unknown';
  3653. }
  3654. # get tag name
  3655. if ($tagInfo and $$tagInfo{Name}) {
  3656. $tag = $$tagInfo{Name};
  3657. } else {
  3658. my $prefix;
  3659. $prefix = $parms{Table}{TAG_PREFIX} if $parms{Table};
  3660. if ($prefix or $hexID) {
  3661. $prefix = 'Unknown' unless $prefix;
  3662. $tag = $prefix . '_' . ($hexID ? $hexID : $tagID);
  3663. } else {
  3664. $tag = $tagID;
  3665. }
  3666. }
  3667. my $dataPt = $parms{DataPt};
  3668. my $size = $parms{Size};
  3669. $size = length $$dataPt unless defined $size or not $dataPt;
  3670. my $indent = $$self{INDENT};
  3671. # Level 1: print tag/value information
  3672. $line = $indent;
  3673. my $index = $parms{Index};
  3674. if (defined $index) {
  3675. $line .= $index . ') ';
  3676. $line .= ' ' if length($index) < 2;
  3677. $indent .= ' '; # indent everything else to align with tag name
  3678. }
  3679. $line .= $tag;
  3680. if ($tagInfo and $$tagInfo{SubDirectory}) {
  3681. $line .= ' (SubDirectory) -->';
  3682. } else {
  3683. my $maxLen = 90 - length($line);
  3684. if (defined $parms{Value}) {
  3685. $line .= ' = ' . $self->Printable($parms{Value}, $maxLen);
  3686. } elsif ($dataPt) {
  3687. my $start = $parms{Start} || 0;
  3688. $line .= ' = ' . $self->Printable(substr($$dataPt,$start,$size), $maxLen);
  3689. }
  3690. }
  3691. print $out "$line\n";
  3692. # Level 2: print detailed information about the tag
  3693. if ($verbose > 1 and ($parms{Extra} or $parms{Format} or
  3694. $parms{DataPt} or defined $size or $tagID =~ /\//))
  3695. {
  3696. $line = $indent . '- Tag ';
  3697. if ($hexID) {
  3698. $line .= $hexID;
  3699. } else {
  3700. $tagID =~ s/([\0-\x1f\x7f-\xff])/sprintf('\\x%.2x',ord $1)/ge;
  3701. $line .= "'$tagID'";
  3702. }
  3703. $line .= $parms{Extra} if defined $parms{Extra};
  3704. my $format = $parms{Format};
  3705. if ($format or defined $size) {
  3706. $line .= ' (';
  3707. if (defined $size) {
  3708. $line .= "$size bytes";
  3709. $line .= ', ' if $format;
  3710. }
  3711. if ($format) {
  3712. $line .= $format;
  3713. $line .= '['.$parms{Count}.']' if $parms{Count};
  3714. }
  3715. $line .= ')';
  3716. }
  3717. $line .= ':' if $verbose > 2 and $parms{DataPt};
  3718. print $out "$line\n";
  3719. }
  3720. # Level 3: do hex dump of value
  3721. if ($verbose > 2 and $parms{DataPt}) {
  3722. $parms{Out} = $out;
  3723. $parms{Prefix} = $indent;
  3724. # limit dump length if Verbose < 5
  3725. $parms{MaxLen} = $verbose == 3 ? 96 : 2048 if $verbose < 5;
  3726. HexDump($dataPt, $size, %parms);
  3727. }
  3728. }
  3729. #------------------------------------------------------------------------------
  3730. # Dump trailer information
  3731. # Inputs: 0) ExifTool object ref, 1) dirInfo hash (RAF, DirName, DataPos, DirLen)
  3732. # Notes: Restores current file position before returning
  3733. sub DumpTrailer($$)
  3734. {
  3735. my ($self, $dirInfo) = @_;
  3736. my $raf = $$dirInfo{RAF};
  3737. my $curPos = $raf->Tell();
  3738. my $trailer = $$dirInfo{DirName} || 'Unknown';
  3739. my $pos = $$dirInfo{DataPos};
  3740. my $verbose = $$self{OPTIONS}{Verbose};
  3741. my $htmlDump = $$self{HTML_DUMP};
  3742. my ($buff, $buf2);
  3743. my $size = $$dirInfo{DirLen};
  3744. $pos = $curPos unless defined $pos;
  3745. # get full trailer size if not specified
  3746. for (;;) {
  3747. unless ($size) {
  3748. $raf->Seek(0, 2) or last;
  3749. $size = $raf->Tell() - $pos;
  3750. last unless $size;
  3751. }
  3752. $raf->Seek($pos, 0) or last;
  3753. if ($htmlDump) {
  3754. my $num = $raf->Read($buff, $size) or return;
  3755. my $desc = "$trailer trailer";
  3756. $desc = "[$desc]" if $trailer eq 'Unknown';
  3757. $self->HDump($pos, $num, $desc, undef, 0x08);
  3758. last;
  3759. }
  3760. my $out = $$self{OPTIONS}{TextOut};
  3761. printf $out "$trailer trailer (%d bytes at offset 0x%.4x):\n", $size, $pos;
  3762. last unless $verbose > 2;
  3763. my $num = $size; # number of bytes to read
  3764. # limit size if not very verbose
  3765. if ($verbose < 5) {
  3766. my $limit = $verbose < 4 ? 96 : 512;
  3767. $num = $limit if $num > $limit;
  3768. }
  3769. $raf->Read($buff, $num) == $num or return;
  3770. # read the end of the trailer too if not done already
  3771. if ($size > 2 * $num) {
  3772. $raf->Seek($pos + $size - $num, 0);
  3773. $raf->Read($buf2, $num);
  3774. } elsif ($size > $num) {
  3775. $raf->Seek($pos + $num, 0);
  3776. $raf->Read($buf2, $size - $num);
  3777. $buff .= $buf2;
  3778. undef $buf2;
  3779. }
  3780. HexDump(\$buff, undef, Addr => $pos, Out => $out);
  3781. if (defined $buf2) {
  3782. print $out " [snip ", $size - $num * 2, " bytes]\n";
  3783. HexDump(\$buf2, undef, Addr => $pos + $size - $num, Out => $out);
  3784. }
  3785. last;
  3786. }
  3787. $raf->Seek($curPos, 0);
  3788. }
  3789. #------------------------------------------------------------------------------
  3790. # Dump unknown trailer information
  3791. # Inputs: 0) ExifTool ref, 1) dirInfo ref (with RAF, DataPos and DirLen defined)
  3792. # Notes: changes dirInfo elements
  3793. sub DumpUnknownTrailer($$)
  3794. {
  3795. my ($self, $dirInfo) = @_;
  3796. my $pos = $$dirInfo{DataPos};
  3797. my $endPos = $pos + $$dirInfo{DirLen};
  3798. # account for preview/MPF image trailer
  3799. my $prePos = $$self{VALUE}{PreviewImageStart} || $$self{PreviewImageStart};
  3800. my $preLen = $$self{VALUE}{PreviewImageLength} || $$self{PreviewImageLength};
  3801. my $tag = 'PreviewImage';
  3802. my $mpImageNum = 0;
  3803. my (%image, $lastOne);
  3804. for (;;) {
  3805. # add to Preview block list if valid and in the trailer
  3806. $image{$prePos} = [$tag, $preLen] if $prePos and $preLen and $prePos+$preLen > $pos;
  3807. last if $lastOne; # checked all images
  3808. # look for MPF images (in the the proper order)
  3809. ++$mpImageNum;
  3810. $prePos = $$self{VALUE}{"MPImageStart ($mpImageNum)"};
  3811. if (defined $prePos) {
  3812. $preLen = $$self{VALUE}{"MPImageLength ($mpImageNum)"};
  3813. } else {
  3814. $prePos = $$self{VALUE}{'MPImageStart'};
  3815. $preLen = $$self{VALUE}{'MPImageLength'};
  3816. $lastOne = 1;
  3817. }
  3818. $tag = "MPImage$mpImageNum";
  3819. }
  3820. # dump trailer sections in order
  3821. $image{$endPos} = [ '', 0 ]; # add terminator "image"
  3822. foreach $prePos (sort { $a <=> $b } keys %image) {
  3823. if ($pos < $prePos) {
  3824. # dump unknown trailer data
  3825. $$dirInfo{DirName} = 'Unknown';
  3826. $$dirInfo{DataPos} = $pos;
  3827. $$dirInfo{DirLen} = $prePos - $pos;
  3828. $self->DumpTrailer($dirInfo);
  3829. }
  3830. ($tag, $preLen) = @{$image{$prePos}};
  3831. last unless $preLen;
  3832. # dump image if verbose (it is htmlDump'd by ExtractImage)
  3833. if ($$self{OPTIONS}{Verbose}) {
  3834. $$dirInfo{DirName} = $tag;
  3835. $$dirInfo{DataPos} = $prePos;
  3836. $$dirInfo{DirLen} = $preLen;
  3837. $self->DumpTrailer($dirInfo);
  3838. }
  3839. $pos = $prePos + $preLen;
  3840. }
  3841. }
  3842. #------------------------------------------------------------------------------
  3843. # Find last element in linked list
  3844. # Inputs: 0) element in list
  3845. # Returns: Last element in list
  3846. sub LastInList($)
  3847. {
  3848. my $element = shift;
  3849. while ($$element{Next}) {
  3850. $element = $$element{Next};
  3851. }
  3852. return $element;
  3853. }
  3854. #------------------------------------------------------------------------------
  3855. # Print verbose directory information
  3856. # Inputs: 0) ExifTool object reference, 1) directory name or dirInfo ref
  3857. # 2) number of entries in directory (or 0 if unknown)
  3858. # 3) optional size of directory in bytes
  3859. sub VerboseDir($$;$$)
  3860. {
  3861. my ($self, $name, $entries, $size) = @_;
  3862. return unless $$self{OPTIONS}{Verbose};
  3863. if (ref $name eq 'HASH') {
  3864. $size = $$name{DirLen} unless $size;
  3865. $name = $$name{Name} || $$name{DirName};
  3866. }
  3867. my $indent = substr($$self{INDENT}, 0, -2);
  3868. my $out = $$self{OPTIONS}{TextOut};
  3869. my $str = $entries ? " with $entries entries" : '';
  3870. $str .= ", $size bytes" if $size;
  3871. print $out "$indent+ [$name directory$str]\n";
  3872. }
  3873. #------------------------------------------------------------------------------
  3874. # Print verbose value while writing
  3875. # Inputs: 0) ExifTool object ref, 1) heading "eg. '+ IPTC:Keywords',
  3876. # 2) value, 3) [optional] extra text after value
  3877. sub VerboseValue($$$;$)
  3878. {
  3879. return unless $_[0]{OPTIONS}{Verbose} > 1;
  3880. my ($self, $str, $val, $xtra) = @_;
  3881. my $out = $$self{OPTIONS}{TextOut};
  3882. $xtra or $xtra = '';
  3883. my $maxLen = 81 - length($str) - length($xtra);
  3884. $val = $self->Printable($val, $maxLen);
  3885. print $out " $str = '$val'$xtra\n";
  3886. }
  3887. #------------------------------------------------------------------------------
  3888. # Pack Unicode numbers into UTF8 string
  3889. # Inputs: 0-N) list of Unicode numbers
  3890. # Returns: Packed UTF-8 string
  3891. sub PackUTF8(@)
  3892. {
  3893. my @out;
  3894. while (@_) {
  3895. my $ch = pop;
  3896. unshift(@out, $ch), next if $ch < 0x80;
  3897. unshift(@out, 0x80 | ($ch & 0x3f));
  3898. $ch >>= 6;
  3899. unshift(@out, 0xc0 | $ch), next if $ch < 0x20;
  3900. unshift(@out, 0x80 | ($ch & 0x3f));
  3901. $ch >>= 6;
  3902. unshift(@out, 0xe0 | $ch), next if $ch < 0x10;
  3903. unshift(@out, 0x80 | ($ch & 0x3f));
  3904. $ch >>= 6;
  3905. unshift(@out, 0xf0 | ($ch & 0x07));
  3906. }
  3907. return pack('C*', @out);
  3908. }
  3909. #------------------------------------------------------------------------------
  3910. # Unpack numbers from UTF8 string
  3911. # Inputs: 0) UTF-8 string
  3912. # Returns: List of Unicode numbers (sets $evalWarning on error)
  3913. sub UnpackUTF8($)
  3914. {
  3915. my (@out, $pos);
  3916. pos($_[0]) = $pos = 0; # start at beginning of string
  3917. for (;;) {
  3918. my ($ch, $newPos, $val, $byte);
  3919. if ($_[0] =~ /([\x80-\xff])/g) {
  3920. $ch = ord($1);
  3921. $newPos = pos($_[0]) - 1;
  3922. } else {
  3923. $newPos = length $_[0];
  3924. }
  3925. # unpack 7-bit characters
  3926. my $len = $newPos - $pos;
  3927. push @out, unpack("x${pos}C$len",$_[0]) if $len;
  3928. last unless defined $ch;
  3929. $pos = $newPos + 1;
  3930. # minimum lead byte for 2-byte sequence is 0xc2 (overlong sequences
  3931. # not allowed), 0xf8-0xfd are restricted by RFC 3629 (no 5 or 6 byte
  3932. # sequences), and 0xfe and 0xff are not valid in UTF-8 strings
  3933. if ($ch < 0xc2 or $ch >= 0xf8) {
  3934. push @out, ord('?'); # invalid UTF-8
  3935. $evalWarning = 'Bad UTF-8';
  3936. next;
  3937. }
  3938. # decode 2, 3 and 4-byte sequences
  3939. my $n = 1;
  3940. if ($ch < 0xe0) {
  3941. $val = $ch & 0x1f; # 2-byte sequence
  3942. } elsif ($ch < 0xf0) {
  3943. $val = $ch & 0x0f; # 3-byte sequence
  3944. ++$n;
  3945. } else {
  3946. $val = $ch & 0x07; # 4-byte sequence
  3947. $n += 2;
  3948. }
  3949. unless ($_[0] =~ /\G([\x80-\xbf]{$n})/g) {
  3950. pos($_[0]) = $pos; # restore position
  3951. push @out, ord('?'); # invalid UTF-8
  3952. $evalWarning = 'Bad UTF-8';
  3953. next;
  3954. }
  3955. foreach $byte (unpack 'C*', $1) {
  3956. $val = ($val << 6) | ($byte & 0x3f);
  3957. }
  3958. push @out, $val; # save Unicode character value
  3959. $pos += $n; # position at end of UTF-8 character
  3960. }
  3961. return @out;
  3962. }
  3963. #------------------------------------------------------------------------------
  3964. # Return current time in EXIF format
  3965. # Inputs: 0) flag to include timezone (0 to disable, undef or 1 to include)
  3966. # Returns: time string
  3967. sub TimeNow(;$)
  3968. {
  3969. my $tzFlag = shift;
  3970. my $time = time();
  3971. my @tm = localtime $time;
  3972. my $tz = ($tzFlag or not defined $tzFlag) ? TimeZoneString(\@tm, $time) : '';
  3973. return sprintf("%4d:%.2d:%.2d %.2d:%.2d:%.2d%s",
  3974. $tm[5]+1900, $tm[4]+1, $tm[3],
  3975. $tm[2], $tm[1], $tm[0], $tz);
  3976. }
  3977. #------------------------------------------------------------------------------
  3978. # Generate a new, random GUID
  3979. # Inputs: <none>
  3980. # Returns: GUID string
  3981. my $guidCount;
  3982. sub NewGUID()
  3983. {
  3984. my @tm = localtime time;
  3985. $guidCount = 0 unless defined $guidCount and ++$guidCount < 0x100;
  3986. return sprintf('%.4d%.2d%.2d%.2d%.2d%.2d%.2X%.4X%.4X%.4X%.4X',
  3987. $tm[5]+1900, $tm[4]+1, $tm[3], $tm[2], $tm[1], $tm[0], $guidCount,
  3988. $$ & 0xffff, rand(0x10000), rand(0x10000), rand(0x10000));
  3989. }
  3990. #------------------------------------------------------------------------------
  3991. # Inverse date/time print conversion (reformat to YYYY:mm:dd HH:MM:SS[.ss][+-HH:MM|Z])
  3992. # Inputs: 0) ExifTool object ref, 1) Date/Time string, 2) timezone flag:
  3993. # 0 - remove timezone and sub-seconds if they exist
  3994. # 1 - add timezone if it doesn't exist
  3995. # undef - leave timezone alone
  3996. # 3) flag to allow date-only (YYYY, YYYY:mm or YYYY:mm:dd) or time without seconds
  3997. # Returns: formatted date/time string (or undef and issues warning on error)
  3998. # Notes: currently accepts different separators, but doesn't use DateFormat yet
  3999. sub InverseDateTime($$;$$)
  4000. {
  4001. my ($self, $val, $tzFlag, $dateOnly) = @_;
  4002. my ($rtnVal, $tz);
  4003. # strip off timezone first if it exists
  4004. if ($val =~ s/([+-])(\d{1,2}):?(\d{2})\s*$//i) {
  4005. $tz = sprintf("$1%.2d:$3", $2);
  4006. } elsif ($val =~ s/Z$//i) {
  4007. $tz = 'Z';
  4008. } else {
  4009. $tz = '';
  4010. # allow special value of 'now'
  4011. return TimeNow($tzFlag) if lc($val) eq 'now';
  4012. }
  4013. if ($val =~ /(\d{4})/g) { # get YYYY
  4014. my $yr = $1;
  4015. my @a = ($val =~ /\d{1,2}/g); # get mm, dd, HH, and maybe MM, SS
  4016. length($_) < 2 and $_ = "0$_" foreach @a; # pad to 2 digits if necessary
  4017. if (@a >= 3) {
  4018. my $ss = $a[4]; # get SS
  4019. push @a, '00' while @a < 5; # add MM, SS if not given
  4020. # get sub-seconds if they exist (must be after SS, and have leading ".")
  4021. my $fs = (@a > 5 and $val =~ /(\.\d+)\s*$/) ? $1 : '';
  4022. # add/remove timezone if necessary
  4023. if ($tzFlag) {
  4024. if (not $tz) {
  4025. if (eval { require Time::Local }) {
  4026. # determine timezone offset for this time
  4027. my @args = ($a[4],$a[3],$a[2],$a[1],$a[0]-1,$yr-1900);
  4028. my $diff = Time::Local::timegm(@args) - TimeLocal(@args);
  4029. $tz = TimeZoneString($diff / 60);
  4030. } else {
  4031. $tz = 'Z'; # don't know time zone
  4032. }
  4033. }
  4034. } elsif (defined $tzFlag) {
  4035. $tz = $fs = ''; # remove timezone and sub-seconds
  4036. }
  4037. if (defined $ss) {
  4038. $ss = ":$ss";
  4039. } elsif ($dateOnly) {
  4040. $ss = '';
  4041. } else {
  4042. $ss = ':00';
  4043. }
  4044. # construct properly formatted date/time string
  4045. $rtnVal = "$yr:$a[0]:$a[1] $a[2]:$a[3]$ss$fs$tz";
  4046. } elsif ($dateOnly) {
  4047. $rtnVal = join ':', $yr, @a;
  4048. }
  4049. }
  4050. $rtnVal or warn "Invalid date/time (use YYYY:mm:dd HH:MM:SS[.ss][+/-HH:MM|Z])\n";
  4051. return $rtnVal;
  4052. }
  4053. #------------------------------------------------------------------------------
  4054. # Set byte order according to our current preferences
  4055. # Inputs: 0) ExifTool object ref
  4056. # Returns: new byte order ('II' or 'MM') and sets current byte order
  4057. # Notes: takes the first of the following that is valid:
  4058. # 1) ByteOrder option
  4059. # 2) new value for ExifByteOrder
  4060. # 3) makenote byte order from last file read
  4061. # 4) big endian
  4062. sub SetPreferredByteOrder($)
  4063. {
  4064. my $self = shift;
  4065. my $byteOrder = $self->Options('ByteOrder') ||
  4066. $self->GetNewValue('ExifByteOrder') ||
  4067. $$self{MAKER_NOTE_BYTE_ORDER} || 'MM';
  4068. unless (SetByteOrder($byteOrder)) {
  4069. warn "Invalid byte order '$byteOrder'\n" if $self->Options('Verbose');
  4070. $byteOrder = $$self{MAKER_NOTE_BYTE_ORDER} || 'MM';
  4071. SetByteOrder($byteOrder);
  4072. }
  4073. return GetByteOrder();
  4074. }
  4075. #------------------------------------------------------------------------------
  4076. # Assemble a continuing fraction into a rational value
  4077. # Inputs: 0) numerator, 1) denominator
  4078. # 2-N) list of fraction denominators, deepest first
  4079. # Returns: numerator, denominator (in list context)
  4080. sub AssembleRational($$@)
  4081. {
  4082. @_ < 3 and return @_;
  4083. my ($num, $denom, $frac) = splice(@_, 0, 3);
  4084. return AssembleRational($frac*$num+$denom, $num, @_);
  4085. }
  4086. #------------------------------------------------------------------------------
  4087. # Convert a floating point number (or 'inf' or 'undef' or a fraction) into a rational
  4088. # Inputs: 0) floating point number, 1) optional maximum value (defaults to 0x7fffffff)
  4089. # Returns: numerator, denominator (in list context)
  4090. # Notes:
  4091. # - the returned rational will be accurate to at least 8 significant figures if possible
  4092. # - eg. an input of 3.14159265358979 returns a rational of 104348/33215,
  4093. # which equals 3.14159265392142 and is accurate to 10 significant figures
  4094. # - these routines were a bit tricky, but fun to write!
  4095. sub Rationalize($;$)
  4096. {
  4097. my $val = shift;
  4098. return (1, 0) if $val eq 'inf';
  4099. return (0, 0) if $val eq 'undef';
  4100. return ($1,$2) if $val =~ m{^([-+]?\d+)/(\d+)$}; # accept fractional values
  4101. # Note: Just testing "if $val" doesn't work because '0.0' is true! (ugghh!)
  4102. return (0, 1) if $val == 0;
  4103. my $sign = $val < 0 ? ($val = -$val, -1) : 1;
  4104. my ($num, $denom, @fracs);
  4105. my $frac = $val;
  4106. my $maxInt = shift || 0x7fffffff;
  4107. for (;;) {
  4108. my ($n, $d) = AssembleRational(int($frac + 0.5), 1, @fracs);
  4109. if ($n > $maxInt or $d > $maxInt) {
  4110. last if defined $num;
  4111. return ($sign, $maxInt) if $val < 1;
  4112. return ($sign * $maxInt, 1);
  4113. }
  4114. ($num, $denom) = ($n, $d); # save last good values
  4115. my $err = ($n/$d-$val) / $val; # get error of this rational
  4116. last if abs($err) < 1e-8; # all done if error is small
  4117. my $int = int($frac);
  4118. unshift @fracs, $int;
  4119. last unless $frac -= $int;
  4120. $frac = 1 / $frac;
  4121. }
  4122. return ($num * $sign, $denom);
  4123. }
  4124. #------------------------------------------------------------------------------
  4125. # Utility routines to for writing binary data values
  4126. # Inputs: 0) value, 1) data ref, 2) offset
  4127. # Notes: prototype is (@) so values can be passed from list if desired
  4128. sub Set16s(@)
  4129. {
  4130. my $val = shift;
  4131. $val < 0 and $val += 0x10000;
  4132. return Set16u($val, @_);
  4133. }
  4134. sub Set32s(@)
  4135. {
  4136. my $val = shift;
  4137. $val < 0 and $val += 0xffffffff, ++$val;
  4138. return Set32u($val, @_);
  4139. }
  4140. sub Set64u(@)
  4141. {
  4142. my $val = shift;
  4143. my $hi = int($val / 4294967296);
  4144. my $lo = Set32u($val - $hi * 4294967296);
  4145. $hi = Set32u($hi);
  4146. $val = GetByteOrder() eq 'MM' ? $hi . $lo : $lo . $hi;
  4147. $_[1] and substr(${$_[1]}, $_[2], length($val)) = $val;
  4148. return $val;
  4149. }
  4150. sub SetRational64u(@) {
  4151. my ($numer,$denom) = Rationalize($_[0],0xffffffff);
  4152. my $val = Set32u($numer) . Set32u($denom);
  4153. $_[1] and substr(${$_[1]}, $_[2], length($val)) = $val;
  4154. return $val;
  4155. }
  4156. sub SetRational64s(@) {
  4157. my ($numer,$denom) = Rationalize($_[0]);
  4158. my $val = Set32s($numer) . Set32u($denom);
  4159. $_[1] and substr(${$_[1]}, $_[2], length($val)) = $val;
  4160. return $val;
  4161. }
  4162. sub SetRational32u(@) {
  4163. my ($numer,$denom) = Rationalize($_[0],0xffff);
  4164. my $val = Set16u($numer) . Set16u($denom);
  4165. $_[1] and substr(${$_[1]}, $_[2], length($val)) = $val;
  4166. return $val;
  4167. }
  4168. sub SetRational32s(@) {
  4169. my ($numer,$denom) = Rationalize($_[0],0x7fff);
  4170. my $val = Set16s($numer) . Set16u($denom);
  4171. $_[1] and substr(${$_[1]}, $_[2], length($val)) = $val;
  4172. return $val;
  4173. }
  4174. sub SetFixed16u(@) {
  4175. my $val = int(shift() * 0x100 + 0.5);
  4176. return Set16u($val, @_);
  4177. }
  4178. sub SetFixed16s(@) {
  4179. my $val = shift;
  4180. return Set16s(int($val * 0x100 + ($val < 0 ? -0.5 : 0.5)), @_);
  4181. }
  4182. sub SetFixed32u(@) {
  4183. my $val = int(shift() * 0x10000 + 0.5);
  4184. return Set32u($val, @_);
  4185. }
  4186. sub SetFixed32s(@) {
  4187. my $val = shift;
  4188. return Set32s(int($val * 0x10000 + ($val < 0 ? -0.5 : 0.5)), @_);
  4189. }
  4190. sub SetFloat(@) {
  4191. my $val = SwapBytes(pack('f',$_[0]), 4);
  4192. $_[1] and substr(${$_[1]}, $_[2], length($val)) = $val;
  4193. return $val;
  4194. }
  4195. sub SetDouble(@) {
  4196. # swap 32-bit words (ARM quirk) and bytes if necessary
  4197. my $val = SwapBytes(SwapWords(pack('d',$_[0])), 8);
  4198. $_[1] and substr(${$_[1]}, $_[2], length($val)) = $val;
  4199. return $val;
  4200. }
  4201. #------------------------------------------------------------------------------
  4202. # hash lookups for writing binary data values
  4203. my %writeValueProc = (
  4204. int8s => \&Set8s,
  4205. int8u => \&Set8u,
  4206. int16s => \&Set16s,
  4207. int16u => \&Set16u,
  4208. int16uRev => \&Set16uRev,
  4209. int32s => \&Set32s,
  4210. int32u => \&Set32u,
  4211. int64u => \&Set64u,
  4212. rational32s => \&SetRational32s,
  4213. rational32u => \&SetRational32u,
  4214. rational64s => \&SetRational64s,
  4215. rational64u => \&SetRational64u,
  4216. fixed16u => \&SetFixed16u,
  4217. fixed16s => \&SetFixed16s,
  4218. fixed32u => \&SetFixed32u,
  4219. fixed32s => \&SetFixed32s,
  4220. float => \&SetFloat,
  4221. double => \&SetDouble,
  4222. ifd => \&Set32u,
  4223. );
  4224. # verify that we can write floats on this platform
  4225. {
  4226. my %writeTest = (
  4227. float => [ -3.14159, 'c0490fd0' ],
  4228. double => [ -3.14159, 'c00921f9f01b866e' ],
  4229. );
  4230. my $format;
  4231. my $oldOrder = GetByteOrder();
  4232. SetByteOrder('MM');
  4233. foreach $format (keys %writeTest) {
  4234. my ($val, $hex) = @{$writeTest{$format}};
  4235. # add floating point entries if we can write them
  4236. next if unpack('H*', &{$writeValueProc{$format}}($val)) eq $hex;
  4237. delete $writeValueProc{$format}; # we can't write them
  4238. }
  4239. SetByteOrder($oldOrder);
  4240. }
  4241. #------------------------------------------------------------------------------
  4242. # write binary data value (with current byte ordering)
  4243. # Inputs: 0) value, 1) format string
  4244. # 2) number of values:
  4245. # undef = 1 for numerical types, or data length for string/undef types
  4246. # -1 = number of space-delimited values in the input string
  4247. # 3) optional data reference, 4) value offset (may be negative for bytes from end)
  4248. # Returns: packed value (and sets value in data) or undef on error
  4249. # Notes: May modify input value to round for integer formats
  4250. sub WriteValue($$;$$$$)
  4251. {
  4252. my ($val, $format, $count, $dataPt, $offset) = @_;
  4253. my $proc = $writeValueProc{$format};
  4254. my $packed;
  4255. if ($proc) {
  4256. my @vals = split(' ',$val);
  4257. if ($count) {
  4258. $count = @vals if $count < 0;
  4259. } else {
  4260. $count = 1; # assume 1 if count not specified
  4261. }
  4262. $packed = '';
  4263. while ($count--) {
  4264. $val = shift @vals;
  4265. return undef unless defined $val;
  4266. # validate numerical formats
  4267. if ($format =~ /^int/) {
  4268. unless (IsInt($val) or IsHex($val)) {
  4269. return undef unless IsFloat($val);
  4270. # round to nearest integer
  4271. $val = int($val + ($val < 0 ? -0.5 : 0.5));
  4272. $_[0] = $val;
  4273. }
  4274. } elsif (not IsFloat($val)) {
  4275. return undef unless $format =~ /^rational/ and ($val eq 'inf' or
  4276. $val eq 'undef' or IsRational($val));
  4277. }
  4278. $packed .= &$proc($val);
  4279. }
  4280. } elsif ($format eq 'string' or $format eq 'undef') {
  4281. $format eq 'string' and $val .= "\0"; # null-terminate strings
  4282. if ($count and $count > 0) {
  4283. my $diff = $count - length($val);
  4284. if ($diff) {
  4285. #warn "wrong string length!\n";
  4286. # adjust length of string to match specified count
  4287. if ($diff < 0) {
  4288. if ($format eq 'string') {
  4289. return undef unless $count;
  4290. $val = substr($val, 0, $count - 1) . "\0";
  4291. } else {
  4292. $val = substr($val, 0, $count);
  4293. }
  4294. } else {
  4295. $val .= "\0" x $diff;
  4296. }
  4297. }
  4298. } else {
  4299. $count = length($val);
  4300. }
  4301. $dataPt and substr($$dataPt, $offset, $count) = $val;
  4302. return $val;
  4303. } else {
  4304. warn "Sorry, Can't write $format values on this platform\n";
  4305. return undef;
  4306. }
  4307. $dataPt and substr($$dataPt, $offset, length($packed)) = $packed;
  4308. return $packed;
  4309. }
  4310. #------------------------------------------------------------------------------
  4311. # Encode bit mask (the inverse of DecodeBits())
  4312. # Inputs: 0) value to encode, 1) Reference to hash for encoding (or undef)
  4313. # 2) optional number of bits per word (defaults to 32), 3) total bits
  4314. # Returns: bit mask or undef on error (plus error string in list context)
  4315. sub EncodeBits($$;$$)
  4316. {
  4317. my ($val, $lookup, $bits, $num) = @_;
  4318. $bits or $bits = 32;
  4319. $num or $num = $bits;
  4320. my $words = int(($num + $bits - 1) / $bits);
  4321. my @outVal = (0) x $words;
  4322. if ($val ne '(none)') {
  4323. my @vals = split /\s*,\s*/, $val;
  4324. foreach $val (@vals) {
  4325. my $bit;
  4326. if ($lookup) {
  4327. $bit = ReverseLookup($val, $lookup);
  4328. # (Note: may get non-numerical $bit values from Unknown() tags)
  4329. unless (defined $bit) {
  4330. if ($val =~ /\[(\d+)\]/) { # numerical bit specification
  4331. $bit = $1;
  4332. } else {
  4333. # don't return error string unless more than one value
  4334. return undef unless @vals > 1 and wantarray;
  4335. return (undef, "no match for '$val'");
  4336. }
  4337. }
  4338. } else {
  4339. $bit = $val;
  4340. }
  4341. unless (IsInt($bit) and $bit < $num) {
  4342. return undef unless wantarray;
  4343. return (undef, IsInt($bit) ? 'bit number too high' : 'not an integer');
  4344. }
  4345. my $word = int($bit / $bits);
  4346. $outVal[$word] |= (1 << ($bit - $word * $bits));
  4347. }
  4348. }
  4349. return "@outVal";
  4350. }
  4351. #------------------------------------------------------------------------------
  4352. # get current position in output file (or end of file if a scalar reference)
  4353. # Inputs: 0) file or scalar reference
  4354. # Returns: Current position or -1 on error
  4355. sub Tell($)
  4356. {
  4357. my $outfile = shift;
  4358. if (UNIVERSAL::isa($outfile,'GLOB')) {
  4359. return tell($outfile);
  4360. } else {
  4361. return length($$outfile);
  4362. }
  4363. }
  4364. #------------------------------------------------------------------------------
  4365. # write to file or memory
  4366. # Inputs: 0) file or scalar reference, 1-N) list of stuff to write
  4367. # Returns: true on success
  4368. sub Write($@)
  4369. {
  4370. my $outfile = shift;
  4371. if (UNIVERSAL::isa($outfile,'GLOB')) {
  4372. return print $outfile @_;
  4373. } elsif (ref $outfile eq 'SCALAR') {
  4374. $$outfile .= join('', @_);
  4375. return 1;
  4376. }
  4377. return 0;
  4378. }
  4379. #------------------------------------------------------------------------------
  4380. # Write trailer buffer to file (applying fixups if necessary)
  4381. # Inputs: 0) ExifTool object ref, 1) trailer dirInfo ref, 2) output file ref
  4382. # Returns: 1 on success
  4383. sub WriteTrailerBuffer($$$)
  4384. {
  4385. my ($self, $trailInfo, $outfile) = @_;
  4386. if ($$self{DEL_GROUP}{Trailer}) {
  4387. $self->VPrint(0, " Deleting trailer ($$trailInfo{Offset} bytes)\n");
  4388. ++$$self{CHANGED};
  4389. return 1;
  4390. }
  4391. my $pos = Tell($outfile);
  4392. my $trailPt = $$trailInfo{OutFile};
  4393. # apply fixup if necessary (AFCP requires this)
  4394. if ($$trailInfo{Fixup}) {
  4395. if ($pos > 0) {
  4396. # shift offsets to final AFCP location and write it out
  4397. $$trailInfo{Fixup}{Shift} += $pos;
  4398. $$trailInfo{Fixup}->ApplyFixup($trailPt);
  4399. } else {
  4400. $self->Error("Can't get file position for trailer offset fixup",1);
  4401. }
  4402. }
  4403. return Write($outfile, $$trailPt);
  4404. }
  4405. #------------------------------------------------------------------------------
  4406. # Add trailers as a block
  4407. # Inputs: 0) ExifTool object ref, 1) [optional] trailer data raf,
  4408. # 1 or 2-N) trailer types to add (or none to add all)
  4409. # Returns: new trailer ref, or undef
  4410. # - increments CHANGED if trailer was added
  4411. sub AddNewTrailers($;@)
  4412. {
  4413. my ($self, @types) = @_;
  4414. my $trailPt;
  4415. ref $types[0] and $trailPt = shift @types;
  4416. $types[0] or shift @types; # (in case undef data ref is passed)
  4417. # add all possible trailers if none specified (currently only CanonVRD)
  4418. @types or @types = qw(CanonVRD CanonDR4);
  4419. # add trailers as a block (if not done already)
  4420. my $type;
  4421. foreach $type (@types) {
  4422. next unless $$self{NEW_VALUE}{$Image::ExifTool::Extra{$type}};
  4423. next if $$self{"Did$type"};
  4424. my $val = $self->GetNewValue($type) or next;
  4425. # DR4 record must be wrapped in VRD trailer package
  4426. if ($type eq 'CanonDR4') {
  4427. next if $$self{DidCanonVRD}; # (only allow one VRD trailer)
  4428. require Image::ExifTool::CanonVRD;
  4429. $val = Image::ExifTool::CanonVRD::WrapDR4($val);
  4430. $$self{DidCanonVRD} = 1;
  4431. }
  4432. my $verb = $trailPt ? 'Writing' : 'Adding';
  4433. $self->VPrint(0, " $verb $type as a block\n");
  4434. if ($trailPt) {
  4435. $$trailPt .= $val;
  4436. } else {
  4437. $trailPt = \$val;
  4438. }
  4439. $$self{"Did$type"} = 1;
  4440. ++$$self{CHANGED};
  4441. }
  4442. return $trailPt;
  4443. }
  4444. #------------------------------------------------------------------------------
  4445. # Write segment, splitting up into multiple segments if necessary
  4446. # Inputs: 0) file or scalar reference, 1) segment marker
  4447. # 2) segment header, 3) segment data ref, 4) segment type
  4448. # Returns: number of segments written, or 0 on error
  4449. sub WriteMultiSegment($$$$;$)
  4450. {
  4451. my ($outfile, $marker, $header, $dataPt, $type) = @_;
  4452. $type or $type = '';
  4453. my $len = length($$dataPt);
  4454. my $hdr = "\xff" . chr($marker);
  4455. my $count = 0;
  4456. my $maxLen = $maxSegmentLen - length($header);
  4457. $maxLen -= 2 if $type eq 'ICC'; # leave room for segment counters
  4458. my $num = int(($len + $maxLen - 1) / $maxLen); # number of segments to write
  4459. my $n;
  4460. # write data, splitting into multiple segments if necessary
  4461. # (each segment gets its own header)
  4462. for ($n=0; $n<$len; $n+=$maxLen) {
  4463. ++$count;
  4464. my $size = $len - $n;
  4465. $size > $maxLen and $size = $maxLen;
  4466. my $buff = substr($$dataPt,$n,$size);
  4467. $size += length($header);
  4468. if ($type eq 'ICC') {
  4469. $buff = pack('CC', $count, $num) . $buff;
  4470. $size += 2;
  4471. }
  4472. # write the new segment with appropriate header
  4473. my $segHdr = $hdr . pack('n', $size + 2);
  4474. Write($outfile, $segHdr, $header, $buff) or return 0;
  4475. }
  4476. return $count;
  4477. }
  4478. #------------------------------------------------------------------------------
  4479. # Write XMP segment(s) to JPEG file
  4480. # Inputs: 0) ExifTool object ref, 1) outfile ref, 2) XMP data ref,
  4481. # 3) extended XMP data ref, 4) 32-char extended XMP GUID (or undef if no extended data)
  4482. # Returns: true on success, false on write error
  4483. sub WriteMultiXMP($$$$$)
  4484. {
  4485. my ($self, $outfile, $dataPt, $extPt, $guid) = @_;
  4486. my $success = 1;
  4487. # write main XMP segment
  4488. my $size = length($$dataPt) + length($xmpAPP1hdr);
  4489. if ($size > $maxXMPLen) {
  4490. $self->Error("XMP block too large for JPEG segment! ($size bytes)", 1);
  4491. return 1;
  4492. }
  4493. my $app1hdr = "\xff\xe1" . pack('n', $size + 2);
  4494. Write($outfile, $app1hdr, $xmpAPP1hdr, $$dataPt) or $success = 0;
  4495. # write extended XMP segment(s) if necessary
  4496. if (defined $guid) {
  4497. $size = length($$extPt);
  4498. my $maxLen = $maxXMPLen - 75; # maximum size without 75-byte header
  4499. my $off;
  4500. for ($off=0; $off<$size; $off+=$maxLen) {
  4501. # header(75) = signature(35) + guid(32) + size(4) + offset(4)
  4502. my $len = $size - $off;
  4503. $len = $maxLen if $len > $maxLen;
  4504. $app1hdr = "\xff\xe1" . pack('n', $len + 75 + 2);
  4505. $self->VPrint(0, "Writing extended XMP segment ($len bytes)\n");
  4506. Write($outfile, $app1hdr, $xmpExtAPP1hdr, $guid, pack('N2', $size, $off),
  4507. substr($$extPt, $off, $len)) or $success = 0;
  4508. }
  4509. }
  4510. return $success;
  4511. }
  4512. #------------------------------------------------------------------------------
  4513. # WriteJPEG : Write JPEG image
  4514. # Inputs: 0) ExifTool object reference, 1) dirInfo reference
  4515. # Returns: 1 on success, 0 if this wasn't a valid JPEG file, or -1 if
  4516. # an output file was specified and a write error occurred
  4517. sub WriteJPEG($$)
  4518. {
  4519. my ($self, $dirInfo) = @_;
  4520. my $outfile = $$dirInfo{OutFile};
  4521. my $raf = $$dirInfo{RAF};
  4522. my ($ch, $s, $length,$err, %doneDir, $isEXV, $creatingEXV);
  4523. my $verbose = $$self{OPTIONS}{Verbose};
  4524. my $out = $$self{OPTIONS}{TextOut};
  4525. my $rtnVal = 0;
  4526. my %dumpParms = ( Out => $out );
  4527. my ($writeBuffer, $oldOutfile); # used to buffer writing until PreviewImage position is known
  4528. # check to be sure this is a valid JPG or EXV file
  4529. unless ($raf->Read($s,2) == 2 and $s eq "\xff\xd8") {
  4530. if (defined $s and length $s) {
  4531. return 0 unless $s eq "\xff\x01" and $raf->Read($s,5) == 5 and $s eq 'Exiv2';
  4532. } else {
  4533. return 0 unless $$self{FILE_TYPE} eq 'EXV';
  4534. $s = 'Exiv2';
  4535. $creatingEXV = 1;
  4536. }
  4537. Write($outfile,"\xff\x01") or $err = 1;
  4538. $isEXV = 1;
  4539. }
  4540. $dumpParms{MaxLen} = 128 unless $verbose > 3;
  4541. delete $$self{PREVIEW_INFO}; # reset preview information
  4542. delete $$self{DEL_PREVIEW}; # reset flag to delete preview
  4543. Write($outfile, $s) or $err = 1;
  4544. # figure out what segments we need to write for the tags we have set
  4545. my $addDirs = $$self{ADD_DIRS};
  4546. my $editDirs = $$self{EDIT_DIRS};
  4547. my $delGroup = $$self{DEL_GROUP};
  4548. my $path = $$self{PATH};
  4549. my $pn = scalar @$path;
  4550. # set input record separator to 0xff (the JPEG marker) to make reading quicker
  4551. local $/ = "\xff";
  4552. #
  4553. # pre-scan image to determine if any create-able segment already exists
  4554. #
  4555. my $pos = $raf->Tell();
  4556. my ($marker, @dirOrder, %dirCount);
  4557. Prescan: for (;;) {
  4558. # read up to next marker (JPEG markers begin with 0xff)
  4559. $raf->ReadLine($s) or last;
  4560. # JPEG markers can be padded with unlimited 0xff's
  4561. for (;;) {
  4562. $raf->Read($ch, 1) or last Prescan;
  4563. $marker = ord($ch);
  4564. last unless $marker == 0xff;
  4565. }
  4566. # SOS signifies end of meta information
  4567. if ($marker == 0xda) {
  4568. push(@dirOrder, 'SOS');
  4569. $dirCount{SOS} = 1;
  4570. last;
  4571. }
  4572. my $dirName;
  4573. # handle SOF markers: SOF0-SOF15, except DHT(0xc4), JPGA(0xc8) and DAC(0xcc)
  4574. if (($marker & 0xf0) == 0xc0 and ($marker == 0xc0 or $marker & 0x03)) {
  4575. last unless $raf->Seek(7, 1);
  4576. # read data for all markers except stand-alone
  4577. # markers 0x00, 0x01 and 0xd0-0xd7 (NULL, TEM, RST0-RST7)
  4578. } elsif ($marker!=0x00 and $marker!=0x01 and ($marker<0xd0 or $marker>0xd7)) {
  4579. # read record length word
  4580. last unless $raf->Read($s, 2) == 2;
  4581. my $len = unpack('n',$s); # get data length
  4582. last unless defined($len) and $len >= 2;
  4583. $len -= 2; # subtract size of length word
  4584. if (($marker & 0xf0) == 0xe0) { # is this an APP segment?
  4585. my $n = $len < 64 ? $len : 64;
  4586. $raf->Read($s, $n) == $n or last;
  4587. $len -= $n;
  4588. # Note: only necessary to recognize APP segments that we can create,
  4589. # or delete as a group (and the names below should match @delGroups)
  4590. if ($marker == 0xe0) {
  4591. $s =~ /^JFIF\0/ and $dirName = 'JFIF';
  4592. $s =~ /^JFXX\0\x10/ and $dirName = 'JFXX';
  4593. $s =~ /^(II|MM).{4}HEAPJPGM/s and $dirName = 'CIFF';
  4594. } elsif ($marker == 0xe1) {
  4595. $s =~ /^(.{0,4})$exifAPP1hdr/s and $dirName = 'IFD0';
  4596. $s =~ /^$xmpAPP1hdr/ and $dirName = 'XMP';
  4597. $s =~ /^$xmpExtAPP1hdr/ and $dirName = 'XMP';
  4598. } elsif ($marker == 0xe2) {
  4599. $s =~ /^ICC_PROFILE\0/ and $dirName = 'ICC_Profile';
  4600. $s =~ /^FPXR\0/ and $dirName = 'FlashPix';
  4601. $s =~ /^MPF\0/ and $dirName = 'MPF';
  4602. } elsif ($marker == 0xe3) {
  4603. $s =~ /^(Meta|META|Exif)\0\0/ and $dirName = 'Meta';
  4604. } elsif ($marker == 0xe5) {
  4605. $s =~ /^RMETA\0/ and $dirName = 'RMETA';
  4606. } elsif ($marker == 0xec) {
  4607. $s =~ /^Ducky/ and $dirName = 'Ducky';
  4608. } elsif ($marker == 0xed) {
  4609. $s =~ /^$psAPP13hdr/ and $dirName = 'Photoshop';
  4610. } elsif ($marker == 0xee) {
  4611. $s =~ /^Adobe/ and $dirName = 'Adobe';
  4612. }
  4613. # initialize doneDir as a flag that the directory exists
  4614. # (unless we are deleting it anyway)
  4615. $doneDir{$dirName} = 0 if defined $dirName and not $$delGroup{$dirName};
  4616. }
  4617. $raf->Seek($len, 1) or last;
  4618. }
  4619. $dirName or $dirName = JpegMarkerName($marker);
  4620. $dirCount{$dirName} = ($dirCount{$dirName} || 0) + 1;
  4621. push @dirOrder, $dirName;
  4622. }
  4623. unless ($marker and $marker == 0xda) {
  4624. $isEXV or $self->Error('Corrupted JPEG image'), return 1;
  4625. $marker and $marker ne 0xd9 and $self->Error('Corrupted EXV file'), return 1;
  4626. push @dirOrder, 'EOI';
  4627. $dirCount{EOI} = 1;
  4628. }
  4629. $raf->Seek($pos, 0) or $self->Error('Seek error'), return 1;
  4630. #
  4631. # re-write the image
  4632. #
  4633. my ($combinedSegData, $segPos, %extendedXMP);
  4634. my (@iccChunk, $iccChunkCount, $iccChunksTotal);
  4635. # read through each segment in the JPEG file
  4636. Marker: for (;;) {
  4637. # read up to next marker (JPEG markers begin with 0xff)
  4638. my $segJunk;
  4639. $raf->ReadLine($segJunk) or $segJunk = '';
  4640. # remove the 0xff but write the rest of the junk up to this point
  4641. # (this will handle the data after the first 7 bytes of SOF segments)
  4642. chomp($segJunk);
  4643. Write($outfile, $segJunk) if length $segJunk;
  4644. # JPEG markers can be padded with unlimited 0xff's
  4645. for (;;) {
  4646. if ($raf->Read($ch, 1)) {
  4647. $marker = ord($ch);
  4648. last unless $marker == 0xff;
  4649. } elsif ($creatingEXV) {
  4650. # create EXV from scratch
  4651. $marker = 0xd9; # EOI
  4652. last;
  4653. } else {
  4654. $self->Error('Format error');
  4655. return 1;
  4656. }
  4657. }
  4658. # read the segment data
  4659. my $segData;
  4660. # handle SOF markers: SOF0-SOF15, except DHT(0xc4), JPGA(0xc8) and DAC(0xcc)
  4661. if (($marker & 0xf0) == 0xc0 and ($marker == 0xc0 or $marker & 0x03)) {
  4662. last unless $raf->Read($segData, 7) == 7;
  4663. # read data for all markers except stand-alone
  4664. # markers 0x00, 0x01 and 0xd0-0xd7 (NULL, TEM, EOI, RST0-RST7)
  4665. } elsif ($marker!=0x00 and $marker!=0x01 and $marker!=0xd9 and
  4666. ($marker<0xd0 or $marker>0xd7))
  4667. {
  4668. # read record length word
  4669. last unless $raf->Read($s, 2) == 2;
  4670. my $len = unpack('n',$s); # get data length
  4671. last unless defined($len) and $len >= 2;
  4672. $segPos = $raf->Tell();
  4673. $len -= 2; # subtract size of length word
  4674. last unless $raf->Read($segData, $len) == $len;
  4675. }
  4676. # initialize variables for this segment
  4677. my $hdr = "\xff" . chr($marker); # segment header
  4678. my $markerName = JpegMarkerName($marker);
  4679. my $dirName = shift @dirOrder; # get directory name
  4680. #
  4681. # create all segments that must come before this one
  4682. # (nothing comes before SOI or after SOS)
  4683. #
  4684. while ($markerName ne 'SOI') {
  4685. if (exists $$addDirs{JFIF} and not defined $doneDir{JFIF}) {
  4686. $doneDir{JFIF} = 1;
  4687. if ($verbose) {
  4688. print $out "Creating APP0:\n";
  4689. print $out " Creating JFIF with default values\n";
  4690. }
  4691. my $jfif = "\x01\x02\x01\0\x48\0\x48\0\0";
  4692. SetByteOrder('MM');
  4693. my $tagTablePtr = GetTagTable('Image::ExifTool::JFIF::Main');
  4694. my %dirInfo = (
  4695. DataPt => \$jfif,
  4696. DirStart => 0,
  4697. DirLen => length $jfif,
  4698. Parent => 'JFIF',
  4699. );
  4700. # must temporarily remove JFIF from DEL_GROUP so we can
  4701. # delete JFIF and add it back again in a single step
  4702. my $delJFIF = $$delGroup{JFIF};
  4703. delete $$delGroup{JFIF};
  4704. $$path[$pn] = 'JFIF';
  4705. my $newData = $self->WriteDirectory(\%dirInfo, $tagTablePtr);
  4706. $$delGroup{JFIF} = $delJFIF if defined $delJFIF;
  4707. if (defined $newData and length $newData) {
  4708. my $app0hdr = "\xff\xe0" . pack('n', length($newData) + 7);
  4709. Write($outfile,$app0hdr,"JFIF\0",$newData) or $err = 1;
  4710. }
  4711. }
  4712. # don't create anything before APP0 or APP1 EXIF (containing IFD0)
  4713. last if $markerName eq 'APP0' or $dirCount{IFD0};
  4714. # EXIF information must come immediately after APP0
  4715. if (exists $$addDirs{IFD0} and not defined $doneDir{IFD0}) {
  4716. $doneDir{IFD0} = 1;
  4717. $verbose and print $out "Creating APP1:\n";
  4718. # write new EXIF data
  4719. $$self{TIFF_TYPE} = 'APP1';
  4720. my $tagTablePtr = GetTagTable('Image::ExifTool::Exif::Main');
  4721. my %dirInfo = (
  4722. DirName => 'IFD0',
  4723. Parent => 'APP1',
  4724. );
  4725. $$path[$pn] = 'APP1';
  4726. my $buff = $self->WriteDirectory(\%dirInfo, $tagTablePtr, \&WriteTIFF);
  4727. if (defined $buff and length $buff) {
  4728. my $size = length($buff) + length($exifAPP1hdr);
  4729. if ($size <= $maxSegmentLen) {
  4730. # switch to buffered output if required
  4731. if (($$self{PREVIEW_INFO} or $$self{LeicaTrailer}) and not $oldOutfile) {
  4732. $writeBuffer = '';
  4733. $oldOutfile = $outfile;
  4734. $outfile = \$writeBuffer;
  4735. # account for segment, EXIF and TIFF headers
  4736. $$self{PREVIEW_INFO}{Fixup}{Start} += 18 if $$self{PREVIEW_INFO};
  4737. $$self{LeicaTrailer}{Fixup}{Start} += 18 if $$self{LeicaTrailer};
  4738. }
  4739. # write the new segment with appropriate header
  4740. my $app1hdr = "\xff\xe1" . pack('n', $size + 2);
  4741. Write($outfile,$app1hdr,$exifAPP1hdr,$buff) or $err = 1;
  4742. } else {
  4743. delete $$self{PREVIEW_INFO};
  4744. $self->Warn("EXIF APP1 segment too large! ($size bytes)");
  4745. }
  4746. }
  4747. }
  4748. # APP13 Photoshop segment next
  4749. last if $dirCount{Photoshop};
  4750. if (exists $$addDirs{Photoshop} and not defined $doneDir{Photoshop}) {
  4751. $doneDir{Photoshop} = 1;
  4752. $verbose and print $out "Creating APP13:\n";
  4753. # write new APP13 Photoshop record to memory
  4754. my $tagTablePtr = GetTagTable('Image::ExifTool::Photoshop::Main');
  4755. my %dirInfo = (
  4756. Parent => 'APP13',
  4757. );
  4758. $$path[$pn] = 'APP13';
  4759. my $buff = $self->WriteDirectory(\%dirInfo, $tagTablePtr);
  4760. if (defined $buff and length $buff) {
  4761. WriteMultiSegment($outfile, 0xed, $psAPP13hdr, \$buff) or $err = 1;
  4762. ++$$self{CHANGED};
  4763. }
  4764. }
  4765. # then APP1 XMP segment
  4766. last if $dirCount{XMP};
  4767. if (exists $$addDirs{XMP} and not defined $doneDir{XMP}) {
  4768. $doneDir{XMP} = 1;
  4769. $verbose and print $out "Creating APP1:\n";
  4770. # write new XMP data
  4771. my $tagTablePtr = GetTagTable('Image::ExifTool::XMP::Main');
  4772. my %dirInfo = (
  4773. Parent => 'APP1',
  4774. # specify MaxDataLen so XMP is split if required
  4775. MaxDataLen => $maxXMPLen - length($xmpAPP1hdr),
  4776. );
  4777. $$path[$pn] = 'APP1';
  4778. my $buff = $self->WriteDirectory(\%dirInfo, $tagTablePtr);
  4779. if (defined $buff and length $buff) {
  4780. WriteMultiXMP($self, $outfile, \$buff, $dirInfo{ExtendedXMP},
  4781. $dirInfo{ExtendedGUID}) or $err = 1;
  4782. }
  4783. }
  4784. # then APP2 ICC_Profile segment
  4785. last if $dirCount{ICC_Profile};
  4786. if (exists $$addDirs{ICC_Profile} and not defined $doneDir{ICC_Profile}) {
  4787. $doneDir{ICC_Profile} = 1;
  4788. next if $$delGroup{ICC_Profile} and $$delGroup{ICC_Profile} != 2;
  4789. $verbose and print $out "Creating APP2:\n";
  4790. # write new ICC_Profile data
  4791. my $tagTablePtr = GetTagTable('Image::ExifTool::ICC_Profile::Main');
  4792. my %dirInfo = (
  4793. Parent => 'APP2',
  4794. );
  4795. $$path[$pn] = 'APP2';
  4796. my $buff = $self->WriteDirectory(\%dirInfo, $tagTablePtr);
  4797. if (defined $buff and length $buff) {
  4798. WriteMultiSegment($outfile, 0xe2, "ICC_PROFILE\0", \$buff, 'ICC') or $err = 1;
  4799. ++$$self{CHANGED};
  4800. }
  4801. }
  4802. # then APP12 Ducky segment
  4803. last if $dirCount{Ducky};
  4804. if (exists $$addDirs{Ducky} and not defined $doneDir{Ducky}) {
  4805. $doneDir{Ducky} = 1;
  4806. $verbose and print $out "Creating APP12 Ducky:\n";
  4807. # write new Ducky segment data
  4808. my $tagTablePtr = GetTagTable('Image::ExifTool::APP12::Ducky');
  4809. my %dirInfo = (
  4810. Parent => 'APP12',
  4811. );
  4812. $$path[$pn] = 'APP12';
  4813. my $buff = $self->WriteDirectory(\%dirInfo, $tagTablePtr);
  4814. if (defined $buff and length $buff) {
  4815. my $size = length($buff) + 5;
  4816. if ($size <= $maxSegmentLen) {
  4817. # write the new segment with appropriate header
  4818. my $app12hdr = "\xff\xec" . pack('n', $size + 2);
  4819. Write($outfile, $app12hdr, 'Ducky', $buff) or $err = 1;
  4820. } else {
  4821. $self->Warn("Ducky APP12 segment too large! ($size bytes)");
  4822. }
  4823. }
  4824. }
  4825. # then APP14 Adobe segment
  4826. last if $dirCount{Adobe};
  4827. if (exists $$addDirs{Adobe} and not defined $doneDir{Adobe}) {
  4828. $doneDir{Adobe} = 1;
  4829. my $buff = $self->GetNewValue('Adobe');
  4830. if ($buff) {
  4831. $verbose and print $out "Creating APP14:\n Creating Adobe segment\n";
  4832. my $size = length($buff);
  4833. if ($size <= $maxSegmentLen) {
  4834. # write the new segment with appropriate header
  4835. my $app14hdr = "\xff\xee" . pack('n', $size + 2);
  4836. Write($outfile, $app14hdr, $buff) or $err = 1;
  4837. ++$$self{CHANGED};
  4838. } else {
  4839. $self->Warn("Adobe APP14 segment too large! ($size bytes)");
  4840. }
  4841. }
  4842. }
  4843. # finally, COM segment
  4844. last if $dirCount{COM};
  4845. if (exists $$addDirs{COM} and not defined $doneDir{COM}) {
  4846. $doneDir{COM} = 1;
  4847. next if $$delGroup{File} and $$delGroup{File} != 2;
  4848. my $newComment = $self->GetNewValue('Comment');
  4849. if (defined $newComment and length($newComment)) {
  4850. if ($verbose) {
  4851. print $out "Creating COM:\n";
  4852. $self->VerboseValue('+ Comment', $newComment);
  4853. }
  4854. WriteMultiSegment($outfile, 0xfe, '', \$newComment) or $err = 1;
  4855. ++$$self{CHANGED};
  4856. }
  4857. }
  4858. last; # didn't want to loop anyway
  4859. }
  4860. $$path[$pn] = $markerName;
  4861. # decrement counter for this directory since we are about to process it
  4862. --$dirCount{$dirName};
  4863. #
  4864. # rewrite existing segments
  4865. #
  4866. # handle SOF markers: SOF0-SOF15, except DHT(0xc4), JPGA(0xc8) and DAC(0xcc)
  4867. if (($marker & 0xf0) == 0xc0 and ($marker == 0xc0 or $marker & 0x03)) {
  4868. $verbose and print $out "JPEG $markerName:\n";
  4869. Write($outfile, $hdr, $segData) or $err = 1;
  4870. next;
  4871. } elsif ($marker == 0xda) { # SOS
  4872. pop @$path;
  4873. $verbose and print $out "JPEG SOS\n";
  4874. # write SOS segment
  4875. $s = pack('n', length($segData) + 2);
  4876. Write($outfile, $hdr, $s, $segData) or $err = 1;
  4877. my ($buff, $endPos, $trailInfo);
  4878. my $delPreview = $$self{DEL_PREVIEW};
  4879. $trailInfo = IdentifyTrailer($raf) unless $$delGroup{Trailer};
  4880. unless ($oldOutfile or $delPreview or $trailInfo or $$delGroup{Trailer}) {
  4881. # blindly copy the rest of the file
  4882. while ($raf->Read($buff, 65536)) {
  4883. Write($outfile, $buff) or $err = 1, last;
  4884. }
  4885. $rtnVal = 1; # success unless we have a file write error
  4886. last; # all done
  4887. }
  4888. # write the rest of the image (as quickly as possible) up to the EOI
  4889. my $endedWithFF;
  4890. for (;;) {
  4891. my $n = $raf->Read($buff, 65536) or last Marker;
  4892. if (($endedWithFF and $buff =~ m/^\xd9/sg) or
  4893. $buff =~ m/\xff\xd9/sg)
  4894. {
  4895. $rtnVal = 1; # the JPEG is OK
  4896. # write up to the EOI
  4897. my $pos = pos($buff);
  4898. Write($outfile, substr($buff, 0, $pos)) or $err = 1;
  4899. $buff = substr($buff, $pos);
  4900. last;
  4901. }
  4902. unless ($n == 65536) {
  4903. $self->Error('JPEG EOI marker not found');
  4904. last Marker;
  4905. }
  4906. Write($outfile, $buff) or $err = 1;
  4907. $endedWithFF = substr($buff, 65535, 1) eq "\xff" ? 1 : 0;
  4908. }
  4909. # remember position of last data copied
  4910. $endPos = $raf->Tell() - length($buff);
  4911. # rewrite trailers if they exist
  4912. if ($trailInfo) {
  4913. my $tbuf = '';
  4914. $raf->Seek(-length($buff), 1); # seek back to just after EOI
  4915. $$trailInfo{OutFile} = \$tbuf; # rewrite the trailer
  4916. $$trailInfo{ScanForAFCP} = 1; # scan if necessary
  4917. $self->ProcessTrailers($trailInfo) or undef $trailInfo;
  4918. }
  4919. if (not $oldOutfile) {
  4920. # do nothing special
  4921. } elsif ($$self{LeicaTrailer}) {
  4922. my $trailLen;
  4923. if ($trailInfo) {
  4924. $trailLen = $$trailInfo{DataPos} - $endPos;
  4925. } else {
  4926. $raf->Seek(0, 2) or $err = 1;
  4927. $trailLen = $raf->Tell() - $endPos;
  4928. }
  4929. my $fixup = $$self{LeicaTrailer}{Fixup};
  4930. $$self{LeicaTrailer}{TrailPos} = $endPos;
  4931. $$self{LeicaTrailer}{TrailLen} = $trailLen;
  4932. # get _absolute_ position of new Leica trailer
  4933. my $absPos = Tell($oldOutfile) + length($$outfile);
  4934. require Image::ExifTool::Panasonic;
  4935. my $dat = Image::ExifTool::Panasonic::ProcessLeicaTrailer($self, $absPos);
  4936. # allow some junk before Leica trailer (just in case)
  4937. my $junk = $$self{LeicaTrailerPos} - $endPos;
  4938. # set MakerNote pointer and size (subtract 10 for segment and EXIF headers)
  4939. $fixup->SetMarkerPointers($outfile, 'LeicaTrailer', length($$outfile) - 10 + $junk);
  4940. # use this fixup to set the size too (sneaky)
  4941. my $trailSize = defined($dat) ? length($dat) - $junk : $$self{LeicaTrailer}{Size};
  4942. $$fixup{Start} -= 4; $$fixup{Shift} += 4;
  4943. $fixup->SetMarkerPointers($outfile, 'LeicaTrailer', $trailSize) if defined $trailSize;
  4944. $$fixup{Start} += 4; $$fixup{Shift} -= 4;
  4945. # clean up and write the buffered data
  4946. $outfile = $oldOutfile;
  4947. undef $oldOutfile;
  4948. Write($outfile, $writeBuffer) or $err = 1;
  4949. undef $writeBuffer;
  4950. if (defined $dat) {
  4951. Write($outfile, $dat) or $err = 1; # write new Leica trailer
  4952. $delPreview = 1; # delete existing Leica trailer
  4953. }
  4954. } else {
  4955. # locate preview image and fix up preview offsets
  4956. my $scanLen = $$self{Make} =~ /^SONY/i ? 65536 : 1024;
  4957. if (length($buff) < $scanLen) { # make sure we have enough trailer to scan
  4958. my $buf2;
  4959. $buff .= $buf2 if $raf->Read($buf2, $scanLen - length($buff));
  4960. }
  4961. # get new preview image position, relative to EXIF base
  4962. my $newPos = length($$outfile) - 10; # (subtract 10 for segment and EXIF headers)
  4963. my $junkLen;
  4964. # adjust position if image isn't at the start (eg. Olympus E-1/E-300)
  4965. if ($buff =~ /(\xff\xd8\xff.|.\xd8\xff\xdb)(..)/sg) {
  4966. my ($jpegHdr, $segLen) = ($1, $2);
  4967. $junkLen = pos($buff) - 6;
  4968. # Sony previewimage trailer has a 32 byte header
  4969. if ($$self{Make} =~ /^SONY/i and $junkLen > 32) {
  4970. # with some newer Sony models, the makernotes preview pointer
  4971. # points to JPEG at end of EXIF inside MPImage preview (what a pain!)
  4972. if ($jpegHdr eq "\xff\xd8\xff\xe1") { # is the first segment EXIF?
  4973. $segLen = unpack('n', $segLen); # the EXIF segment length
  4974. # Sony PreviewImage starts with last 2 bytes of EXIF segment
  4975. # (and first byte is usually "\0", not "\xff", so don't check this)
  4976. if (length($buff) > $junkLen + $segLen + 6 and
  4977. substr($buff, $junkLen + $segLen + 3, 3) eq "\xd8\xff\xdb")
  4978. {
  4979. $junkLen += $segLen + 2;
  4980. # (note: this will not copy the trailer after PreviewImage,
  4981. # which is a 14kB block full of zeros for the A77)
  4982. }
  4983. }
  4984. $junkLen -= 32;
  4985. }
  4986. $newPos += $junkLen;
  4987. }
  4988. # fix up the preview offsets to point to the start of the new image
  4989. my $previewInfo = $$self{PREVIEW_INFO};
  4990. delete $$self{PREVIEW_INFO};
  4991. my $fixup = $$previewInfo{Fixup};
  4992. $newPos += ($$previewInfo{BaseShift} || 0);
  4993. # adjust to absolute file offset if necessary (Samsung STMN)
  4994. $newPos += Tell($oldOutfile) + 10 if $$previewInfo{Absolute};
  4995. if ($$previewInfo{Relative}) {
  4996. # adjust for our base by looking at how far the pointer got shifted
  4997. $newPos -= ($fixup->GetMarkerPointers($outfile, 'PreviewImage') || 0);
  4998. } elsif ($$previewInfo{ChangeBase}) {
  4999. # Leica S2 uses relative offsets for the preview only (leica sucks)
  5000. my $makerOffset = $fixup->GetMarkerPointers($outfile, 'LeicaTrailer');
  5001. $newPos -= $makerOffset if $makerOffset;
  5002. }
  5003. $fixup->SetMarkerPointers($outfile, 'PreviewImage', $newPos);
  5004. # clean up and write the buffered data
  5005. $outfile = $oldOutfile;
  5006. undef $oldOutfile;
  5007. Write($outfile, $writeBuffer) or $err = 1;
  5008. undef $writeBuffer;
  5009. # write preview image
  5010. if ($$previewInfo{Data} ne 'LOAD_PREVIEW') {
  5011. # write any junk that existed before the preview image
  5012. Write($outfile, substr($buff,0,$junkLen)) or $err = 1 if $junkLen;
  5013. # write the saved preview image
  5014. Write($outfile, $$previewInfo{Data}) or $err = 1;
  5015. delete $$previewInfo{Data};
  5016. # (don't increment CHANGED because we could be rewriting existing preview)
  5017. $delPreview = 1; # remove old preview
  5018. }
  5019. }
  5020. # copy over preview image if necessary
  5021. unless ($delPreview) {
  5022. my $extra;
  5023. if ($trailInfo) {
  5024. # copy everything up to start of first processed trailer
  5025. $extra = $$trailInfo{DataPos} - $endPos;
  5026. } else {
  5027. # copy everything up to end of file
  5028. $raf->Seek(0, 2) or $err = 1;
  5029. $extra = $raf->Tell() - $endPos;
  5030. }
  5031. if ($extra > 0) {
  5032. if ($$delGroup{Trailer}) {
  5033. $verbose and print $out " Deleting unknown trailer ($extra bytes)\n";
  5034. ++$$self{CHANGED};
  5035. } else {
  5036. # copy over unknown trailer
  5037. $verbose and print $out " Preserving unknown trailer ($extra bytes)\n";
  5038. $raf->Seek($endPos, 0) or $err = 1;
  5039. CopyBlock($raf, $outfile, $extra) or $err = 1;
  5040. }
  5041. }
  5042. }
  5043. # write trailer if necessary
  5044. if ($trailInfo) {
  5045. $self->WriteTrailerBuffer($trailInfo, $outfile) or $err = 1;
  5046. undef $trailInfo;
  5047. }
  5048. last; # all done parsing file
  5049. } elsif ($marker==0xd9 and $isEXV) {
  5050. # write EXV EOI
  5051. Write($outfile, "\xff\xd9") or $err = 1;
  5052. $rtnVal = 1;
  5053. last;
  5054. } elsif ($marker==0x00 or $marker==0x01 or ($marker>=0xd0 and $marker<=0xd7)) {
  5055. $verbose and $marker and print $out "JPEG $markerName:\n";
  5056. # handle stand-alone markers 0x00, 0x01 and 0xd0-0xd7 (NULL, TEM, RST0-RST7)
  5057. Write($outfile, $hdr) or $err = 1;
  5058. next;
  5059. }
  5060. #
  5061. # NOTE: A 'next' statement after this point will cause $$segDataPt
  5062. # not to be written if there is an output file, so in this case
  5063. # the $$self{CHANGED} flags must be updated
  5064. #
  5065. my $segDataPt = \$segData;
  5066. $length = length($segData);
  5067. if ($verbose) {
  5068. print $out "JPEG $markerName ($length bytes):\n";
  5069. if ($verbose > 2 and $markerName =~ /^APP/) {
  5070. HexDump($segDataPt, undef, %dumpParms);
  5071. }
  5072. }
  5073. # group delete of APP segements
  5074. if ($$delGroup{$dirName}) {
  5075. $verbose and print $out " Deleting $dirName segment\n";
  5076. ++$$self{CHANGED};
  5077. next Marker;
  5078. }
  5079. my ($segType, $del);
  5080. # rewrite this segment only if we are changing a tag which is contained in its
  5081. # directory (or deleting '*', in which case we need to identify the segment type)
  5082. while (exists $$editDirs{$markerName} or $$delGroup{'*'}) {
  5083. my $oldChanged = $$self{CHANGED};
  5084. if ($marker == 0xe0) { # APP0 (JFIF, CIFF)
  5085. if ($$segDataPt =~ /^JFIF\0/) {
  5086. $segType = 'JFIF';
  5087. $$delGroup{JFIF} and $del = 1, last;
  5088. last unless $$editDirs{JFIF};
  5089. SetByteOrder('MM');
  5090. my $tagTablePtr = GetTagTable('Image::ExifTool::JFIF::Main');
  5091. my %dirInfo = (
  5092. DataPt => $segDataPt,
  5093. DataPos => $segPos,
  5094. DataLen => $length,
  5095. DirStart => 5, # directory starts after identifier
  5096. DirLen => $length-5,
  5097. Parent => $markerName,
  5098. );
  5099. my $newData = $self->WriteDirectory(\%dirInfo, $tagTablePtr);
  5100. if (defined $newData and length $newData) {
  5101. $$segDataPt = "JFIF\0" . $newData;
  5102. }
  5103. } elsif ($$segDataPt =~ /^JFXX\0\x10/) {
  5104. $segType = 'JFXX';
  5105. $$delGroup{JFIF} and $del = 1;
  5106. } elsif ($$segDataPt =~ /^(II|MM).{4}HEAPJPGM/s) {
  5107. $segType = 'CIFF';
  5108. $$delGroup{CIFF} and $del = 1, last;
  5109. last unless $$editDirs{CIFF};
  5110. my $newData = '';
  5111. my %dirInfo = (
  5112. RAF => new File::RandomAccess($segDataPt),
  5113. OutFile => \$newData,
  5114. );
  5115. require Image::ExifTool::CanonRaw;
  5116. if (Image::ExifTool::CanonRaw::WriteCRW($self, \%dirInfo) > 0) {
  5117. if (length $newData) {
  5118. $$segDataPt = $newData;
  5119. } else {
  5120. undef $segDataPt;
  5121. $del = 1; # delete this segment
  5122. }
  5123. }
  5124. }
  5125. } elsif ($marker == 0xe1) { # APP1 (EXIF, XMP)
  5126. # check for EXIF data
  5127. if ($$segDataPt =~ /^(.{0,4})$exifAPP1hdr/is) {
  5128. my $hdrLen = length $exifAPP1hdr;
  5129. if (length $1) {
  5130. $hdrLen += length $1;
  5131. $self->Error('Unknown garbage at start of EXIF segment',1);
  5132. } elsif ($$segDataPt !~ /^Exif\0/) {
  5133. $self->Error('Incorrect EXIF segment identifier',1);
  5134. }
  5135. $segType = 'EXIF';
  5136. $doneDir{IFD0} and $self->Warn('Multiple APP1 EXIF segments');
  5137. $doneDir{IFD0} = 1;
  5138. last unless $$editDirs{IFD0};
  5139. # check del groups now so we can change byte order in one step
  5140. if ($$delGroup{IFD0} or $$delGroup{EXIF}) {
  5141. delete $doneDir{IFD0}; # delete so we will create a new one
  5142. $del = 1;
  5143. last;
  5144. }
  5145. # rewrite EXIF as if this were a TIFF file in memory
  5146. my %dirInfo = (
  5147. DataPt => $segDataPt,
  5148. DataPos => -$hdrLen, # (remember: relative to Base!)
  5149. DirStart => $hdrLen,
  5150. Base => $segPos + $hdrLen,
  5151. Parent => $markerName,
  5152. DirName => 'IFD0',
  5153. );
  5154. # write new EXIF data to memory
  5155. my $tagTablePtr = GetTagTable('Image::ExifTool::Exif::Main');
  5156. my $buff = $self->WriteDirectory(\%dirInfo, $tagTablePtr, \&WriteTIFF);
  5157. if (defined $buff) {
  5158. # update segment with new data
  5159. $$segDataPt = $exifAPP1hdr . $buff;
  5160. } else {
  5161. last Marker unless $self->Options('IgnoreMinorErrors');
  5162. $$self{CHANGED} = $oldChanged; # nothing changed
  5163. }
  5164. # switch to buffered output if required
  5165. if (($$self{PREVIEW_INFO} or $$self{LeicaTrailer}) and not $oldOutfile) {
  5166. $writeBuffer = '';
  5167. $oldOutfile = $outfile;
  5168. $outfile = \$writeBuffer;
  5169. # must account for segment, EXIF and TIFF headers
  5170. $$self{PREVIEW_INFO}{Fixup}{Start} += 18 if $$self{PREVIEW_INFO};
  5171. $$self{LeicaTrailer}{Fixup}{Start} += 18 if $$self{LeicaTrailer};
  5172. }
  5173. # delete segment if IFD contains no entries
  5174. $del = 1 unless length($$segDataPt) > length($exifAPP1hdr);
  5175. # check for XMP data
  5176. } elsif ($$segDataPt =~ /^($xmpAPP1hdr|$xmpExtAPP1hdr)/) {
  5177. $segType = 'XMP';
  5178. $$delGroup{XMP} and $del = 1, last;
  5179. $doneDir{XMP} = ($doneDir{XMP} || 0) + 1;
  5180. last unless $$editDirs{XMP};
  5181. if ($doneDir{XMP} + $dirCount{XMP} > 1) {
  5182. # must assemble all XMP segments before writing
  5183. my ($guid, $extXMP);
  5184. if ($$segDataPt =~ /^$xmpExtAPP1hdr/) {
  5185. # save extended XMP data
  5186. if (length $$segDataPt < 75) {
  5187. $extendedXMP{Error} = 'Truncated data';
  5188. } else {
  5189. my ($size, $off) = unpack('x67N2', $$segDataPt);
  5190. $guid = substr($$segDataPt, 35, 32);
  5191. if ($guid =~ /[^A-Za-z0-9]/) { # (technically, should be uppercase)
  5192. $extendedXMP{Error} = 'Invalid GUID';
  5193. } else {
  5194. # remember extended data for each GUID
  5195. $extXMP = $extendedXMP{$guid};
  5196. if ($extXMP) {
  5197. $size == $$extXMP{Size} or $extendedXMP{Error} = 'Inconsistent size';
  5198. } else {
  5199. $extXMP = $extendedXMP{$guid} = { };
  5200. }
  5201. $$extXMP{Size} = $size;
  5202. $$extXMP{$off} = substr($$segDataPt, 75);
  5203. }
  5204. }
  5205. } else {
  5206. # save all main XMP segments (should normally be only one)
  5207. $extendedXMP{Main} = [] unless $extendedXMP{Main};
  5208. push @{$extendedXMP{Main}}, substr($$segDataPt, length $xmpAPP1hdr);
  5209. }
  5210. # continue processing only if we have read all the segments
  5211. next Marker if $dirCount{XMP};
  5212. # reconstruct an XMP super-segment
  5213. $$segDataPt = $xmpAPP1hdr;
  5214. my $goodGuid = '';
  5215. foreach (@{$extendedXMP{Main}}) {
  5216. # get the HasExtendedXMP GUID if it exists
  5217. if (/:HasExtendedXMP\s*(=\s*['"]|>)(\w{32})/) {
  5218. # warn of subsequent XMP blocks specifying a different
  5219. # HasExtendedXMP (have never seen this)
  5220. if ($goodGuid and $goodGuid ne $2) {
  5221. $self->WarnOnce('Multiple XMP segments specifying different extended XMP GUID');
  5222. }
  5223. $goodGuid = $2; # GUID for the standard extended XMP
  5224. }
  5225. $$segDataPt .= $_;
  5226. }
  5227. # GUID of the extended XMP that we want to read
  5228. my $readGuid = $$self{OPTIONS}{ExtendedXMP} || 0;
  5229. $readGuid = $goodGuid if $readGuid eq '1';
  5230. foreach $guid (sort keys %extendedXMP) {
  5231. next unless length $guid == 32; # ignore other (internal) keys
  5232. if ($guid ne $readGuid and $readGuid ne '2') {
  5233. my $non = $guid eq $goodGuid ? '' : 'non-';
  5234. $self->Warn("Ignored ${non}standard extended XMP (GUID $guid)");
  5235. next;
  5236. }
  5237. if ($guid ne $goodGuid) {
  5238. $self->Warn("Reading non-standard extended XMP (GUID $guid)");
  5239. }
  5240. $extXMP = $extendedXMP{$guid};
  5241. next unless ref $extXMP eq 'HASH'; # (just to be safe)
  5242. my $size = $$extXMP{Size};
  5243. my (@offsets, $off);
  5244. for ($off=0; $off<$size; ) {
  5245. last unless defined $$extXMP{$off};
  5246. push @offsets, $off;
  5247. $off += length $$extXMP{$off};
  5248. }
  5249. if ($off == $size) {
  5250. # add all XMP to super-segment
  5251. $$segDataPt .= $$extXMP{$_} foreach @offsets;
  5252. } else {
  5253. $self->Error("Incomplete extended XMP (GUID $guid)", 1);
  5254. }
  5255. }
  5256. $self->Error("$extendedXMP{Error} in extended XMP", 1) if $extendedXMP{Error};
  5257. }
  5258. my $start = length $xmpAPP1hdr;
  5259. my $tagTablePtr = GetTagTable('Image::ExifTool::XMP::Main');
  5260. my %dirInfo = (
  5261. DataPt => $segDataPt,
  5262. DirStart => $start,
  5263. Parent => $markerName,
  5264. # limit XMP size and create extended XMP if necessary
  5265. MaxDataLen => $maxXMPLen - length($xmpAPP1hdr),
  5266. );
  5267. my $newData = $self->WriteDirectory(\%dirInfo, $tagTablePtr);
  5268. if (defined $newData) {
  5269. undef %extendedXMP;
  5270. if (length $newData) {
  5271. # write multi-segment XMP (XMP plus extended XMP if necessary)
  5272. WriteMultiXMP($self, $outfile, \$newData, $dirInfo{ExtendedXMP},
  5273. $dirInfo{ExtendedGUID}) or $err = 1;
  5274. undef $$segDataPt; # free the old buffer
  5275. next Marker;
  5276. } else {
  5277. $$segDataPt = ''; # delete the XMP
  5278. }
  5279. } else {
  5280. $$self{CHANGED} = $oldChanged;
  5281. $verbose and print $out " [XMP rewritten with no changes]\n";
  5282. if ($doneDir{XMP} > 1) {
  5283. # re-write original multi-segment XMP
  5284. my ($dat, $guid, $extXMP, $off);
  5285. foreach $dat (@{$extendedXMP{Main}}) { # main XMP
  5286. next unless length $dat;
  5287. $s = pack('n', length($xmpAPP1hdr) + length($dat) + 2);
  5288. Write($outfile, $hdr, $s, $xmpAPP1hdr, $dat) or $err = 1;
  5289. }
  5290. foreach $guid (sort keys %extendedXMP) { # extended XMP
  5291. next unless length $guid == 32;
  5292. $extXMP = $extendedXMP{$guid};
  5293. next unless ref $extXMP eq 'HASH';
  5294. my $size = $$extXMP{Size} or next;
  5295. for ($off=0; defined $$extXMP{$off}; $off += length $$extXMP{$off}) {
  5296. $s = pack('n', length($xmpExtAPP1hdr) + length($$extXMP{$off}) + 42);
  5297. Write($outfile, $hdr, $s, $xmpExtAPP1hdr, $guid,
  5298. pack('N2', $size, $off), $$extXMP{$off}) or $err = 1;
  5299. }
  5300. }
  5301. undef $$segDataPt; # free the old buffer
  5302. undef %extendedXMP;
  5303. next Marker;
  5304. }
  5305. # continue on to re-write original single-segment XMP
  5306. }
  5307. $del = 1 unless length $$segDataPt;
  5308. } elsif ($$segDataPt =~ /^http/ or $$segDataPt =~ /<exif:/) {
  5309. $self->Warn('Ignored APP1 XMP segment with non-standard header', 1);
  5310. }
  5311. } elsif ($marker == 0xe2) { # APP2 (ICC Profile, FPXR, MPF)
  5312. if ($$segDataPt =~ /^ICC_PROFILE\0/ and $length >= 14) {
  5313. $segType = 'ICC_Profile';
  5314. $$delGroup{ICC_Profile} and $del = 1, last;
  5315. # must concatenate blocks of profile
  5316. my $chunkNum = Get8u($segDataPt, 12);
  5317. my $chunksTot = Get8u($segDataPt, 13);
  5318. if (defined $iccChunksTotal) {
  5319. # abort parsing ICC_Profile if the total chunk count is inconsistent
  5320. if ($chunksTot != $iccChunksTotal and defined $iccChunkCount) {
  5321. # an error because the accumulated profile data will be lost
  5322. $self->Error('Inconsistent ICC_Profile chunk count', 1);
  5323. undef $iccChunkCount; # abort ICC_Profile parsing
  5324. undef $chunkNum; # avoid 2nd warning below
  5325. ++$$self{CHANGED}; # we are deleting the bad chunks before this one
  5326. }
  5327. } else {
  5328. $iccChunkCount = 0;
  5329. $iccChunksTotal = $chunksTot;
  5330. $self->Warn('ICC_Profile chunk count is zero') if !$chunksTot;
  5331. }
  5332. if (defined $iccChunkCount) {
  5333. # save this chunk
  5334. if (defined $iccChunk[$chunkNum]) {
  5335. $self->Warn("Duplicate ICC_Profile chunk number $chunkNum");
  5336. $iccChunk[$chunkNum] .= substr($$segDataPt, 14);
  5337. } else {
  5338. $iccChunk[$chunkNum] = substr($$segDataPt, 14);
  5339. }
  5340. # continue accumulating chunks unless we have all of them
  5341. next Marker unless ++$iccChunkCount >= $iccChunksTotal;
  5342. undef $iccChunkCount; # prevent reprocessing
  5343. $doneDir{ICC_Profile} = 1;
  5344. # combine the ICC_Profile chunks
  5345. my $icc_profile = '';
  5346. defined $_ and $icc_profile .= $_ foreach @iccChunk;
  5347. undef @iccChunk; # free memory
  5348. $segDataPt = \$icc_profile;
  5349. $length = length $icc_profile;
  5350. my $tagTablePtr = GetTagTable('Image::ExifTool::ICC_Profile::Main');
  5351. my %dirInfo = (
  5352. DataPt => $segDataPt,
  5353. DataPos => $segPos + 14,
  5354. DataLen => $length,
  5355. DirStart => 0,
  5356. DirLen => $length,
  5357. Parent => $markerName,
  5358. );
  5359. my $newData = $self->WriteDirectory(\%dirInfo, $tagTablePtr);
  5360. if (defined $newData) {
  5361. undef $$segDataPt; # free the old buffer
  5362. $segDataPt = \$newData;
  5363. }
  5364. length $$segDataPt or $del = 1, last;
  5365. # write as ICC multi-segment
  5366. WriteMultiSegment($outfile, $marker, "ICC_PROFILE\0", $segDataPt, 'ICC') or $err = 1;
  5367. undef $$segDataPt;
  5368. next Marker;
  5369. } elsif (defined $chunkNum) {
  5370. $self->WarnOnce('Invalid or extraneous ICC_Profile chunk(s)');
  5371. # fall through to preserve this extra profile...
  5372. }
  5373. } elsif ($$segDataPt =~ /^FPXR\0/) {
  5374. $segType = 'FPXR';
  5375. $$delGroup{FlashPix} and $del = 1;
  5376. } elsif ($$segDataPt =~ /^MPF\0/) {
  5377. $segType = 'MPF';
  5378. $$delGroup{MPF} and $del = 1;
  5379. }
  5380. } elsif ($marker == 0xe3) { # APP3 (Kodak Meta)
  5381. if ($$segDataPt =~ /^(Meta|META|Exif)\0\0/) {
  5382. $segType = 'Kodak Meta';
  5383. $$delGroup{Meta} and $del = 1, last;
  5384. $doneDir{Meta} and $self->Warn('Multiple APP3 Meta segments');
  5385. $doneDir{Meta} = 1;
  5386. last unless $$editDirs{Meta};
  5387. # rewrite Meta IFD as if this were a TIFF file in memory
  5388. my %dirInfo = (
  5389. DataPt => $segDataPt,
  5390. DataPos => -6, # (remember: relative to Base!)
  5391. DirStart => 6,
  5392. Base => $segPos + 6,
  5393. Parent => $markerName,
  5394. DirName => 'Meta',
  5395. );
  5396. # write new data to memory
  5397. my $tagTablePtr = GetTagTable('Image::ExifTool::Kodak::Meta');
  5398. my $buff = $self->WriteDirectory(\%dirInfo, $tagTablePtr, \&WriteTIFF);
  5399. if (defined $buff) {
  5400. # update segment with new data
  5401. $$segDataPt = substr($$segDataPt,0,6) . $buff;
  5402. } else {
  5403. last Marker unless $self->Options('IgnoreMinorErrors');
  5404. $$self{CHANGED} = $oldChanged; # nothing changed
  5405. }
  5406. # delete segment if IFD contains no entries
  5407. $del = 1 unless length($$segDataPt) > 6;
  5408. }
  5409. } elsif ($marker == 0xe5) { # APP5 (Ricoh RMETA)
  5410. if ($$segDataPt =~ /^RMETA\0/) {
  5411. $segType = 'Ricoh RMETA';
  5412. $$delGroup{RMETA} and $del = 1;
  5413. }
  5414. } elsif ($marker == 0xec) { # APP12 (Ducky)
  5415. if ($$segDataPt =~ /^Ducky/) {
  5416. $segType = 'Ducky';
  5417. $$delGroup{Ducky} and $del = 1, last;
  5418. $doneDir{Ducky} and $self->Warn('Multiple APP12 Ducky segments');
  5419. $doneDir{Ducky} = 1;
  5420. last unless $$editDirs{Ducky};
  5421. my $tagTablePtr = GetTagTable('Image::ExifTool::APP12::Ducky');
  5422. my %dirInfo = (
  5423. DataPt => $segDataPt,
  5424. DataPos => $segPos,
  5425. DataLen => $length,
  5426. DirStart => 5, # directory starts after identifier
  5427. DirLen => $length-5,
  5428. Parent => $markerName,
  5429. );
  5430. my $newData = $self->WriteDirectory(\%dirInfo, $tagTablePtr);
  5431. if (defined $newData) {
  5432. undef $$segDataPt; # free the old buffer
  5433. # add header to new segment unless empty
  5434. $newData = 'Ducky' . $newData if length $newData;
  5435. $segDataPt = \$newData;
  5436. } else {
  5437. $$self{CHANGED} = $oldChanged;
  5438. }
  5439. $del = 1 unless length $$segDataPt;
  5440. }
  5441. } elsif ($marker == 0xed) { # APP13 (Photoshop)
  5442. if ($$segDataPt =~ /^$psAPP13hdr/) {
  5443. $segType = 'Photoshop';
  5444. # add this data to the combined data if it exists
  5445. if (defined $combinedSegData) {
  5446. $combinedSegData .= substr($$segDataPt,length($psAPP13hdr));
  5447. $segDataPt = \$combinedSegData;
  5448. $length = length $combinedSegData; # update length
  5449. }
  5450. # peek ahead to see if the next segment is photoshop data too
  5451. if ($dirOrder[0] eq 'Photoshop') {
  5452. # initialize combined data if necessary
  5453. $combinedSegData = $$segDataPt unless defined $combinedSegData;
  5454. next Marker; # get the next segment to combine
  5455. }
  5456. if ($doneDir{Photoshop}) {
  5457. $self->Warn('Multiple Photoshop records');
  5458. # only rewrite the first Photoshop segment when deleting this group
  5459. # (to remove multiples when deleting and adding back in one step)
  5460. $$delGroup{Photoshop} and $del = 1, last;
  5461. }
  5462. $doneDir{Photoshop} = 1;
  5463. # process APP13 Photoshop record
  5464. my $tagTablePtr = GetTagTable('Image::ExifTool::Photoshop::Main');
  5465. my %dirInfo = (
  5466. DataPt => $segDataPt,
  5467. DataPos => $segPos,
  5468. DataLen => $length,
  5469. DirStart => 14, # directory starts after identifier
  5470. DirLen => $length-14,
  5471. Parent => $markerName,
  5472. );
  5473. my $newData = $self->WriteDirectory(\%dirInfo, $tagTablePtr);
  5474. if (defined $newData) {
  5475. undef $$segDataPt; # free the old buffer
  5476. $segDataPt = \$newData;
  5477. } else {
  5478. $$self{CHANGED} = $oldChanged;
  5479. }
  5480. length $$segDataPt or $del = 1, last;
  5481. # write as multi-segment
  5482. WriteMultiSegment($outfile, $marker, $psAPP13hdr, $segDataPt) or $err = 1;
  5483. undef $combinedSegData;
  5484. undef $$segDataPt;
  5485. next Marker;
  5486. }
  5487. } elsif ($marker == 0xee) { # APP14 (Adobe)
  5488. if ($$segDataPt =~ /^Adobe/) {
  5489. $segType = 'Adobe';
  5490. # delete it and replace it later if editing
  5491. if ($$delGroup{Adobe} or $$editDirs{Adobe}) {
  5492. $del = 1;
  5493. undef $doneDir{Adobe}; # so we can add it back again above
  5494. }
  5495. }
  5496. } elsif ($marker == 0xfe) { # COM (JPEG comment)
  5497. my $newComment;
  5498. unless ($doneDir{COM}) {
  5499. $doneDir{COM} = 1;
  5500. unless ($$delGroup{File} and $$delGroup{File} != 2) {
  5501. my $tagInfo = $Image::ExifTool::Extra{Comment};
  5502. my $nvHash = $self->GetNewValueHash($tagInfo);
  5503. my $val = $segData;
  5504. $val =~ s/\0+$//; # allow for stupid software that adds NULL terminator
  5505. if ($self->IsOverwriting($nvHash, $val) or $$delGroup{File}) {
  5506. $newComment = $self->GetNewValue($nvHash);
  5507. } else {
  5508. delete $$editDirs{COM}; # we aren't editing COM after all
  5509. last;
  5510. }
  5511. }
  5512. }
  5513. $self->VerboseValue('- Comment', $$segDataPt);
  5514. if (defined $newComment and length $newComment) {
  5515. # write out the comments
  5516. $self->VerboseValue('+ Comment', $newComment);
  5517. WriteMultiSegment($outfile, 0xfe, '', \$newComment) or $err = 1;
  5518. } else {
  5519. $verbose and print $out " Deleting COM segment\n";
  5520. }
  5521. ++$$self{CHANGED}; # increment the changed flag
  5522. undef $segDataPt; # don't write existing comment
  5523. }
  5524. last; # didn't want to loop anyway
  5525. }
  5526. # delete necessary segments (including unknown segments if deleting all)
  5527. if ($del or ($$delGroup{'*'} and not $segType and $marker>=0xe0 and $marker<=0xef)) {
  5528. $segType = 'unknown' unless $segType;
  5529. $verbose and print $out " Deleting $markerName $segType segment\n";
  5530. ++$$self{CHANGED};
  5531. next Marker;
  5532. }
  5533. # write out this segment if $segDataPt is still defined
  5534. if (defined $segDataPt and defined $$segDataPt) {
  5535. # write the data for this record (the data could have been
  5536. # modified, so recalculate the length word)
  5537. my $size = length($$segDataPt);
  5538. if ($size > $maxSegmentLen) {
  5539. $segType or $segType = 'Unknown';
  5540. $self->Error("$segType $markerName segment too large! ($size bytes)");
  5541. $err = 1;
  5542. } else {
  5543. $s = pack('n', length($$segDataPt) + 2);
  5544. Write($outfile, $hdr, $s, $$segDataPt) or $err = 1;
  5545. }
  5546. undef $$segDataPt; # free the buffer
  5547. undef $segDataPt;
  5548. }
  5549. }
  5550. # make sure the ICC_Profile was complete
  5551. $self->Error('Incomplete ICC_Profile record', 1) if defined $iccChunkCount;
  5552. pop @$path if @$path > $pn;
  5553. # if oldOutfile is still set, there was an error copying the JPEG
  5554. $oldOutfile and return 0;
  5555. if ($rtnVal) {
  5556. # add any new trailers we are creating
  5557. my $trailPt = $self->AddNewTrailers();
  5558. Write($outfile, $$trailPt) or $err = 1 if $trailPt;
  5559. }
  5560. # set return value to -1 if we only had a write error
  5561. $rtnVal = -1 if $rtnVal and $err;
  5562. if ($creatingEXV and $rtnVal > 0 and not $$self{CHANGED}) {
  5563. $self->Error('Nothing written');
  5564. $rtnVal = -1;
  5565. }
  5566. return $rtnVal;
  5567. }
  5568. #------------------------------------------------------------------------------
  5569. # Validate an image for writing
  5570. # Inputs: 0) ExifTool object reference, 1) raw value reference
  5571. # Returns: error string or undef on success
  5572. sub CheckImage($$)
  5573. {
  5574. my ($self, $valPtr) = @_;
  5575. if (length($$valPtr) and $$valPtr!~/^\xff\xd8/ and not
  5576. $self->Options('IgnoreMinorErrors'))
  5577. {
  5578. return '[minor] Not a valid image';
  5579. }
  5580. return undef;
  5581. }
  5582. #------------------------------------------------------------------------------
  5583. # check a value for validity
  5584. # Inputs: 0) value reference, 1) format string, 2) optional count
  5585. # Returns: error string, or undef on success
  5586. # Notes: May modify value (if a count is specified for a string, it is null-padded
  5587. # to the specified length, and floating point values are rounded to integer if required)
  5588. sub CheckValue($$;$)
  5589. {
  5590. my ($valPtr, $format, $count) = @_;
  5591. my (@vals, $val, $n);
  5592. if ($format eq 'string' or $format eq 'undef') {
  5593. return undef unless $count and $count > 0;
  5594. my $len = length($$valPtr);
  5595. if ($format eq 'string') {
  5596. $len >= $count and return 'String too long';
  5597. } else {
  5598. $len > $count and return 'Data too long';
  5599. }
  5600. if ($len < $count) {
  5601. $$valPtr .= "\0" x ($count - $len);
  5602. }
  5603. return undef;
  5604. }
  5605. if ($count and $count != 1) {
  5606. @vals = split(' ',$$valPtr);
  5607. $count < 0 and ($count = @vals or return undef);
  5608. } else {
  5609. $count = 1;
  5610. @vals = ( $$valPtr );
  5611. }
  5612. if (@vals != $count) {
  5613. my $str = @vals > $count ? 'Too many' : 'Not enough';
  5614. return "$str values specified ($count required)";
  5615. }
  5616. for ($n=0; $n<$count; ++$n) {
  5617. $val = shift @vals;
  5618. if ($format =~ /^int/) {
  5619. # make sure the value is integer
  5620. unless (IsInt($val)) {
  5621. if (IsHex($val)) {
  5622. $val = $$valPtr = hex($val);
  5623. } else {
  5624. # round single floating point values to the nearest integer
  5625. return 'Not an integer' unless IsFloat($val) and $count == 1;
  5626. $val = $$valPtr = int($val + ($val < 0 ? -0.5 : 0.5));
  5627. }
  5628. }
  5629. my $rng = $intRange{$format} or return "Bad int format: $format";
  5630. return "Value below $format minimum" if $val < $$rng[0];
  5631. # (allow 0xfeedfeed code as value for 16-bit pointers)
  5632. return "Value above $format maximum" if $val > $$rng[1] and $val != 0xfeedfeed;
  5633. } elsif ($format =~ /^rational/ or $format eq 'float' or $format eq 'double') {
  5634. # make sure the value is a valid floating point number
  5635. unless (IsFloat($val)) {
  5636. # allow 'inf', 'undef' and fractional rational values
  5637. if ($format =~ /^rational/) {
  5638. next if $val eq 'inf' or $val eq 'undef';
  5639. if ($val =~ m{^([-+]?\d+)/(\d+)$}) {
  5640. next unless $1 < 0 and $format =~ /u$/;
  5641. return 'Must be an unsigned rational';
  5642. }
  5643. }
  5644. return 'Not a floating point number';
  5645. }
  5646. if ($format =~ /^rational\d+u$/ and $val < 0) {
  5647. return 'Must be a positive number';
  5648. }
  5649. }
  5650. }
  5651. return undef; # success!
  5652. }
  5653. #------------------------------------------------------------------------------
  5654. # check new value for binary data block
  5655. # Inputs: 0) ExifTool object ref, 1) tagInfo hash ref, 2) raw value ref
  5656. # Returns: error string or undef (and may modify value) on success
  5657. sub CheckBinaryData($$$)
  5658. {
  5659. my ($self, $tagInfo, $valPtr) = @_;
  5660. my $format = $$tagInfo{Format};
  5661. unless ($format) {
  5662. my $table = $$tagInfo{Table};
  5663. if ($table and $$table{FORMAT}) {
  5664. $format = $$table{FORMAT};
  5665. } else {
  5666. # use default 'int8u' unless specified
  5667. $format = 'int8u';
  5668. }
  5669. }
  5670. my $count;
  5671. if ($format =~ /(.*)\[(.*)\]/) {
  5672. $format = $1;
  5673. $count = $2;
  5674. # can't evaluate $count now because we don't know $size yet
  5675. undef $count if $count =~ /\$size/;
  5676. }
  5677. return CheckValue($valPtr, $format, $count);
  5678. }
  5679. #------------------------------------------------------------------------------
  5680. # Rename a file (with patch for Windows Unicode file names, and other problem)
  5681. # Inputs: 0) ExifTool ref, 1) old name, 2) new name
  5682. # Returns: true on success
  5683. sub Rename($$$)
  5684. {
  5685. my ($self, $old, $new) = @_;
  5686. my ($result, $try, $winUni);
  5687. if ($self->EncodeFileName($old)) {
  5688. $self->EncodeFileName($new, 1);
  5689. $winUni = 1;
  5690. } elsif ($self->EncodeFileName($new)) {
  5691. $old = $_[1];
  5692. $self->EncodeFileName($old, 1);
  5693. $winUni = 1;
  5694. }
  5695. for (;;) {
  5696. if ($winUni) {
  5697. $result = eval { Win32API::File::MoveFileExW($old, $new,
  5698. Win32API::File::MOVEFILE_REPLACE_EXISTING() |
  5699. Win32API::File::MOVEFILE_COPY_ALLOWED()) };
  5700. } else {
  5701. $result = rename($old, $new);
  5702. }
  5703. last if $result or $^O ne 'MSWin32';
  5704. # keep trying for up to 0.5 seconds
  5705. # (patch for Windows denial-of-service susceptibility)
  5706. $try = ($try || 1) + 1;
  5707. last if $try > 50;
  5708. select(undef,undef,undef,0.01); # sleep for 0.01 sec
  5709. }
  5710. return $result;
  5711. }
  5712. #------------------------------------------------------------------------------
  5713. # Delete a file (with patch for Windows Unicode file names)
  5714. # Inputs: 0) ExifTool ref, 1-N) names of files to delete
  5715. # Returns: number of files deleted
  5716. sub Unlink($@)
  5717. {
  5718. my $self = shift;
  5719. my $result = 0;
  5720. while (@_) {
  5721. my $file = shift;
  5722. if ($self->EncodeFileName($file)) {
  5723. ++$result if eval { Win32API::File::DeleteFileW($file) };
  5724. } else {
  5725. ++$result if unlink $file;
  5726. }
  5727. }
  5728. return $result;
  5729. }
  5730. #------------------------------------------------------------------------------
  5731. # Set file times (Unix seconds since the epoch)
  5732. # Inputs: 0) ExifTool ref, 1) file name or ref, 2) access time, 3) modification time,
  5733. # 4) inode change or creation time (or undef for any time to avoid setting)
  5734. # Returns: 1 on success, 0 on error
  5735. my $k32SetFileTime;
  5736. sub SetFileTime($$;$$$)
  5737. {
  5738. my ($self, $file, $atime, $mtime, $ctime) = @_;
  5739. # open file by name if necessary
  5740. unless (ref $file) {
  5741. local *FH;
  5742. $self->Open(\*FH, $file, '+<') or $self->Warn("SetFileTime error for '$file'"), return 0;
  5743. $file = *FH; # (not \*FH, so *FH will be kept open until $file goes out of scope)
  5744. }
  5745. # on Windows, try to work around incorrect file times when daylight saving time is in effect
  5746. if ($^O eq 'MSWin32') {
  5747. if (not eval { require Win32::API }) {
  5748. $self->WarnOnce('Install Win32::API for proper handling of Windows file times');
  5749. } elsif (not eval { require Win32API::File }) {
  5750. $self->WarnOnce('Install Win32API::File for proper handling of Windows file times');
  5751. } else {
  5752. # get Win32 handle, needed for SetFileTime
  5753. my $win32Handle = eval { Win32API::File::GetOsFHandle($file) };
  5754. unless ($win32Handle) {
  5755. $self->Warn("Win32API::File::GetOsFHandle returned invalid handle");
  5756. return 0;
  5757. }
  5758. # convert Unix seconds to FILETIME structs
  5759. my $time;
  5760. foreach $time ($atime, $mtime, $ctime) {
  5761. # set to NULL if not defined (i.e. do not change)
  5762. defined $time or $time = 0, next;
  5763. # convert to 100 ns intervals since 0:00 UTC Jan 1, 1601
  5764. # (89 leap years between 1601 and 1970)
  5765. my $wt = ($time + (((1970-1601)*365+89)*24*3600)) * 1e7;
  5766. my $hi = int($wt / 4294967296);
  5767. $time = pack 'LL', int($wt - $hi * 4294967296), $hi; # pack FILETIME struct
  5768. }
  5769. unless ($k32SetFileTime) {
  5770. return 0 if defined $k32SetFileTime;
  5771. $k32SetFileTime = new Win32::API('KERNEL32', 'SetFileTime', 'NPPP', 'I');
  5772. unless ($k32SetFileTime) {
  5773. $self->Warn('Error calling Win32::API::SetFileTime');
  5774. $k32SetFileTime = 0;
  5775. return 0;
  5776. }
  5777. }
  5778. unless ($k32SetFileTime->Call($win32Handle, $ctime, $atime, $mtime)) {
  5779. $self->Warn("Win32::API::SetFileTime returned " . Win32::GetLastError());
  5780. return 0;
  5781. }
  5782. return 1;
  5783. }
  5784. }
  5785. # other os (or Windows fallback)
  5786. return utime($atime, $mtime, $file) if defined $atime and defined $mtime;
  5787. return 1; # (nothing to do)
  5788. }
  5789. #------------------------------------------------------------------------------
  5790. # Copy data block from RAF to output file in max 64kB chunks
  5791. # Inputs: 0) RAF ref, 1) outfile ref, 2) block size
  5792. # Returns: 1 on success, 0 on read error, undef on write error
  5793. sub CopyBlock($$$)
  5794. {
  5795. my ($raf, $outfile, $size) = @_;
  5796. my $buff;
  5797. for (;;) {
  5798. last unless $size > 0;
  5799. my $n = $size > 65536 ? 65536 : $size;
  5800. $raf->Read($buff, $n) == $n or return 0;
  5801. Write($outfile, $buff) or return undef;
  5802. $size -= $n;
  5803. }
  5804. return 1;
  5805. }
  5806. #------------------------------------------------------------------------------
  5807. # copy image data from one file to another
  5808. # Inputs: 0) ExifTool object reference
  5809. # 1) reference to list of image data [ position, size, pad bytes ]
  5810. # 2) output file ref
  5811. # Returns: true on success
  5812. sub CopyImageData($$$)
  5813. {
  5814. my ($self, $imageDataBlocks, $outfile) = @_;
  5815. my $raf = $$self{RAF};
  5816. my ($dataBlock, $err);
  5817. my $num = @$imageDataBlocks;
  5818. $self->VPrint(0, " Copying $num image data blocks\n") if $num;
  5819. foreach $dataBlock (@$imageDataBlocks) {
  5820. my ($pos, $size, $pad) = @$dataBlock;
  5821. $raf->Seek($pos, 0) or $err = 'read', last;
  5822. my $result = CopyBlock($raf, $outfile, $size);
  5823. $result or $err = defined $result ? 'read' : 'writ';
  5824. # pad if necessary
  5825. Write($outfile, "\0" x $pad) or $err = 'writ' if $pad;
  5826. last if $err;
  5827. }
  5828. if ($err) {
  5829. $self->Error("Error ${err}ing image data");
  5830. return 0;
  5831. }
  5832. return 1;
  5833. }
  5834. #------------------------------------------------------------------------------
  5835. # write to binary data block
  5836. # Inputs: 0) ExifTool object ref, 1) source dirInfo ref, 2) tag table ref
  5837. # Returns: Binary data block or undefined on error
  5838. sub WriteBinaryData($$$)
  5839. {
  5840. my ($self, $dirInfo, $tagTablePtr) = @_;
  5841. $self or return 1; # allow dummy access to autoload this package
  5842. # get default format ('int8u' unless specified)
  5843. my $dataPt = $$dirInfo{DataPt} or return undef;
  5844. my $defaultFormat = $$tagTablePtr{FORMAT} || 'int8u';
  5845. my $increment = FormatSize($defaultFormat);
  5846. unless ($increment) {
  5847. warn "Unknown format $defaultFormat\n";
  5848. return undef;
  5849. }
  5850. # extract data members first if necessary
  5851. my @varOffsets;
  5852. if ($$tagTablePtr{DATAMEMBER}) {
  5853. $$dirInfo{DataMember} = $$tagTablePtr{DATAMEMBER};
  5854. $$dirInfo{VarFormatData} = \@varOffsets;
  5855. $self->ProcessBinaryData($dirInfo, $tagTablePtr);
  5856. delete $$dirInfo{DataMember};
  5857. delete $$dirInfo{VarFormatData};
  5858. }
  5859. my $dirStart = $$dirInfo{DirStart} || 0;
  5860. my $dirLen = $$dirInfo{DirLen} || length($$dataPt) - $dirStart;
  5861. my $newData = substr($$dataPt, $dirStart, $dirLen) or return undef;
  5862. my $dirName = $$dirInfo{DirName};
  5863. my $varSize = 0;
  5864. my @varInfo = @varOffsets;
  5865. my $tagInfo;
  5866. $dataPt = \$newData;
  5867. foreach $tagInfo ($self->GetNewTagInfoList($tagTablePtr)) {
  5868. my $tagID = $$tagInfo{TagID};
  5869. # evaluate conditional tags now if necessary
  5870. if (ref $$tagTablePtr{$tagID} eq 'ARRAY' or $$tagInfo{Condition}) {
  5871. my $writeInfo = $self->GetTagInfo($tagTablePtr, $tagID);
  5872. next unless $writeInfo and $writeInfo eq $tagInfo;
  5873. }
  5874. # add offsets for variable-sized tags if necessary
  5875. my $varFmt;
  5876. while (@varInfo and $varInfo[0][0] < $tagID) {
  5877. $varSize = $varInfo[0][1]; # get accumulated variable size
  5878. shift @varInfo;
  5879. }
  5880. my $count = 1;
  5881. my $format = $$tagInfo{Format};
  5882. my $entry = int($tagID) * $increment + $varSize; # relative offset of this entry
  5883. if ($format) {
  5884. if ($format =~ /(.*)\[(.*)\]/) {
  5885. $format = $1;
  5886. $count = $2;
  5887. my $size = $dirLen; # used in eval
  5888. # evaluate count to allow count to be based on previous values
  5889. #### eval Format size ($size, $self) - NOTE: %val not supported for writing
  5890. $count = eval $count;
  5891. $@ and warn($@), next;
  5892. } elsif ($format eq 'string') {
  5893. # string with no specified count runs to end of block
  5894. $count = ($dirLen > $entry) ? $dirLen - $entry : 0;
  5895. }
  5896. } else {
  5897. $format = $defaultFormat;
  5898. }
  5899. # read/write using variable format if changed in Hook
  5900. $format = $varInfo[0][2] if @varInfo and $varInfo[0][0] == $tagID;
  5901. my $val = ReadValue($dataPt, $entry, $format, $count, $dirLen-$entry);
  5902. next unless defined $val;
  5903. my $nvHash = $self->GetNewValueHash($tagInfo, $$self{CUR_WRITE_GROUP});
  5904. next unless $self->IsOverwriting($nvHash, $val);
  5905. my $newVal = $self->GetNewValue($nvHash);
  5906. next unless defined $newVal; # can't delete from a binary table
  5907. # only write masked bits if specified
  5908. my $mask = $$tagInfo{Mask};
  5909. $newVal = ($newVal & $mask) | ($val & ~$mask) if defined $mask;
  5910. # set the size
  5911. if ($$tagInfo{DataTag} and not $$tagInfo{IsOffset}) {
  5912. warn 'Internal error' unless $newVal == 0xfeedfeed;
  5913. my $data = $self->GetNewValue($$tagInfo{DataTag});
  5914. $newVal = length($data) if defined $data;
  5915. my $format = $$tagInfo{Format} || $$tagTablePtr{FORMAT} || 'int32u';
  5916. if ($format =~ /^int16/ and $newVal > 0xffff) {
  5917. $self->Error("$$tagInfo{DataTag} is too large (64 kB max. for this file)");
  5918. }
  5919. }
  5920. my $rtnVal = WriteValue($newVal, $format, $count, $dataPt, $entry);
  5921. if (defined $rtnVal) {
  5922. $self->VerboseValue("- $dirName:$$tagInfo{Name}", $val);
  5923. $self->VerboseValue("+ $dirName:$$tagInfo{Name}", $newVal);
  5924. ++$$self{CHANGED};
  5925. }
  5926. }
  5927. # add necessary fixups for any offsets
  5928. if ($$tagTablePtr{IS_OFFSET} and $$dirInfo{Fixup}) {
  5929. $varSize = 0;
  5930. @varInfo = @varOffsets;
  5931. my $fixup = $$dirInfo{Fixup};
  5932. my $tagID;
  5933. foreach $tagID (@{$$tagTablePtr{IS_OFFSET}}) {
  5934. $tagInfo = $self->GetTagInfo($tagTablePtr, $tagID) or next;
  5935. while (@varInfo and $varInfo[0][0] < $tagID) {
  5936. $varSize = $varInfo[0][1];
  5937. shift @varInfo;
  5938. }
  5939. my $entry = $tagID * $increment + $varSize; # (no offset to dirStart for new dir data)
  5940. next unless $entry <= $dirLen - 4;
  5941. # (Ricoh has 16-bit preview image offsets, so can't just assume int32u)
  5942. my $format = $$tagInfo{Format} || $$tagTablePtr{FORMAT} || 'int32u';
  5943. my $offset = ReadValue($dataPt, $entry, $format, 1, $dirLen-$entry);
  5944. # ignore if offset is zero (eg. Ricoh DNG uses this to indicate no preview)
  5945. next unless $offset;
  5946. $fixup->AddFixup($entry, $$tagInfo{DataTag}, $format);
  5947. # handle the preview image now if this is a JPEG file
  5948. next unless $$self{FILE_TYPE} eq 'JPEG' and $$tagInfo{DataTag} and
  5949. $$tagInfo{DataTag} eq 'PreviewImage' and defined $$tagInfo{OffsetPair};
  5950. # NOTE: here we assume there are no var-sized tags between the
  5951. # OffsetPair tags. If this ever becomes possible we must recalculate
  5952. # $varSize for the OffsetPair tag here!
  5953. $entry = $$tagInfo{OffsetPair} * $increment + $varSize;
  5954. my $size = ReadValue($dataPt, $entry, $format, 1, $dirLen-$entry);
  5955. my $previewInfo = $$self{PREVIEW_INFO};
  5956. $previewInfo or $previewInfo = $$self{PREVIEW_INFO} = {
  5957. Fixup => new Image::ExifTool::Fixup,
  5958. };
  5959. # set flag indicating we are using short pointers
  5960. $$previewInfo{IsShort} = 1 unless $format eq 'int32u';
  5961. $$previewInfo{Absolute} = 1 if $$tagInfo{IsOffset} and $$tagInfo{IsOffset} eq '3';
  5962. # get the value of the Composite::PreviewImage tag
  5963. $$previewInfo{Data} = $self->GetNewValue($Image::ExifTool::Composite{PreviewImage});
  5964. unless (defined $$previewInfo{Data}) {
  5965. if ($offset >= 0 and $offset + $size <= $$dirInfo{DataLen}) {
  5966. $$previewInfo{Data} = substr(${$$dirInfo{DataPt}},$offset,$size);
  5967. } else {
  5968. $$previewInfo{Data} = 'LOAD_PREVIEW'; # flag to load preview later
  5969. }
  5970. }
  5971. }
  5972. }
  5973. # write any necessary SubDirectories
  5974. if ($$tagTablePtr{IS_SUBDIR}) {
  5975. $varSize = 0;
  5976. @varInfo = @varOffsets;
  5977. my $tagID;
  5978. foreach $tagID (@{$$tagTablePtr{IS_SUBDIR}}) {
  5979. my $tagInfo = $self->GetTagInfo($tagTablePtr, $tagID);
  5980. next unless defined $tagInfo;
  5981. while (@varInfo and $varInfo[0][0] < $tagID) {
  5982. $varSize = $varInfo[0][1];
  5983. shift @varInfo;
  5984. }
  5985. my $entry = int($tagID) * $increment + $varSize;
  5986. last if $entry >= $dirLen;
  5987. # get value for Condition if necessary
  5988. unless ($tagInfo) {
  5989. my $more = $dirLen - $entry;
  5990. $more = 128 if $more > 128;
  5991. my $v = substr($newData, $entry, $more);
  5992. $tagInfo = $self->GetTagInfo($tagTablePtr, $tagID, \$v);
  5993. next unless $tagInfo;
  5994. }
  5995. next unless $$tagInfo{SubDirectory}; # (just to be safe)
  5996. my %subdirInfo = ( DataPt => \$newData, DirStart => $entry );
  5997. my $subTablePtr = GetTagTable($$tagInfo{SubDirectory}{TagTable});
  5998. my $dat = $self->WriteDirectory(\%subdirInfo, $subTablePtr);
  5999. substr($newData, $entry) = $dat if defined $dat and length $dat;
  6000. }
  6001. }
  6002. return $newData;
  6003. }
  6004. #------------------------------------------------------------------------------
  6005. # Write TIFF as a directory
  6006. # Inputs: 0) ExifTool object ref, 1) dirInfo ref, 2) tag table ref
  6007. # Returns: New directory data or undefined on error
  6008. sub WriteTIFF($$$)
  6009. {
  6010. my ($self, $dirInfo, $tagTablePtr) = @_;
  6011. my $buff = '';
  6012. $$dirInfo{OutFile} = \$buff;
  6013. return $buff if $self->ProcessTIFF($dirInfo, $tagTablePtr) > 0;
  6014. return undef;
  6015. }
  6016. 1; # end
  6017. __END__
  6018. =head1 NAME
  6019. Image::ExifTool::Writer.pl - ExifTool routines for writing meta information
  6020. =head1 SYNOPSIS
  6021. These routines are autoloaded by Image::ExifTool when required.
  6022. =head1 DESCRIPTION
  6023. This module contains ExifTool write routines and other infrequently
  6024. used routines.
  6025. =head1 AUTHOR
  6026. Copyright 2003-2016, Phil Harvey (phil at owl.phy.queensu.ca)
  6027. This library is free software; you can redistribute it and/or modify it
  6028. under the same terms as Perl itself.
  6029. =head1 SEE ALSO
  6030. L<Image::ExifTool(3pm)|Image::ExifTool>
  6031. =cut